?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Remove inclusion of sys/socket.h from nntp-thread.c
[claws.git] / src / plugins / perl / perl_plugin.c
blobee9e15f2196b8812ca1711b9a5324bc469cfabaf
1 /* Perl plugin -- Perl Support for Claws Mail
2 *
3 * Copyright (C) 2004-2022 Holger Berndt and the Claws Mail Team
4 *
5 * Claws Mail are GTK based, lightweight, and fast e-mail clients
6 * Copyright (C) 1999-2022 the Claws Mail Team
7 *
8 * This program is free software; you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation; either version 3 of the License, or
11 * (at your option) any later version.
12 *
13 * This program is distributed in the hope that it will be useful,
14 * but WITHOUT ANY WARRANTY; without even the implied warranty of
15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 * GNU General Public License for more details.
17 *
18 * You should have received a copy of the GNU General Public License
19 * along with this program. If not, see <http://www.gnu.org/licenses/>.
20 */
21
22 #ifdef HAVE_CONFIG_H
23 # include "config.h"
24 #include "claws-features.h"
25 #endif
26
27 #include "common/version.h"
28 #include "common/defs.h"
29 #include "common/utils.h"
30 #include "common/claws.h"
31 #include "common/prefs.h"
32 #include "procmsg.h"
33 #include "procheader.h"
34 #include "folder.h"
35 #include "account.h"
36 #include "compose.h"
37 #include "addrindex.h"
38 #include "addritem.h"
39 #include "addr_compl.h"
40 #include "statusbar.h"
41 #include "alertpanel.h"
42 #include "common/hooks.h"
43 #include "prefs_common.h"
44 #include "prefs_gtk.h"
45 #include "common/log.h"
46 #include "common/plugin.h"
47 #include "common/tags.h"
48 #include "file-utils.h"
49
50 #ifdef YYEMPTY
51 # undef YYEMPTY
52 #endif
53
54 #include <EXTERN.h>
55 #include <perl.h>
56 #include <XSUB.h>
57
58 #ifdef _
59 # undef _
60 #endif
61
62 #include <glib.h>
63 #include <glib/gi18n.h>
64
65 #include <string.h>
66 #include <sys/types.h>
67 #include <sys/stat.h>
68 #include <sys/wait.h>
69 #include <unistd.h>
70
71 #include "perl_plugin.h"
72 #include "perl_gtk.h"
73
74
75 /* XSRETURN_UV was introduced in Perl 5.8.1,
76 this fixes things for 5.8.0. */
77 #ifndef XSRETURN_UV
78 # ifndef XST_mUV
79 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
80 # endif /* XST_mUV */
81 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
82 #endif /* XSRETURN_UV */
83
84 /* set this to "1" to recompile the Perl script for every mail,
85 even if it hasn't changed */
86 #define DO_CLEAN "0"
87
88 /* distinguish between automatic and manual filtering */
89 #define AUTO_FILTER 0
90 #define MANU_FILTER 1
91
92 /* embedded Perl stuff */
93 static PerlInterpreter *my_perl = NULL;
94 EXTERN_C void xs_init(pTHX);
95 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
96
97 /* plugin stuff */
98 static guint filtering_hook_id = HOOK_NONE;
99 static guint manual_filtering_hook_id = HOOK_NONE;
100 static MailFilteringData *mail_filtering_data = NULL;
101 static MsgInfo *msginfo = NULL;
102 static gboolean stop_filtering = FALSE;
103 static gboolean manual_filtering = FALSE;
104 static gboolean wrote_filter_log_head = FALSE;
105 static gint filter_log_verbosity;
106 static FILE *message_file = NULL;
107 static gchar *attribute_key = NULL;
108
109 /* configuration */
110 static PerlPluginConfig config;
111
112 static PrefParam param[] = {
113 {"filter_log_verbosity", "2", &config.filter_log_verbosity,
114 P_INT, NULL, NULL, NULL},
115 {NULL, NULL, NULL, P_OTHER, NULL, NULL, NULL}
116 };
117
118
119 /* Utility functions */
120
121 /* fire and forget */
122 gint execute_detached(gchar **cmdline)
123 {
124 pid_t pid;
125
126 if((pid = fork()) < 0) { /* fork error */
127 perror("fork");
128 return 0;
129 }
130 else if(pid > 0) { /* parent */
131 waitpid(pid, NULL, 0);
132 return 1;
133 }
134 else { /* child */
135 if((pid = fork()) < 0) { /* fork error */
136 perror("fork");
137 return 0;
138 }
139 else if(pid > 0) { /* child */
140 /* make grand child an orphan */
141 _exit(0);
142 }
143 else { /* grand child */
144 execvp(cmdline[0], cmdline);
145 perror("execvp");
146 _exit(1);
147 }
148 }
149 return 0;
150 }
151
152
153 /* filter logfile */
154 #define LOG_MANUAL 1
155 #define LOG_ACTION 2
156 #define LOG_MATCH 3
157
158 static void filter_log_write(gint type, gchar *text) {
159 if(filter_log_verbosity >= type) {
160 if(!wrote_filter_log_head) {
161 log_message(LOG_PROTOCOL, "From: %s || Subject: %s || Message-ID: %s\n",
162 msginfo->from ? msginfo->from : "<no From header>",
163 msginfo->subject ? msginfo->subject : "<no Subject header>",
164 msginfo->msgid ? msginfo->msgid : "<no message id>");
165 wrote_filter_log_head = TRUE;
166 }
167 switch(type) {
168 case LOG_MANUAL:
169 log_message(LOG_PROTOCOL, " MANUAL: %s\n", text?text:"<no text specified>");
170 break;
171 case LOG_ACTION:
172 log_message(LOG_PROTOCOL, " ACTION: %s\n", text?text:"<no text specified>");
173 break;
174 case LOG_MATCH:
175 log_message(LOG_PROTOCOL, " MATCH: %s\n", text?text:"<no text specified>");
176 break;
177 default:
178 g_warning("Perl plugin: wrong use of filter_log_write");
179 break;
180 }
181 }
182 }
183
184 /* Addressbook interface */
185
186 static PerlPluginTimedSList *email_slist = NULL;
187 static GHashTable *attribute_hash = NULL;
188
189 /* addressbook email collector callback */
190 static gint add_to_email_slist(ItemPerson *person, const gchar *bookname)
191 {
192 PerlPluginEmailEntry *ee;
193 GList *nodeM;
194
195 /* Process each E-Mail address */
196 nodeM = person->listEMail;
197 while(nodeM) {
198 ItemEMail *email = nodeM->data;
199 ee = g_new0(PerlPluginEmailEntry,1);
200 g_return_val_if_fail(ee != NULL, -1);
201
202 if(email->address != NULL) ee->address = g_strdup(email->address);
203 else ee->address = NULL;
204 if(bookname != NULL) ee->bookname = g_strdup(bookname);
205 else ee->bookname = NULL;
206
207 email_slist->g_slist = g_slist_prepend(email_slist->g_slist,ee);
208 nodeM = g_list_next(nodeM);
209 }
210 return 0;
211 }
212
213 /* free a GSList of PerlPluginEmailEntry's. */
214 static void free_PerlPluginEmailEntry_slist(GSList *slist)
215 {
216 GSList *walk;
217
218 if(slist == NULL)
219 return;
220
221 walk = slist;
222 for(; walk != NULL; walk = g_slist_next(walk)) {
223 PerlPluginEmailEntry *ee = (PerlPluginEmailEntry *) walk->data;
224 if(ee != NULL) {
225 if(ee->address != NULL) g_free(ee->address);
226 if(ee->bookname != NULL) g_free(ee->bookname);
227 g_free(ee);
228 ee = NULL;
229 }
230 }
231 g_slist_free(slist);
232
233 debug_print("PerlPluginEmailEntry slist freed\n");
234 }
235
236 /* free email_slist */
237 static void free_email_slist(void)
238 {
239 if(email_slist == NULL)
240 return;
241
242 free_PerlPluginEmailEntry_slist(email_slist->g_slist);
243 email_slist->g_slist = NULL;
244
245 g_free(email_slist);
246 email_slist = NULL;
247
248 debug_print("email_slist freed\n");
249 }
250
251 /* check if tl->g_slist exists and is recent enough */
252 static gboolean update_PerlPluginTimedSList(PerlPluginTimedSList *tl)
253 {
254 gboolean retVal;
255 gchar *indexfile;
256 GStatBuf filestat;
257
258 if(tl->g_slist == NULL)
259 return TRUE;
260
261 indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
262 if((g_stat(indexfile,&filestat) == 0) && filestat.st_mtime <= tl->mtime)
263 retVal = FALSE;
264 else
265 retVal = TRUE;
266
267 g_free(indexfile);
268 return retVal;
269 }
270
271 /* (re)initialize email slist */
272 static void init_email_slist(void)
273 {
274 gchar *indexfile;
275 GStatBuf filestat;
276
277 if(email_slist->g_slist != NULL) {
278 free_PerlPluginEmailEntry_slist(email_slist->g_slist);
279 email_slist->g_slist = NULL;
280 }
281
282 addrindex_load_person_attribute(NULL,add_to_email_slist);
283
284 indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
285 if(g_stat(indexfile,&filestat) == 0)
286 email_slist->mtime = filestat.st_mtime;
287 g_free(indexfile);
288 debug_print("Initialisation of email slist completed\n");
289 }
290
291 /* check if given address is in given addressbook */
292 static gboolean addr_in_addressbook(gchar *addr, gchar *bookname)
293 {
294 /* If no book is given, check the address completion list
295 * (there may be other addresses that are not in the address book,
296 * added by other plugins). */
297 if(bookname == NULL) {
298 gboolean found;
299 start_address_completion(NULL);
300 found = (complete_matches_found(addr) > 0);
301 end_address_completion();
302 return found;
303 }
304 else {
305 GSList *walk;
306
307 /* check if email_list exists */
308 if(email_slist == NULL) {
309 email_slist = g_new0(PerlPluginTimedSList,1);
310 email_slist->g_slist = NULL;
311 debug_print("email_slist created\n");
312 }
313
314 if(update_PerlPluginTimedSList(email_slist))
315 init_email_slist();
316
317 walk = email_slist->g_slist;
318 for(; walk != NULL; walk = g_slist_next(walk)) {
319 PerlPluginEmailEntry *ee = (PerlPluginEmailEntry *) walk->data;
320 gchar *a = g_utf8_casefold(ee->address, -1);
321 gchar *b = g_utf8_casefold(addr, -1);
322 if((!g_utf8_collate(a,b)) &&
323 ((bookname == NULL) || (!strcmp(ee->bookname,bookname)))) {
324 g_free(a);
325 g_free(b);
326 return TRUE;
327 }
328 g_free(a);
329 g_free(b);
330 }
331 }
332
333 return FALSE;
334 }
335
336 /* attribute hash collector callback */
337 static gint add_to_attribute_hash(ItemPerson *person, const gchar *bookname)
338 {
339 PerlPluginTimedSList *tl;
340 PerlPluginAttributeEntry *ae;
341 GList *nodeA;
342 GList *nodeM;
343
344 nodeA = person->listAttrib;
345 /* Process each User Attribute */
346 while(nodeA) {
347 UserAttribute *attrib = nodeA->data;
348 if(attrib->name && !strcmp(attrib->name,attribute_key) ) {
349 /* Process each E-Mail address */
350 nodeM = person->listEMail;
351 while(nodeM) {
352 ItemEMail *email = nodeM->data;
353
354 ae = g_new0(PerlPluginAttributeEntry,1);
355 g_return_val_if_fail(ae != NULL, -1);
356
357 if(email->address != NULL) ae->address = g_strdup(email->address);
358 else ae->address = NULL;
359 if(attrib->value != NULL) ae->value = g_strdup(attrib->value);
360 else ae->value = NULL;
361 if(bookname != NULL) ae->bookname = g_strdup(bookname);
362 else ae->bookname = NULL;
363
364 tl = (PerlPluginTimedSList *) g_hash_table_lookup(attribute_hash,attribute_key);
365 tl->g_slist = g_slist_prepend(tl->g_slist,ae);
366
367 nodeM = g_list_next(nodeM);
368 }
369 }
370 nodeA = g_list_next(nodeA);
371 }
372
373 return 0;
374 }
375
376 /* free a key of the attribute hash */
377 static gboolean free_attribute_hash_key(gpointer key, gpointer value, gpointer user_data)
378 {
379 GSList *walk;
380 PerlPluginTimedSList *tl;
381
382 debug_print("Freeing key `%s' from attribute_hash\n",key?(char*)key:"");
383
384 tl = (PerlPluginTimedSList *) value;
385
386 if(tl != NULL) {
387 if(tl->g_slist != NULL) {
388 walk = tl->g_slist;
389 for(; walk != NULL; walk = g_slist_next(walk)) {
390 PerlPluginAttributeEntry *ae = (PerlPluginAttributeEntry *) walk->data;
391 if(ae != NULL) {
392 if(ae->address != NULL) g_free(ae->address);
393 if(ae->value != NULL) g_free(ae->value);
394 if(ae->bookname != NULL) g_free(ae->bookname);
395 g_free(ae);
396 ae = NULL;
397 }
398 }
399 g_slist_free(tl->g_slist);
400 tl->g_slist = NULL;
401 }
402 g_free(tl);
403 tl = NULL;
404 }
405
406 if(key != NULL) {
407 g_free(key);
408 key = NULL;
409 }
410
411 return TRUE;
412 }
413
414 /* free whole attribute hash */
415 static void free_attribute_hash(void)
416 {
417 if(attribute_hash == NULL)
418 return;
419
420 g_hash_table_foreach_remove(attribute_hash,free_attribute_hash_key,NULL);
421 g_hash_table_destroy(attribute_hash);
422 attribute_hash = NULL;
423
424 debug_print("attribute_hash freed\n");
425 }
426
427 /* Free the key if it exists. Insert the new key. */
428 static void insert_attribute_hash(gchar *attr)
429 {
430 PerlPluginTimedSList *tl;
431 gchar *indexfile;
432 GStatBuf filestat;
433
434 /* Check if key exists. Free it if it does. */
435 if((tl = g_hash_table_lookup(attribute_hash,attr)) != NULL) {
436 gpointer origkey;
437 gpointer value;
438 if (g_hash_table_lookup_extended(attribute_hash,attr,&origkey,&value)) {
439 g_hash_table_remove(attribute_hash,origkey);
440 free_attribute_hash_key(origkey,value,NULL);
441 debug_print("Existing key `%s' freed.\n",attr);
442 }
443 }
444
445 tl = g_new0(PerlPluginTimedSList,1);
446 tl->g_slist = NULL;
447
448 attribute_key = g_strdup(attr);
449 g_hash_table_insert(attribute_hash,attribute_key,tl);
450
451 addrindex_load_person_attribute(attribute_key,add_to_attribute_hash);
452
453 indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
454 if(g_stat(indexfile,&filestat) == 0)
455 tl->mtime = filestat.st_mtime;
456 g_free(indexfile);
457
458 debug_print("added key `%s' to attribute_hash\n",attribute_key?attribute_key:"");
459 }
460
461 /* check if an update of the attribute hash entry is necessary */
462 static gboolean update_attribute_hash(const gchar *attr)
463 {
464 PerlPluginTimedSList *tl;
465
466 /* check if key attr exists in the attribute hash */
467 if((tl = (PerlPluginTimedSList*) g_hash_table_lookup(attribute_hash,attr)) == NULL)
468 return TRUE;
469
470 /* check if entry is recent enough */
471 return update_PerlPluginTimedSList(tl);
472 }
473
474 /* given an email address, return attribute value of specific book */
475 static gchar* get_attribute_value(gchar *email, gchar *attr, gchar *bookname)
476 {
477 GSList *walk;
478 PerlPluginTimedSList *tl;
479
480 /* check if attribute hash exists */
481 if(attribute_hash == NULL) {
482 attribute_hash = g_hash_table_new(g_str_hash,g_str_equal);
483 debug_print("attribute_hash created\n");
484 }
485
486 if(update_attribute_hash(attr)) {
487 debug_print("Initialisation of attribute hash entry `%s' is necessary\n",attr);
488 insert_attribute_hash(attr);
489 }
490
491 if((tl = (PerlPluginTimedSList*) g_hash_table_lookup(attribute_hash,attr)) == NULL)
492 return NULL;
493
494 walk = tl->g_slist;
495 for(; walk != NULL; walk = g_slist_next(walk)) {
496 PerlPluginAttributeEntry *ae = (PerlPluginAttributeEntry *) walk->data;
497 gchar *a, *b;
498 a = g_utf8_strdown(ae->address, -1);
499 b = g_utf8_strdown(email, -1);
500 if(!g_utf8_collate(a, b)) {
501 if((bookname == NULL) ||
502 ((ae->bookname != NULL) && !strcmp(bookname,ae->bookname))) {
503 g_free(a); g_free(b);
504 return ae->value;
505 }
506 }
507 g_free(a); g_free(b);
508 }
509 return NULL;
510 }
511
512 /* free up all memory allocated with lists */
513 static void free_all_lists(void)
514 {
515 /* email list */
516 free_email_slist();
517
518 /* attribute hash */
519 free_attribute_hash();
520 }
521
522
523
524 /* ClawsMail::C module */
525
526 /* Initialization */
527
528 /* ClawsMail::C::filter_init(int) */
529 static XS(XS_ClawsMail_filter_init)
530 {
531 int flag;
532 /* flags:
533 *
534 * msginfo
535 * 1 size
536 * 2 date
537 * 3 from
538 * 4 to
539 * 5 cc
540 * 6 newsgroups
541 * 7 subject
542 * 8 msgid
543 * 9 inreplyto
544 * 10 xref
545 * 11 xface
546 * 12 dispositionnotificationto
547 * 13 returnreceiptto
548 * 14 references
549 * 15 score
550 * 16 not used anymore
551 * 17 plaintext_file
552 * 18 not used anymore
553 * 19 hidden
554 * 20 message file path
555 * 21 partial_recv
556 * 22 total_size
557 * 23 account_server
558 * 24 account_login
559 * 25 planned_download
560 *
561 * general
562 * 100 manual
563 */
564 char *charp;
565 gchar buf[BUFFSIZE];
566 GSList *walk;
567 int ii;
568 gchar *xface;
569
570 dXSARGS;
571 if(items != 1) {
572 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::init");
573 XSRETURN_UNDEF;
574 }
575 flag = SvIV(ST(0));
576 switch(flag) {
577
578 /* msginfo */
579 case 1:
580 if (msginfo->size) {
581 XSRETURN_UV(msginfo->size);
582 }
583 else {
584 XSRETURN_UNDEF;
585 }
586 case 2:
587 if (msginfo->date) {
588 XSRETURN_PV(msginfo->date);
589 }
590 else {
591 XSRETURN_UNDEF;
592 }
593 case 3:
594 if (msginfo->from) {
595 XSRETURN_PV(msginfo->from);
596 }
597 else {
598 XSRETURN_UNDEF;
599 }
600 case 4:
601 if (msginfo->to) {
602 XSRETURN_PV(msginfo->to);
603 }
604 else {
605 XSRETURN_UNDEF;
606 }
607 case 5:
608 if (msginfo->cc) {
609 XSRETURN_PV(msginfo->cc);
610 }
611 else {
612 XSRETURN_UNDEF;
613 }
614 case 6:
615 if (msginfo->newsgroups) {
616 XSRETURN_PV(msginfo->newsgroups);
617 }
618 else {
619 XSRETURN_UNDEF;
620 }
621 case 7:
622 if (msginfo->subject) {
623 XSRETURN_PV(msginfo->subject);
624 }
625 else {
626 XSRETURN_UNDEF;
627 }
628 case 8:
629 if (msginfo->msgid) {
630 XSRETURN_PV(msginfo->msgid);
631 }
632 else {
633 XSRETURN_UNDEF;
634 }
635 case 9:
636 if (msginfo->inreplyto) {
637 XSRETURN_PV(msginfo->inreplyto);
638 }
639 else {
640 XSRETURN_UNDEF;
641 }
642 case 10:
643 if (msginfo->xref) {
644 XSRETURN_PV(msginfo->xref);
645 }
646 else {
647 XSRETURN_UNDEF;
648 }
649 case 11:
650 xface = procmsg_msginfo_get_avatar(msginfo, AVATAR_XFACE);
651 if (xface) {
652 XSRETURN_PV(xface);
653 }
654 else {
655 XSRETURN_UNDEF;
656 }
657 case 12:
658 if (msginfo->extradata && msginfo->extradata->dispositionnotificationto) {
659 XSRETURN_PV(msginfo->extradata->dispositionnotificationto);
660 }
661 else {
662 XSRETURN_UNDEF;
663 }
664 case 13:
665 if (msginfo->extradata && msginfo->extradata->returnreceiptto) {
666 XSRETURN_PV(msginfo->extradata->returnreceiptto);
667 }
668 else {
669 XSRETURN_UNDEF;
670 }
671 case 14:
672 EXTEND(SP, g_slist_length(msginfo->references));
673 ii = 0;
674 for(walk = msginfo->references; walk != NULL; walk = g_slist_next(walk))
675 XST_mPV(ii++,walk->data ? (gchar*) walk->data: "");
676 if (ii) {
677 XSRETURN(ii);
678 }
679 else {
680 XSRETURN_UNDEF;
681 }
682 case 15:
683 if (msginfo->score) {
684 XSRETURN_IV(msginfo->score);
685 }
686 else {
687 XSRETURN_UNDEF;
688 }
689 case 17:
690 if (msginfo->plaintext_file) {
691 XSRETURN_PV(msginfo->plaintext_file);
692 }
693 else {
694 XSRETURN_UNDEF;
695 }
696 case 19:
697 if (msginfo->hidden) {
698 XSRETURN_IV(msginfo->hidden);
699 }
700 else {
701 XSRETURN_UNDEF;
702 }
703 case 20:
704 if((charp = procmsg_get_message_file_path(msginfo)) != NULL) {
705 strncpy2(buf,charp,sizeof(buf));
706 g_free(charp);
707 XSRETURN_PV(buf);
708 }
709 else {
710 XSRETURN_UNDEF;
711 }
712 case 21:
713 if (msginfo->extradata && msginfo->extradata->partial_recv) {
714 XSRETURN_PV(msginfo->extradata->partial_recv);
715 }
716 else {
717 XSRETURN_UNDEF;
718 }
719 case 22:
720 if (msginfo->total_size) {
721 XSRETURN_IV(msginfo->total_size);
722 }
723 else {
724 XSRETURN_UNDEF;
725 }
726 case 23:
727 if (msginfo->extradata && msginfo->extradata->account_server) {
728 XSRETURN_PV(msginfo->extradata->account_server);
729 }
730 else {
731 XSRETURN_UNDEF;
732 }
733 case 24:
734 if (msginfo->extradata && msginfo->extradata->account_login) {
735 XSRETURN_PV(msginfo->extradata->account_login);
736 }
737 else {
738 XSRETURN_UNDEF;
739 }
740 case 25:
741 if (msginfo->planned_download) {
742 XSRETURN_IV(msginfo->planned_download);
743 }
744 else {
745 XSRETURN_UNDEF;
746 }
747
748 /* general */
749 case 100:
750 if(manual_filtering) {
751 XSRETURN_YES;
752 }
753 else {
754 XSRETURN_NO;
755 }
756 default:
757 g_warning("Perl plugin: wrong argument to ClawsMail::C::init");
758 XSRETURN_UNDEF;
759 }
760 }
761
762 /* ClawsMail::C::open_mail_file */
763 static XS(XS_ClawsMail_open_mail_file)
764 {
765 char *file;
766
767 dXSARGS;
768 if(items != 0) {
769 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::open_mail_file");
770 XSRETURN_UNDEF;
771 }
772 file = procmsg_get_message_file_path(msginfo);
773 if(!file) {
774 XSRETURN_UNDEF;
775 }
776 if((message_file = claws_fopen(file, "rb")) == NULL) {
777 FILE_OP_ERROR(file, "claws_fopen");
778 g_warning("Perl plugin: file open error in ClawsMail::C::open_mail_file");
779 g_free(file);
780 XSRETURN_UNDEF;
781 }
782 g_free(file);
783 }
784
785 /* ClawsMail::C::close_mail_file */
786 static XS(XS_ClawsMail_close_mail_file)
787 {
788 dXSARGS;
789 if(items != 0) {
790 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::close_mail_file");
791 XSRETURN_UNDEF;
792 }
793 if(message_file != NULL)
794 claws_fclose(message_file);
795 XSRETURN_YES;
796 }
797
798 /* ClawsMail::C::get_next_header */
799 static XS(XS_ClawsMail_get_next_header)
800 {
801 gchar *buf;
802 Header *header;
803
804 dXSARGS;
805 if(items != 0) {
806 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::get_next_header");
807 XSRETURN_EMPTY;
808 }
809 if(message_file == NULL) {
810 g_warning("Perl plugin: message file not open. Use ClawsMail::C::open_message_file first");
811 XSRETURN_EMPTY;
812 }
813 if(procheader_get_one_field(&buf, message_file, NULL) != -1) {
814 header = procheader_parse_header(buf);
815 EXTEND(SP, 2);
816 if(header) {
817 XST_mPV(0,header->name);
818 XST_mPV(1,header->body);
819 procheader_header_free(header);
820 }
821 else {
822 XST_mPV(0,"");
823 XST_mPV(1,"");
824 }
825 g_free(buf);
826 XSRETURN(2);
827 }
828 else {
829 XSRETURN_EMPTY;
830 }
831 }
832
833 /* ClawsMail::C::get_next_body_line */
834 static XS(XS_ClawsMail_get_next_body_line)
835 {
836 gchar buf[BUFFSIZE];
837
838 dXSARGS;
839 if(items != 0) {
840 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::get_next_body_line");
841 XSRETURN_UNDEF;
842 }
843 if(message_file == NULL) {
844 g_warning("Perl plugin: message file not open. Use ClawsMail::C::open_message_file first");
845 XSRETURN_UNDEF;
846 }
847 if(claws_fgets(buf, sizeof(buf), message_file) != NULL) {
848 XSRETURN_PV(buf);
849 }
850 else {
851 XSRETURN_UNDEF;
852 }
853 }
854
855
856 /* Filter matchers */
857
858 /* ClawsMail::C::check_flag(int) */
859 static XS(XS_ClawsMail_check_flag)
860 {
861 int flag;
862 /* flags: 1 marked
863 * 2 unread
864 * 3 deleted
865 * 4 new
866 * 5 replied
867 * 6 forwarded
868 * 7 locked
869 * 8 ignore thread
870 */
871
872 dXSARGS;
873 if(items != 1) {
874 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::check_flag");
875 XSRETURN_UNDEF;
876 }
877 flag = SvIV(ST(0));
878
879 switch(flag) {
880 case 1:
881 if(MSG_IS_MARKED(msginfo->flags)) {
882 filter_log_write(LOG_MATCH,"marked");
883 XSRETURN_YES;
884 }
885 else {
886 XSRETURN_NO;
887 }
888 case 2:
889 if(MSG_IS_UNREAD(msginfo->flags)) {
890 filter_log_write(LOG_MATCH,"unread");
891 XSRETURN_YES;
892 }
893 else {
894 XSRETURN_NO;
895 }
896 case 3:
897 if(MSG_IS_DELETED(msginfo->flags)) {
898 filter_log_write(LOG_MATCH,"deleted");
899 XSRETURN_YES;
900 }
901 else {
902 XSRETURN_NO;
903 }
904 case 4:
905 if(MSG_IS_NEW(msginfo->flags)) {
906 filter_log_write(LOG_MATCH,"new");
907 XSRETURN_YES;
908 }
909 else {
910 XSRETURN_NO;
911 }
912 case 5:
913 if(MSG_IS_REPLIED(msginfo->flags)) {
914 filter_log_write(LOG_MATCH,"replied");
915 XSRETURN_YES;
916 }
917 else {
918 XSRETURN_NO;
919 }
920 case 6:
921 if(MSG_IS_FORWARDED(msginfo->flags)) {
922 filter_log_write(LOG_MATCH,"forwarded");
923 XSRETURN_YES;
924 }
925 else {
926 XSRETURN_NO;
927 }
928 case 7:
929 if(MSG_IS_LOCKED(msginfo->flags)) {
930 filter_log_write(LOG_MATCH,"locked");
931 XSRETURN_YES;
932 }
933 else {
934 XSRETURN_NO;
935 }
936 case 8:
937 if(MSG_IS_IGNORE_THREAD(msginfo->flags)) {
938 filter_log_write(LOG_MATCH,"ignore_thread");
939 XSRETURN_YES;
940 }
941 else {
942 XSRETURN_NO;
943 }
944 default:
945 g_warning("Perl plugin: unknown argument to ClawsMail::C::check_flag");
946 XSRETURN_UNDEF;
947 }
948 }
949
950 /* ClawsMail::C::colorlabel(int) */
951 static XS(XS_ClawsMail_colorlabel)
952 {
953 int color;
954
955 dXSARGS;
956 if(items != 1) {
957 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::colorlabel");
958 XSRETURN_UNDEF;
959 }
960 color = SvIV(ST(0));
961
962 if((MSG_GET_COLORLABEL_VALUE(msginfo->flags) == (guint32)color)) {
963 filter_log_write(LOG_MATCH,"colorlabel");
964 XSRETURN_YES;
965 }
966 else {
967 XSRETURN_NO;
968 }
969 }
970
971 /* ClawsMail::C::age_greater(int) */
972 static XS(XS_ClawsMail_age_greater)
973 {
974 int age;
975 time_t t;
976
977 dXSARGS;
978 if(items != 1) {
979 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::age_greater");
980 XSRETURN_UNDEF;
981 }
982 age = SvIV(ST(0));
983 t = time(NULL);
984 if(((t - msginfo->date_t) / 86400) >= age) {
985 filter_log_write(LOG_MATCH,"age_greater");
986 XSRETURN_YES;
987 }
988 else {
989 XSRETURN_NO;
990 }
991 }
992
993 /* ClawsMail::C::age_lower(int) */
994 static XS(XS_ClawsMail_age_lower)
995 {
996 int age;
997 time_t t;
998
999 dXSARGS;
1000 if(items != 1) {
1001 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::age_lower");
1002 XSRETURN_UNDEF;
1003 }
1004 age = SvIV(ST(0));
1005 t = time(NULL);
1006 if(((t - msginfo->date_t) / 86400) <= age) {
1007 filter_log_write(LOG_MATCH,"age_lower");
1008 XSRETURN_YES;
1009 }
1010 else {
1011 XSRETURN_NO;
1012 }
1013 }
1014
1015 /* ClawsMail::C::tagged() */
1016 static XS(XS_ClawsMail_tagged)
1017 {
1018 dXSARGS;
1019 if(items != 0) {
1020 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::tagged");
1021 XSRETURN_UNDEF;
1022 }
1023
1024 if (msginfo->tags) {
1025 XSRETURN_YES;
1026 }
1027 else {
1028 XSRETURN_NO;
1029 }
1030 }
1031
1032 /* ClawsMail::C::get_tags() */
1033 static XS(XS_ClawsMail_get_tags)
1034 {
1035 guint iTag;
1036 guint num_tags;
1037 GSList *walk;
1038
1039 dXSARGS;
1040 if(items != 0) {
1041 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::get_tags");
1042 XSRETURN_UNDEF;
1043 }
1044
1045 num_tags = g_slist_length(msginfo->tags);
1046
1047 EXTEND(SP, num_tags);
1048 iTag = 0;
1049 for(walk = msginfo->tags; walk != NULL; walk = g_slist_next(walk)) {
1050 const char *tag_str;
1051 tag_str = tags_get_tag(GPOINTER_TO_INT(walk->data));
1052 XST_mPV(iTag++, tag_str ? tag_str: "");
1053 }
1054
1055 XSRETURN(num_tags);
1056 }
1057
1058
1059
1060 /* ClawsMail::C::set_tag(char*) */
1061 static XS(XS_ClawsMail_set_tag)
1062 {
1063 gchar *tag_str;
1064 gint tag_id;
1065
1066 dXSARGS;
1067 if(items != 1) {
1068 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::set_tag");
1069 XSRETURN_UNDEF;
1070 }
1071
1072 tag_str = SvPV_nolen(ST(0));
1073 tag_id = tags_get_id_for_str(tag_str);
1074 if(tag_id == -1) {
1075 g_warning("Perl plugin: set_tag requested setting of a non-existing tag");
1076 XSRETURN_UNDEF;
1077 }
1078
1079 procmsg_msginfo_update_tags(msginfo, TRUE, tag_id);
1080
1081 XSRETURN_YES;
1082 }
1083
1084 /* ClawsMail::C::unset_tag(char*) */
1085 static XS(XS_ClawsMail_unset_tag)
1086 {
1087 gchar *tag_str;
1088 gint tag_id;
1089
1090 dXSARGS;
1091 if(items != 1) {
1092 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::unset_tag");
1093 XSRETURN_UNDEF;
1094 }
1095
1096 tag_str = SvPV_nolen(ST(0));
1097 tag_id = tags_get_id_for_str(tag_str);
1098 if(tag_id == -1) {
1099 g_warning("Perl plugin: unset_tag requested setting of a non-existing tag");
1100 XSRETURN_UNDEF;
1101 }
1102
1103 procmsg_msginfo_update_tags(msginfo, FALSE, tag_id);
1104
1105 XSRETURN_YES;
1106 }
1107
1108 /* ClawsMail::C::clear_tags() */
1109 static XS(XS_ClawsMail_clear_tags)
1110 {
1111 dXSARGS;
1112 if(items != 0) {
1113 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::clear_tags");
1114 XSRETURN_UNDEF;
1115 }
1116
1117 procmsg_msginfo_clear_tags(msginfo);
1118 XSRETURN_YES;
1119 }
1120
1121
1122 /* ClawsMail::C::make_sure_tag_exists(char*) */
1123 static XS(XS_ClawsMail_make_sure_tag_exists)
1124 {
1125 gchar *tag_str;
1126
1127 dXSARGS;
1128 if(items != 1) {
1129 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::make_sure_tag_exists");
1130 XSRETURN_UNDEF;
1131 }
1132
1133 tag_str = SvPV_nolen(ST(0));
1134
1135 if(IS_NOT_RESERVED_TAG(tag_str) == FALSE) {
1136 g_warning("Perl plugin: trying to create a tag with a reserved name: %s", tag_str);
1137 XSRETURN_UNDEF;
1138 }
1139
1140 tags_add_tag(tag_str);
1141
1142 XSRETURN_YES;
1143 }
1144
1145
1146
1147 /* ClawsMail::C::make_sure_folder_exists(char*) */
1148 static XS(XS_ClawsMail_make_sure_folder_exists)
1149 {
1150 gchar *identifier;
1151 FolderItem *item;
1152
1153 dXSARGS;
1154 if(items != 1) {
1155 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::make_sure_folder_exists");
1156 XSRETURN_UNDEF;
1157 }
1158
1159 identifier = SvPV_nolen(ST(0));
1160 item = folder_get_item_from_identifier(identifier);
1161 if(item) {
1162 XSRETURN_YES;
1163 }
1164 else {
1165 XSRETURN_NO;
1166 }
1167 }
1168
1169
1170 /* ClawsMail::C::addr_in_addressbook(char* [, char*]) */
1171 static XS(XS_ClawsMail_addr_in_addressbook)
1172 {
1173 gchar *addr;
1174 gchar *bookname;
1175 gboolean found;
1176
1177 dXSARGS;
1178 if(items != 1 && items != 2) {
1179 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::addr_in_addressbook");
1180 XSRETURN_UNDEF;
1181 }
1182
1183 addr = SvPV_nolen(ST(0));
1184
1185 if(items == 1) {
1186 found = addr_in_addressbook(addr,NULL);
1187 }
1188 else {
1189 bookname = SvPV_nolen(ST(1));
1190 found = addr_in_addressbook(addr,bookname);
1191 }
1192
1193 if(found) {
1194 filter_log_write(LOG_MATCH,"addr_in_addressbook");
1195 XSRETURN_YES;
1196 }
1197 else {
1198 XSRETURN_NO;
1199 }
1200 }
1201
1202
1203 /* Filter actions */
1204
1205 /* ClawsMail::C::set_flag(int) */
1206 static XS(XS_ClawsMail_set_flag)
1207 {
1208 int flag;
1209 /* flags: 1 mark
1210 * 2 mark as unread
1211 * 7 lock
1212 */
1213
1214 dXSARGS;
1215 if(items != 1) {
1216 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::set_flag");
1217 XSRETURN_UNDEF;
1218 }
1219 flag = SvIV(ST(0));
1220
1221 switch(flag) {
1222 case 1:
1223 MSG_SET_PERM_FLAGS(msginfo->flags, MSG_MARKED);
1224 procmsg_msginfo_set_flags(msginfo, MSG_MARKED,0);
1225 filter_log_write(LOG_ACTION,"mark");
1226 XSRETURN_YES;
1227 case 2:
1228 MSG_SET_PERM_FLAGS(msginfo->flags, MSG_UNREAD);
1229 procmsg_msginfo_set_flags(msginfo, MSG_UNREAD,0);
1230 filter_log_write(LOG_ACTION,"mark_as_unread");
1231 XSRETURN_YES;
1232 case 7:
1233 MSG_SET_PERM_FLAGS(msginfo->flags, MSG_LOCKED);
1234 procmsg_msginfo_set_flags(msginfo, MSG_LOCKED,0);
1235 filter_log_write(LOG_ACTION,"lock");
1236 XSRETURN_YES;
1237 default:
1238 g_warning("Perl plugin: unknown argument to ClawsMail::C::set_flag");
1239 XSRETURN_UNDEF;
1240 }
1241 }
1242
1243 /* ClawsMail::C::unset_flag(int) */
1244 static XS(XS_ClawsMail_unset_flag)
1245 {
1246 int flag;
1247 /*
1248 * flags: 1 unmark
1249 * 2 mark as read
1250 * 7 unlock
1251 */
1252
1253 dXSARGS;
1254 if(items != 1) {
1255 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::unset_flag");
1256 XSRETURN_UNDEF;
1257 }
1258 flag = SvIV(ST(0));
1259
1260 switch(flag) {
1261 case 1:
1262 MSG_UNSET_PERM_FLAGS(msginfo->flags, MSG_MARKED);
1263 procmsg_msginfo_unset_flags(msginfo, MSG_MARKED,0);
1264 filter_log_write(LOG_ACTION,"unmark");
1265 XSRETURN_YES;
1266 case 2:
1267 MSG_UNSET_PERM_FLAGS(msginfo->flags, MSG_UNREAD | MSG_NEW);
1268 procmsg_msginfo_unset_flags(msginfo, MSG_UNREAD | MSG_NEW,0);
1269 filter_log_write(LOG_ACTION,"mark_as_read");
1270 XSRETURN_YES;
1271 case 7:
1272 MSG_UNSET_PERM_FLAGS(msginfo->flags, MSG_LOCKED);
1273 procmsg_msginfo_unset_flags(msginfo, MSG_LOCKED,0);
1274 filter_log_write(LOG_ACTION,"unlock");
1275 XSRETURN_YES;
1276 default:
1277 g_warning("Perl plugin: unknown argument to ClawsMail::C::unset_flag");
1278 XSRETURN_UNDEF;
1279 }
1280 }
1281
1282 /* ClawsMail::C::move(char*) */
1283 static XS(XS_ClawsMail_move)
1284 {
1285 gchar *targetfolder;
1286 gchar *logtext;
1287 FolderItem *dest_folder;
1288
1289 dXSARGS;
1290 if(items != 1) {
1291 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::move");
1292 XSRETURN_UNDEF;
1293 }
1294
1295 targetfolder = SvPV_nolen(ST(0));
1296 dest_folder = folder_find_item_from_identifier(targetfolder);
1297
1298 if (!dest_folder) {
1299 g_warning("Perl plugin: move: folder not found '%s'",
1300 targetfolder ? targetfolder :"");
1301 XSRETURN_UNDEF;
1302 }
1303 if (folder_item_move_msg(dest_folder, msginfo) == -1) {
1304 g_warning("Perl plugin: move: could not move message");
1305 XSRETURN_UNDEF;
1306 }
1307 stop_filtering = TRUE;
1308 logtext = g_strconcat("move to ", targetfolder, NULL);
1309 filter_log_write(LOG_ACTION, logtext);
1310 g_free(logtext);
1311 XSRETURN_YES;
1312 }
1313
1314 /* ClawsMail::C::copy(char*) */
1315 static XS(XS_ClawsMail_copy)
1316 {
1317 char *targetfolder;
1318 gchar *logtext;
1319 FolderItem *dest_folder;
1320
1321 dXSARGS;
1322 if(items != 1) {
1323 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::copy");
1324 XSRETURN_UNDEF;
1325 }
1326 targetfolder = SvPV_nolen(ST(0));
1327 dest_folder = folder_find_item_from_identifier(targetfolder);
1328
1329 if (!dest_folder) {
1330 g_warning("Perl plugin: copy: folder not found '%s'",
1331 targetfolder ? targetfolder :"");
1332 XSRETURN_UNDEF;
1333 }
1334 if (folder_item_copy_msg(dest_folder, msginfo) == -1) {
1335 g_warning("Perl plugin: copy: could not copy message");
1336 XSRETURN_UNDEF;
1337 }
1338 logtext = g_strconcat("copy to ", targetfolder, NULL);
1339 filter_log_write(LOG_ACTION, logtext);
1340 g_free(logtext);
1341 XSRETURN_YES;
1342 }
1343
1344 /* ClawsMail::C::delete */
1345 static XS(XS_ClawsMail_delete)
1346 {
1347 dXSARGS;
1348 if(items != 0) {
1349 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::delete");
1350 XSRETURN_UNDEF;
1351 }
1352 folder_item_remove_msg(msginfo->folder, msginfo->msgnum);
1353 stop_filtering = TRUE;
1354 filter_log_write(LOG_ACTION, "delete");
1355 XSRETURN_YES;
1356 }
1357
1358 /* ClawsMail::C::hide */
1359 static XS(XS_ClawsMail_hide)
1360 {
1361 dXSARGS;
1362 if(items != 0) {
1363 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::hide");
1364 XSRETURN_UNDEF;
1365 }
1366 msginfo->hidden = TRUE;
1367 filter_log_write(LOG_ACTION, "hide");
1368 XSRETURN_YES;
1369 }
1370
1371
1372 /* ClawsMail::C::color(int) */
1373 static XS(XS_ClawsMail_color)
1374 {
1375 int color;
1376 gchar *logtext;
1377
1378 dXSARGS;
1379 if(items != 1) {
1380 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::color");
1381 XSRETURN_UNDEF;
1382 }
1383 color = SvIV(ST(0));
1384 procmsg_msginfo_unset_flags(msginfo, MSG_CLABEL_FLAG_MASK, 0);
1385 procmsg_msginfo_set_flags(msginfo, MSG_COLORLABEL_TO_FLAGS(color), 0);
1386 MSG_SET_COLORLABEL_VALUE(msginfo->flags,color);
1387
1388 logtext = g_strdup_printf("color: %d", color);
1389 filter_log_write(LOG_ACTION, logtext);
1390 g_free(logtext);
1391
1392 XSRETURN_YES;
1393 }
1394
1395 /* ClawsMail::C::change_score(int) */
1396 static XS(XS_ClawsMail_change_score)
1397 {
1398 int score;
1399 gchar *logtext;
1400
1401 dXSARGS;
1402 if(items != 1) {
1403 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::change_score");
1404 XSRETURN_UNDEF;
1405 }
1406 score = SvIV(ST(0));
1407 msginfo->score += score;
1408
1409 logtext = g_strdup_printf("change score: %+d", score);
1410 filter_log_write(LOG_ACTION, logtext);
1411 g_free(logtext);
1412
1413 XSRETURN_IV(msginfo->score);
1414 }
1415
1416 /* ClawsMail::C::set_score(int) */
1417 static XS(XS_ClawsMail_set_score)
1418 {
1419 int score;
1420 gchar *logtext;
1421
1422 dXSARGS;
1423 if(items != 1) {
1424 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::set_score");
1425 XSRETURN_UNDEF;
1426 }
1427 score = SvIV(ST(0));
1428 msginfo->score = score;
1429
1430 logtext = g_strdup_printf("set score: %d", score);
1431 filter_log_write(LOG_ACTION, logtext);
1432 g_free(logtext);
1433
1434 XSRETURN_IV(msginfo->score);
1435 }
1436
1437 /* ClawsMail::C::forward(int,int,char*) */
1438 static XS(XS_ClawsMail_forward)
1439 {
1440 int flag;
1441 /* flags: 1 forward
1442 * 2 forward as attachment
1443 */
1444 int account_id,val;
1445 char *dest;
1446 gchar *logtext;
1447 PrefsAccount *account;
1448 Compose *compose;
1449
1450 dXSARGS;
1451 if(items != 3) {
1452 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::forward");
1453 XSRETURN_UNDEF;
1454 }
1455
1456 flag = SvIV(ST(0));
1457 account_id = SvIV(ST(1));
1458 dest = SvPV_nolen(ST(2));
1459
1460 account = account_find_from_id(account_id);
1461 compose = compose_forward(account, msginfo,
1462 flag == 1 ? FALSE : TRUE,
1463 NULL, TRUE, TRUE);
1464 compose_entry_append(compose, dest,
1465 compose->account->protocol == A_NNTP ?
1466 COMPOSE_NEWSGROUPS : COMPOSE_TO, PREF_NONE);
1467
1468 val = compose_send(compose);
1469
1470 if(val == 0) {
1471
1472 logtext = g_strdup_printf("forward%s to %s",
1473 flag==2 ? " as attachment" : "",
1474 dest ? dest : "<unknown destination>");
1475 filter_log_write(LOG_ACTION, logtext);
1476 g_free(logtext);
1477
1478 XSRETURN_YES;
1479 }
1480 else {
1481 XSRETURN_UNDEF;
1482 }
1483 }
1484
1485 /* ClawsMail::C::redirect(int,char*) */
1486 static XS(XS_ClawsMail_redirect)
1487 {
1488 int account_id,val;
1489 char *dest;
1490 gchar *logtext;
1491 PrefsAccount *account;
1492 Compose *compose;
1493
1494 dXSARGS;
1495 if(items != 2) {
1496 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::redirect");
1497 XSRETURN_UNDEF;
1498 }
1499
1500 account_id = SvIV(ST(0));
1501 dest = SvPV_nolen(ST(1));
1502
1503 account = account_find_from_id(account_id);
1504 compose = compose_redirect(account, msginfo, TRUE);
1505
1506 if (compose->account->protocol == A_NNTP) {
1507 XSRETURN_UNDEF;
1508 }
1509 else
1510 compose_entry_append(compose, dest, COMPOSE_TO, PREF_NONE);
1511
1512 val = compose_send(compose);
1513
1514 if(val == 0) {
1515
1516 logtext = g_strdup_printf("redirect to %s",
1517 dest ? dest : "<unknown destination>");
1518 filter_log_write(LOG_ACTION, logtext);
1519 g_free(logtext);
1520
1521 XSRETURN_YES;
1522 }
1523 else {
1524 XSRETURN_UNDEF;
1525 }
1526 }
1527
1528
1529 /* Utilities */
1530
1531 /* ClawsMail::C::move_to_trash */
1532 static XS(XS_ClawsMail_move_to_trash)
1533 {
1534 FolderItem *dest_folder;
1535
1536 dXSARGS;
1537 if(items != 0) {
1538 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::move_to_trash");
1539 XSRETURN_UNDEF;
1540 }
1541 dest_folder = folder_get_default_trash();
1542 if (!dest_folder) {
1543 g_warning("Perl plugin: move_to_trash: Trash folder not found");
1544 XSRETURN_UNDEF;
1545 }
1546 if (folder_item_move_msg(dest_folder, msginfo) == -1) {
1547 g_warning("Perl plugin: move_to_trash: could not move message to trash");
1548 XSRETURN_UNDEF;
1549 }
1550 stop_filtering = TRUE;
1551 filter_log_write(LOG_ACTION, "move_to_trash");
1552 XSRETURN_YES;
1553 }
1554
1555 /* ClawsMail::C::abort */
1556 static XS(XS_ClawsMail_abort)
1557 {
1558 FolderItem *inbox_folder;
1559
1560 dXSARGS;
1561 if(items != 0) {
1562 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::abort");
1563 XSRETURN_UNDEF;
1564 }
1565 if(!manual_filtering) {
1566 inbox_folder = folder_get_default_inbox();
1567 if (!inbox_folder) {
1568 g_warning("Perl plugin: abort: inbox folder not found");
1569 XSRETURN_UNDEF;
1570 }
1571 if (folder_item_move_msg(inbox_folder, msginfo) == -1) {
1572 g_warning("Perl plugin: abort: could not move message to default inbox");
1573 XSRETURN_UNDEF;
1574 }
1575 filter_log_write(LOG_ACTION, "abort -- message moved to default inbox");
1576 }
1577 else
1578 filter_log_write(LOG_ACTION, "abort");
1579
1580 stop_filtering = TRUE;
1581 XSRETURN_YES;
1582 }
1583
1584 /* ClawsMail::C::get_attribute_value(char*,char*[,char*]) */
1585 static XS(XS_ClawsMail_get_attribute_value)
1586 {
1587 char *addr;
1588 char *attr;
1589 char *attribute_value;
1590 char *bookname;
1591
1592 dXSARGS;
1593 if(items != 2 && items != 3) {
1594 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::get_attribute_value");
1595 XSRETURN_UNDEF;
1596 }
1597 addr = SvPV_nolen(ST(0));
1598 attr = SvPV_nolen(ST(1));
1599
1600 if(items == 2)
1601 attribute_value = get_attribute_value(addr,attr,NULL);
1602 else {
1603 bookname = SvPV_nolen(ST(2));
1604 attribute_value = get_attribute_value(addr,attr,bookname);
1605 }
1606
1607 if(attribute_value) {
1608 XSRETURN_PV(attribute_value);
1609 }
1610 XSRETURN_PV("");
1611 }
1612
1613 /* ClawsMail::C::filter_log(char*,char*) */
1614 static XS(XS_ClawsMail_filter_log)
1615 {
1616 char *text;
1617 char *type;
1618
1619 dXSARGS;
1620 if(items != 2) {
1621 g_warning("Perl plugin: wrong number of arguments to ClawsMail::C::filter_log");
1622 XSRETURN_UNDEF;
1623 }
1624 type = SvPV_nolen(ST(0));
1625 text = SvPV_nolen(ST(1));
1626 if(!strcmp(type, "LOG_ACTION"))
1627 filter_log_write(LOG_ACTION, text);
1628 else if(!strcmp(type, "LOG_MANUAL"))
1629 filter_log_write(LOG_MANUAL, text);
1630 else if(!strcmp(type, "LOG_MATCH"))
1631 filter_log_write(LOG_MATCH, text);
1632 else {
1633 g_warning("Perl plugin: ClawsMail::C::filter_log -- wrong first argument");
1634 XSRETURN_UNDEF;
1635 }
1636 XSRETURN_YES;
1637 }
1638
1639 /* ClawsMail::C::filter_log_verbosity(int) */
1640 static XS(XS_ClawsMail_filter_log_verbosity)
1641 {
1642 int retval;
1643
1644 dXSARGS;
1645 if(items != 1 && items != 0) {
1646 g_warning("Perl plugin: wrong number of arguments to "
1647 "ClawsMail::C::filter_log_verbosity");
1648 XSRETURN_UNDEF;
1649 }
1650 retval = filter_log_verbosity;
1651
1652 if(items == 1)
1653 filter_log_verbosity = SvIV(ST(0));
1654
1655 XSRETURN_IV(retval);
1656 }
1657
1658 /* register extensions */
1659 EXTERN_C void xs_init(pTHX)
1660 {
1661 char *file = __FILE__;
1662 dXSUB_SYS;
1663 newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1664 newXS("ClawsMail::C::filter_init", XS_ClawsMail_filter_init, "ClawsMail::C");
1665 newXS("ClawsMail::C::check_flag", XS_ClawsMail_check_flag, "ClawsMail::C");
1666 newXS("ClawsMail::C::age_greater", XS_ClawsMail_age_greater, "ClawsMail::C");
1667 newXS("ClawsMail::C::age_lower", XS_ClawsMail_age_lower, "ClawsMail::C");
1668 newXS("ClawsMail::C::tagged", XS_ClawsMail_tagged, "ClawsMail::C");
1669 newXS("ClawsMail::C::set_flag", XS_ClawsMail_set_flag, "ClawsMail::C");
1670 newXS("ClawsMail::C::unset_flag", XS_ClawsMail_unset_flag, "ClawsMail::C");
1671 newXS("ClawsMail::C::delete", XS_ClawsMail_delete, "ClawsMail::C");
1672 newXS("ClawsMail::C::move", XS_ClawsMail_move, "ClawsMail::C");
1673 newXS("ClawsMail::C::copy", XS_ClawsMail_copy, "ClawsMail::C");
1674 newXS("ClawsMail::C::color", XS_ClawsMail_color, "ClawsMail::C");
1675 newXS("ClawsMail::C::colorlabel", XS_ClawsMail_colorlabel, "ClawsMail::C");
1676 newXS("ClawsMail::C::change_score", XS_ClawsMail_change_score, "ClawsMail::C");
1677 newXS("ClawsMail::C::set_score", XS_ClawsMail_set_score, "ClawsMail::C");
1678 newXS("ClawsMail::C::hide", XS_ClawsMail_hide, "ClawsMail::C");
1679 newXS("ClawsMail::C::forward", XS_ClawsMail_forward, "ClawsMail::C");
1680 newXS("ClawsMail::C::redirect", XS_ClawsMail_redirect, "ClawsMail::C");
1681 newXS("ClawsMail::C::set_tag", XS_ClawsMail_set_tag, "ClawsMail::C");
1682 newXS("ClawsMail::C::unset_tag", XS_ClawsMail_unset_tag, "ClawsMail::C");
1683 newXS("ClawsMail::C::clear_tags", XS_ClawsMail_clear_tags, "ClawsMail::C");
1684 newXS("ClawsMail::C::make_sure_folder_exists",
1685 XS_ClawsMail_make_sure_folder_exists,"ClawsMail::C");
1686 newXS("ClawsMail::C::make_sure_tag_exists", XS_ClawsMail_make_sure_tag_exists,"ClawsMail::C");
1687 newXS("ClawsMail::C::get_tags", XS_ClawsMail_get_tags,"ClawsMail::C");
1688 newXS("ClawsMail::C::addr_in_addressbook",
1689 XS_ClawsMail_addr_in_addressbook,"ClawsMail::C");
1690 newXS("ClawsMail::C::open_mail_file",
1691 XS_ClawsMail_open_mail_file,"ClawsMail::C");
1692 newXS("ClawsMail::C::close_mail_file",
1693 XS_ClawsMail_close_mail_file,"ClawsMail::C");
1694 newXS("ClawsMail::C::get_next_header",
1695 XS_ClawsMail_get_next_header,"ClawsMail::C");
1696 newXS("ClawsMail::C::get_next_body_line",
1697 XS_ClawsMail_get_next_body_line,"ClawsMail::C");
1698 newXS("ClawsMail::C::move_to_trash",XS_ClawsMail_move_to_trash,"ClawsMail::C");
1699 newXS("ClawsMail::C::abort", XS_ClawsMail_abort, "ClawsMail::C");
1700 newXS("ClawsMail::C::get_attribute_value",
1701 XS_ClawsMail_get_attribute_value,"ClawsMail::C");
1702 newXS("ClawsMail::C::filter_log", XS_ClawsMail_filter_log, "ClawsMail::C");
1703 newXS("ClawsMail::C::filter_log_verbosity",
1704 XS_ClawsMail_filter_log_verbosity, "ClawsMail::C");
1705 }
1706
1707 /*
1708 * The workhorse.
1709 * Returns: 0 on success
1710 * 1 error in scriptfile or invocation of external
1711 * editor -> retry
1712 * 2 error in scriptfile -> abort
1713 * (Yes, I know..)
1714 */
1715 static int perl_load_file(void)
1716 {
1717 gchar *args[] = {"", DO_CLEAN, NULL};
1718 gchar *noargs[] = { NULL };
1719 gchar *perlfilter;
1720 gchar **cmdline;
1721 gchar buf[1024];
1722 gchar *pp;
1723 STRLEN n_a;
1724
1725 call_argv("ClawsMail::Filter::Matcher::filter_init_",
1726 G_DISCARD | G_EVAL | G_NOARGS,noargs);
1727 /* check $@ */
1728 if(SvTRUE(ERRSV)) {
1729 debug_print("%s", SvPV(ERRSV,n_a));
1730 return 1;
1731 }
1732 perlfilter = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, PERLFILTER, NULL);
1733 args[0] = perlfilter;
1734 call_argv("ClawsMail::Persistent::eval_file",
1735 G_DISCARD | G_EVAL, args);
1736 g_free(perlfilter);
1737 if(SvTRUE(ERRSV)) {
1738 AlertValue val;
1739 gchar *message;
1740
1741 if(strstr(SvPV(ERRSV,n_a),"intended"))
1742 return 0;
1743
1744 debug_print("%s", SvPV(ERRSV,n_a));
1745 message = g_strdup_printf(_("Error processing Perl script file: "
1746 "(line numbers may not be valid)\n%s"),
1747 SvPV(ERRSV,n_a));
1748 val = alertpanel(_("Perl Plugin error"), message, NULL, _("Retry"), NULL,
1749 _("Abort"), NULL, _("Edit"), ALERTFOCUS_FIRST);
1750 g_free(message);
1751
1752 if(val == G_ALERTOTHER) {
1753 /* Open PERLFILTER in an external editor */
1754 perlfilter = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, PERLFILTER, NULL);
1755 if (prefs_common_get_ext_editor_cmd() &&
1756 (pp = strchr(prefs_common_get_ext_editor_cmd(), '%')) &&
1757 *(pp + 1) == 's' && !strchr(pp + 2, '%')) {
1758 g_snprintf(buf, sizeof(buf), prefs_common_get_ext_editor_cmd(), perlfilter);
1759 }
1760 else {
1761 if (prefs_common_get_ext_editor_cmd())
1762 g_warning("Perl plugin: External editor command-line is invalid: `%s'",
1763 prefs_common_get_ext_editor_cmd());
1764 g_snprintf(buf, sizeof(buf), "emacs %s", perlfilter);
1765 }
1766 g_free(perlfilter);
1767 cmdline = strsplit_with_quote(buf, " ", 1024);
1768 execute_detached(cmdline);
1769 g_strfreev(cmdline);
1770 return 1;
1771 }
1772 else if(val == G_ALERTDEFAULT)
1773 return 1;
1774 else
1775 return 2;
1776 }
1777
1778 return 0;
1779 }
1780
1781
1782 /* let there be magic */
1783 static int perl_init(void)
1784 {
1785 int exitstatus;
1786 char *initialize[] = { "", "-w", "-e", "1;"};
1787 /* The `persistent' module is taken from the Perl documentation
1788 and has only slightly been modified. */
1789 const char perl_persistent[] = {
1790 "package ClawsMail::Persistent;\n"
1791 "\n"
1792 "use strict;\n"
1793 "our %Cache;\n"
1794 "use Symbol qw(delete_package);\n"
1795 "\n"
1796 "sub valid_package_name {\n"
1797 " my($string) = @_;\n"
1798 " $string =~ s/([^A-Za-z0-9\\/])/sprintf(\"_%2x\",unpack(\"C\",$1))/eg;\n"
1799 " # second pass only for words starting with a digit\n"
1800 " $string =~ s|/(\\d)|sprintf(\"/_%2x\",unpack(\"C\",$1))|eg;\n"
1801 " \n"
1802 " # Dress it up as a real package name\n"
1803 " $string =~ s|/|::|g;\n"
1804 " return \"ClawsMail\" . $string;\n"
1805 "}\n"
1806 "\n"
1807 "sub eval_file {\n"
1808 " my($file, $delete) = @_;\n"
1809 " my $package = valid_package_name($file);\n"
1810 " my $mtime = -M $file;\n"
1811 " if(!(defined $Cache{$package}{mtime} &&\n"
1812 " $Cache{$package}{mtime} <= $mtime)) {\n"
1813 " delete_package($package) if defined $Cache{$package}{mtime};\n"
1814 " local *FH;\n"
1815 " open FH, $file or die \"Failed to open '$file': $!\";\n"
1816 " local($/) = undef;\n"
1817 " my $sub = <FH>;\n"
1818 " close FH;\n"
1819 " #wrap the code into a subroutine inside our unique package\n"
1820 " my $eval = qq{package $package;\n"
1821 " use ClawsMail::Filter::Matcher;\n"
1822 " use ClawsMail::Filter::Action;\n"
1823 " use ClawsMail::Utils;\n"
1824 " sub handler { $sub; }};\n"
1825 " {\n"
1826 " # hide our variables within this block\n"
1827 " my($file,$mtime,$package,$sub);\n"
1828 " eval $eval;\n"
1829 " }\n"
1830 " die $@ if $@;\n"
1831 " #cache it unless we're cleaning out each time\n"
1832 " $Cache{$package}{mtime} = $mtime unless $delete;\n"
1833 " }\n"
1834 " eval {$package->handler;};\n"
1835 " die $@ if $@;\n"
1836 " delete_package($package) if $delete;\n"
1837 "}\n"
1838 };
1839 const char perl_filter_matcher[] = {
1840 "BEGIN {$INC{'ClawsMail/Filter/Matcher.pm'} = 1;}\n"
1841 "package ClawsMail::Filter::Matcher;\n"
1842 "use locale;\n"
1843 "use base qw(Exporter);\n"
1844 "use strict;\n"
1845 "our @EXPORT = (qw(header body filepath manual),\n"
1846 " qw(filter_log_verbosity filter_log),\n"
1847 " qw(all marked unread deleted new replied),\n"
1848 " qw(forwarded locked colorlabel match matchcase),\n"
1849 " qw(regexp regexpcase test),\n"
1850 " qw(to cc subject from to_or_cc newsgroups inreplyto),\n"
1851 " qw(references body_part headers_part headers_cont message),\n"
1852 " qw(size_greater size_smaller size_equal),\n"
1853 " qw(score_greater score_lower score_equal),\n"
1854 " qw(age_greater age_lower partial tagged $permanent));\n"
1855 "# Global Variables\n"
1856 "our(%header,$body,%msginfo,$mail_done,$manual);\n"
1857 "our %colors = ('none' => 0,'orange' => 1,'red' => 2,\n"
1858 " 'pink' => 3,'sky blue' => 4,'blue' => 5,\n"
1859 " 'green' => 6,'brown' => 7);\n"
1860 "# For convenience\n"
1861 "sub lc2_ {\n"
1862 " my $arg = shift;\n"
1863 " if(defined $arg) {\n"
1864 " return lc $arg;\n"
1865 " }\n"
1866 " else {\n"
1867 " return \"\";\n"
1868 " }\n"
1869 "}\n"
1870 "sub to { return \"to\"; }\n"
1871 "sub cc { return \"cc\"; }\n"
1872 "sub from { return \"from\"; }\n"
1873 "sub subject { return \"subject\"; }\n"
1874 "sub to_or_cc { return \"to_or_cc\"; }\n"
1875 "sub newsgroups { return \"newsgroups\"; }\n"
1876 "sub inreplyto { return \"in-reply-to\"; }\n"
1877 "sub references { return \"references\"; }\n"
1878 "sub body_part { return \"body_part\"; }\n"
1879 "sub headers_part { return \"headers_part\"; }\n"
1880 "sub headers_cont { return \"headers_cont\"; }\n"
1881 "sub message { return \"message\"; }\n"
1882 "# access the mail directly\n"
1883 "sub header {\n"
1884 " my $key = shift;\n"
1885 " if(not defined $key) {\n"
1886 " init_();\n"
1887 " return keys %header;\n"
1888 " }\n"
1889 " $key = lc2_ $key; $key =~ s/:$//;\n"
1890 " init_() unless exists $header{$key};\n"
1891 " if(exists $header{$key}) {\n"
1892 " wantarray ? return @{$header{$key}} : return $header{$key}->[-1];\n"
1893 " }\n"
1894 " return undef;\n"
1895 "}\n"
1896 "sub body {init_();return $body;}\n"
1897 "sub filepath {return $msginfo{\"filepath\"};}\n"
1898 "sub manual {\n"
1899 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"manual\") if $manual;\n"
1900 " return $manual;\n"
1901 "}\n"
1902 "sub filter_log {\n"
1903 " my $arg1 = shift;\n"
1904 " my $arg2 = shift;\n"
1905 " return ClawsMail::C::filter_log($arg1,$arg2)\n"
1906 " if defined($arg2);\n"
1907 " return ClawsMail::C::filter_log(\"LOG_MANUAL\",$arg1);\n"
1908 "}\n"
1909 "sub filter_log_verbosity {\n"
1910 " $_ = shift;\n"
1911 " return ClawsMail::C::filter_log_verbosity($_)\n"
1912 " if defined($_);\n"
1913 " return ClawsMail::C::filter_log_verbosity();\n"
1914 "}\n"
1915 "# Public Matcher Tests\n"
1916 "sub all { ClawsMail::C::filter_log(\"LOG_MATCH\",\"all\");return 1; }\n"
1917 "sub marked { return ClawsMail::C::check_flag(1);}\n"
1918 "sub unread { return ClawsMail::C::check_flag(2);}\n"
1919 "sub deleted { return ClawsMail::C::check_flag(3);}\n"
1920 "sub new { return ClawsMail::C::check_flag(4);}\n"
1921 "sub replied { return ClawsMail::C::check_flag(5);}\n"
1922 "sub forwarded { return ClawsMail::C::check_flag(6);}\n"
1923 "sub locked { return ClawsMail::C::check_flag(7);}\n"
1924 "sub ignore_thread { return ClawsMail::C::check_flag(8);}\n"
1925 "sub age_greater {return ClawsMail::C::age_greater(@_);}\n"
1926 "sub age_lower {return ClawsMail::C::age_lower(@_); }\n"
1927 "sub tagged {return ClawsMail::C::tagged(@_); }\n"
1928 "sub score_equal {\n"
1929 " my $my_score = shift;\n"
1930 " return 0 unless (defined($msginfo{\"score\"}) and defined($my_score));\n"
1931 " if($my_score == $msginfo{\"score\"}) {\n"
1932 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"score_equal\");\n"
1933 " return 1;\n"
1934 " }else{return 0;}\n"
1935 "}\n"
1936 "sub score_greater {\n"
1937 " my $my_score = shift;\n"
1938 " return 0 unless (defined($msginfo{\"score\"}) and defined($my_score));\n"
1939 " if($msginfo{\"score\"} > $my_score) {\n"
1940 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"score_greater\");\n"
1941 " return 1;\n"
1942 " }else{return 0;}\n"
1943 "}\n"
1944 "sub score_lower {\n"
1945 " my $my_score = shift;\n"
1946 " return 0 unless (defined($msginfo{\"score\"}) and defined($my_score));\n"
1947 " if($msginfo{\"score\"} < $my_score) {\n"
1948 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"score_lower\");\n"
1949 " return 1;\n"
1950 " }else{return 0;}\n"
1951 "}\n"
1952 "sub colorlabel {\n"
1953 " my $color = shift;\n"
1954 " $color = lc2_ $color;\n"
1955 " $color = $colors{$color} if exists $colors{$color};\n"
1956 " $color = 0 if $color =~ m/\\D/;\n"
1957 " return ClawsMail::C::colorlabel($color);\n"
1958 "}\n"
1959 "sub size_greater {\n"
1960 " my $my_size = shift;\n"
1961 " return 0 unless (defined($msginfo{\"size\"}) and defined($my_size));\n"
1962 " if($msginfo{\"size\"} > $my_size) {\n"
1963 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"size_greater\");\n"
1964 " return 1;\n"
1965 " }else{return 0;}\n"
1966 "}\n"
1967 "sub size_smaller {\n"
1968 " my $my_size = shift;\n"
1969 " return 0 unless (defined($msginfo{\"size\"}) and defined($my_size));\n"
1970 " if($msginfo{\"size\"} < $my_size) {\n"
1971 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"size_smaller\");\n"
1972 " return 1;\n"
1973 " }else{return 0;}\n"
1974 "}\n"
1975 "sub size_equal {\n"
1976 " my $my_size = shift;\n"
1977 " return 0 unless (defined($msginfo{\"size\"}) and defined($my_size));\n"
1978 " if($msginfo{\"size\"} == $my_size) {\n"
1979 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"size_equal\");\n"
1980 " return 1;\n"
1981 " }else{return 0;}\n"
1982 "}\n"
1983 "sub partial {\n"
1984 " return 0 unless defined($msginfo{\"total_size\"})\n"
1985 " and defined($msginfo{\"size\"});\n"
1986 " if($msginfo{\"total_size\"} != 0\n"
1987 " && $msginfo{\"size\"} != $msginfo{\"total_size\"}) {\n"
1988 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"partial\");\n"
1989 " return 1;\n"
1990 " }else{return 0;}\n"
1991 "}\n"
1992 "sub test {\n"
1993 " $_ = shift; my $command = \"\"; my $hl=\"\"; my $re=\"\"; my $retval;\n"
1994 " my $cmdline = $_;\n"
1995 " s/\\\"/\"/g; #fool stupid emacs perl mode\";\n"
1996 " s/([^%]*)//; $command .= $1;\n"
1997 " while($_) {\n"
1998 " if (/^%%/){s/^%%([^%]*)//;$command .= \"\\\\%\".$1; next;}\n"
1999 " elsif(/^%s/){s/^%s([^%]*)//;$hl=header(\"subject\");$re=$1;}\n"
2000 " elsif(/^%f/){s/^%f([^%]*)//;$hl=header(\"from\");$re=$1;}\n"
2001 " elsif(/^%t/){s/^%t([^%]*)//;$hl=header(\"to\");$re=$1;}\n"
2002 " elsif(/^%c/){s/^%c([^%]*)//;$hl=header(\"cc\");$re=$1;}\n"
2003 " elsif(/^%d/){s/^%d([^%]*)//;$hl=header(\"date\");$re=$1;}\n"
2004 " elsif(/^%i/){s/^%i([^%]*)//;$hl=header(\"message-id\");$re=$1;}\n"
2005 " elsif(/^%n/){s/^%n([^%]*)//;$hl=header(\"newsgroups\");$re=$1;}\n"
2006 " elsif(/^%r/){s/^%r([^%]*)//;$hl=header(\"references\");$re=$1;}\n"
2007 " elsif(/^%F/){s/^%F([^%]*)//;$hl=filepath();$re=$1;}\n"
2008 " else {s/^(%[^%]*)//; $command .= $1;}\n"
2009 " $command .= \"\\Q$hl\\E\" if defined $hl;$hl=\"\";\n"
2010 " $command .= $re;$re=\"\";\n"
2011 " }\n"
2012 " $retval = !(system($command)>>8);\n"
2013 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"test: $cmdline\")\n"
2014 " if $retval;\n"
2015 " return $retval;\n"
2016 "}\n"
2017 "sub matchcase {\n"
2018 " my $retval;\n"
2019 " $retval = match_(@_,\"i\");\n"
2020 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"matchcase: $_[0], $_[1]\")\n"
2021 " if $retval;\n"
2022 " return $retval;\n"
2023 "}\n"
2024 "sub match {\n"
2025 " my $retval;\n"
2026 " $retval = match_(@_);\n"
2027 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"match: $_[0], $_[1]\")\n"
2028 " if $retval;\n"
2029 " return $retval;\n"
2030 "}\n"
2031 "sub regexpcase {\n"
2032 " my $retval;\n"
2033 " $retval = match_(@_,\"ri\");\n"
2034 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"regexpcase: $_[0], $_[1]\")\n"
2035 " if $retval;\n"
2036 " return $retval;\n"
2037 "}\n"
2038 "sub regexp {\n"
2039 " my $retval;\n"
2040 " $retval = match_(@_,\"r\");\n"
2041 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"regexp: $_[0], $_[1]\")\n"
2042 " if $retval;\n"
2043 " return $retval;\n"
2044 "}\n"
2045 "# Internals\n"
2046 "sub add_header_entries_ {\n"
2047 " my($key,@values) = @_; $key = lc2_ $key; $key =~ s/:$//;\n"
2048 " $header{$key} = [] unless exists $header{$key};\n"
2049 " push @{$header{$key}},@values;\n"
2050 "}\n"
2051 "# read whole mail\n"
2052 "sub init_ {\n"
2053 " return 0 if $mail_done;\n"
2054 " ClawsMail::C::open_mail_file();\n"
2055 " read_headers_();\n"
2056 " read_body_();\n"
2057 " ClawsMail::C::close_mail_file();\n"
2058 " $mail_done = 1;\n"
2059 "}\n"
2060 "sub filter_init_ {\n"
2061 " %header = (); %msginfo = (); undef $body; $mail_done = 0;\n"
2062 " $manual = ClawsMail::C::filter_init(100);\n"
2063 " $msginfo{\"size\"} = ClawsMail::C::filter_init( 1) ;\n"
2064 " add_header_entries_(\"date\", ClawsMail::C::filter_init( 2));\n"
2065 " add_header_entries_(\"from\", ClawsMail::C::filter_init( 3));\n"
2066 " add_header_entries_(\"to\", ClawsMail::C::filter_init( 4));\n"
2067 " add_header_entries_(\"cc\", ClawsMail::C::filter_init( 5));\n"
2068 " add_header_entries_(\"newsgroups\",ClawsMail::C::filter_init( 6));\n"
2069 " add_header_entries_(\"subject\", ClawsMail::C::filter_init( 7));\n"
2070 " add_header_entries_(\"msgid\", ClawsMail::C::filter_init( 8));\n"
2071 " add_header_entries_(\"inreplyto\", ClawsMail::C::filter_init( 9));\n"
2072 " add_header_entries_(\"xref\", ClawsMail::C::filter_init(10));\n"
2073 " add_header_entries_(\"xface\", ClawsMail::C::filter_init(11));\n"
2074 " add_header_entries_(\"dispositionnotificationto\",\n"
2075 " ClawsMail::C::filter_init(12));\n"
2076 " add_header_entries_(\"returnreceiptto\",\n"
2077 " ClawsMail::C::filter_init(13));\n"
2078 " add_header_entries_(\"references\",ClawsMail::C::filter_init(14));\n"
2079 " $msginfo{\"score\"} = ClawsMail::C::filter_init(15);\n"
2080 " $msginfo{\"plaintext_file\"} = ClawsMail::C::filter_init(17);\n"
2081 " $msginfo{\"hidden\"} = ClawsMail::C::filter_init(19);\n"
2082 " $msginfo{\"filepath\"} = ClawsMail::C::filter_init(20);\n"
2083 " $msginfo{\"partial_recv\"} = ClawsMail::C::filter_init(21);\n"
2084 " $msginfo{\"total_size\"} = ClawsMail::C::filter_init(22);\n"
2085 " $msginfo{\"account_server\"} = ClawsMail::C::filter_init(23);\n"
2086 " $msginfo{\"account_login\"} = ClawsMail::C::filter_init(24);\n"
2087 " $msginfo{\"planned_download\"} = ClawsMail::C::filter_init(25);\n"
2088 "} \n"
2089 "sub read_headers_ {\n"
2090 " my($key,$value);\n"
2091 " %header = ();\n"
2092 " while(($key,$value) = ClawsMail::C::get_next_header()) {\n"
2093 " next unless $key =~ /:$/;\n"
2094 " add_header_entries_($key,$value);\n"
2095 " }\n"
2096 "}\n"
2097 "sub read_body_ {\n"
2098 " my $line;\n"
2099 " while(defined($line = ClawsMail::C::get_next_body_line())) {\n"
2100 " $body .= $line;\n"
2101 " } \n"
2102 "}\n"
2103 "sub match_ {\n"
2104 " my ($where,$what,$modi) = @_; $modi ||= \"\";\n"
2105 " my $nocase=\"\"; $nocase = \"1\" if (index($modi,\"i\") != -1);\n"
2106 " my $regexp=\"\"; $regexp = \"1\" if (index($modi,\"r\") != -1);\n"
2107 " if($where eq \"to_or_cc\") {\n"
2108 " if(not $regexp) { \n"
2109 " return ((index(header(\"to\"),$what) != -1) or\n"
2110 " (index(header(\"cc\"),$what) != -1)) unless $nocase;\n"
2111 " return ((index(lc2_(header(\"to\")),lc2_($what)) != -1) or\n"
2112 " (index(lc2_(header(\"cc\")),lc2_($what)) != -1))\n"
2113 " } else {\n"
2114 " return ((header(\"to\") =~ m/$what/) or\n"
2115 " (header(\"cc\") =~ m/$what/)) unless $nocase;\n"
2116 " return ((header(\"to\") =~ m/$what/i) or\n"
2117 " (header(\"cc\") =~ m/$what/i));\n"
2118 " }\n"
2119 " } elsif($where eq \"body_part\") {\n"
2120 " my $mybody = body(); $mybody =~ s/\\s+/ /g;\n"
2121 " if(not $regexp) {\n"
2122 " return (index($mybody,$what) != -1) unless $nocase;\n"
2123 " return (index(lc2_($mybody),lc2_($what)) != -1);\n"
2124 " } else {\n"
2125 " return ($body =~ m/$what/) unless $nocase;\n"
2126 " return ($body =~ m/$what/i);\n"
2127 " }\n"
2128 " } elsif($where eq \"headers_part\") {\n"
2129 " my $myheader = header_as_string_();\n"
2130 " if(not $regexp) {\n"
2131 " $myheader =~ s/\\s+/ /g;\n"
2132 " return (index($myheader,$what) != -1) unless $nocase;\n"
2133 " return (index(lc2_($myheader),lc2_($what)) != -1);\n"
2134 " } else {\n"
2135 " return ($myheader =~ m/$what/) unless $nocase;\n"
2136 " return ($myheader =~ m/$what/i);\n"
2137 " }\n"
2138 " } elsif($where eq \"headers_cont\") {\n"
2139 " (my $myheader = header_as_string_()) =~ s{^\\S+:\\s*}{};\n"
2140 " if(not $regexp) {\n"
2141 " $myheader =~ s/\\s+/ /g;\n"
2142 " return (index($myheader,$what) != -1) unless $nocase;\n"
2143 " return (index(lc2_($myheader),lc2_($what)) != -1);\n"
2144 " } else {\n"
2145 " return ($myheader =~ m/$what/) unless $nocase;\n"
2146 " return ($myheader =~ m/$what/i);\n"
2147 " }\n"
2148 " } elsif($where eq \"message\") {\n"
2149 " my $message = header_as_string_();\n"
2150 " $message .= \"\\n\".body();\n"
2151 " if(not $regexp) {\n"
2152 " $message =~ s/\\s+/ /g;\n"
2153 " return (index($message,$what) != -1) unless $nocase;\n"
2154 " return (index(lc2_($message),lc2_($what)) != -1);\n"
2155 " } else {\n"
2156 " return ($message =~ m/$what/) unless $nocase;\n"
2157 " return ($message =~ m/$what/i);\n"
2158 " }\n"
2159 " } elsif($where eq \"tag\") {\n"
2160 " my $found = 0;\n"
2161 " sub ClawsMail::Utils::get_tags;"
2162 " foreach my $tag (ClawsMail::Utils::get_tags) {\n"
2163 " if(not $regexp) {\n"
2164 " if($nocase) {\n"
2165 " $found = (index(lc2_($tag),lc2_($what)) != -1);\n"
2166 " } else {\n"
2167 " $found = (index($tag,$what) != -1);\n"
2168 " }\n"
2169 " } else {\n"
2170 " if ($nocase) {\n"
2171 " $found = ($tag =~ m/$what/i);\n"
2172 " } else {\n"
2173 " $found = ($tag =~ m/$what/);\n"
2174 " }\n"
2175 " }\n"
2176 " last if $found;\n"
2177 " }\n"
2178 " return $found;"
2179 " } else {\n"
2180 " $where = lc2_ $where;\n"
2181 " my $myheader = header(lc2_ $where); $myheader ||= \"\";\n"
2182 " return 0 unless $myheader;\n"
2183 " if(not $regexp) { \n"
2184 " return (index(header($where),$what) != -1) unless $nocase;\n"
2185 " return (index(lc2_(header($where)),lc2_($what)) != -1);\n"
2186 " } else {\n"
2187 " return (header($where) =~ m/$what/) unless $nocase;\n"
2188 " return (header($where) =~ m/$what/i);\n"
2189 " } \n"
2190 " }\n"
2191 "}\n"
2192 "sub header_as_string_ {\n"
2193 " my $headerstring=\"\";\n"
2194 " my @headerkeys = header(); my(@fields,$field);\n"
2195 " foreach $field (@headerkeys) {\n"
2196 " @fields = header($field);\n"
2197 " foreach (@fields) {\n"
2198 " $headerstring .= $field.\": \".$_.\"\\n\";\n"
2199 " }\n"
2200 " }\n"
2201 " return $headerstring;\n"
2202 "}\n"
2203 "our $permanent = \"\";\n"
2204 "1;\n"
2205 };
2206 const char perl_filter_action[] = {
2207 "BEGIN {$INC{'ClawsMail/Filter/Action.pm'} = 1;}\n"
2208 "package ClawsMail::Filter::Action;\n"
2209 "use base qw(Exporter);\n"
2210 "our @EXPORT = (qw(mark unmark dele mark_as_unread mark_as_read),\n"
2211 " qw(lock unlock move copy color execute),\n"
2212 " qw(hide set_score change_score stop exit),\n"
2213 " qw(forward forward_as_attachment redirect),\n"
2214 " qw(set_tag unset_tag clear_tags),\n"
2215 " );\n"
2216 "our %colors = ('none' => 0,'orange' => 1,\n"
2217 " 'red' => 2,'pink' => 3,\n"
2218 " 'sky blue' => 4,'blue' => 5,\n"
2219 " 'green' => 6,'brown' => 7);\n"
2220 "sub mark { ClawsMail::C::set_flag (1);}\n"
2221 "sub unmark { ClawsMail::C::unset_flag(1);}\n"
2222 "sub mark_as_unread { ClawsMail::C::set_flag (2);}\n"
2223 "sub mark_as_read { ClawsMail::C::unset_flag(2);}\n"
2224 "sub lock { ClawsMail::C::set_flag (7);}\n"
2225 "sub unlock { ClawsMail::C::unset_flag(7);}\n"
2226 "sub copy { ClawsMail::C::copy (@_);}\n"
2227 "sub forward { ClawsMail::C::forward(1,@_);}\n"
2228 "sub forward_as_attachment {ClawsMail::C::forward(2,@_);}\n"
2229 "sub redirect { ClawsMail::C::redirect(@_); }\n"
2230 "sub hide { ClawsMail::C::hide(); }\n"
2231 "sub exit {\n"
2232 " ClawsMail::C::filter_log(\"LOG_ACTION\",\"exit\");\n"
2233 " stop(1);\n"
2234 "}\n"
2235 "sub stop {\n"
2236 " my $nolog = shift;\n"
2237 " ClawsMail::C::filter_log(\"LOG_ACTION\", \"stop\")\n"
2238 " unless defined($nolog);\n"
2239 " die 'intended';\n"
2240 "}\n"
2241 "sub set_score {\n"
2242 " $ClawsMail::Filter::Matcher::msginfo{\"score\"} =\n"
2243 " ClawsMail::C::set_score(@_);\n"
2244 "}\n"
2245 "sub change_score {\n"
2246 " $ClawsMail::Filter::Matcher::msginfo{\"score\"} =\n"
2247 " ClawsMail::C::change_score(@_);\n"
2248 "}\n"
2249 "sub execute {\n"
2250 " my $flv; my $cmd = shift; return 0 unless defined($cmd);\n"
2251 " $flv = ClawsMail::C::filter_log_verbosity(0);\n"
2252 " ClawsMail::Filter::Matcher::test($cmd);\n"
2253 " ClawsMail::C::filter_log_verbosity($flv);\n"
2254 " ClawsMail::C::filter_log(\"LOG_ACTION\", \"execute: $cmd\");\n"
2255 " 1;\n"
2256 "}\n"
2257 "sub move { ClawsMail::C::move(@_); stop(1);}\n"
2258 "sub dele { ClawsMail::C::delete(); stop(1);}\n"
2259 "sub color {\n"
2260 " ($color) = @_;$color = lc2_ $color;\n"
2261 " $color = $colors{$color} if exists $colors{$color};\n"
2262 " $color = 0 if $color =~ m/\\D/;\n"
2263 " ClawsMail::C::color($color);\n"
2264 "}\n"
2265 "sub set_tag { ClawsMail::C::set_tag(@_);}\n"
2266 "sub unset_tag { ClawsMail::C::unset_tag(@_);}\n"
2267 "sub clear_tags { ClawsMail::C::clear_tags(@_);}\n"
2268 "1;\n"
2269 };
2270 const char perl_utils[] = {
2271 "BEGIN {$INC{'ClawsMail/Utils.pm'} = 1;}\n"
2272 "package ClawsMail::Utils;\n"
2273 "use base qw(Exporter);\n"
2274 "our @EXPORT = (\n"
2275 " qw(SA_is_spam extract_addresses move_to_trash abort),\n"
2276 " qw(addr_in_addressbook from_in_addressbook),\n"
2277 " qw(get_attribute_value make_sure_folder_exists),\n"
2278 " qw(make_sure_tag_exists get_tags),\n"
2279 " );\n"
2280 "# Spam\n"
2281 "sub SA_is_spam {\n"
2282 " my $retval;\n"
2283 " $retval = not ClawsMail::Filter::Matcher::test('spamc -c < %F > /dev/null');\n"
2284 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"SA_is_spam\") if $retval;\n"
2285 " return $retval;\n"
2286 "}\n"
2287 "# simple extract email addresses from a header field\n"
2288 "sub extract_addresses {\n"
2289 " my $hf = shift; return undef unless defined($hf);\n"
2290 " my @addr = ();\n"
2291 " while($hf =~ m/[-.+\\w]+\\@[-.+\\w]+/) {\n"
2292 " $hf =~ s/^.*?([-.+\\w]+\\@[-.+\\w]+)//;\n"
2293 " push @addr,$1;\n"
2294 " }\n"
2295 " push @addr,\"\" unless @addr;\n"
2296 " return @addr;\n"
2297 "}\n"
2298 "# move to trash\n"
2299 "sub move_to_trash {\n"
2300 " ClawsMail::C::move_to_trash();\n"
2301 " ClawsMail::Filter::Action::stop(1);\n"
2302 "}\n"
2303 "# make sure a folder with a given id exists\n"
2304 "sub make_sure_folder_exists {\n"
2305 " ClawsMail::C::make_sure_folder_exists(@_);\n"
2306 "}\n"
2307 "sub make_sure_tag_exists {\n"
2308 " ClawsMail::C::make_sure_tag_exists(@_);\n"
2309 "}\n"
2310 "sub get_tags {\n"
2311 " ClawsMail::C::get_tags(@_);\n"
2312 "}\n"
2313 "# abort: stop() and do not continue with built-in filtering\n"
2314 "sub abort {\n"
2315 " ClawsMail::C::abort();\n"
2316 " ClawsMail::Filter::Action::stop(1);\n"
2317 "}\n"
2318 "# addressbook query\n"
2319 "sub addr_in_addressbook {\n"
2320 " return ClawsMail::C::addr_in_addressbook(@_) if @_;\n"
2321 " return 0;\n"
2322 "}\n"
2323 "sub from_in_addressbook {\n"
2324 " my ($from) = extract_addresses(ClawsMail::Filter::Matcher::header(\"from\"));\n"
2325 " return 0 unless $from;\n"
2326 " return addr_in_addressbook($from,@_);\n"
2327 "}\n"
2328 "sub get_attribute_value {\n"
2329 " my $email = shift; my $key = shift;\n"
2330 " return \"\" unless ($email and $key);\n"
2331 " return ClawsMail::C::get_attribute_value($email,$key,@_);\n"
2332 "}\n"
2333 "1;\n"
2334 };
2335
2336 if((my_perl = perl_alloc()) == NULL) {
2337 g_warning("Perl plugin: not enough memory to allocate Perl interpreter");
2338 return -1;
2339 }
2340 PL_perl_destruct_level = 1;
2341 perl_construct(my_perl);
2342
2343 exitstatus = perl_parse(my_perl, xs_init, 4, initialize, NULL);
2344 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
2345 eval_pv(perl_filter_matcher,TRUE);
2346 eval_pv(perl_filter_action,TRUE);
2347 eval_pv(perl_persistent,TRUE);
2348 eval_pv(perl_utils,TRUE);
2349 return exitstatus;
2350 }
2351
2352 static gboolean my_filtering_hook(gpointer source, gpointer data)
2353 {
2354 int retry;
2355
2356 g_return_val_if_fail(source != NULL, FALSE);
2357
2358 mail_filtering_data = (MailFilteringData *) source;
2359 msginfo = mail_filtering_data->msginfo;
2360 if (!msginfo)
2361 return FALSE;
2362 stop_filtering = FALSE;
2363 wrote_filter_log_head = FALSE;
2364 filter_log_verbosity = config.filter_log_verbosity;
2365 if(GPOINTER_TO_UINT(data) == AUTO_FILTER)
2366 manual_filtering = FALSE;
2367 else if(GPOINTER_TO_UINT(data) == MANU_FILTER)
2368 manual_filtering = TRUE;
2369 else
2370 debug_print("Invalid user data ignored.\n");
2371
2372 if(!manual_filtering)
2373 statusbar_print_all("Perl Plugin: filtering message...");
2374
2375 /* Process Skript File */
2376 retry = perl_load_file();
2377 while(retry == 1) {
2378 debug_print("Error processing Perl script file. Retrying..\n");
2379 retry = perl_load_file();
2380 }
2381 if(retry == 2) {
2382 debug_print("Error processing Perl script file. Aborting..\n");
2383 stop_filtering = FALSE;
2384 }
2385 return stop_filtering;
2386 }
2387
2388 static void perl_plugin_save_config(void)
2389 {
2390 PrefFile *pfile;
2391 gchar *rcpath;
2392
2393 debug_print("Saving Perl plugin Configuration\n");
2394
2395 rcpath = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, COMMON_RC, NULL);
2396 pfile = prefs_write_open(rcpath);
2397 g_free(rcpath);
2398 if (!pfile || (prefs_set_block_label(pfile, "PerlPlugin") < 0))
2399 return;
2400
2401 if (prefs_write_param(param, pfile->fp) < 0) {
2402 g_warning("failed to write Perl plugin configuration to file");
2403 prefs_file_close_revert(pfile);
2404 return;
2405 }
2406 if (fprintf(pfile->fp, "\n") < 0) {
2407 FILE_OP_ERROR(rcpath, "fprintf");
2408 prefs_file_close_revert(pfile);
2409 } else
2410 prefs_file_close(pfile);
2411 }
2412
2413 gint plugin_init(gchar **error)
2414 {
2415 int argc;
2416 char **argv;
2417 char **env;
2418 int status = 0;
2419 FILE *fp;
2420 gchar *perlfilter;
2421 gchar *rcpath;
2422
2423 /* version check */
2424 if(!check_plugin_version(MAKE_NUMERIC_VERSION(3,7,4,6),
2425 VERSION_NUMERIC, "Perl", error))
2426 return -1;
2427
2428 /* register hook for automatic and manual filtering */
2429 filtering_hook_id = hooks_register_hook(MAIL_FILTERING_HOOKLIST,
2430 my_filtering_hook,
2431 GUINT_TO_POINTER(AUTO_FILTER));
2432 if(filtering_hook_id == HOOK_NONE) {
2433 *error = g_strdup("Failed to register mail filtering hook");
2434 return -1;
2435 }
2436 manual_filtering_hook_id = hooks_register_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
2437 my_filtering_hook,
2438 GUINT_TO_POINTER(MANU_FILTER));
2439 if(manual_filtering_hook_id == HOOK_NONE) {
2440 hooks_unregister_hook(MAIL_FILTERING_HOOKLIST, filtering_hook_id);
2441 *error = g_strdup("Failed to register manual mail filtering hook");
2442 return -1;
2443 }
2444
2445 rcpath = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, COMMON_RC, NULL);
2446 prefs_read_config(param, "PerlPlugin", rcpath, NULL);
2447 g_free(rcpath);
2448
2449 /* make sure we have at least an empty scriptfile */
2450 perlfilter = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, PERLFILTER, NULL);
2451 if((fp = claws_fopen(perlfilter, "a")) == NULL) {
2452 *error = g_strdup("Failed to create blank scriptfile");
2453 g_free(perlfilter);
2454 hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
2455 filtering_hook_id);
2456 hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
2457 manual_filtering_hook_id);
2458 return -1;
2459 }
2460 /* chmod for security */
2461 if (change_file_mode_rw(fp, perlfilter) < 0) {
2462 FILE_OP_ERROR(perlfilter, "chmod");
2463 g_warning("Perl plugin: can't change file mode");
2464 }
2465 claws_fclose(fp);
2466 g_free(perlfilter);
2467
2468 argc = 1;
2469 argv = g_new0(char*, 1);
2470 argv[0] = NULL;
2471 env = g_new0(char*, 1);
2472 env[0] = NULL;
2473
2474
2475 /* Initialize Perl Interpreter */
2476 PERL_SYS_INIT3(&argc, &argv, &env);
2477 g_free(argv);
2478 g_free(env);
2479 if(my_perl == NULL)
2480 status = perl_init();
2481 if(status) {
2482 *error = g_strdup("Failed to load Perl Interpreter\n");
2483 hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
2484 filtering_hook_id);
2485 hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
2486 manual_filtering_hook_id);
2487 return -1;
2488 }
2489
2490 perl_gtk_init();
2491 debug_print("Perl Plugin loaded\n");
2492 return 0;
2493 }
2494
2495 gboolean plugin_done(void)
2496 {
2497 hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
2498 filtering_hook_id);
2499 hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
2500 manual_filtering_hook_id);
2501
2502 free_all_lists();
2503
2504 if(my_perl != NULL) {
2505 PL_perl_destruct_level = 1;
2506 perl_destruct(my_perl);
2507 perl_free(my_perl);
2508 }
2509 PERL_SYS_TERM();
2510
2511 perl_plugin_save_config();
2512
2513 perl_gtk_done();
2514 debug_print("Perl Plugin unloaded\n");
2515 return TRUE;
2516 }
2517
2518 const gchar *plugin_name(void)
2519 {
2520 return "Perl";
2521 }
2522
2523 const gchar *plugin_desc(void)
2524 {
2525 return _("This plugin provides a Perl scripting interface for mail filters.\n"
2526 "Feedback to <berndth@gmx.de> is welcome.\n");
2527 }
2528
2529 const gchar *plugin_type(void)
2530 {
2531 return "GTK3";
2532 }
2533
2534 const gchar *plugin_licence(void)
2535 {
2536 return "GPL3+";
2537 }
2538
2539 const gchar *plugin_version(void)
2540 {
2541 return VERSION;
2542 }
2543
2544 struct PluginFeature *plugin_provides(void)
2545 {
2546 static struct PluginFeature features[] =
2547 { {PLUGIN_FILTERING, N_("Perl integration")},
2548 {PLUGIN_NOTHING, NULL}};
2549 return features;
2550 }