1 /* Perl plugin -- Perl Support for Claws Mail
3 * Copyright (C) 2004-2007 Holger Berndt
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
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.
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.
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/>.
24 #include "claws-features.h"
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"
33 #include "procheader.h"
37 #include "addrindex.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"
58 #include <glib/gi18n.h>
61 #include <sys/types.h>
66 #include "perl_plugin.h"
70 /* XSRETURN_UV was introduced in Perl 5.8.1,
71 this fixes things for 5.8.0. */
74 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
76 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
77 #endif /* XSRETURN_UV */
79 /* set this to "1" to recompile the Perl script for every mail,
80 even if it hasn't changed */
83 /* distinguish between automatic and manual filtering */
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);
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;
105 static PerlPluginConfig config;
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}
114 /* Utility functions */
116 /* fire and forget */
117 gint execute_detached(gchar **cmdline)
121 if((pid = fork()) < 0) { /* fork error */
125 else if(pid > 0) { /* parent */
126 waitpid(pid, NULL, 0);
130 if((pid = fork()) < 0) { /* fork error */
134 else if(pid > 0) { /* child */
135 /* make grand child an orphan */
138 else { /* grand child */
139 execvp(cmdline[0], cmdline);
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;
164 log_message(LOG_PROTOCOL, " MANUAL: %s\n", text?text:"<no text specified>");
167 log_message(LOG_PROTOCOL, " ACTION: %s\n", text?text:"<no text specified>");
170 log_message(LOG_PROTOCOL, " MATCH: %s\n", text?text:"<no text specified>");
173 g_warning("Perl Plugin: Wrong use of filter_log_write");
179 /* Addressbook interface */
181 static PerlPluginTimedSList *email_slist = NULL;
182 static GHashTable *attribute_hash = NULL;
184 /* addressbook email collector callback */
185 static gint add_to_email_slist(ItemPerson *person, const gchar *bookname)
187 PerlPluginEmailEntry *ee;
190 /* Process each E-Mail address */
191 nodeM = person->listEMail;
193 ItemEMail *email = nodeM->data;
194 ee = g_new0(PerlPluginEmailEntry,1);
195 g_return_val_if_fail(ee != NULL, -1);
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;
202 email_slist->g_slist = g_slist_prepend(email_slist->g_slist,ee);
203 nodeM = g_list_next(nodeM);
208 /* free a GSList of PerlPluginEmailEntry's. */
209 static void free_PerlPluginEmailEntry_slist(GSList *slist)
217 for(; walk != NULL; walk = g_slist_next(walk)) {
218 PerlPluginEmailEntry *ee = (PerlPluginEmailEntry *) walk->data;
220 if(ee->address != NULL) g_free(ee->address);
221 if(ee->bookname != NULL) g_free(ee->bookname);
228 debug_print("PerlPluginEmailEntry slist freed\n");
231 /* free email_slist */
232 static void free_email_slist(void)
234 if(email_slist == NULL)
237 free_PerlPluginEmailEntry_slist(email_slist->g_slist);
238 email_slist->g_slist = NULL;
243 debug_print("email_slist freed\n");
246 /* check if tl->g_slist exists and is recent enough */
247 static gboolean update_PerlPluginTimedSList(PerlPluginTimedSList *tl)
253 if(tl->g_slist == NULL)
256 indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
257 if((g_stat(indexfile,&filestat) == 0) && filestat.st_mtime <= tl->mtime)
266 /* (re)initialize email slist */
267 static void init_email_slist(void)
272 if(email_slist->g_slist != NULL) {
273 free_PerlPluginEmailEntry_slist(email_slist->g_slist);
274 email_slist->g_slist = NULL;
277 addrindex_load_person_attribute(NULL,add_to_email_slist);
279 indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
280 if(g_stat(indexfile,&filestat) == 0)
281 email_slist->mtime = filestat.st_mtime;
283 debug_print("Initialisation of email slist completed\n");
286 /* check if given address is in given addressbook */
287 static gboolean addr_in_addressbook(gchar *addr, gchar *bookname)
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) {
294 start_address_completion(NULL);
295 found = (complete_matches_found(addr) > 0);
296 end_address_completion();
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");
309 if(update_PerlPluginTimedSList(email_slist))
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)))) {
331 /* attribute hash collector callback */
332 static gint add_to_attribute_hash(ItemPerson *person, const gchar *bookname)
334 PerlPluginTimedSList *tl;
335 PerlPluginAttributeEntry *ae;
339 nodeA = person->listAttrib;
340 /* Process each User Attribute */
342 UserAttribute *attrib = nodeA->data;
343 if(attrib->name && !strcmp(attrib->name,attribute_key) ) {
344 /* Process each E-Mail address */
345 nodeM = person->listEMail;
347 ItemEMail *email = nodeM->data;
349 ae = g_new0(PerlPluginAttributeEntry,1);
350 g_return_val_if_fail(ae != NULL, -1);
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;
359 tl = (PerlPluginTimedSList *) g_hash_table_lookup(attribute_hash,attribute_key);
360 tl->g_slist = g_slist_prepend(tl->g_slist,ae);
362 nodeM = g_list_next(nodeM);
365 nodeA = g_list_next(nodeA);
371 /* free a key of the attribute hash */
372 static gboolean free_attribute_hash_key(gpointer key, gpointer value, gpointer user_data)
375 PerlPluginTimedSList *tl;
377 debug_print("Freeing key `%s' from attribute_hash\n",key?(char*)key:"");
379 tl = (PerlPluginTimedSList *) value;
382 if(tl->g_slist != NULL) {
384 for(; walk != NULL; walk = g_slist_next(walk)) {
385 PerlPluginAttributeEntry *ae = (PerlPluginAttributeEntry *) walk->data;
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);
394 g_slist_free(tl->g_slist);
409 /* free whole attribute hash */
410 static void free_attribute_hash(void)
412 if(attribute_hash == NULL)
415 g_hash_table_foreach_remove(attribute_hash,free_attribute_hash_key,NULL);
416 g_hash_table_destroy(attribute_hash);
417 attribute_hash = NULL;
419 debug_print("attribute_hash freed\n");
422 /* Free the key if it exists. Insert the new key. */
423 static void insert_attribute_hash(gchar *attr)
425 PerlPluginTimedSList *tl;
429 /* Check if key exists. Free it if it does. */
430 if((tl = g_hash_table_lookup(attribute_hash,attr)) != NULL) {
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);
439 tl = g_new0(PerlPluginTimedSList,1);
442 attribute_key = g_strdup(attr);
443 g_hash_table_insert(attribute_hash,attribute_key,tl);
445 addrindex_load_person_attribute(attribute_key,add_to_attribute_hash);
447 indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
448 if(g_stat(indexfile,&filestat) == 0)
449 tl->mtime = filestat.st_mtime;
452 debug_print("added key `%s' to attribute_hash\n",attribute_key?attribute_key:"");
455 /* check if an update of the attribute hash entry is necessary */
456 static gboolean update_attribute_hash(const gchar *attr)
458 PerlPluginTimedSList *tl;
460 /* check if key attr exists in the attribute hash */
461 if((tl = (PerlPluginTimedSList*) g_hash_table_lookup(attribute_hash,attr)) == NULL)
464 /* check if entry is recent enough */
465 return update_PerlPluginTimedSList(tl);
468 /* given an email address, return attribute value of specific book */
469 static gchar* get_attribute_value(gchar *email, gchar *attr, gchar *bookname)
472 PerlPluginTimedSList *tl;
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");
480 if(update_attribute_hash(attr)) {
481 debug_print("Initialisation of attribute hash entry `%s' is necessary\n",attr);
482 insert_attribute_hash(attr);
485 if((tl = (PerlPluginTimedSList*) g_hash_table_lookup(attribute_hash,attr)) == NULL)
489 for(; walk != NULL; walk = g_slist_next(walk)) {
490 PerlPluginAttributeEntry *ae = (PerlPluginAttributeEntry *) walk->data;
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);
501 g_free(a); g_free(b);
506 /* free up all memory allocated with lists */
507 static void free_all_lists(void)
513 free_attribute_hash();
518 /* ClawsMail::C module */
522 /* ClawsMail::C::filter_init(int) */
523 static XS(XS_ClawsMail_filter_init)
540 * 12 dispositionnotificationto
544 * 16 not used anymore
546 * 18 not used anymore
548 * 20 message file path
553 * 25 planned_download
566 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::init");
574 msginfo->size ? XSRETURN_UV(msginfo->size) : XSRETURN_UNDEF;
576 msginfo->date ? XSRETURN_PV(msginfo->date) : XSRETURN_UNDEF;
578 msginfo->from ? XSRETURN_PV(msginfo->from) : XSRETURN_UNDEF;
580 msginfo->to ? XSRETURN_PV(msginfo->to) : XSRETURN_UNDEF;
582 msginfo->cc ? XSRETURN_PV(msginfo->cc) : XSRETURN_UNDEF;
584 msginfo->newsgroups ? XSRETURN_PV(msginfo->newsgroups) : XSRETURN_UNDEF;
586 msginfo->subject ? XSRETURN_PV(msginfo->subject) : XSRETURN_UNDEF;
588 msginfo->msgid ? XSRETURN_PV(msginfo->msgid) : XSRETURN_UNDEF;
590 msginfo->inreplyto ? XSRETURN_PV(msginfo->inreplyto) : XSRETURN_UNDEF;
592 msginfo->xref ? XSRETURN_PV(msginfo->xref) : XSRETURN_UNDEF;
594 xface = procmsg_msginfo_get_avatar(msginfo, AVATAR_XFACE);
595 xface ? XSRETURN_PV(xface) : XSRETURN_UNDEF;
597 (msginfo->extradata && msginfo->extradata->dispositionnotificationto) ?
598 XSRETURN_PV(msginfo->extradata->dispositionnotificationto) : XSRETURN_UNDEF;
600 (msginfo->extradata && msginfo->extradata->returnreceiptto) ?
601 XSRETURN_PV(msginfo->extradata->returnreceiptto) : XSRETURN_UNDEF;
603 EXTEND(SP, g_slist_length(msginfo->references));
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;
609 msginfo->score ? XSRETURN_IV(msginfo->score) : XSRETURN_UNDEF;
611 msginfo->plaintext_file ?
612 XSRETURN_PV(msginfo->plaintext_file) : XSRETURN_UNDEF;
614 msginfo->hidden ? XSRETURN_IV(msginfo->hidden) : XSRETURN_UNDEF;
616 if((charp = procmsg_get_message_file_path(msginfo)) != NULL) {
617 strncpy2(buf,charp,sizeof(buf));
624 (msginfo->extradata && msginfo->extradata->partial_recv) ?
625 XSRETURN_PV(msginfo->extradata->partial_recv) : XSRETURN_UNDEF;
627 msginfo->total_size ? XSRETURN_IV(msginfo->total_size) : XSRETURN_UNDEF;
629 (msginfo->extradata && msginfo->extradata->account_server) ?
630 XSRETURN_PV(msginfo->extradata->account_server) : XSRETURN_UNDEF;
632 (msginfo->extradata && msginfo->extradata->account_login) ?
633 XSRETURN_PV(msginfo->extradata->account_login) : XSRETURN_UNDEF;
635 msginfo->planned_download ?
636 XSRETURN_IV(msginfo->planned_download) : XSRETURN_UNDEF;
645 g_warning("Perl Plugin: Wrong argument to ClawsMail::C::init");
650 /* ClawsMail::C::open_mail_file */
651 static XS(XS_ClawsMail_open_mail_file)
658 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::open_mail_file");
661 file = procmsg_get_message_file_path(msginfo);
664 strncpy2(buf,file,sizeof(buf));
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");
673 /* ClawsMail::C::close_mail_file */
674 static XS(XS_ClawsMail_close_mail_file)
678 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::close_mail_file");
681 if(message_file != NULL)
682 fclose(message_file);
686 /* ClawsMail::C::get_next_header */
687 static XS(XS_ClawsMail_get_next_header)
694 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::get_next_header");
697 if(message_file == NULL) {
698 g_warning("Perl Plugin: Message file not open. Use ClawsMail::C::open_message_file first.");
701 if(procheader_get_one_field(buf, sizeof(buf), message_file, NULL) != -1) {
702 header = procheader_parse_header(buf);
705 XST_mPV(0,header->name);
706 XST_mPV(1,header->body);
707 procheader_header_free(header);
719 /* ClawsMail::C::get_next_body_line */
720 static XS(XS_ClawsMail_get_next_body_line)
726 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::get_next_body_line");
729 if(message_file == NULL) {
730 g_warning("Perl Plugin: Message file not open. Use ClawsMail::C::open_message_file first.");
733 if(fgets(buf, sizeof(buf), message_file) != NULL)
740 /* Filter matchers */
742 /* ClawsMail::C::check_flag(int) */
743 static XS(XS_ClawsMail_check_flag)
758 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::check_flag");
765 if(MSG_IS_MARKED(msginfo->flags)) {
766 filter_log_write(LOG_MATCH,"marked");
772 if(MSG_IS_UNREAD(msginfo->flags)) {
773 filter_log_write(LOG_MATCH,"unread");
779 if(MSG_IS_DELETED(msginfo->flags)) {
780 filter_log_write(LOG_MATCH,"deleted");
786 if(MSG_IS_NEW(msginfo->flags)) {
787 filter_log_write(LOG_MATCH,"new");
793 if(MSG_IS_REPLIED(msginfo->flags)) {
794 filter_log_write(LOG_MATCH,"replied");
800 if(MSG_IS_FORWARDED(msginfo->flags)) {
801 filter_log_write(LOG_MATCH,"forwarded");
807 if(MSG_IS_LOCKED(msginfo->flags)) {
808 filter_log_write(LOG_MATCH,"locked");
814 if(MSG_IS_IGNORE_THREAD(msginfo->flags)) {
815 filter_log_write(LOG_MATCH,"ignore_thread");
821 g_warning("Perl Plugin: Unknown argument to ClawsMail::C::check_flag");
826 /* ClawsMail::C::colorlabel(int) */
827 static XS(XS_ClawsMail_colorlabel)
833 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::colorlabel");
838 if((MSG_GET_COLORLABEL_VALUE(msginfo->flags) == (guint32)color)) {
839 filter_log_write(LOG_MATCH,"colorlabel");
846 /* ClawsMail::C::age_greater(int) */
847 static XS(XS_ClawsMail_age_greater)
854 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::age_greater");
859 if(((t - msginfo->date_t) / 86400) >= age) {
860 filter_log_write(LOG_MATCH,"age_greater");
867 /* ClawsMail::C::age_lower(int) */
868 static XS(XS_ClawsMail_age_lower)
875 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::age_lower");
880 if(((t - msginfo->date_t) / 86400) <= age) {
881 filter_log_write(LOG_MATCH,"age_lower");
888 /* ClawsMail::C::tagged() */
889 static XS(XS_ClawsMail_tagged)
893 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::tagged");
897 return msginfo->tags ? XSRETURN_YES : XSRETURN_NO;
900 /* ClawsMail::C::get_tags() */
901 static XS(XS_ClawsMail_get_tags)
909 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::get_tags");
913 num_tags = g_slist_length(msginfo->tags);
915 EXTEND(SP, num_tags);
917 for(walk = msginfo->tags; walk != NULL; walk = g_slist_next(walk)) {
919 tag_str = tags_get_tag(GPOINTER_TO_INT(walk->data));
920 XST_mPV(iTag++, tag_str ? tag_str: "");
928 /* ClawsMail::C::set_tag(char*) */
929 static XS(XS_ClawsMail_set_tag)
936 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::set_tag");
940 tag_str = SvPV_nolen(ST(0));
941 tag_id = tags_get_id_for_str(tag_str);
943 g_warning("Perl Plugin: set_tag requested setting of a non-existing tag");
947 procmsg_msginfo_update_tags(msginfo, TRUE, tag_id);
952 /* ClawsMail::C::unset_tag(char*) */
953 static XS(XS_ClawsMail_unset_tag)
960 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::unset_tag");
964 tag_str = SvPV_nolen(ST(0));
965 tag_id = tags_get_id_for_str(tag_str);
967 g_warning("Perl Plugin: unset_tag requested setting of a non-existing tag");
971 procmsg_msginfo_update_tags(msginfo, FALSE, tag_id);
976 /* ClawsMail::C::clear_tags() */
977 static XS(XS_ClawsMail_clear_tags)
981 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::clear_tags");
985 procmsg_msginfo_clear_tags(msginfo);
990 /* ClawsMail::C::make_sure_tag_exists(char*) */
991 static XS(XS_ClawsMail_make_sure_tag_exists)
997 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::make_sure_tag_exists");
1001 tag_str = SvPV_nolen(ST(0));
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);
1008 tags_add_tag(tag_str);
1015 /* ClawsMail::C::make_sure_folder_exists(char*) */
1016 static XS(XS_ClawsMail_make_sure_folder_exists)
1023 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::make_sure_folder_exists");
1027 identifier = SvPV_nolen(ST(0));
1028 item = folder_get_item_from_identifier(identifier);
1036 /* ClawsMail::C::addr_in_addressbook(char* [, char*]) */
1037 static XS(XS_ClawsMail_addr_in_addressbook)
1044 if(items != 1 && items != 2) {
1045 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::addr_in_addressbook");
1049 addr = SvPV_nolen(ST(0));
1052 found = addr_in_addressbook(addr,NULL);
1055 bookname = SvPV_nolen(ST(1));
1056 found = addr_in_addressbook(addr,bookname);
1060 filter_log_write(LOG_MATCH,"addr_in_addressbook");
1068 /* Filter actions */
1070 /* ClawsMail::C::set_flag(int) */
1071 static XS(XS_ClawsMail_set_flag)
1081 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::set_flag");
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");
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");
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");
1103 g_warning("Perl Plugin: Unknown argument to ClawsMail::C::set_flag");
1108 /* ClawsMail::C::unset_flag(int) */
1109 static XS(XS_ClawsMail_unset_flag)
1120 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::unset_flag");
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");
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");
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");
1142 g_warning("Perl Plugin: Unknown argument to ClawsMail::C::unset_flag");
1147 /* ClawsMail::C::move(char*) */
1148 static XS(XS_ClawsMail_move)
1150 gchar *targetfolder;
1152 FolderItem *dest_folder;
1156 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::move");
1160 targetfolder = SvPV_nolen(ST(0));
1161 dest_folder = folder_find_item_from_identifier(targetfolder);
1164 g_warning("Perl Plugin: move: folder not found '%s'",
1165 targetfolder ? targetfolder :"");
1168 if (folder_item_move_msg(dest_folder, msginfo) == -1) {
1169 g_warning("Perl Plugin: move: could not move message");
1172 stop_filtering = TRUE;
1173 logtext = g_strconcat("move to ", targetfolder, NULL);
1174 filter_log_write(LOG_ACTION, logtext);
1179 /* ClawsMail::C::copy(char*) */
1180 static XS(XS_ClawsMail_copy)
1184 FolderItem *dest_folder;
1188 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::copy");
1191 targetfolder = SvPV_nolen(ST(0));
1192 dest_folder = folder_find_item_from_identifier(targetfolder);
1195 g_warning("Perl Plugin: copy: folder not found '%s'",
1196 targetfolder ? targetfolder :"");
1199 if (folder_item_copy_msg(dest_folder, msginfo) == -1) {
1200 g_warning("Perl Plugin: copy: could not copy message");
1203 logtext = g_strconcat("copy to ", targetfolder, NULL);
1204 filter_log_write(LOG_ACTION, logtext);
1209 /* ClawsMail::C::delete */
1210 static XS(XS_ClawsMail_delete)
1214 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::delete");
1217 folder_item_remove_msg(msginfo->folder, msginfo->msgnum);
1218 stop_filtering = TRUE;
1219 filter_log_write(LOG_ACTION, "delete");
1223 /* ClawsMail::C::hide */
1224 static XS(XS_ClawsMail_hide)
1228 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::hide");
1231 msginfo->hidden = TRUE;
1232 filter_log_write(LOG_ACTION, "hide");
1237 /* ClawsMail::C::color(int) */
1238 static XS(XS_ClawsMail_color)
1245 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::color");
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);
1253 logtext = g_strdup_printf("color: %d", color);
1254 filter_log_write(LOG_ACTION, logtext);
1260 /* ClawsMail::C::change_score(int) */
1261 static XS(XS_ClawsMail_change_score)
1268 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::change_score");
1271 score = SvIV(ST(0));
1272 msginfo->score += score;
1274 logtext = g_strdup_printf("change score: %+d", score);
1275 filter_log_write(LOG_ACTION, logtext);
1278 XSRETURN_IV(msginfo->score);
1281 /* ClawsMail::C::set_score(int) */
1282 static XS(XS_ClawsMail_set_score)
1289 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::set_score");
1292 score = SvIV(ST(0));
1293 msginfo->score = score;
1295 logtext = g_strdup_printf("set score: %d", score);
1296 filter_log_write(LOG_ACTION, logtext);
1299 XSRETURN_IV(msginfo->score);
1302 /* ClawsMail::C::forward(int,int,char*) */
1303 static XS(XS_ClawsMail_forward)
1307 * 2 forward as attachment
1312 PrefsAccount *account;
1317 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::forward");
1322 account_id = SvIV(ST(1));
1323 dest = SvPV_nolen(ST(2));
1325 account = account_find_from_id(account_id);
1326 compose = compose_forward(account, msginfo,
1327 flag == 1 ? FALSE : TRUE,
1329 compose_entry_append(compose, dest,
1330 compose->account->protocol == A_NNTP ?
1331 COMPOSE_NEWSGROUPS : COMPOSE_TO, PREF_NONE);
1333 val = compose_send(compose);
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);
1349 /* ClawsMail::C::redirect(int,char*) */
1350 static XS(XS_ClawsMail_redirect)
1355 PrefsAccount *account;
1360 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::redirect");
1364 account_id = SvIV(ST(0));
1365 dest = SvPV_nolen(ST(1));
1367 account = account_find_from_id(account_id);
1368 compose = compose_redirect(account, msginfo, TRUE);
1370 if (compose->account->protocol == A_NNTP)
1373 compose_entry_append(compose, dest, COMPOSE_TO, PREF_NONE);
1375 val = compose_send(compose);
1379 logtext = g_strdup_printf("redirect to %s",
1380 dest ? dest : "<unknown destination>");
1381 filter_log_write(LOG_ACTION, logtext);
1393 /* ClawsMail::C::move_to_trash */
1394 static XS(XS_ClawsMail_move_to_trash)
1396 FolderItem *dest_folder;
1400 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::move_to_trash");
1403 dest_folder = folder_get_default_trash();
1405 g_warning("Perl Plugin: move_to_trash: Trash folder not found");
1408 if (folder_item_move_msg(dest_folder, msginfo) == -1) {
1409 g_warning("Perl Plugin: move_to_trash: could not move message to trash");
1412 stop_filtering = TRUE;
1413 filter_log_write(LOG_ACTION, "move_to_trash");
1417 /* ClawsMail::C::abort */
1418 static XS(XS_ClawsMail_abort)
1420 FolderItem *inbox_folder;
1424 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::abort");
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");
1433 if (folder_item_move_msg(inbox_folder, msginfo) == -1) {
1434 g_warning("Perl Plugin: abort: Could not move message to default inbox");
1437 filter_log_write(LOG_ACTION, "abort -- message moved to default inbox");
1440 filter_log_write(LOG_ACTION, "abort");
1442 stop_filtering = TRUE;
1446 /* ClawsMail::C::get_attribute_value(char*,char*[,char*]) */
1447 static XS(XS_ClawsMail_get_attribute_value)
1451 char *attribute_value;
1455 if(items != 2 && items != 3) {
1456 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::get_attribute_value");
1459 addr = SvPV_nolen(ST(0));
1460 attr = SvPV_nolen(ST(1));
1463 attribute_value = get_attribute_value(addr,attr,NULL);
1465 bookname = SvPV_nolen(ST(2));
1466 attribute_value = get_attribute_value(addr,attr,bookname);
1470 XSRETURN_PV(attribute_value);
1474 /* ClawsMail::C::filter_log(char*,char*) */
1475 static XS(XS_ClawsMail_filter_log)
1482 g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::filter_log");
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);
1494 g_warning("Perl Plugin: ClawsMail::C::filter_log -- wrong first argument");
1500 /* ClawsMail::C::filter_log_verbosity(int) */
1501 static XS(XS_ClawsMail_filter_log_verbosity)
1506 if(items != 1 && items != 0) {
1507 g_warning("Perl Plugin: Wrong number of arguments to "
1508 "ClawsMail::C::filter_log_verbosity");
1511 retval = filter_log_verbosity;
1514 filter_log_verbosity = SvIV(ST(0));
1516 XSRETURN_IV(retval);
1519 /* register extensions */
1520 EXTERN_C void xs_init(pTHX)
1522 char *file = __FILE__;
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");
1570 * Returns: 0 on success
1571 * 1 error in scriptfile or invocation of external
1573 * 2 error in scriptfile -> abort
1576 static int perl_load_file(void)
1578 gchar *args[] = {"", DO_CLEAN, NULL};
1579 gchar *noargs[] = { NULL };
1586 call_argv("ClawsMail::Filter::Matcher::filter_init_",
1587 G_DISCARD | G_EVAL | G_NOARGS,noargs);
1590 debug_print("%s", SvPV(ERRSV,n_a));
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);
1602 if(strstr(SvPV(ERRSV,n_a),"intended"))
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",
1609 val = alertpanel("Perl Plugin error",message,"Retry","Abort","Edit");
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);
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);
1627 cmdline = strsplit_with_quote(buf, " ", 1024);
1628 execute_detached(cmdline);
1629 g_strfreev(cmdline);
1632 else if(val == G_ALERTDEFAULT)
1642 /* let there be magic */
1643 static int perl_init(void)
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"
1654 "use Symbol qw(delete_package);\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"
1662 " # Dress it up as a real package name\n"
1663 " $string =~ s|/|::|g;\n"
1664 " return \"ClawsMail\" . $string;\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"
1675 " open FH, $file or die \"Failed to open '$file': $!\";\n"
1676 " local($/) = undef;\n"
1677 " my $sub = <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"
1686 " # hide our variables within this block\n"
1687 " my($file,$mtime,$package,$sub);\n"
1691 " #cache it unless we're cleaning out each time\n"
1692 " $Cache{$package}{mtime} = $mtime unless $delete;\n"
1694 " eval {$package->handler;};\n"
1696 " delete_package($package) if $delete;\n"
1699 const char perl_filter_matcher[] = {
1700 "BEGIN {$INC{'ClawsMail/Filter/Matcher.pm'} = 1;}\n"
1701 "package ClawsMail::Filter::Matcher;\n"
1703 "use base qw(Exporter);\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"
1722 " my $arg = shift;\n"
1723 " if(defined $arg) {\n"
1724 " return lc $arg;\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"
1744 " my $key = shift;\n"
1745 " if(not defined $key) {\n"
1747 " return keys %header;\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"
1756 "sub body {init_();return $body;}\n"
1757 "sub filepath {return $msginfo{\"filepath\"};}\n"
1759 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"manual\") if $manual;\n"
1760 " return $manual;\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"
1769 "sub filter_log_verbosity {\n"
1771 " return ClawsMail::C::filter_log_verbosity($_)\n"
1772 " if defined($_);\n"
1773 " return ClawsMail::C::filter_log_verbosity();\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"
1794 " }else{return 0;}\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"
1802 " }else{return 0;}\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"
1810 " }else{return 0;}\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"
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"
1825 " }else{return 0;}\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"
1833 " }else{return 0;}\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"
1841 " }else{return 0;}\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"
1850 " }else{return 0;}\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"
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"
1872 " $retval = !(system($command)>>8);\n"
1873 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"test: $cmdline\")\n"
1875 " return $retval;\n"
1879 " $retval = match_(@_,\"i\");\n"
1880 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"matchcase: $_[0], $_[1]\")\n"
1882 " return $retval;\n"
1886 " $retval = match_(@_);\n"
1887 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"match: $_[0], $_[1]\")\n"
1889 " return $retval;\n"
1891 "sub regexpcase {\n"
1893 " $retval = match_(@_,\"ri\");\n"
1894 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"regexpcase: $_[0], $_[1]\")\n"
1896 " return $retval;\n"
1900 " $retval = match_(@_,\"r\");\n"
1901 " ClawsMail::C::filter_log(\"LOG_MATCH\",\"regexp: $_[0], $_[1]\")\n"
1903 " return $retval;\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"
1911 "# read whole mail\n"
1913 " return 0 if $mail_done;\n"
1914 " ClawsMail::C::open_mail_file();\n"
1915 " read_headers_();\n"
1917 " ClawsMail::C::close_mail_file();\n"
1918 " $mail_done = 1;\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"
1949 "sub read_headers_ {\n"
1950 " my($key,$value);\n"
1952 " while(($key,$value) = ClawsMail::C::get_next_header()) {\n"
1953 " next unless $key =~ /:$/;\n"
1954 " add_header_entries_($key,$value);\n"
1957 "sub read_body_ {\n"
1959 " while(defined($line = ClawsMail::C::get_next_body_line())) {\n"
1960 " $body .= $line;\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"
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"
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"
1985 " return ($body =~ m/$what/) unless $nocase;\n"
1986 " return ($body =~ m/$what/i);\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"
1995 " return ($myheader =~ m/$what/) unless $nocase;\n"
1996 " return ($myheader =~ m/$what/i);\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"
2005 " return ($myheader =~ m/$what/) unless $nocase;\n"
2006 " return ($myheader =~ m/$what/i);\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"
2016 " return ($message =~ m/$what/) unless $nocase;\n"
2017 " return ($message =~ m/$what/i);\n"
2019 " } elsif($where eq \"tag\") {\n"
2021 " sub ClawsMail::Utils::get_tags;"
2022 " foreach my $tag (ClawsMail::Utils::get_tags) {\n"
2023 " if(not $regexp) {\n"
2025 " $found = (index(lc2_($tag),lc2_($what)) != -1);\n"
2027 " $found = (index($tag,$what) != -1);\n"
2031 " $found = ($tag =~ m/$what/i);\n"
2033 " $found = ($tag =~ m/$what/);\n"
2036 " last if $found;\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"
2047 " return (header($where) =~ m/$what/) unless $nocase;\n"
2048 " return (header($where) =~ m/$what/i);\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"
2061 " return $headerstring;\n"
2063 "our $permanent = \"\";\n"
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"
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"
2092 " ClawsMail::C::filter_log(\"LOG_ACTION\",\"exit\");\n"
2096 " my $nolog = shift;\n"
2097 " ClawsMail::C::filter_log(\"LOG_ACTION\", \"stop\")\n"
2098 " unless defined($nolog);\n"
2099 " die 'intended';\n"
2102 " $ClawsMail::Filter::Matcher::msginfo{\"score\"} =\n"
2103 " ClawsMail::C::set_score(@_);\n"
2105 "sub change_score {\n"
2106 " $ClawsMail::Filter::Matcher::msginfo{\"score\"} =\n"
2107 " ClawsMail::C::change_score(@_);\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"
2117 "sub move { ClawsMail::C::move(@_); stop(1);}\n"
2118 "sub dele { ClawsMail::C::delete(); stop(1);}\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"
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"
2130 const char perl_utils[] = {
2131 "BEGIN {$INC{'ClawsMail/Utils.pm'} = 1;}\n"
2132 "package ClawsMail::Utils;\n"
2133 "use base qw(Exporter);\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"
2141 "sub SA_is_spam {\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"
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"
2151 " while($hf =~ m/[-.+\\w]+\\@[-.+\\w]+/) {\n"
2152 " $hf =~ s/^.*?([-.+\\w]+\\@[-.+\\w]+)//;\n"
2155 " push @addr,\"\" unless @addr;\n"
2159 "sub move_to_trash {\n"
2160 " ClawsMail::C::move_to_trash();\n"
2161 " ClawsMail::Filter::Action::stop(1);\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"
2167 "sub make_sure_tag_exists {\n"
2168 " ClawsMail::C::make_sure_tag_exists(@_);\n"
2171 " ClawsMail::C::get_tags(@_);\n"
2173 "# abort: stop() and do not continue with built-in filtering\n"
2175 " ClawsMail::C::abort();\n"
2176 " ClawsMail::Filter::Action::stop(1);\n"
2178 "# addressbook query\n"
2179 "sub addr_in_addressbook {\n"
2180 " return ClawsMail::C::addr_in_addressbook(@_) if @_;\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"
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"
2196 if((my_perl = perl_alloc()) == NULL) {
2197 g_warning("Perl Plugin: Not enough memory to allocate Perl interpreter");
2200 PL_perl_destruct_level = 1;
2201 perl_construct(my_perl);
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);
2212 static gboolean my_filtering_hook(gpointer source, gpointer data)
2216 g_return_val_if_fail(source != NULL, FALSE);
2218 mail_filtering_data = (MailFilteringData *) source;
2219 msginfo = mail_filtering_data->msginfo;
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;
2230 debug_print("Invalid user data ignored.\n");
2232 if(!manual_filtering)
2233 statusbar_print_all("Perl Plugin: filtering message...");
2235 /* Process Skript File */
2236 retry = perl_load_file();
2238 debug_print("Error processing Perl script file. Retrying..\n");
2239 retry = perl_load_file();
2242 debug_print("Error processing Perl script file. Aborting..\n");
2243 stop_filtering = FALSE;
2245 return stop_filtering;
2248 static void perl_plugin_save_config(void)
2253 debug_print("Saving Perl Plugin Configuration\n");
2255 rcpath = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, COMMON_RC, NULL);
2256 pfile = prefs_write_open(rcpath);
2258 if (!pfile || (prefs_set_block_label(pfile, "PerlPlugin") < 0))
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);
2266 if (fprintf(pfile->fp, "\n") < 0) {
2267 FILE_OP_ERROR(rcpath, "fprintf");
2268 prefs_file_close_revert(pfile);
2270 prefs_file_close(pfile);
2273 gint plugin_init(gchar **error)
2284 if(!check_plugin_version(MAKE_NUMERIC_VERSION(3,7,4,6),
2285 VERSION_NUMERIC, "Perl", error))
2288 /* register hook for automatic and manual filtering */
2289 filtering_hook_id = hooks_register_hook(MAIL_FILTERING_HOOKLIST,
2291 GUINT_TO_POINTER(AUTO_FILTER));
2292 if(filtering_hook_id == (guint) -1) {
2293 *error = g_strdup("Failed to register mail filtering hook");
2296 manual_filtering_hook_id = hooks_register_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
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");
2305 rcpath = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, COMMON_RC, NULL);
2306 prefs_read_config(param, "PerlPlugin", rcpath, NULL);
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");
2314 hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
2316 hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
2317 manual_filtering_hook_id);
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");
2329 argv = g_new0(char*, 1);
2331 env = g_new0(char*, 1);
2335 /* Initialize Perl Interpreter */
2336 PERL_SYS_INIT3(&argc, &argv, &env);
2340 status = perl_init();
2342 *error = g_strdup("Failed to load Perl Interpreter\n");
2343 hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
2345 hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
2346 manual_filtering_hook_id);
2351 debug_print("Perl Plugin loaded\n");
2355 gboolean plugin_done(void)
2357 hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
2359 hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
2360 manual_filtering_hook_id);
2364 if(my_perl != NULL) {
2365 PL_perl_destruct_level = 1;
2366 perl_destruct(my_perl);
2371 perl_plugin_save_config();
2374 debug_print("Perl Plugin unloaded\n");
2378 const gchar *plugin_name(void)
2383 const gchar *plugin_desc(void)
2385 return "This plugin provides a Perl scripting "
2386 "interface for mail filters.\nFeedback "
2387 "to <berndth@gmx.de> is welcome.";
2390 const gchar *plugin_type(void)
2395 const gchar *plugin_licence(void)
2400 const gchar *plugin_version(void)
2405 struct PluginFeature *plugin_provides(void)
2407 static struct PluginFeature features[] =
2408 { {PLUGIN_FILTERING, N_("Perl integration")},
2409 {PLUGIN_NOTHING, NULL}};