Fix error creation and warning
[claws.git] / src / plugins / perl / tools / matcherrc2perlfilter.pl
blob8b0dad93eb262a3108d442936f663784ed773b92
1 #!/usr/bin/perl -w
3 ## script purpose : convert matcherrc filtering rules into
4 ## perl_filter rules
6 # This conversion-tool doesn't produce nice Perl code and is just
7 # intended to get you started. If you choose to use the Perl plugin,
8 # consider rewriting your rules.
10 # Copyright (C) 2004-2014 Holger Berndt
13 # This file is free software; you can redistribute it and/or modify it
14 # under the terms of the GNU General Public License as published by
15 # the Free Software Foundation; either version 3 of the License, or
16 # (at your option) any later version.
18 # This program is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 # General Public License for more details.
23 # You should have received a copy of the GNU General Public License
24 # along with this program. If not, see <http://www.gnu.org/licenses/>.
26 use strict;
28 our $warnings = 0;
29 our $lines = 0;
30 our $tokens = 0;
32 my $home_dir = $ENV{"HOME"}; $home_dir ||= ".";
33 my $sylph_dir = `claws-mail --config-dir`;
34 my $matcherrc = "matcherrc";
35 my $perlfilter = "perl_filter";
36 my $dirsep = "/";
38 chomp($sylph_dir); $sylph_dir =~ s/.*\n(.*)$/$1/;
39 my $inpath = $home_dir.$dirsep.$sylph_dir.$dirsep.$matcherrc;
40 my $outpath = $home_dir.$dirsep.$sylph_dir.$dirsep.$perlfilter;
41 open IN, $inpath or die "Cannot open $inpath: $!";
42 open OUT,">>",$outpath or die "Cannot open $outpath: $!";
44 print "Filtering rules are read from `$inpath', converted to Perl\n";
45 print "syntax and appended to `$outpath'\n";
46 print "`$inpath' is not changed, so you might want to make a backup\n";
47 print "copy of it and then remove your former filtering rules\n";
48 print "---\n";
49 my $date = `date`;
50 chomp($date);
51 print OUT "### Begin: Rules converted by matcherrc2perlfilter.pl $date ###\n";
52 while(my $line = <IN>) {
53 $line =~ s/^\s*(.*)\s*$/$1/;
54 if($line =~ /^\[filtering\]$/i) {
55 while($line = <IN>) {
56 $line =~ s/^\s*(.*)\s*$/$1/;
57 next if $line =~ /^$/;
58 if($line =~ /^\[(.+)\]$/) {
59 last unless ($1 =~ /filtering/i);
61 my @fields = splitline($line);
62 $lines++;
63 convert(@fields);
67 print "---\n" if $warnings;
68 print "Finished conversion of $lines rules with $warnings warnings.\n";
69 print OUT "### End: Rules converted by matcherrc2perlfilter.pl $date ###\n";
71 # convert a rule
72 sub convert {
73 my $act = 0;
74 my $output="(";
75 while(my $token = shift) {
76 $tokens++;
77 if($token eq "&") {
78 $token = shift;
80 elsif($token eq "|") {
81 $output =~ s/&& $/\|\| /;
82 $token = shift;
84 elsif($tokens != 1 and $act == 0) {
85 $act = 1;
86 if($output =~ / (&&|\|\|) $/) {
87 $output =~ s/ (&&|\|\|) $/\) $1 /;
89 else {
90 $output .= ")";
94 if($token eq "~") {
95 $output .= "!";
96 $token = shift;
99 if($token eq "all" or
100 $token eq "marked" or
101 $token eq "deleted" or
102 $token eq "replied" or
103 $token eq "forwarded" or
104 $token eq "locked" or
105 $token eq "unread" or
106 $token eq "new" or
107 $token eq "partial" or
108 $token eq "ignore_thread" or
109 $token eq "mark" or
110 $token eq "unmark" or
111 $token eq "lock" or
112 $token eq "unlock" or
113 $token eq "stop" or
114 $token eq "hide" or
115 $token eq "mark_as_read" or
116 $token eq "mark_as_unread") {
117 $output .= qq|($token) && |;
119 elsif($token eq "delete") {
120 $output .= qq|(dele) && |;
122 elsif($token eq "subject" or
123 $token eq "from" or
124 $token eq "to" or
125 $token eq "cc" or
126 $token eq "to_or_cc" or
127 $token eq "newsgroups" or
128 $token eq "inreplyto" or
129 $token eq "references" or
130 $token eq "headers_part" or
131 $token eq "headers_cont" or
132 $token eq "body_part" or
133 $token eq "message") {
134 my $match = shift;
135 my $what = shift;
136 $what =~ s/\\"/"/g;$what =~ s/'/\\'/g;
137 $what =~ s/^"(.*)"$/'$1'/;
138 $output .= qq|($match($token,$what)) && |;
140 elsif($token eq "age_greater" or
141 $token eq "age_lower" or
142 $token eq "colorlabel" or
143 $token eq "score_greater" or
144 $token eq "score_lower" or
145 $token eq "score_equal" or
146 $token eq "size_greater" or
147 $token eq "size_smaller" or
148 $token eq "size_equal" or
149 $token eq "move" or
150 $token eq "copy" or
151 $token eq "execute" or
152 $token eq "color" or
153 $token eq "test" or
154 $token eq "change_score" or
155 $token eq "set_score") {
156 my $arg = shift;
157 $arg =~ s/\\"/"/g;$arg =~ s/'/\\'/g;
158 $arg =~ s/^"(.*)"$/'$1'/;
159 $output .= qq|($token($arg)) && |;
161 elsif($token eq "header") {
162 my $headername = shift;
163 $headername =~ s/\\"/"/g;$headername =~ s/'/\\'/g;
164 $headername =~ s/^"(.*)"$/'$1'/;
165 my $match = shift;
166 my $what = shift;
167 $what =~ s/\\"/"/g;$what =~ s/'/\\'/g;
168 $what =~ s/^"(.*)"$/'$1'/;
169 $output .= qq|($match($headername,$what)) && |;
171 elsif($token eq "stop") {
172 $output .= qq|(return) && |;
174 else {
175 print STDERR "WARNING: unknown token in $inpath ignored: $token\n";
176 $warnings++;
179 $output =~ s| && $|;\n|;
180 print OUT $output;
181 $tokens = 0;
184 # split the input line
185 sub splitline {
186 my @fields;
187 my $line = shift;
188 while($line) {
189 $line =~ s/^\s+//;
190 if($line =~ m#^"#) {
191 $line =~ s#^(".*?[^\\]")##;
192 push @fields,$1;
194 elsif($line =~ /^~/) {
195 $line =~ s#^(~)##;
196 push @fields,$1;
198 else {
199 $line =~ s#^(\S+)##;
200 push @fields,$1;
203 return @fields;