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