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 #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 */
 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
 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 */
 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. */
 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 */
 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 */
 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 */
 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 */
 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 */
 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 */
 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 */
 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. */
 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 */
 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 */
 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 */
 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) */
 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 */
 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 */
 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 */
 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 */
 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) */
 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) */
 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) */
 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) */
 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() */
 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() */
 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*) */
 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*) */
 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() */
 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*) */
 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*) */
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*]) */
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) */
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) */
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*) */
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*) */
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 */
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 */
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) */
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) */
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) */
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*) */
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*) */
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 */
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 */
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*]) */
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*) */
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) */
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 */
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  */
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 */
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
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
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
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
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
2381 const gchar *plugin_name(void)
2382 {
2383   return "Perl";
2384 }
2385
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
2393 const gchar *plugin_type(void)
2394 {
2395   return "GTK2";
2396 }
2397
2398 const gchar *plugin_licence(void)
2399 {
2400   return "GPL3+";
2401 }
2402
2403 const gchar *plugin_version(void)
2404 {
2405   return VERSION;
2406 }
2407
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 }