/* Perl plugin -- Perl Support for Claws Mail
*
* Copyright (C) 2004-2007 Holger Berndt
*
* Sylpheed and Claws-Mail are GTK+ based, lightweight, and fast e-mail clients
* Copyright (C) 1999-2007 Hiroyuki Yamamoto and the Claws Mail Team
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 3 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program. If not, see <http://www.gnu.org/licenses/>.
*/
#ifdef HAVE_CONFIG_H
# include "config.h"
#endif
#include "pluginconfig.h"
#include <glib.h>
#include <glib/gi18n.h>
#include "common/version.h"
#include "common/defs.h"
#include "common/utils.h"
#include "common/claws.h"
#include "common/prefs.h"
#include "procmsg.h"
#include "procheader.h"
#include "folder.h"
#include "account.h"
#include "compose.h"
#include "addrindex.h"
#include "addritem.h"
#include "statusbar.h"
#include "alertpanel.h"
#include "hooks.h"
#include "prefs_common.h"
#include "prefs_gtk.h"
#include "log.h"
#include "plugin.h"
#include <string.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <sys/wait.h>
#include <unistd.h>
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include "pluginconfig.h"
#include "perl_plugin.h"
#include "perl_gtk.h"
/* XSRETURN_UV was introduced in Perl 5.8.1,
this fixes things for 5.8.0. */
#ifndef XSRETURN_UV
# ifndef XST_mUV
# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
# endif /* XST_mUV */
# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
#endif /* XSRETURN_UV */
/* set this to "1" to recompile the Perl script for every mail,
even if it hasn't changed */
#define DO_CLEAN "0"
/* distinguish between automatic and manual filtering */
#define AUTO_FILTER 0
#define MANU_FILTER 1
/* embedded Perl stuff */
static PerlInterpreter *my_perl = NULL;
EXTERN_C void xs_init(pTHX);
EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
/* plugin stuff */
static guint filtering_hook_id;
static guint manual_filtering_hook_id;
static MailFilteringData *mail_filtering_data = NULL;
static MsgInfo *msginfo = NULL;
static gboolean stop_filtering = FALSE;
static gboolean manual_filtering = FALSE;
static gboolean wrote_filter_log_head = FALSE;
static gint filter_log_verbosity;
static FILE *message_file = NULL;
static gchar *attribute_key = NULL;
/* configuration */
static PerlPluginConfig config;
static PrefParam param[] = {
{"filter_log_verbosity", "2", &config.filter_log_verbosity,
P_INT, NULL, NULL, NULL},
{NULL, NULL, NULL, P_OTHER, NULL, NULL, NULL}
};
/* Utility functions */
/* fire and forget */
gint execute_detached(gchar **cmdline)
{
pid_t pid;
if((pid = fork()) < 0) { /* fork error */
perror("fork");
return 0;
}
else if(pid > 0) { /* parent */
waitpid(pid, NULL, 0);
return 1;
}
else { /* child */
if((pid = fork()) < 0) { /* fork error */
perror("fork");
return 0;
}
else if(pid > 0) { /* child */
/* make grand child an orphan */
_exit(0);
}
else { /* grand child */
execvp(cmdline[0], cmdline);
perror("execvp");
_exit(1);
}
}
}
/* filter logfile */
#define LOG_MANUAL 1
#define LOG_ACTION 2
#define LOG_MATCH 3
static void filter_log_write(gint type, gchar *text) {
if(filter_log_verbosity >= type) {
if(!wrote_filter_log_head) {
log_message(LOG_PROTOCOL, "From: %s || Subject: %s || Message-ID: %s\n",
msginfo->from ? msginfo->from : "<no From header>",
msginfo->subject ? msginfo->subject : "<no Subject header>",
msginfo->msgid ? msginfo->msgid : "<no message id>");
wrote_filter_log_head = TRUE;
}
switch(type) {
case LOG_MANUAL:
log_message(LOG_PROTOCOL, " MANUAL: %s\n", text?text:"<no text specified>");
break;
case LOG_ACTION:
log_message(LOG_PROTOCOL, " ACTION: %s\n", text?text:"<no text specified>");
break;
case LOG_MATCH:
log_message(LOG_PROTOCOL, " MATCH: %s\n", text?text:"<no text specified>");
break;
default:
g_warning("Perl Plugin: Wrong use of filter_log_write");
}
}
}
/* Addressbook interface */
static PerlPluginTimedSList *email_slist = NULL;
static GHashTable *attribute_hash = NULL;
/* addressbook email collector callback */
static gint add_to_email_slist(ItemPerson *person, const gchar *bookname)
{
PerlPluginEmailEntry *ee;
GList *nodeM;
/* Process each E-Mail address */
nodeM = person->listEMail;
while(nodeM) {
ItemEMail *email = nodeM->data;
ee = g_new0(PerlPluginEmailEntry,1);
g_return_val_if_fail(ee != NULL, -1);
if(email->address != NULL) ee->address = g_strdup(email->address);
else ee->address = NULL;
if(bookname != NULL) ee->bookname = g_strdup(bookname);
else ee->bookname = NULL;
email_slist->g_slist = g_slist_prepend(email_slist->g_slist,ee);
nodeM = g_list_next(nodeM);
}
return 0;
}
/* free a GSList of PerlPluginEmailEntry's. */
static void free_PerlPluginEmailEntry_slist(GSList *slist)
{
GSList *walk;
if(slist == NULL)
return;
walk = slist;
for(; walk != NULL; walk = g_slist_next(walk)) {
PerlPluginEmailEntry *ee = (PerlPluginEmailEntry *) walk->data;
if(ee != NULL) {
if(ee->address != NULL) g_free(ee->address);
if(ee->bookname != NULL) g_free(ee->bookname);
g_free(ee);
ee = NULL;
}
}
g_slist_free(slist);
debug_print("PerlPluginEmailEntry slist freed\n");
}
/* free email_slist */
static void free_email_slist(void)
{
if(email_slist == NULL)
return;
free_PerlPluginEmailEntry_slist(email_slist->g_slist);
email_slist->g_slist = NULL;
g_free(email_slist);
email_slist = NULL;
debug_print("email_slist freed\n");
}
/* check if tl->g_slist exists and is recent enough */
static gboolean update_PerlPluginTimedSList(PerlPluginTimedSList *tl)
{
gboolean retVal;
gchar *indexfile;
struct stat filestat;
if(tl->g_slist == NULL)
return TRUE;
indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
if((stat(indexfile,&filestat) == 0) && filestat.st_mtime <= tl->mtime)
retVal = FALSE;
else
retVal = TRUE;
g_free(indexfile);
return retVal;
}
/* (re)initialize email slist */
static void init_email_slist(void)
{
gchar *indexfile;
struct stat filestat;
if(email_slist->g_slist != NULL) {
free_PerlPluginEmailEntry_slist(email_slist->g_slist);
email_slist->g_slist = NULL;
}
addrindex_load_person_attribute(NULL,add_to_email_slist);
indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
if(stat(indexfile,&filestat) == 0)
email_slist->mtime = filestat.st_mtime;
g_free(indexfile);
debug_print("Initialisation of email slist completed\n");
}
/* check if given address is in given addressbook */
static gboolean addr_in_addressbook(gchar *addr, gchar *bookname)
{
GSList *walk;
/* check if email_list exists */
if(email_slist == NULL) {
email_slist = g_new0(PerlPluginTimedSList,1);
email_slist->g_slist = NULL;
debug_print("email_slist created\n");
}
if(update_PerlPluginTimedSList(email_slist))
init_email_slist();
walk = email_slist->g_slist;
for(; walk != NULL; walk = g_slist_next(walk)) {
PerlPluginEmailEntry *ee = (PerlPluginEmailEntry *) walk->data;
if((!g_strcasecmp(ee->address,addr)) &&
((bookname == NULL) || (!strcmp(ee->bookname,bookname))))
return TRUE;
}
return FALSE;
}
/* attribute hash collector callback */
static gint add_to_attribute_hash(ItemPerson *person, const gchar *bookname)
{
PerlPluginTimedSList *tl;
PerlPluginAttributeEntry *ae;
GList *nodeA;
GList *nodeM;
nodeA = person->listAttrib;
/* Process each User Attribute */
while(nodeA) {
UserAttribute *attrib = nodeA->data;
if(attrib->name && !strcmp(attrib->name,attribute_key) ) {
/* Process each E-Mail address */
nodeM = person->listEMail;
while(nodeM) {
ItemEMail *email = nodeM->data;
ae = g_new0(PerlPluginAttributeEntry,1);
g_return_val_if_fail(ae != NULL, -1);
if(email->address != NULL) ae->address = g_strdup(email->address);
else ae->address = NULL;
if(attrib->value != NULL) ae->value = g_strdup(attrib->value);
else ae->value = NULL;
if(bookname != NULL) ae->bookname = g_strdup(bookname);
else ae->bookname = NULL;
tl = (PerlPluginTimedSList *) g_hash_table_lookup(attribute_hash,attribute_key);
tl->g_slist = g_slist_prepend(tl->g_slist,ae);
nodeM = g_list_next(nodeM);
}
}
nodeA = g_list_next(nodeA);
}
return 0;
}
/* free a key of the attribute hash */
static gboolean free_attribute_hash_key(gpointer key, gpointer value, gpointer user_data)
{
GSList *walk;
PerlPluginTimedSList *tl;
debug_print("Freeing key `%s' from attribute_hash\n",key?(char*)key:"");
tl = (PerlPluginTimedSList *) value;
if(tl != NULL) {
if(tl->g_slist != NULL) {
walk = tl->g_slist;
for(; walk != NULL; walk = g_slist_next(walk)) {
PerlPluginAttributeEntry *ae = (PerlPluginAttributeEntry *) walk->data;
if(ae != NULL) {
if(ae->address != NULL) g_free(ae->address);
if(ae->value != NULL) g_free(ae->value);
if(ae->bookname != NULL) g_free(ae->bookname);
g_free(ae);
ae = NULL;
}
}
g_slist_free(tl->g_slist);
tl->g_slist = NULL;
}
g_free(tl);
tl = NULL;
}
if(key != NULL) {
g_free(key);
key = NULL;
}
return TRUE;
}
/* free whole attribute hash */
static void free_attribute_hash(void)
{
if(attribute_hash == NULL)
return;
g_hash_table_foreach_remove(attribute_hash,free_attribute_hash_key,NULL);
g_hash_table_destroy(attribute_hash);
attribute_hash = NULL;
debug_print("attribute_hash freed\n");
}
/* Free the key if it exists. Insert the new key. */
static void insert_attribute_hash(gchar *attr)
{
PerlPluginTimedSList *tl;
gchar *indexfile;
struct stat filestat;
/* Check if key exists. Free it if it does. */
if((tl = g_hash_table_lookup(attribute_hash,attr)) != NULL) {
gpointer origkey;
gpointer value;
g_hash_table_lookup_extended(attribute_hash,attr,&origkey,&value);
g_hash_table_remove(attribute_hash,origkey);
free_attribute_hash_key(origkey,value,NULL);
debug_print("Existing key `%s' freed.\n",attr);
}
tl = g_new0(PerlPluginTimedSList,1);
tl->g_slist = NULL;
attribute_key = g_strdup(attr);
g_hash_table_insert(attribute_hash,attribute_key,tl);
addrindex_load_person_attribute(attribute_key,add_to_attribute_hash);
indexfile = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, ADDRESSBOOK_INDEX_FILE, NULL);
if(stat(indexfile,&filestat) == 0)
tl->mtime = filestat.st_mtime;
g_free(indexfile);
debug_print("added key `%s' to attribute_hash\n",attribute_key?attribute_key:"");
}
/* check if an update of the attribute hash entry is necessary */
static gboolean update_attribute_hash(const gchar *attr)
{
PerlPluginTimedSList *tl;
/* check if key attr exists in the attribute hash */
if((tl = (PerlPluginTimedSList*) g_hash_table_lookup(attribute_hash,attr)) == NULL)
return TRUE;
/* check if entry is recent enough */
return update_PerlPluginTimedSList(tl);
}
/* given an email address, return attribute value of specific book */
static gchar* get_attribute_value(gchar *email, gchar *attr, gchar *bookname)
{
GSList *walk;
PerlPluginTimedSList *tl;
/* check if attribute hash exists */
if(attribute_hash == NULL) {
attribute_hash = g_hash_table_new(g_str_hash,g_str_equal);
debug_print("attribute_hash created\n");
}
if(update_attribute_hash(attr)) {
debug_print("Initialisation of attribute hash entry `%s' is necessary\n",attr);
insert_attribute_hash(attr);
}
if((tl = (PerlPluginTimedSList*) g_hash_table_lookup(attribute_hash,attr)) == NULL)
return NULL;
walk = tl->g_slist;
for(; walk != NULL; walk = g_slist_next(walk)) {
PerlPluginAttributeEntry *ae = (PerlPluginAttributeEntry *) walk->data;
if(!g_strcasecmp(ae->address,email)) {
if((bookname == NULL) ||
((ae->bookname != NULL) && !strcmp(bookname,ae->bookname)))
return ae->value;
}
}
return NULL;
}
/* free up all memory allocated with lists */
static void free_all_lists(void)
{
/* email list */
free_email_slist();
/* attribute hash */
free_attribute_hash();
}
/* ClawsMail::C module */
/* Initialization */
/* ClawsMail::C::filter_init(int) */
static XS(XS_ClawsMail_filter_init)
{
int flag;
/* flags:
*
* msginfo
* 1 size
* 2 date
* 3 from
* 4 to
* 5 cc
* 6 newsgroups
* 7 subject
* 8 msgid
* 9 inreplyto
* 10 xref
* 11 xface
* 12 dispositionnotificationto
* 13 returnreceiptto
* 14 references
* 15 score
* 16 not used anymore
* 17 plaintext_file
* 18 not used anymore
* 19 hidden
* 20 message file path
* 21 partial_recv
* 22 total_size
* 23 account_server
* 24 account_login
* 25 planned_download
*
* general
* 100 manual
*/
char *charp;
gchar buf[BUFFSIZE];
GSList *walk;
int ii;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::init");
XSRETURN_UNDEF;
}
flag = SvIV(ST(0));
switch(flag) {
/* msginfo */
case 1:
msginfo->size ? XSRETURN_UV(msginfo->size) : XSRETURN_UNDEF;
case 2:
msginfo->date ? XSRETURN_PV(msginfo->date) : XSRETURN_UNDEF;
case 3:
msginfo->from ? XSRETURN_PV(msginfo->from) : XSRETURN_UNDEF;
case 4:
msginfo->to ? XSRETURN_PV(msginfo->to) : XSRETURN_UNDEF;
case 5:
msginfo->cc ? XSRETURN_PV(msginfo->cc) : XSRETURN_UNDEF;
case 6:
msginfo->newsgroups ? XSRETURN_PV(msginfo->newsgroups) : XSRETURN_UNDEF;
case 7:
msginfo->subject ? XSRETURN_PV(msginfo->subject) : XSRETURN_UNDEF;
case 8:
msginfo->msgid ? XSRETURN_PV(msginfo->msgid) : XSRETURN_UNDEF;
case 9:
msginfo->inreplyto ? XSRETURN_PV(msginfo->inreplyto) : XSRETURN_UNDEF;
case 10:
msginfo->xref ? XSRETURN_PV(msginfo->xref) : XSRETURN_UNDEF;
case 11:
(msginfo->extradata && msginfo->extradata->xface) ?
XSRETURN_PV(msginfo->extradata->xface) : XSRETURN_UNDEF;
case 12:
(msginfo->extradata && msginfo->extradata->dispositionnotificationto) ?
XSRETURN_PV(msginfo->extradata->dispositionnotificationto) : XSRETURN_UNDEF;
case 13:
(msginfo->extradata && msginfo->extradata->returnreceiptto) ?
XSRETURN_PV(msginfo->extradata->returnreceiptto) : XSRETURN_UNDEF;
case 14:
ii = 0;
for(walk = msginfo->references; walk != NULL; walk = g_slist_next(walk))
XST_mPV(ii++,walk->data ? (gchar*) walk->data: "");
ii ? XSRETURN(ii) : XSRETURN_UNDEF;
case 15:
msginfo->score ? XSRETURN_IV(msginfo->score) : XSRETURN_UNDEF;
case 17:
msginfo->plaintext_file ?
XSRETURN_PV(msginfo->plaintext_file) : XSRETURN_UNDEF;
case 19:
msginfo->hidden ? XSRETURN_IV(msginfo->hidden) : XSRETURN_UNDEF;
case 20:
if((charp = procmsg_get_message_file_path(msginfo)) != NULL) {
strncpy2(buf,charp,sizeof(buf));
g_free(charp);
XSRETURN_PV(buf);
}
else
XSRETURN_UNDEF;
case 21:
(msginfo->extradata && msginfo->extradata->partial_recv) ?
XSRETURN_PV(msginfo->extradata->partial_recv) : XSRETURN_UNDEF;
case 22:
msginfo->total_size ? XSRETURN_IV(msginfo->total_size) : XSRETURN_UNDEF;
case 23:
(msginfo->extradata && msginfo->extradata->account_server) ?
XSRETURN_PV(msginfo->extradata->account_server) : XSRETURN_UNDEF;
case 24:
(msginfo->extradata && msginfo->extradata->account_login) ?
XSRETURN_PV(msginfo->extradata->account_login) : XSRETURN_UNDEF;
case 25:
msginfo->planned_download ?
XSRETURN_IV(msginfo->planned_download) : XSRETURN_UNDEF;
/* general */
case 100:
if(manual_filtering)
XSRETURN_YES;
else
XSRETURN_NO;
default:
g_warning("Perl Plugin: Wrong argument to ClawsMail::C::init");
XSRETURN_UNDEF;
}
}
/* ClawsMail::C::open_mail_file */
static XS(XS_ClawsMail_open_mail_file)
{
char *file;
gchar buf[BUFFSIZE];
dXSARGS;
if(items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::open_mail_file");
XSRETURN_UNDEF;
}
file = procmsg_get_message_file_path(msginfo);
if(!file)
XSRETURN_UNDEF;
strncpy2(buf,file,sizeof(buf));
g_free(file);
if((message_file = fopen(buf, "rb")) == NULL) {
FILE_OP_ERROR(buf, "fopen");
g_warning("Perl Plugin: File open error in ClawsMail::C::open_mail_file");
XSRETURN_UNDEF;
}
}
/* ClawsMail::C::close_mail_file */
static XS(XS_ClawsMail_close_mail_file)
{
dXSARGS;
if(items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::close_mail_file");
XSRETURN_UNDEF;
}
if(message_file != NULL)
fclose(message_file);
XSRETURN_YES;
}
/* ClawsMail::C::get_next_header */
static XS(XS_ClawsMail_get_next_header)
{
gchar buf[BUFFSIZE];
Header *header;
dXSARGS;
if(items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::get_next_header");
XSRETURN_EMPTY;
}
if(message_file == NULL) {
g_warning("Perl Plugin: Message file not open. Use ClawsMail::C::open_message_file first.");
XSRETURN_EMPTY;
}
if(procheader_get_one_field(buf, sizeof(buf), message_file, NULL) != -1) {
header = procheader_parse_header(buf);
XST_mPV(0,header->name);
XST_mPV(1,header->body);
procheader_header_free(header);
XSRETURN(2);
}
else
XSRETURN_EMPTY;
}
/* ClawsMail::C::get_next_body_line */
static XS(XS_ClawsMail_get_next_body_line)
{
gchar buf[BUFFSIZE];
dXSARGS;
if(items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::get_next_body_line");
XSRETURN_UNDEF;
}
if(message_file == NULL) {
g_warning("Perl Plugin: Message file not open. Use ClawsMail::C::open_message_file first.");
XSRETURN_UNDEF;
}
if(fgets(buf, sizeof(buf), message_file) != NULL)
XSRETURN_PV(buf);
else
XSRETURN_UNDEF;
}
/* Filter matchers */
/* ClawsMail::C::check_flag(int) */
static XS(XS_ClawsMail_check_flag)
{
int flag;
/* flags: 1 marked
* 2 unread
* 3 deleted
* 4 new
* 5 replied
* 6 forwarded
* 7 locked
* 8 ignore thread
*/
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::check_flag");
XSRETURN_UNDEF;
}
flag = SvIV(ST(0));
switch(flag) {
case 1:
if(MSG_IS_MARKED(msginfo->flags)) {
filter_log_write(LOG_MATCH,"marked");
XSRETURN_YES;
}
else
XSRETURN_NO;
case 2:
if(MSG_IS_UNREAD(msginfo->flags)) {
filter_log_write(LOG_MATCH,"unread");
XSRETURN_YES;
}
else
XSRETURN_NO;
case 3:
if(MSG_IS_DELETED(msginfo->flags)) {
filter_log_write(LOG_MATCH,"deleted");
XSRETURN_YES;
}
else
XSRETURN_NO;
case 4:
if(MSG_IS_NEW(msginfo->flags)) {
filter_log_write(LOG_MATCH,"new");
XSRETURN_YES;
}
else
XSRETURN_NO;
case 5:
if(MSG_IS_REPLIED(msginfo->flags)) {
filter_log_write(LOG_MATCH,"replied");
XSRETURN_YES;
}
else
XSRETURN_NO;
case 6:
if(MSG_IS_FORWARDED(msginfo->flags)) {
filter_log_write(LOG_MATCH,"forwarded");
XSRETURN_YES;
}
else
XSRETURN_NO;
case 7:
if(MSG_IS_LOCKED(msginfo->flags)) {
filter_log_write(LOG_MATCH,"locked");
XSRETURN_YES;
}
else
XSRETURN_NO;
case 8:
if(MSG_IS_IGNORE_THREAD(msginfo->flags)) {
filter_log_write(LOG_MATCH,"ignore_thread");
XSRETURN_YES;
}
else
XSRETURN_NO;
default:
g_warning("Perl Plugin: Unknown argument to ClawsMail::C::check_flag");
XSRETURN_UNDEF;
}
}
/* ClawsMail::C::colorlabel(int) */
static XS(XS_ClawsMail_colorlabel)
{
int color;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::colorlabel");
XSRETURN_UNDEF;
}
color = SvIV(ST(0));
if((MSG_GET_COLORLABEL_VALUE(msginfo->flags) == (guint32)color)) {
filter_log_write(LOG_MATCH,"colorlabel");
XSRETURN_YES;
}
else
XSRETURN_NO;
}
/* ClawsMail::C::age_greater(int) */
static XS(XS_ClawsMail_age_greater)
{
int age;
time_t t;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::age_greater");
XSRETURN_UNDEF;
}
age = SvIV(ST(0));
t = time(NULL);
if(((t - msginfo->date_t) / 86400) >= age) {
filter_log_write(LOG_MATCH,"age_greater");
XSRETURN_YES;
}
else
XSRETURN_NO;
}
/* ClawsMail::C::age_lower(int) */
static XS(XS_ClawsMail_age_lower)
{
int age;
time_t t;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::age_lower");
XSRETURN_UNDEF;
}
age = SvIV(ST(0));
t = time(NULL);
if(((t - msginfo->date_t) / 86400) <= age) {
filter_log_write(LOG_MATCH,"age_lower");
XSRETURN_YES;
}
else
XSRETURN_NO;
}
/* ClawsMail::C::addr_in_addressbook(char* [, char*]) */
static XS(XS_ClawsMail_addr_in_addressbook)
{
gchar *addr;
gchar *bookname;
gboolean found;
dXSARGS;
if(items != 1 && items != 2) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::addr_in_addressbook");
XSRETURN_UNDEF;
}
addr = SvPV_nolen(ST(0));
if(items == 1) {
found = addr_in_addressbook(addr,NULL);
}
else {
bookname = SvPV_nolen(ST(1));
found = addr_in_addressbook(addr,bookname);
}
if(found) {
filter_log_write(LOG_MATCH,"addr_in_addressbook");
XSRETURN_YES;
}
else
XSRETURN_NO;
}
/* Filter actions */
/* ClawsMail::C::set_flag(int) */
static XS(XS_ClawsMail_set_flag)
{
int flag;
/* flags: 1 mark
* 2 mark as unread
* 7 lock
*/
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::set_flag");
XSRETURN_UNDEF;
}
flag = SvIV(ST(0));
switch(flag) {
case 1:
MSG_SET_PERM_FLAGS(msginfo->flags, MSG_MARKED);
procmsg_msginfo_set_flags(msginfo, MSG_MARKED,0);
filter_log_write(LOG_ACTION,"mark");
XSRETURN_YES;
case 2:
MSG_SET_PERM_FLAGS(msginfo->flags, MSG_UNREAD);
procmsg_msginfo_set_flags(msginfo, MSG_UNREAD,0);
filter_log_write(LOG_ACTION,"mark_as_unread");
XSRETURN_YES;
case 7:
MSG_SET_PERM_FLAGS(msginfo->flags, MSG_LOCKED);
procmsg_msginfo_set_flags(msginfo, MSG_LOCKED,0);
filter_log_write(LOG_ACTION,"lock");
XSRETURN_YES;
default:
g_warning("Perl Plugin: Unknown argument to ClawsMail::C::set_flag");
XSRETURN_UNDEF;
}
}
/* ClawsMail::C::unset_flag(int) */
static XS(XS_ClawsMail_unset_flag)
{
int flag;
/*
* flags: 1 unmark
* 2 mark as read
* 7 unlock
*/
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::unset_flag");
XSRETURN_UNDEF;
}
flag = SvIV(ST(0));
switch(flag) {
case 1:
MSG_UNSET_PERM_FLAGS(msginfo->flags, MSG_MARKED);
procmsg_msginfo_unset_flags(msginfo, MSG_MARKED,0);
filter_log_write(LOG_ACTION,"unmark");
XSRETURN_YES;
case 2:
MSG_UNSET_PERM_FLAGS(msginfo->flags, MSG_UNREAD | MSG_NEW);
procmsg_msginfo_unset_flags(msginfo, MSG_UNREAD | MSG_NEW,0);
filter_log_write(LOG_ACTION,"mark_as_read");
XSRETURN_YES;
case 7:
MSG_UNSET_PERM_FLAGS(msginfo->flags, MSG_LOCKED);
procmsg_msginfo_unset_flags(msginfo, MSG_LOCKED,0);
filter_log_write(LOG_ACTION,"unlock");
XSRETURN_YES;
default:
g_warning("Perl Plugin: Unknown argument to ClawsMail::C::unset_flag");
XSRETURN_UNDEF;
}
}
/* ClawsMail::C::move(char*) */
static XS(XS_ClawsMail_move)
{
gchar *targetfolder;
gchar *logtext;
FolderItem *dest_folder;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::move");
XSRETURN_UNDEF;
}
targetfolder = SvPV_nolen(ST(0));
dest_folder = folder_find_item_from_identifier(targetfolder);
if (!dest_folder) {
g_warning("Perl Plugin: move: folder not found '%s'",
targetfolder ? targetfolder :"");
XSRETURN_UNDEF;
}
if (folder_item_move_msg(dest_folder, msginfo) == -1) {
g_warning("Perl Plugin: move: could not move message");
XSRETURN_UNDEF;
}
stop_filtering = TRUE;
logtext = g_strconcat("move to ", targetfolder, NULL);
filter_log_write(LOG_ACTION, logtext);
g_free(logtext);
XSRETURN_YES;
}
/* ClawsMail::C::copy(char*) */
static XS(XS_ClawsMail_copy)
{
char *targetfolder;
gchar *logtext;
FolderItem *dest_folder;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::copy");
XSRETURN_UNDEF;
}
targetfolder = SvPV_nolen(ST(0));
dest_folder = folder_find_item_from_identifier(targetfolder);
if (!dest_folder) {
g_warning("Perl Plugin: copy: folder not found '%s'",
targetfolder ? targetfolder :"");
XSRETURN_UNDEF;
}
if (folder_item_copy_msg(dest_folder, msginfo) == -1) {
g_warning("Perl Plugin: copy: could not copy message");
XSRETURN_UNDEF;
}
logtext = g_strconcat("copy to ", targetfolder, NULL);
filter_log_write(LOG_ACTION, logtext);
g_free(logtext);
XSRETURN_YES;
}
/* ClawsMail::C::delete */
static XS(XS_ClawsMail_delete)
{
dXSARGS;
if(items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::delete");
XSRETURN_UNDEF;
}
folder_item_remove_msg(msginfo->folder, msginfo->msgnum);
stop_filtering = TRUE;
filter_log_write(LOG_ACTION, "delete");
XSRETURN_YES;
}
/* ClawsMail::C::hide */
static XS(XS_ClawsMail_hide)
{
dXSARGS;
if(items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::hide");
XSRETURN_UNDEF;
}
msginfo->hidden = TRUE;
filter_log_write(LOG_ACTION, "hide");
XSRETURN_YES;
}
/* ClawsMail::C::color(int) */
static XS(XS_ClawsMail_color)
{
int color;
gchar *logtext;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::color");
XSRETURN_UNDEF;
}
color = SvIV(ST(0));
procmsg_msginfo_unset_flags(msginfo, MSG_CLABEL_FLAG_MASK, 0);
procmsg_msginfo_set_flags(msginfo, MSG_COLORLABEL_TO_FLAGS(color), 0);
MSG_SET_COLORLABEL_VALUE(msginfo->flags,color);
logtext = g_strdup_printf("color: %d", color);
filter_log_write(LOG_ACTION, logtext);
g_free(logtext);
XSRETURN_YES;
}
/* ClawsMail::C::change_score(int) */
static XS(XS_ClawsMail_change_score)
{
int score;
gchar *logtext;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::change_score");
XSRETURN_UNDEF;
}
score = SvIV(ST(0));
msginfo->score += score;
logtext = g_strdup_printf("change score: %+d", score);
filter_log_write(LOG_ACTION, logtext);
g_free(logtext);
XSRETURN_IV(msginfo->score);
}
/* ClawsMail::C::set_score(int) */
static XS(XS_ClawsMail_set_score)
{
int score;
gchar *logtext;
dXSARGS;
if(items != 1) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::set_score");
XSRETURN_UNDEF;
}
score = SvIV(ST(0));
msginfo->score = score;
logtext = g_strdup_printf("set score: %d", score);
filter_log_write(LOG_ACTION, logtext);
g_free(logtext);
XSRETURN_IV(msginfo->score);
}
/* ClawsMail::C::forward(int,int,char*) */
static XS(XS_ClawsMail_forward)
{
int flag;
/* flags: 1 forward
* 2 forward as attachment
*/
int account_id,val;
char *dest;
gchar *logtext;
PrefsAccount *account;
Compose *compose;
dXSARGS;
if(items != 3) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::forward");
XSRETURN_UNDEF;
}
flag = SvIV(ST(0));
account_id = SvIV(ST(1));
dest = SvPV_nolen(ST(2));
account = account_find_from_id(account_id);
compose = compose_forward(account, msginfo,
flag == 1 ? FALSE : TRUE,
NULL, TRUE, TRUE);
compose_entry_append(compose, dest,
compose->account->protocol == A_NNTP ?
COMPOSE_NEWSGROUPS : COMPOSE_TO);
val = compose_send(compose);
if(val == 0) {
logtext = g_strdup_printf("forward%s to %s",
flag==2 ? " as attachment" : "",
dest ? dest : "<unknown destination>");
filter_log_write(LOG_ACTION, logtext);
g_free(logtext);
XSRETURN_YES;
}
else
XSRETURN_UNDEF;
}
/* ClawsMail::C::redirect(int,char*) */
static XS(XS_ClawsMail_redirect)
{
int account_id,val;
char *dest;
gchar *logtext;
PrefsAccount *account;
Compose *compose;
dXSARGS;
if(items != 2) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::redirect");
XSRETURN_UNDEF;
}
account_id = SvIV(ST(0));
dest = SvPV_nolen(ST(1));
account = account_find_from_id(account_id);
compose = compose_redirect(account, msginfo, TRUE);
if (compose->account->protocol == A_NNTP)
XSRETURN_UNDEF;
else
compose_entry_append(compose, dest, COMPOSE_TO);
val = compose_send(compose);
if(val == 0) {
logtext = g_strdup_printf("redirect to %s",
dest ? dest : "<unknown destination>");
filter_log_write(LOG_ACTION, logtext);
g_free(logtext);
XSRETURN_YES;
}
else
XSRETURN_UNDEF;
}
/* Utilities */
/* ClawsMail::C::move_to_trash */
static XS(XS_ClawsMail_move_to_trash)
{
FolderItem *dest_folder;
dXSARGS;
if(items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::move_to_trash");
XSRETURN_UNDEF;
}
dest_folder = folder_get_default_trash();
if (!dest_folder) {
g_warning("Perl Plugin: move_to_trash: Trash folder not found");
XSRETURN_UNDEF;
}
if (folder_item_move_msg(dest_folder, msginfo) == -1) {
g_warning("Perl Plugin: move_to_trash: could not move message to trash");
XSRETURN_UNDEF;
}
stop_filtering = TRUE;
filter_log_write(LOG_ACTION, "move_to_trash");
XSRETURN_YES;
}
/* ClawsMail::C::abort */
static XS(XS_ClawsMail_abort)
{
FolderItem *inbox_folder;
dXSARGS;
if(items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::abort");
XSRETURN_UNDEF;
}
if(!manual_filtering) {
inbox_folder = folder_get_default_inbox();
if (!inbox_folder) {
g_warning("Perl Plugin: abort: Inbox folder not found");
XSRETURN_UNDEF;
}
if (folder_item_move_msg(inbox_folder, msginfo) == -1) {
g_warning("Perl Plugin: abort: Could not move message to default inbox");
XSRETURN_UNDEF;
}
filter_log_write(LOG_ACTION, "abort -- message moved to default inbox");
}
else
filter_log_write(LOG_ACTION, "abort");
stop_filtering = TRUE;
XSRETURN_YES;
}
/* ClawsMail::C::get_attribute_value(char*,char*[,char*]) */
static XS(XS_ClawsMail_get_attribute_value)
{
char *addr;
char *attr;
char *attribute_value;
char *bookname;
dXSARGS;
if(items != 2 && items != 3) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::get_attribute_value");
XSRETURN_UNDEF;
}
addr = SvPV_nolen(ST(0));
attr = SvPV_nolen(ST(1));
if(items == 2)
attribute_value = get_attribute_value(addr,attr,NULL);
else {
bookname = SvPV_nolen(ST(2));
attribute_value = get_attribute_value(addr,attr,bookname);
}
if(attribute_value)
XSRETURN_PV(attribute_value);
XSRETURN_PV("");
}
/* ClawsMail::C::filter_log(char*,char*) */
static XS(XS_ClawsMail_filter_log)
{
char *text;
char *type;
dXSARGS;
if(items != 2) {
g_warning("Perl Plugin: Wrong number of arguments to ClawsMail::C::filter_log");
XSRETURN_UNDEF;
}
type = SvPV_nolen(ST(0));
text = SvPV_nolen(ST(1));
if(!strcmp(type, "LOG_ACTION"))
filter_log_write(LOG_ACTION, text);
else if(!strcmp(type, "LOG_MANUAL"))
filter_log_write(LOG_MANUAL, text);
else if(!strcmp(type, "LOG_MATCH"))
filter_log_write(LOG_MATCH, text);
else {
g_warning("Perl Plugin: ClawsMail::C::filter_log -- wrong first argument");
XSRETURN_UNDEF;
}
XSRETURN_YES;
}
/* ClawsMail::C::filter_log_verbosity(int) */
static XS(XS_ClawsMail_filter_log_verbosity)
{
int retval;
dXSARGS;
if(items != 1 && items != 0) {
g_warning("Perl Plugin: Wrong number of arguments to "
"ClawsMail::C::filter_log_verbosity");
XSRETURN_UNDEF;
}
retval = filter_log_verbosity;
if(items == 1)
filter_log_verbosity = SvIV(ST(0));
XSRETURN_IV(retval);
}
/* register extensions */
EXTERN_C void xs_init(pTHX)
{
char *file = __FILE__;
dXSUB_SYS;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
newXS("ClawsMail::C::filter_init", XS_ClawsMail_filter_init, "ClawsMail::C");
newXS("ClawsMail::C::check_flag", XS_ClawsMail_check_flag, "ClawsMail::C");
newXS("ClawsMail::C::age_greater", XS_ClawsMail_age_greater, "ClawsMail::C");
newXS("ClawsMail::C::age_lower", XS_ClawsMail_age_lower, "ClawsMail::C");
newXS("ClawsMail::C::set_flag", XS_ClawsMail_set_flag, "ClawsMail::C");
newXS("ClawsMail::C::unset_flag", XS_ClawsMail_unset_flag, "ClawsMail::C");
newXS("ClawsMail::C::delete", XS_ClawsMail_delete, "ClawsMail::C");
newXS("ClawsMail::C::move", XS_ClawsMail_move, "ClawsMail::C");
newXS("ClawsMail::C::copy", XS_ClawsMail_copy, "ClawsMail::C");
newXS("ClawsMail::C::color", XS_ClawsMail_color, "ClawsMail::C");
newXS("ClawsMail::C::colorlabel", XS_ClawsMail_colorlabel, "ClawsMail::C");
newXS("ClawsMail::C::change_score", XS_ClawsMail_change_score, "ClawsMail::C");
newXS("ClawsMail::C::set_score", XS_ClawsMail_set_score, "ClawsMail::C");
newXS("ClawsMail::C::hide", XS_ClawsMail_hide, "ClawsMail::C");
newXS("ClawsMail::C::forward", XS_ClawsMail_forward, "ClawsMail::C");
newXS("ClawsMail::C::redirect", XS_ClawsMail_redirect, "ClawsMail::C");
newXS("ClawsMail::C::addr_in_addressbook",
XS_ClawsMail_addr_in_addressbook,"ClawsMail::C");
newXS("ClawsMail::C::open_mail_file",
XS_ClawsMail_open_mail_file,"ClawsMail::C");
newXS("ClawsMail::C::close_mail_file",
XS_ClawsMail_close_mail_file,"ClawsMail::C");
newXS("ClawsMail::C::get_next_header",
XS_ClawsMail_get_next_header,"ClawsMail::C");
newXS("ClawsMail::C::get_next_body_line",
XS_ClawsMail_get_next_body_line,"ClawsMail::C");
newXS("ClawsMail::C::move_to_trash",XS_ClawsMail_move_to_trash,"ClawsMail::C");
newXS("ClawsMail::C::abort", XS_ClawsMail_abort, "ClawsMail::C");
newXS("ClawsMail::C::get_attribute_value",
XS_ClawsMail_get_attribute_value,"ClawsMail::C");
newXS("ClawsMail::C::filter_log", XS_ClawsMail_filter_log, "ClawsMail::C");
newXS("ClawsMail::C::filter_log_verbosity",
XS_ClawsMail_filter_log_verbosity, "ClawsMail::C");
}
/*
* The workhorse.
* Returns: 0 on success
* 1 error in scriptfile or invocation of external
* editor -> retry
* 2 error in scriptfile -> abort
* (Yes, I know..)
*/
static int perl_load_file(void)
{
gchar *args[] = {"", DO_CLEAN, NULL};
gchar *noargs[] = { NULL };
gchar *perlfilter;
gchar **cmdline;
gchar buf[1024];
gchar *pp;
STRLEN n_a;
call_argv("ClawsMail::Filter::Matcher::filter_init_",
G_DISCARD | G_EVAL | G_NOARGS,noargs);
/* check $@ */
if(SvTRUE(ERRSV)) {
debug_print("%s", SvPV(ERRSV,n_a));
return 1;
}
perlfilter = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, PERLFILTER, NULL);
args[0] = perlfilter;
call_argv("ClawsMail::Persistent::eval_file",
G_DISCARD | G_EVAL, args);
g_free(perlfilter);
if(SvTRUE(ERRSV)) {
AlertValue val;
gchar *message;
if(strstr(SvPV(ERRSV,n_a),"intended"))
return 0;
debug_print("%s", SvPV(ERRSV,n_a));
message = g_strdup_printf("Error processing Perl script file: "
"(line numbers may not be valid)\n%s",
SvPV(ERRSV,n_a));
val = alertpanel("Perl Plugin error",message,"Retry","Abort","Edit");
g_free(message);
if(val == G_ALERTOTHER) {
/* Open PERLFILTER in an external editor */
perlfilter = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, PERLFILTER, NULL);
if (prefs_common.ext_editor_cmd &&
(pp = strchr(prefs_common.ext_editor_cmd, '%')) &&
*(pp + 1) == 's' && !strchr(pp + 2, '%')) {
g_snprintf(buf, sizeof(buf), prefs_common.ext_editor_cmd, perlfilter);
}
else {
if (prefs_common.ext_editor_cmd)
g_warning("Perl Plugin: External editor command line is invalid: `%s'",
prefs_common.ext_editor_cmd);
g_snprintf(buf, sizeof(buf), "emacs %s", perlfilter);
}
g_free(perlfilter);
cmdline = strsplit_with_quote(buf, " ", 1024);
execute_detached(cmdline);
g_strfreev(cmdline);
return 1;
}
else if(val == G_ALERTDEFAULT)
return 1;
else
return 2;
}
return 0;
}
/* let there be magic */
static int perl_init(void)
{
int exitstatus;
char *initialize[] = { "", "-w", "-e", "1;"};
/* The `persistent' module is taken from the Perl documentation
and has only slightly been modified. */
const char perl_persistent[] = {
"package ClawsMail::Persistent;\n"
"\n"
"use strict;\n"
"our %Cache;\n"
"use Symbol qw(delete_package);\n"
"\n"
"sub valid_package_name {\n"
" my($string) = @_;\n"
" $string =~ s/([^A-Za-z0-9\\/])/sprintf(\"_%2x\",unpack(\"C\",$1))/eg;\n"
" # second pass only for words starting with a digit\n"
" $string =~ s|/(\\d)|sprintf(\"/_%2x\",unpack(\"C\",$1))|eg;\n"
" \n"
" # Dress it up as a real package name\n"
" $string =~ s|/|::|g;\n"
" return \"ClawsMail\" . $string;\n"
"}\n"
"\n"
"sub eval_file {\n"
" my($file, $delete) = @_;\n"
" my $package = valid_package_name($file);\n"
" my $mtime = -M $file;\n"
" if(!(defined $Cache{$package}{mtime} &&\n"
" $Cache{$package}{mtime} <= $mtime)) {\n"
" delete_package($package) if defined $Cache{$package}{mtime};\n"
" local *FH;\n"
" open FH, $file or die \"Failed to open '$file': $!\";\n"
" local($/) = undef;\n"
" my $sub = <FH>;\n"
" close FH;\n"
" #wrap the code into a subroutine inside our unique package\n"
" my $eval = qq{package $package;\n"
" use ClawsMail::Filter::Matcher;\n"
" use ClawsMail::Filter::Action;\n"
" use ClawsMail::Utils;\n"
" sub handler { $sub; }};\n"
" {\n"
" # hide our variables within this block\n"
" my($file,$mtime,$package,$sub);\n"
" eval $eval;\n"
" }\n"
" die $@ if $@;\n"
" #cache it unless we're cleaning out each time\n"
" $Cache{$package}{mtime} = $mtime unless $delete;\n"
" }\n"
" eval {$package->handler;};\n"
" die $@ if $@;\n"
" delete_package($package) if $delete;\n"
"}\n"
};
const char perl_filter_matcher[] = {
"BEGIN {$INC{'ClawsMail/Filter/Matcher.pm'} = 1;}\n"
"package ClawsMail::Filter::Matcher;\n"
"use locale;\n"
"use base qw(Exporter);\n"
"use strict;\n"
"our @EXPORT = (qw(header body filepath manual),\n"
" qw(filter_log_verbosity filter_log),\n"
" qw(all marked unread deleted new replied),\n"
" qw(forwarded locked colorlabel match matchcase),\n"
" qw(regexp regexpcase test),\n"
" qw(to cc subject from to_or_cc newsgroups inreplyto),\n"
" qw(references body_part headers_part message),\n"
" qw(size_greater size_smaller size_equal),\n"
" qw(score_greater score_lower score_equal),\n"
" qw(age_greater age_lower partial $permanent));\n"
"# Global Variables\n"
"our(%header,$body,%msginfo,$mail_done,$manual);\n"
"our %colors = ('none' => 0,'orange' => 1,'red' => 2,\n"
" 'pink' => 3,'sky blue' => 4,'blue' => 5,\n"
" 'green' => 6,'brown' => 7);\n"
"# For convenience\n"
"sub to { return \"to\"; }\n"
"sub cc { return \"cc\"; }\n"
"sub from { return \"from\"; }\n"
"sub subject { return \"subject\"; }\n"
"sub to_or_cc { return \"to_or_cc\"; }\n"
"sub newsgroups { return \"newsgroups\"; }\n"
"sub inreplyto { return \"in-reply-to\"; }\n"
"sub references { return \"references\"; }\n"
"sub body_part { return \"body_part\"; }\n"
"sub headers_part { return \"headers_part\"; }\n"
"sub message { return \"message\"; }\n"
"# access the mail directly\n"
"sub header {\n"
" my $key = shift;\n"
" if(not defined $key) {\n"
" init_();\n"
" return keys %header;\n"
" }\n"
" $key = lc $key; $key =~ s/:$//;\n"
" init_() unless exists $header{$key};\n"
" if(exists $header{$key}) {\n"
" wantarray ? return @{$header{$key}} : return $header{$key}->[-1];\n"
" }\n"
" return undef;\n"
"}\n"
"sub body {init_();return $body;}\n"
"sub filepath {return $msginfo{\"filepath\"};}\n"
"sub manual {\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"manual\") if $manual;\n"
" return $manual;\n"
"}\n"
"sub filter_log {\n"
" my $arg1 = shift;\n"
" my $arg2 = shift;\n"
" return ClawsMail::C::filter_log($arg1,$arg2)\n"
" if defined($arg2);\n"
" return ClawsMail::C::filter_log(\"LOG_MANUAL\",$arg1);\n"
"}\n"
"sub filter_log_verbosity {\n"
" $_ = shift;\n"
" return ClawsMail::C::filter_log_verbosity($_)\n"
" if defined($_);\n"
" return ClawsMail::C::filter_log_verbosity();\n"
"}\n"
"# Public Matcher Tests\n"
"sub all { ClawsMail::C::filter_log(\"LOG_MATCH\",\"all\");return 1; }\n"
"sub marked { return ClawsMail::C::check_flag(1);}\n"
"sub unread { return ClawsMail::C::check_flag(2);}\n"
"sub deleted { return ClawsMail::C::check_flag(3);}\n"
"sub new { return ClawsMail::C::check_flag(4);}\n"
"sub replied { return ClawsMail::C::check_flag(5);}\n"
"sub forwarded { return ClawsMail::C::check_flag(6);}\n"
"sub locked { return ClawsMail::C::check_flag(7);}\n"
"sub ignore_thread { return ClawsMail::C::check_flag(8);}\n"
"sub age_greater {return ClawsMail::C::age_greater(@_);}\n"
"sub age_lower {return ClawsMail::C::age_lower(@_); }\n"
"sub score_equal {\n"
" my $my_score = shift;\n"
" return 0 unless (defined($msginfo{\"score\"}) and defined($my_score));\n"
" if($my_score == $msginfo{\"score\"}) {\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"score_equal\");\n"
" return 1;\n"
" }else{return 0;}\n"
"}\n"
"sub score_greater {\n"
" my $my_score = shift;\n"
" return 0 unless (defined($msginfo{\"score\"}) and defined($my_score));\n"
" if($msginfo{\"score\"} > $my_score) {\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"score_greater\");\n"
" return 1;\n"
" }else{return 0;}\n"
"}\n"
"sub score_lower {\n"
" my $my_score = shift;\n"
" return 0 unless (defined($msginfo{\"score\"}) and defined($my_score));\n"
" if($msginfo{\"score\"} < $my_score) {\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"score_lower\");\n"
" return 1;\n"
" }else{return 0;}\n"
"}\n"
"sub colorlabel {\n"
" my $color = shift;\n"
" $color = lc $color;\n"
" $color = $colors{$color} if exists $colors{$color};\n"
" $color = 0 if $color =~ m/\\D/;\n"
" return ClawsMail::C::colorlabel($color);\n"
"}\n"
"sub size_greater {\n"
" my $my_size = shift;\n"
" return 0 unless (defined($msginfo{\"size\"}) and defined($my_size));\n"
" if($msginfo{\"size\"} > $my_size) {\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"size_greater\");\n"
" return 1;\n"
" }else{return 0;}\n"
"}\n"
"sub size_smaller {\n"
" my $my_size = shift;\n"
" return 0 unless (defined($msginfo{\"size\"}) and defined($my_size));\n"
" if($msginfo{\"size\"} < $my_size) {\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"size_smaller\");\n"
" return 1;\n"
" }else{return 0;}\n"
"}\n"
"sub size_equal {\n"
" my $my_size = shift;\n"
" return 0 unless (defined($msginfo{\"size\"}) and defined($my_size));\n"
" if($msginfo{\"size\"} == $my_size) {\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"size_equal\");\n"
" return 1;\n"
" }else{return 0;}\n"
"}\n"
"sub partial {\n"
" return 0 unless defined($msginfo{\"total_size\"})\n"
" and defined($msginfo{\"size\"});\n"
" if($msginfo{\"total_size\"} != 0\n"
" && $msginfo{\"size\"} != $msginfo{\"total_size\"}) {\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"partial\");\n"
" return 1;\n"
" }else{return 0;}\n"
"}\n"
"sub test {\n"
" $_ = shift; my $command = \"\"; my $hl=\"\"; my $re=\"\"; my $retval;\n"
" my $cmdline = $_;\n"
" s/\\\"/\"/g; #fool stupid emacs perl mode\";\n"
" s/([^%]*)//; $command .= $1;\n"
" while($_) {\n"
" if (/^%%/){s/^%%([^%]*)//;$command .= \"\\\\%\".$1; next;}\n"
" elsif(/^%s/){s/^%s([^%]*)//;$hl=header(\"subject\");$re=$1;}\n"
" elsif(/^%f/){s/^%f([^%]*)//;$hl=header(\"from\");$re=$1;}\n"
" elsif(/^%t/){s/^%t([^%]*)//;$hl=header(\"to\");$re=$1;}\n"
" elsif(/^%c/){s/^%c([^%]*)//;$hl=header(\"cc\");$re=$1;}\n"
" elsif(/^%d/){s/^%d([^%]*)//;$hl=header(\"date\");$re=$1;}\n"
" elsif(/^%i/){s/^%i([^%]*)//;$hl=header(\"message-id\");$re=$1;}\n"
" elsif(/^%n/){s/^%n([^%]*)//;$hl=header(\"newsgroups\");$re=$1;}\n"
" elsif(/^%r/){s/^%r([^%]*)//;$hl=header(\"references\");$re=$1;}\n"
" elsif(/^%F/){s/^%F([^%]*)//;$hl=filepath();$re=$1;}\n"
" else {s/^(%[^%]*)//; $command .= $1;}\n"
" $command .= \"\\Q$hl\\E\" if defined $hl;$hl=\"\";\n"
" $command .= $re;$re=\"\";\n"
" }\n"
" $retval = !(system($command)>>8);\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"test: $cmdline\")\n"
" if $retval;\n"
" return $retval;\n"
"}\n"
"sub matchcase {\n"
" my $retval;\n"
" $retval = match_(@_,\"i\");\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"matchcase: $_[0], $_[1]\")\n"
" if $retval;\n"
" return $retval;\n"
"}\n"
"sub match {\n"
" my $retval;\n"
" $retval = match_(@_);\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"match: $_[0], $_[1]\")\n"
" if $retval;\n"
" return $retval;\n"
"}\n"
"sub regexpcase {\n"
" my $retval;\n"
" $retval = match_(@_,\"ri\");\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"regexpcase: $_[0], $_[1]\")\n"
" if $retval;\n"
" return $retval;\n"
"}\n"
"sub regexp {\n"
" my $retval;\n"
" $retval = match_(@_,\"r\");\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"regexp: $_[0], $_[1]\")\n"
" if $retval;\n"
" return $retval;\n"
"}\n"
"# Internals\n"
"sub add_header_entries_ {\n"
" my($key,@values) = @_; $key = lc $key; $key =~ s/:$//;\n"
" $header{$key} = [] unless exists $header{$key};\n"
" push @{$header{$key}},@values;\n"
"}\n"
"# read whole mail\n"
"sub init_ {\n"
" return 0 if $mail_done;\n"
" ClawsMail::C::open_mail_file();\n"
" read_headers_();\n"
" read_body_();\n"
" ClawsMail::C::close_mail_file();\n"
" $mail_done = 1;\n"
"}\n"
"sub filter_init_ {\n"
" %header = (); %msginfo = (); undef $body; $mail_done = 0;\n"
" $manual = ClawsMail::C::filter_init(100);\n"
" $msginfo{\"size\"} = ClawsMail::C::filter_init( 1) ;\n"
" add_header_entries_(\"date\", ClawsMail::C::filter_init( 2));\n"
" add_header_entries_(\"from\", ClawsMail::C::filter_init( 3));\n"
" add_header_entries_(\"to\", ClawsMail::C::filter_init( 4));\n"
" add_header_entries_(\"cc\", ClawsMail::C::filter_init( 5));\n"
" add_header_entries_(\"newsgroups\",ClawsMail::C::filter_init( 6));\n"
" add_header_entries_(\"subject\", ClawsMail::C::filter_init( 7));\n"
" add_header_entries_(\"msgid\", ClawsMail::C::filter_init( 8));\n"
" add_header_entries_(\"inreplyto\", ClawsMail::C::filter_init( 9));\n"
" add_header_entries_(\"xref\", ClawsMail::C::filter_init(10));\n"
" add_header_entries_(\"xface\", ClawsMail::C::filter_init(11));\n"
" add_header_entries_(\"dispositionnotificationto\",\n"
" ClawsMail::C::filter_init(12));\n"
" add_header_entries_(\"returnreceiptto\",\n"
" ClawsMail::C::filter_init(13));\n"
" add_header_entries_(\"references\",ClawsMail::C::filter_init(14));\n"
" $msginfo{\"score\"} = ClawsMail::C::filter_init(15);\n"
" $msginfo{\"plaintext_file\"} = ClawsMail::C::filter_init(17);\n"
" $msginfo{\"hidden\"} = ClawsMail::C::filter_init(19);\n"
" $msginfo{\"filepath\"} = ClawsMail::C::filter_init(20);\n"
" $msginfo{\"partial_recv\"} = ClawsMail::C::filter_init(21);\n"
" $msginfo{\"total_size\"} = ClawsMail::C::filter_init(22);\n"
" $msginfo{\"account_server\"} = ClawsMail::C::filter_init(23);\n"
" $msginfo{\"account_login\"} = ClawsMail::C::filter_init(24);\n"
" $msginfo{\"planned_download\"} = ClawsMail::C::filter_init(25);\n"
"} \n"
"sub read_headers_ {\n"
" my($key,$value);\n"
" %header = ();\n"
" while(($key,$value) = ClawsMail::C::get_next_header()) {\n"
" next unless $key =~ /:$/;\n"
" add_header_entries_($key,$value);\n"
" }\n"
"}\n"
"sub read_body_ {\n"
" my $line;\n"
" while(defined($line = ClawsMail::C::get_next_body_line())) {\n"
" $body .= $line;\n"
" } \n"
"}\n"
"sub match_ {\n"
" my ($where,$what,$modi) = @_; $modi ||= \"\";\n"
" my $nocase=\"\"; $nocase = \"1\" if (index($modi,\"i\") != -1);\n"
" my $regexp=\"\"; $regexp = \"1\" if (index($modi,\"r\") != -1);\n"
" if($where eq \"to_or_cc\") {\n"
" if(not $regexp) { \n"
" return ((index(header(\"to\"),$what) != -1) or\n"
" (index(header(\"cc\"),$what) != -1)) unless $nocase;\n"
" return ((index(lc header(\"to\"),lc $what) != -1) or\n"
" (index(lc header(\"cc\"),lc $what) != -1))\n"
" } else {\n"
" return ((header(\"to\") =~ m/$what/) or\n"
" (header(\"cc\") =~ m/$what/)) unless $nocase;\n"
" return ((header(\"to\") =~ m/$what/i) or\n"
" (header(\"cc\") =~ m/$what/i));\n"
" }\n"
" } elsif($where eq \"body_part\") {\n"
" my $mybody = body(); $mybody =~ s/\\s+/ /g;\n"
" if(not $regexp) {\n"
" return (index($mybody,$what) != -1) unless $nocase;\n"
" return (index(lc $mybody,lc $what) != -1);\n"
" } else {\n"
" return ($body =~ m/$what/) unless $nocase;\n"
" return ($body =~ m/$what/i);\n"
" }\n"
" } elsif($where eq \"headers_part\") {\n"
" my $myheader = header_as_string_();\n"
" if(not $regexp) {\n"
" $myheader =~ s/\\s+/ /g;\n"
" return (index($myheader,$what) != -1) unless $nocase;\n"
" return (index(lc $myheader,lc $what) != -1);\n"
" } else {\n"
" return ($myheader =~ m/$what/) unless $nocase;\n"
" return ($myheader =~ m/$what/i);\n"
" }\n"
" } elsif($where eq \"message\") {\n"
" my $message = header_as_string_();\n"
" $message .= \"\\n\".body();\n"
" if(not $regexp) {\n"
" $message =~ s/\\s+/ /g;\n"
" return (index($message,$what) != -1) unless $nocase;\n"
" return (index(lc $message,lc $what) != -1);\n"
" } else {\n"
" return ($message =~ m/$what/) unless $nocase;\n"
" return ($message =~ m/$what/i);\n"
" }\n"
" } else {\n"
" $where = lc $where;\n"
" my $myheader = header(lc $where); $myheader ||= \"\";\n"
" return 0 unless $myheader;\n"
" if(not $regexp) { \n"
" return (index(header($where),$what) != -1) unless $nocase;\n"
" return (index(lc header($where),lc $what) != -1);\n"
" } else {\n"
" return (header($where) =~ m/$what/) unless $nocase;\n"
" return (header($where) =~ m/$what/i);\n"
" } \n"
" }\n"
"}\n"
"sub header_as_string_ {\n"
" my $headerstring=\"\";\n"
" my @headerkeys = header(); my(@fields,$field);\n"
" foreach $field (@headerkeys) {\n"
" @fields = header($field);\n"
" foreach (@fields) {\n"
" $headerstring .= $field.\": \".$_.\"\\n\";\n"
" }\n"
" }\n"
" return $headerstring;\n"
"}\n"
"our $permanent = \"\";\n"
"1;\n"
};
const char perl_filter_action[] = {
"BEGIN {$INC{'ClawsMail/Filter/Action.pm'} = 1;}\n"
"package ClawsMail::Filter::Action;\n"
"use base qw(Exporter);\n"
"our @EXPORT = (qw(mark unmark dele mark_as_unread mark_as_read),\n"
" qw(lock unlock move copy color execute),\n"
" qw(hide set_score change_score stop exit),\n"
" qw(forward forward_as_attachment redirect),\n"
" );\n"
"our %colors = ('none' => 0,'orange' => 1,\n"
" 'red' => 2,'pink' => 3,\n"
" 'sky blue' => 4,'blue' => 5,\n"
" 'green' => 6,'brown' => 7);\n"
"sub mark { ClawsMail::C::set_flag (1);}\n"
"sub unmark { ClawsMail::C::unset_flag(1);}\n"
"sub mark_as_unread { ClawsMail::C::set_flag (2);}\n"
"sub mark_as_read { ClawsMail::C::unset_flag(2);}\n"
"sub lock { ClawsMail::C::set_flag (7);}\n"
"sub unlock { ClawsMail::C::unset_flag(7);}\n"
"sub copy { ClawsMail::C::copy (@_);}\n"
"sub forward { ClawsMail::C::forward(1,@_);}\n"
"sub forward_as_attachment {ClawsMail::C::forward(2,@_);}\n"
"sub redirect { ClawsMail::C::redirect(@_); }\n"
"sub hide { ClawsMail::C::hide(); }\n"
"sub exit {\n"
" ClawsMail::C::filter_log(\"LOG_ACTION\",\"exit\");\n"
" stop(1);\n"
"}\n"
"sub stop {\n"
" my $nolog = shift;\n"
" ClawsMail::C::filter_log(\"LOG_ACTION\", \"stop\")\n"
" unless defined($nolog);\n"
" die 'intended';\n"
"}\n"
"sub set_score {\n"
" $ClawsMail::Filter::Matcher::msginfo{\"score\"} =\n"
" ClawsMail::C::set_score(@_);\n"
"}\n"
"sub change_score {\n"
" $ClawsMail::Filter::Matcher::msginfo{\"score\"} =\n"
" ClawsMail::C::change_score(@_);\n"
"}\n"
"sub execute {\n"
" my $flv; my $cmd = shift; return 0 unless defined($cmd);\n"
" $flv = ClawsMail::C::filter_log_verbosity(0);\n"
" ClawsMail::Filter::Matcher::test($cmd);\n"
" ClawsMail::C::filter_log_verbosity($flv);\n"
" ClawsMail::C::filter_log(\"LOG_ACTION\", \"execute: $cmd\");\n"
" 1;\n"
"}\n"
"sub move { ClawsMail::C::move(@_); stop(1);}\n"
"sub dele { ClawsMail::C::delete(); stop(1);}\n"
"sub color {\n"
" ($color) = @_;$color = lc $color;\n"
" $color = $colors{$color} if exists $colors{$color};\n"
" $color = 0 if $color =~ m/\\D/;\n"
" ClawsMail::C::color($color);\n"
"}\n"
"1;\n"
};
const char perl_utils[] = {
"BEGIN {$INC{'ClawsMail/Utils.pm'} = 1;}\n"
"package ClawsMail::Utils;\n"
"use base qw(Exporter);\n"
"our @EXPORT = (\n"
" qw(SA_is_spam extract_addresses move_to_trash abort),\n"
" qw(addr_in_addressbook from_in_addressbook),\n"
" qw(get_attribute_value),\n"
" );\n"
"# Spam\n"
"sub SA_is_spam {\n"
" my $retval;\n"
" $retval = not ClawsMail::Filter::Matcher::test('spamc -c < %F > /dev/null');\n"
" ClawsMail::C::filter_log(\"LOG_MATCH\",\"SA_is_spam\") if $retval;\n"
" return $retval;\n"
"}\n"
"# simple extract email addresses from a header field\n"
"sub extract_addresses {\n"
" my $hf = shift; return undef unless defined($hf);\n"
" my @addr = ();\n"
" while($hf =~ m/[-.+\\w]+\\@[-.+\\w]+/) {\n"
" $hf =~ s/^.*?([-.+\\w]+\\@[-.+\\w]+)//;\n"
" push @addr,$1;\n"
" }\n"
" push @addr,\"\" unless @addr;\n"
" return @addr;\n"
"}\n"
"# move to trash\n"
"sub move_to_trash {\n"
" ClawsMail::C::move_to_trash();\n"
" ClawsMail::Filter::Action::stop(1);\n"
"}\n"
"# abort: stop() and do not continue with built-in filtering\n"
"sub abort {\n"
" ClawsMail::C::abort();\n"
" ClawsMail::Filter::Action::stop(1);\n"
"}\n"
"# addressbook query\n"
"sub addr_in_addressbook {\n"
" return ClawsMail::C::addr_in_addressbook(@_) if @_;\n"
" return 0;\n"
"}\n"
"sub from_in_addressbook {\n"
" my ($from) = extract_addresses(ClawsMail::Filter::Matcher::header(\"from\"));\n"
" return 0 unless $from;\n"
" return addr_in_addressbook($from,@_);\n"
"}\n"
"sub get_attribute_value {\n"
" my $email = shift; my $key = shift;\n"
" return \"\" unless ($email and $key);\n"
" return ClawsMail::C::get_attribute_value($email,$key,@_);\n"
"}\n"
"1;\n"
};
if((my_perl = perl_alloc()) == NULL) {
g_warning("Perl Plugin: Not enough memory to allocate Perl interpreter");
return -1;
}
PL_perl_destruct_level = 1;
perl_construct(my_perl);
exitstatus = perl_parse(my_perl, xs_init, 4, initialize, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
eval_pv(perl_filter_matcher,TRUE);
eval_pv(perl_filter_action,TRUE);
eval_pv(perl_persistent,TRUE);
eval_pv(perl_utils,TRUE);
return exitstatus;
}
static gboolean my_filtering_hook(gpointer source, gpointer data)
{
int retry;
g_return_val_if_fail(source != NULL, FALSE);
mail_filtering_data = (MailFilteringData *) source;
msginfo = mail_filtering_data->msginfo;
if (!msginfo)
return FALSE;
stop_filtering = FALSE;
wrote_filter_log_head = FALSE;
filter_log_verbosity = config.filter_log_verbosity;
if(GPOINTER_TO_UINT(data) == AUTO_FILTER)
manual_filtering = FALSE;
else if(GPOINTER_TO_UINT(data) == MANU_FILTER)
manual_filtering = TRUE;
else
debug_print("Invalid user data ignored.\n");
if(!manual_filtering)
statusbar_print_all("Perl Plugin: filtering message...");
/* Process Skript File */
retry = perl_load_file();
while(retry == 1) {
debug_print("Error processing Perl script file. Retrying..\n");
retry = perl_load_file();
}
if(retry == 2) {
debug_print("Error processing Perl script file. Aborting..\n");
stop_filtering = FALSE;
}
return stop_filtering;
}
static void perl_plugin_save_config(void)
{
PrefFile *pfile;
gchar *rcpath;
debug_print("Saving Perl Plugin Configuration\n");
rcpath = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, COMMON_RC, NULL);
pfile = prefs_write_open(rcpath);
g_free(rcpath);
if (!pfile || (prefs_set_block_label(pfile, "PerlPlugin") < 0))
return;
if (prefs_write_param(param, pfile->fp) < 0) {
g_warning("Perl Plugin: Failed to write Perl Plugin configuration to file");
prefs_file_close_revert(pfile);
return;
}
fprintf(pfile->fp, "\n");
prefs_file_close(pfile);
}
gint plugin_init(gchar **error)
{
int argc;
char *argv[1];
char *env[1];
int status = 0;
FILE *fp;
gchar *perlfilter;
gchar *rcpath;
argc = 1;
*argv = NULL;
*env = NULL;
/* version check */
if(!check_plugin_version(MAKE_NUMERIC_VERSION(2,9,2,72),
VERSION_NUMERIC, "Perl", error))
return -1;
/* register hook for automatic and manual filtering */
filtering_hook_id = hooks_register_hook(MAIL_FILTERING_HOOKLIST,
my_filtering_hook,
GUINT_TO_POINTER(AUTO_FILTER));
if(filtering_hook_id == (guint) -1) {
*error = g_strdup("Failed to register mail filtering hook");
return -1;
}
manual_filtering_hook_id = hooks_register_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
my_filtering_hook,
GUINT_TO_POINTER(MANU_FILTER));
if(manual_filtering_hook_id == (guint) -1) {
hooks_unregister_hook(MAIL_FILTERING_HOOKLIST, filtering_hook_id);
*error = g_strdup("Failed to register manual mail filtering hook");
return -1;
}
rcpath = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, COMMON_RC, NULL);
prefs_read_config(param, "PerlPlugin", rcpath, NULL);
g_free(rcpath);
/* make sure we have at least an empty scriptfile */
perlfilter = g_strconcat(get_rc_dir(), G_DIR_SEPARATOR_S, PERLFILTER, NULL);
if((fp = fopen(perlfilter, "a")) == NULL) {
*error = g_strdup("Failed to create blank scriptfile");
g_free(perlfilter);
hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
filtering_hook_id);
hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
manual_filtering_hook_id);
return -1;
}
/* chmod for security */
if (change_file_mode_rw(fp, perlfilter) < 0) {
FILE_OP_ERROR(perlfilter, "chmod");
g_warning("Perl Plugin: Can't change file mode");
}
fclose(fp);
g_free(perlfilter);
/* Initialize Perl Interpreter */
PERL_SYS_INIT3(&argc,&argv,&env);
if(my_perl == NULL)
status = perl_init();
if(status) {
*error = g_strdup("Failed to load Perl Interpreter\n");
hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
filtering_hook_id);
hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
manual_filtering_hook_id);
return -1;
}
perl_gtk_init();
debug_print("Perl Plugin loaded\n");
return 0;
}
gboolean plugin_done(void)
{
hooks_unregister_hook(MAIL_FILTERING_HOOKLIST,
filtering_hook_id);
hooks_unregister_hook(MAIL_MANUAL_FILTERING_HOOKLIST,
manual_filtering_hook_id);
free_all_lists();
if(my_perl != NULL) {
PL_perl_destruct_level = 1;
perl_destruct(my_perl);
perl_free(my_perl);
}
PERL_SYS_TERM();
perl_plugin_save_config();
perl_gtk_done();
debug_print("Perl Plugin unloaded\n");
return TRUE;
}
const gchar *plugin_name(void)
{
return "Perl";
}
const gchar *plugin_desc(void)
{
return "This plugin provides a Perl scripting "
"interface for mail filters.\nFeedback "
"to <berndth@gmx.de> is welcome.";
}
const gchar *plugin_type(void)
{
return "GTK2";
}
const gchar *plugin_licence(void)
{
return "GPL3+";
}
const gchar *plugin_version(void)
{
return PLUGINVERSION;
}
struct PluginFeature *plugin_provides(void)
{
static struct PluginFeature features[] =
{ {PLUGIN_FILTERING, N_("Perl integration")},
{PLUGIN_NOTHING, NULL}};
return features;
}
syntax highlighted by Code2HTML, v. 0.9.1