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