2
# Copyright 2006 Apache Software Foundation
4
# Licensed under the Apache License, Version 2.0 (the "License");
5
# you may not use this file except in compliance with the License.
6
# You may obtain a copy of the License at
8
# http://www.apache.org/licenses/LICENSE-2.0
10
# Unless required by applicable law or agreed to in writing, software
11
# distributed under the License is distributed on an "AS IS" BASIS,
12
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13
# See the License for the specific language governing permissions and
14
# limitations under the License.
19
Mail::SpamAssassin::Plugin::BodyRuleBaseExtractor - extract "bases" from body ruleset
23
This is a plugin to extract "base" strings from SpamAssassin 'body' rules,
24
suitable for use in Rule2XSBody rules or other parallel matching algorithms.
28
package Mail::SpamAssassin::Plugin::BodyRuleBaseExtractor;
30
use Mail::SpamAssassin::Plugin;
31
use Mail::SpamAssassin::Logger;
32
use Mail::SpamAssassin::Util qw(untaint_var);
33
use Mail::SpamAssassin::Util::Progress;
35
use Errno qw(ENOENT EACCES EEXIST);
44
@ISA = qw(Mail::SpamAssassin::Plugin);
46
use constant DEBUG_RE_PARSING => 0; # noisy!
48
# a few settings that control what kind of bases are output.
50
# treat all rules as lowercase for purposes of term extraction?
51
# $main->{bases_must_be_casei} = 1;
52
# $main->{bases_can_use_alternations} = 0; # /(foo|bar|baz)/
53
# $main->{bases_can_use_quantifiers} = 0; # /foo.*bar/ or /foo*bar/ or /foooo?bar/
54
# $main->{bases_can_use_char_classes} = 0; # /fo[opqr]bar/
55
# $main->{bases_split_out_alternations} = 1; # /(foo|bar|baz)/ => ["foo", "bar", "baz"]
56
# $main->{base_quiet} = 0; # silences progress output
58
# TODO: it would be nice to have a clean API to pass such settings
59
# through to plugins instead of hanging them off $main
61
##############################################################################
63
# testing purposes only
65
#$fixup_re_test = 1; fixup_re("fr()|\\\\|"); die;
66
#$fixup_re_test = 1; fixup_re("\\x{1b}\$b"); die;
67
#$fixup_re_test = 1; fixup_re("\\33\$b"); die;
68
#$fixup_re_test = 1; fixup_re("[link]"); die;
69
#$fixup_re_test = 1; fixup_re("please do not resend your original message."); die;
71
###########################################################################
75
my $mailsaobject = shift;
76
$class = ref($class) || $class;
77
my $self = $class->SUPER::new($mailsaobject);
78
bless ($self, $class);
80
$self->{show_progress} = !$mailsaobject->{base_quiet};
82
# $self->test(); exit;
86
###########################################################################
88
sub finish_parsing_end {
89
my ($self, $params) = @_;
90
my $conf = $params->{conf};
91
$self->extract_bases($conf);
95
my ($self, $conf) = @_;
97
my $main = $conf->{main};
98
if (!$main->{base_extract}) { return; }
100
$self->{show_progress} and
101
info("base extraction starting. this can take a while...");
103
$self->extract_set($conf, $conf->{body_tests}, 'body');
107
my ($self, $conf, $test_set, $ruletype) = @_;
109
foreach my $pri (keys %{$test_set}) {
110
my $nicepri = $pri; $nicepri =~ s/-/neg/g;
111
$self->extract_set_pri($conf, $test_set->{$pri}, $ruletype.'_'.$nicepri);
115
###########################################################################
117
sub extract_set_pri {
118
my ($self, $conf, $rules, $ruletype) = @_;
126
$self->{main} = $conf->{main}; # for use in extract_hints()
127
$self->{show_progress} and info ("extracting from rules of type $ruletype");
128
my $tflags = $conf->{tflags};
130
# attempt to find good "base strings" (simplified regexp subsets) for each
131
# regexp. We try looking at the regexp from both ends, since there
132
# may be a good long string of text at the end of the rule.
134
# require this many chars in a base string + delimiters for it to be viable
138
$self->{show_progress} and $progress = Mail::SpamAssassin::Util::Progress->new({
139
total => (scalar keys %{$rules} || 1),
146
if ($self->{main}->{bases_cache_dir}) {
147
$cachefile = $self->{main}->{bases_cache_dir}."/rules.$ruletype";
148
dbg("zoom: reading cache file $cachefile");
149
$cached = $self->read_cachefile($cachefile);
153
foreach my $name (keys %{$rules}) {
154
$self->{show_progress} and $progress and $progress->update(++$count);
156
my $rule = $rules->{$name};
157
my $cachekey = join "#", $name, $rule;
159
my $cent = $cached->{rule_bases}->{$cachekey};
161
if (defined $cent->{g}) {
162
dbg("zoom: YES (cached) $rule $name");
163
foreach my $ent (@{$cent->{g}}) {
164
# note: we have to copy these, since otherwise later
165
# modifications corrupt the cached data
167
base => $ent->{base}, orig => $ent->{orig}, name => $ent->{name}
173
dbg("zoom: NO (cached) $rule $name");
174
push @failed, { orig => $rule }; # no need to cache this
180
# ignore ReplaceTags rules
181
my $is_a_replacetags_rule = $conf->{rules_to_replace}->{$name};
182
my ($minlen, $lossy, @bases);
184
if (!$is_a_replacetags_rule) {
185
eval { # catch die()s
186
my ($qr, $mods) = $self->simplify_and_qr_regexp($rule);
187
($lossy, @bases) = $self->extract_hints($rule, $qr, $mods);
188
# dbg("zoom: %s %s -> %s", $name, $rule, join(", ", @bases));
191
my $eval_stat = $@ ne '' ? $@ : "errno=$!"; chomp $eval_stat;
192
dbg("zoom: giving up on regexp: $eval_stat");
195
if ($lossy && ($tflags->{$name}||'') =~ /\bmultiple\b/) {
196
warn "\nzoom: rule $name will loop on SpamAssassin older than 3.3.2 ".
197
"running under Perl 5.12 or older, Bug 6558\n";
200
# if any of the extracted hints in a set are too short, the entire
201
# set is invalid; this is because each set of N hints represents just
203
foreach my $str (@bases) {
204
my $len = length fixup_re($str); # bug 6143: count decoded characters
205
if ($len < $min_chars) { $minlen = undef; @bases = (); last; }
206
elsif (!defined($minlen) || $len < $minlen) { $minlen = $len; }
210
if ($is_a_replacetags_rule || !$minlen || !@bases) {
211
dbg("zoom: ignoring rule %s, %s", $name,
212
$is_a_replacetags_rule ? 'is a replace rule'
213
: !@bases ? 'no bases' : 'no minlen');
214
push @failed, { orig => $rule };
215
$cached->{rule_bases}->{$cachekey} = { };
219
# dbg("zoom: YES <base>$base</base> <origrule>$rule</origrule>");
221
# figure out if we have e.g. ["foo", "foob", "foobar"]; in this
222
# case, we only need to track ["foo"].
224
foreach my $base1 (@bases) {
225
foreach my $base2 (@bases) {
226
if ($base1 ne $base2 && $base1 =~ /\Q$base2\E/) {
227
$subsumed{$base1} = 1; # base2 is inside base1; discard the longer
233
foreach my $base (@bases) {
234
next if $subsumed{$base};
236
base => $base, orig => $rule, name => "$name,[l=$lossy]"
238
# *separate* copies for cache -- we modify the @good_bases entry
240
base => $base, orig => $rule, name => "$name,[l=$lossy]"
244
$cached->{rule_bases}->{$cachekey} = { g => \@forcache };
249
$self->{show_progress} and $progress and $progress->final();
251
dbg("zoom: $ruletype: found ".(scalar @good_bases).
252
" usable base strings in $yes rules, skipped $no rules");
254
# NOTE: re2c will attempt to provide the longest pattern that matched; e.g.
255
# ("food" =~ "foo" / "food") will return "food". So therefore if a pattern
256
# subsumes other patterns, we need to return hits for all of them. We also
257
# need to take care of the case where multiple regexps wind up sharing the
260
# Another gotcha, an exception to the subsumption rule; if one pattern isn't
261
# entirely subsumed (e.g. "food" =~ "foo" / "ood"), then they will be
262
# returned as two hits, correctly. So we only have to be smart about the
263
# full-subsumption case; overlapping is taken care of for us, by re2c.
265
# TODO: there's a bug here. Since the code in extract_hints() has been
266
# modified to support more complex regexps, we can no longer simply assume
267
# that if pattern A is not contained in pattern B, that means that pattern B
268
# doesn't subsume it. Consider, for example, A="foo*bar" and
269
# B="morefobarry"; A is indeed subsumed by B, but we won't be able to test
270
# that without running the A RE match itself somehow against B.
271
# same issue remains with:
273
# "foo?bar" / "fobar"
274
# "fo(?:o|oo|)bar" / "fobar"
275
# "fo(?:o|oo)?bar" / "fobar"
276
# "fo(?:o*|baz)bar" / "fobar"
277
# "(?:fo(?:o*|baz)bar|blargh)" / "fobar"
279
# it's worse with this:
281
# "fo(?:o|oo|)bar" / "foo*bar"
283
# basically, this is impossible to compute without reimplementing most of
284
# re2c, and it appears the re2c developers don't plan to offer this:
285
# https://sourceforge.net/tracker/index.php?func=detail&aid=1540845&group_id=96864&atid=616203
287
$conf->{base_orig}->{$ruletype} = { };
288
$conf->{base_string}->{$ruletype} = { };
291
$self->{show_progress} and $progress = Mail::SpamAssassin::Util::Progress->new({
292
total => (scalar @good_bases || 1),
296
# this bit is annoyingly O(N^2). Rewrite the data -- the @good_bases
297
# array -- into a more efficient format, using arrays and with a little
298
# bit of precomputation, to go (quite a bit) faster
301
foreach my $set1 (@good_bases) {
302
my $base = $set1->{base};
303
next if (!$base || !$set1->{name});
310
0 # 5, has_multiple flag
313
@good_bases = @rewritten;
315
foreach my $set1 (@good_bases) {
316
$self->{show_progress} and $progress and $progress->update(++$count);
318
my $base1 = $set1->[0]; next unless $base1;
319
my $name1 = $set1->[1];
320
my $orig1 = $set1->[2];
321
$conf->{base_orig}->{$ruletype}->{$name1} = $orig1;
322
my $len1 = $set1->[3];
324
foreach my $set2 (@good_bases) {
325
next if ($set1 == $set2);
327
my $base2 = $set2->[0]; next unless $base2;
328
my $name2 = $set2->[1];
330
# clobber exact dups; this can happen if a regexp outputs the
331
# same base string multiple times
332
if ($base1 eq $base2 &&
334
$orig1 eq $set2->[2])
336
$set2->[0] = ''; # clobber
340
# skip if it's too short to contain the other base string
341
next if ($len1 < $set2->[3]);
343
# skip if either already contains the other rule's name
344
# optimize: this can only happen if the base has more than
345
# one rule already attached, ie [5]
346
next if ($set2->[5] && $name2 =~ /(?: |^)\Q$name1\E(?: |$)/);
348
# don't use $name1 here, since another base in the set2 loop
349
# may have added $name2 since we set that
350
next if ($set1->[5] && $set1->[1] =~ /(?: |^)\Q$name2\E(?: |$)/);
352
# and finally check to see if it *does* contain the other base string
353
next if ($base1 !~ $set2->[4]);
355
# base2 is just a subset of base1
356
# dbg("zoom: subsuming '$base2' ($name2) into '$base1': [1]=$set1->[1] [5]=$set1->[5]");
357
$set1->[1] .= " ".$name2;
362
# we can still have duplicate cases; __FRAUD_PTS and __SARE_FRAUD_BADTHINGS
363
# both contain "killed" for example, pointing at different rules, which
364
# the above search hasn't found. Collapse them here with a hash
366
foreach my $set (@good_bases) {
367
my $base = $set->[0];
370
if (defined $bases{$base}) {
371
$bases{$base} .= " ".$set->[1];
373
$bases{$base} = $set->[1];
378
foreach my $base (keys %bases) {
379
# uniq the list, since there are probably dup rules listed
381
for my $i (split ' ', $bases{$base}) {
382
next if exists $u{$i}; undef $u{$i};
384
$conf->{base_string}->{$ruletype}->{$base} = join ' ', sort keys %u;
386
$self->{show_progress} and $progress and $progress->final();
389
$self->write_cachefile ($cachefile, $cached);
392
my $elapsed = time - $start;
393
$self->{show_progress} and info ("$ruletype: ".
394
(scalar keys %{$conf->{base_string}->{$ruletype}}).
395
" base strings extracted in $elapsed seconds\n");
398
###########################################################################
401
# NO /no.{1,10}P(?:er|re)scription.{1,10}(?:needed|require|necessary)/i
402
# => should extract 'scription' somehow
403
# /time to refinance|refinanc\w{1,3}\b.{0,16}\bnow\b/i
404
# => should understand alternations; tricky
406
sub simplify_and_qr_regexp {
410
my $main = $self->{main};
411
$rule = Mail::SpamAssassin::Util::regexp_remove_delimiters($rule);
413
# remove the regexp modifiers, keep for later
415
while ($rule =~ s/^\(\?([a-z]*)\)//) { $mods .= $1; }
418
while ($rule =~ s/^\(\?-([a-z]*)\)//) {
419
foreach my $modchar (split '', $mods) {
420
$mods =~ s/$modchar//g;
426
# now: simplify aspects of the regexp. Bear in mind that we can
427
# simplify as long as we cause the regexp to become more general;
428
# more hits is OK, since false positives will be discarded afterwards
429
# anyway. Simplification that causes the regexp to *not* hit
430
# stuff that the "real" rule would hit, however, is a bad thing.
432
if ($main->{bases_must_be_casei}) {
436
$mods =~ s/i// and $lossy = 0;
438
# always case-i: /A(?i:ct) N(?i:ow)/ => /Act Now/
439
$rule =~ s/(?<!\\)\(\?i\:(.*?)\)/$1/gs and $lossy++;
441
# always case-i: /A(?-i:ct)/ => /Act/
442
$rule =~ s/(?<!\\)\(\?-i\:(.*?)\)/$1/gs and $lossy++;
445
$rule =~ s/\(\?i\)//gs;
448
die "case-i" if $rule =~ /\(\?i\)/;
449
die "case-i" if $mods =~ /i/;
451
# always case-i: /A(?i:ct) N(?i:ow)/ => /Act Now/
452
$rule =~ s/(?<!\\)\(\?i\:(.*?)\)/$1/gs and die "case-i";
454
# we're already non-case-i so this is a no-op: /A(?-i:ct)/ => /Act/
455
$rule =~ s/(?<!\\)\(\?-i\:(.*?)\)/$1/gs;
458
# remove /m and /s modifiers
459
$mods =~ s/m// and $lossy++;
460
$mods =~ s/s// and $lossy++;
463
# T_KAM_STOCKTIP23 /(EXTREME INNOVATIONS|(^|\b)EXTI($|\b))/is
464
$rule =~ s/\(\^\|\\b\)//gs and $lossy++;
465
$rule =~ s/\(\$\|\\b\)//gs and $lossy++;
466
$rule =~ s/\(\\b\|\^\)//gs and $lossy++;
467
$rule =~ s/\(\\b\|\$\)//gs and $lossy++;
470
$rule =~ s/\(\?\![^\)]+\)//gs and $lossy++;
473
$rule =~ s/(?<!\\)\\b//gs and $lossy++;
475
# remove the "?=" trick
476
# (?=[dehklnswxy])(horny|nasty|hot|wild|young|....etc...)
477
$rule =~ s/\(\?\=\[[^\]]+\]\)//gs;
479
$mods .= "L" if $lossy;
489
my $main = $self->{main};
493
$mods =~ s/L// and $lossy++;
495
# if there are anchors, give up; we can't get much
496
# faster than these anyway
497
die "anchors" if $rule =~ /^\(?(?:\^|\\A)/;
499
# die "anchors" if $rule =~ /(?:\$|\\Z)\)?$/;
500
# just remove end-of-string anchors; they're slow so could gain
502
$rule =~ s/(?<!\\)(?:\$|\\Z)\)?$// and $lossy++;
504
# simplify (?:..) to (..)
505
$main->{bases_allow_noncapture_groups} or
506
$rule =~ s/\(\?:/\(/g;
508
# simplify some grouping arrangements so they're easier for us to parse
510
$rule =~ s/\((.*?)\)\?/\($1\|\)/gs;
512
$rule =~ s/(?<!\\)(\w)\?/\($1\|\)/gs;
514
my ($tmpf, $tmpfh) = Mail::SpamAssassin::Util::secure_tmpfile();
515
$tmpfh or die "failed to create a temporary file";
518
print $tmpfh "use bytes; m{" . $rule . "}" . $mods
519
or die "error writing to $tmpf: $!";
520
close $tmpfh or die "error closing $tmpf: $!";
522
my $perl = $self->get_perl();
524
open (IN, "$perl -c -Mre=debug $tmpf 2>&1 |")
525
or die "cannot run $perl: ".exit_status_str($?,$!);
527
my($inbuf,$nread,$fullstr); $fullstr = '';
528
while ( $nread=read(IN,$inbuf,16384) ) { $fullstr .= $inbuf }
529
defined $nread or die "error reading from pipe: $!";
531
close IN or die "error closing pipe: $!";
532
unlink $tmpf or die "cannot unlink $tmpf: $!";
533
defined $fullstr or warn "empty result from a pipe";
535
# now parse the -Mre=debug output.
537
$fullstr =~ s/^.*\nFinal program:\n//gs;
538
# perl 5.6/5.8 format
539
$fullstr =~ s/^(?:.*\n|)size \d[^\n]*\n//gs;
540
$fullstr =~ s/^(?:.*\n|)first at \d[^\n]*\n//gs;
542
$fullstr =~ s/\nOffsets:.*$//gs;
544
# clean up every other line that doesn't start with a space
545
$fullstr =~ s/^\S.*$//gm;
547
if ($fullstr !~ /((?:\s[^\n]+\n)+)/m) {
548
die "failed to parse Mre=debug output: $fullstr m{".$rule."}".$mods." $rawrule";
552
# what's left looks like this:
554
# 3: ANYOF[1ILil](14)
556
# 16: CURLY {2,7}(29)
557
# 18: ANYOF[A-Za-z](0)
559
# 30: EXACTF <http://>(33)
562
DEBUG_RE_PARSING and warn "Mre=debug output: $opsstr";
565
foreach my $op (split(/\n/s, $opsstr)) {
568
if ($op =~ /^\s+\d+: (\s*)([A-Z]\w+)\b(.*?)\s*(?:\(\d+\))?$/) {
569
# perl 5.8: <xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx...>(18)
570
# perl 5.10, 5.12, 5.14: <xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx>... (18)
571
push @ops, [ $1, $2, $3 ];
573
elsif ($op =~ /^ (\s*)<(.*)>\.\.\.\s*$/) {
574
# 5: TRIE-EXACT[im](44)
575
# <message contained attachments that have been blocked by guin>...
577
# we could use the entire length here, but it's easier to trim to
578
# the length of a perl 5.8.x/5.6.x EXACT* string; that way our test
579
# suite results will match, since the sa-update --list extraction will
580
# be the same for all versions. (The "..." trailer is important btw)
581
my $str = substr ($2, 0, 55);
582
push @ops, [ $spcs, '_moretrie', "<$str...>" ];
584
elsif ($op =~ /^ (\s*)(<.*>)\s*(?:\(\d+\))?$/) {
585
# 5: TRIE-EXACT[am](21)
588
push @ops, [ $1, '_moretrie', $2 ];
590
elsif ($op =~ /^ at .+ line \d+$/) {
591
next; # ' at /local/perl561/lib/5.6.1/i86pc-solaris/re.pm line 109':
594
warn "cannot parse '$op': $opsstr";
599
# unroll the branches; returns a list of versions.
600
# e.g. /foo(bar|baz)argh/ => [ "foobarargh", "foobazargh" ]
602
if ($main->{bases_split_out_alternations}) {
603
@unrolled = $self->unroll_branches(0, \@ops);
605
@unrolled = ( \@ops );
608
# now find the longest DFA-friendly string in each unrolled version
610
foreach my $opsarray (@unrolled) {
611
my $longestexact = '';
614
# use a closure to keep the code succinct
615
my $add_candidate = sub {
616
if (length $buf > length $longestexact) { $longestexact = $buf; }
621
foreach my $op (@{$opsarray}) {
622
my ($spcs, $item, $args) = @{$op};
624
next if ($item eq 'NOTHING');
626
# EXACT == case-sensitive
628
# we can do both, since we canonicalize to lc.
629
if (!$spcs && $item =~ /^EXACT/ && $args =~ /<(.*)>/)
633
if ($buf =~ s/\\x\{[0-9a-fA-F]{4,}\}.*$//) {
634
# a high Unicode codepoint, interpreted by perl 5.8.x. cut and stop
637
if (length $str >= 55 && $buf =~ s/\.\.\.$//) {
638
# perl 5.8.x truncates with a "..." here! cut and stop
642
# _moretrie == a TRIE-EXACT entry
643
elsif (!$spcs && $item =~ /^_moretrie/ && $args =~ /<(.*)>/)
646
if (length $1 >= 55 && $buf =~ s/\.\.\.$//) {
647
# perl 5.8.x truncates with a "..." here! cut and stop
651
# /(?:foo|bar|baz){2}/ results in a CURLYX beforehand
652
elsif ($item =~ /^EXACT/ &&
653
$prevop && !$prevop->[0] && $prevop->[1] =~ /^CURLYX/ &&
654
$prevop->[2] =~ /\{(\d+),/ && $1 >= 1 &&
658
if (length $1 >= 55 && $buf =~ s/\.\.\.$//) {
659
# perl 5.8.x truncates with a "..." here! cut and stop
663
# CURLYX, for perl >= 5.9.5
664
elsif ($item =~ /^_moretrie/ &&
665
$prevop && !$prevop->[0] && $prevop->[1] =~ /^CURLYX/ &&
666
$prevop->[2] =~ /\{(\d+),/ && $1 >= 1 &&
670
if (length $1 >= 60 && $buf =~ s/\.\.\.$//) {
671
# perl 5.8.x truncates with a "..." here! cut and stop
676
# not an /^EXACT/; clear the buffer
678
if ($item !~ /^(?:END|CLOSE\d|MINMOD)$/)
681
DEBUG_RE_PARSING and warn "item $item makes regexp lossy";
688
if (!$longestexact) {
689
die "no long-enough string found in $rawrule";
690
# all unrolled versions must have a long string, otherwise
691
# we cannot reliably match all variants of the rule
693
push @longests, ($main->{bases_must_be_casei}) ?
694
lc $longestexact : $longestexact;
698
DEBUG_RE_PARSING and warn "longest base strings: /".join("/", @longests)."/";
699
return ($lossy, @longests);
702
###########################################################################
704
sub unroll_branches {
705
my ($self, $depth, $opslist) = @_;
707
die "too deep" if ($depth++ > 5);
709
my @ops = (@{$opslist}); # copy
715
# our input looks something like this 2-level structure:
717
# 2: EXACT <Dear >(5)
722
# 10: EXACT <Int>(12)
730
# 21: EXACT <net>(24)
732
# 24: EXACT < shop>(27)
743
# 11: CURLY {2,5}(14)
745
# 14: EXACT < g r a >(17)
753
# 5: TRIE-EXACT[am](21)
757
# 14: TRIE-EXACT[ ](19)
764
DEBUG_RE_PARSING and warn "starting parse";
766
# this happens for /foo|bar/ instead of /(?:foo|bar)/ ; transform
767
# it into the latter. bit of a kludge to do this before the loop, but hey.
768
# note that it doesn't fix the CLOSE1/END ordering to be correct
769
if (scalar @ops > 1 && $ops[0]->[1] =~ /^BRANCH/) {
770
my @newops = ([ "", "OPEN1", "" ]);
771
foreach my $op (@ops) {
772
push @newops, [ " ".$op->[0], $op->[1], $op->[2] ];
774
push @newops, [ "", "CLOSE1", "" ];
778
# iterate until we start a branch set. using
779
# /dkjfksl(foo|bar(baz|argh)boo)gab/ as an example, we're at "dkj..."
780
# just hitting an OPEN is not enough; wait until we see a TRIE-EXACT
781
# or a BRANCH, *then* unroll the most recent OPEN set.
784
last unless defined $op;
786
my ($spcs, $item, $args) = @{$op};
787
DEBUG_RE_PARSING and warn "pre: [$spcs] $item $args";
789
if ($item =~ /^OPEN/) {
791
next; # next will be a BRANCH or TRIE
793
} elsif ($item =~ /^TRIE/) {
797
} elsif ($item =~ /^BRANCH/) {
798
$branch_spcs = $spcs;
801
} elsif ($item =~ /^EXACT/ && defined $open_spcs) {
802
# perl 5.9.5 does this; f(o|oish) => OPEN, EXACT, TRIE-EXACT
803
push @pre_branch_ops, [ $open_spcs, $item, $args ];
806
} elsif (defined $open_spcs) {
807
# OPEN not followed immediately by BRANCH, EXACT or TRIE-EXACT:
808
# ignore this OPEN block entirely and don't try to unroll it
812
push @pre_branch_ops, $op;
816
# no branches found? we're done unrolling on this one!
817
if (scalar @ops == 0) {
818
return [ @pre_branch_ops ];
821
# otherwise we're at the start of a new branch set
822
# /(foo|bar(baz|argh)boo)gab/
826
DEBUG_RE_PARSING and warn "entering branch: ".
827
"open='".(defined $open_spcs ? $open_spcs : 'undef')."' ".
828
"branch='".(defined $branch_spcs ? $branch_spcs : 'undef')."' ".
829
"trie='".(defined $trie_spcs ? $trie_spcs : 'undef')."'";
831
# indentation level to remove from "normal" ops (using a s///)
832
my $open_sub_spcs = ($branch_spcs ? $branch_spcs : "")." ";
833
my $trie_sub_spcs = "";
836
last unless defined $op;
837
my ($spcs, $item, $args) = @{$op};
838
DEBUG_RE_PARSING and warn "in: [$spcs] $item $args";
840
if (defined $branch_spcs && $branch_spcs eq $spcs && $item =~ /^BRANCH/) { # alt
841
push @alts, [ @pre_branch_ops, @in_this_branch ];
842
@in_this_branch = ();
843
$open_sub_spcs = $branch_spcs." ";
847
elsif (defined $branch_spcs && $branch_spcs eq $spcs && $item eq 'TAIL') { # end
848
push @alts, [ @pre_branch_ops, @in_this_branch ];
854
elsif (defined $trie_spcs && $trie_spcs eq $spcs && $item eq '_moretrie') {
855
if (scalar @in_this_branch > 0) {
856
push @alts, [ @pre_branch_ops, @in_this_branch ];
858
# use $open_spcs instead of $trie_spcs (which is 2 spcs further indented)
859
@in_this_branch = ( [ $open_spcs, $item, $args ] );
860
$open_sub_spcs = ($branch_spcs ? $branch_spcs : "")." ";
861
$trie_sub_spcs = " ";
864
elsif (defined $open_spcs && $open_spcs eq $spcs && $item =~ /^CLOSE/) { # end
865
push @alts, [ @pre_branch_ops, @in_this_branch ];
873
elsif ($item eq 'END') { # of string
874
push @alts, [ @pre_branch_ops, @in_this_branch ];
883
if ($open_sub_spcs) {
884
# deindent the space-level to match the opening brace
885
$spcs =~ s/^$open_sub_spcs//;
886
# tries also add one more indent level in
887
$spcs =~ s/^$trie_sub_spcs//;
889
push @in_this_branch, [ $spcs, $item, $args ];
890
# note that we ignore ops at a deeper $spcs level entirely (until later!)
894
if (defined $branch_spcs) {
895
die "fell off end of string with a branch open: '$branch_spcs'";
898
# we're now after the branch set: /gab/
899
# @alts looks like [ /dkjfkslfoo/ , /dkjfkslbar(baz|argh)boo/ ]
900
foreach my $alt (@alts) {
901
push @{$alt}, @ops; # add all remaining ops to each one
902
# note that this could include more (?:...); we don't care, since
903
# those can be handled by recursing
906
# ok, parsed the entire ops list
907
# @alts looks like [ /dkjfkslfoogab/ , /dkjfkslbar(baz|argh)boogab/ ]
909
if (DEBUG_RE_PARSING) {
910
print "unrolled: "; foreach my $alt (@alts) { foreach my $o (@{$alt}) { print "{/$o->[0]/$o->[1]/$o->[2]} "; } print "\n"; }
913
# now recurse, to unroll the remaining branches (if any exist)
915
foreach my $alt (@alts) {
916
push @rets, $self->unroll_branches($depth, $alt);
919
if (DEBUG_RE_PARSING) {
920
print "unrolled post-recurse: "; foreach my $alt (@rets) { foreach my $o (@{$alt}) { print "{/$o->[0]/$o->[1]/$o->[2]} "; } print "\n"; }
926
###########################################################################
931
$self->test_split_alt("foo", "/foo/");
932
$self->test_split_alt("(foo)", "/foo/");
933
$self->test_split_alt("foo(bar)baz", "/foobarbaz/");
934
$self->test_split_alt("x(foo|)", "/xfoo/ /x/");
935
$self->test_split_alt("fo(o|)", "/foo/ /fo/");
936
$self->test_split_alt("(foo|bar)", "/foo/ /bar/");
937
$self->test_split_alt("foo|bar", "/foo/ /bar/");
938
$self->test_split_alt("foo (bar|baz) argh", "/foo bar argh/ /foo baz argh/");
939
$self->test_split_alt("foo (bar|baz|bl(arg|at)) cough", "/foo bar cough/ /foo baz cough/ /foo blarg cough/ /foo blat cough/");
940
$self->test_split_alt("(s(otc|tco)k)", "/sotck/ /stcok/");
941
$self->test_split_alt("(business partner(s|ship|)|silent partner(s|ship|))", "/business partners/ /silent partners/ /business partnership/ /silent partnership/ /business partner/ /silent partner/");
945
my ($self, $in, $out) = @_;
947
my @got = $self->split_alt($in);
950
my @want = split(/\/ \//, $out);
953
if (scalar @want != scalar @got) {
954
warn "FAIL: results count don't match";
958
my %got = map { $_ => 1 } @got;
959
foreach my $w (@want) {
961
warn "FAIL: '$w' not found";
968
print "want: /".join('/ /', @want)."/\n" or die "error writing: $!";
969
print "got: /".join('/ /', @got)."/\n" or die "error writing: $!";
972
print "ok\n" or die "error writing: $!";
977
###########################################################################
983
# allow user override of the perl interpreter to use when
984
# extracting base strings.
985
# TODO: expose this via sa-compile command-line option
986
my $fromconf = $self->{main}->{conf}->{re_parser_perl};
990
} elsif ($^X =~ m|^/|) {
994
$perl = $Config{perlpath};
995
$perl =~ s|/[^/]*$|/$^X|;
1001
###########################################################################
1003
sub read_cachefile {
1004
my ($self, $cachefile) = @_;
1006
if (open(IN, "<".$cachefile)) {
1007
my($inbuf,$nread,$str); $str = '';
1008
while ( $nread=read(IN,$inbuf,16384) ) { $str .= $inbuf }
1009
defined $nread or die "error reading from $cachefile: $!";
1010
close IN or die "error closing $cachefile: $!";
1013
my $VAR1; # Data::Dumper
1015
return $VAR1; # Data::Dumper's naming
1021
sub write_cachefile {
1022
my ($self, $cachefile, $cached) = @_;
1024
my $dump = Data::Dumper->new ([ $cached ]);
1028
if (mkdir($self->{main}->{bases_cache_dir})) {
1029
# successfully created
1030
} elsif ($! == EEXIST) {
1031
dbg("zoom: ok, cache directory already existed");
1033
warn "cannot create a directory: $!";
1035
open(CACHE, ">$cachefile") or warn "cannot write to $cachefile";
1036
print CACHE ($dump->Dump, ";1;") or die "error writing: $!";
1037
close CACHE or die "error closing $cachefile: $!";
1042
=item my ($cleanregexp) = fixup_re($regexp);
1044
Converts encoded characters in a regular expression pattern into their
1045
equivalent characters
1054
if ($fixup_re_test) { print "INPUT: /$re/\n" or die "error writing: $!" }
1057
my $TOK = qr([\"\\]);
1061
while ($re =~ /\G(.*?)($TOK)/gcs) {
1066
$output .= "\"$pre\"";
1072
elsif ($tok eq '\\') {
1073
$re =~ /\G(x\{[^\}]+\}|[0-7]{1,3}|.)/gcs or die "\\ at end of string!";
1077
} elsif ($esc eq '\\') {
1078
$output .= '"**BACKSLASH**"'; # avoid hairy escape-parsing
1079
} elsif ($esc =~ /^x\{(\S+)\}\z/) {
1080
$output .= '"'.chr(hex($1)).'"';
1081
} elsif ($esc =~ /^[0-7]{1,3}\z/) {
1082
$output .= '"'.chr(oct($esc)).'"';
1084
$output .= "\"$esc\"";
1088
print "PRE: $pre\nTOK: $tok\n" or die "error writing: $!";
1092
if (!defined(pos($re))) {
1094
$output .= "\"$re\"";
1095
# Bug 6649: protect NL, NULL, ^Z, (and controls to stay on the safe side)
1096
$output =~ s{([\000-\037\177\200\377])}{sprintf("\\%03o",ord($1))}gse;
1098
elsif (pos($re) <= length($re)) {
1099
$output =~ s{([\000-\037\177\200\377])}{sprintf("\\%03o",ord($1))}gse;
1100
$output .= fixup_re(substr($re, pos($re)));
1103
$output =~ s/^""/"/; # protect start and end quotes
1104
$output =~ s/(?<!\\)""\z/"/;
1105
$output =~ s/(?<!\\)""//g; # strip empty strings, or turn "abc""def" -> "abcdef"
1106
$output =~ s/\*\*BACKSLASH\*\*/\\\\/gs;
1108
if ($fixup_re_test) { print "OUTPUT: $output\n" or die "error writing: $!" }
added
removed
.pc/98_sa-compile-quiet/lib/Mail/SpamAssassin/Plugin/BodyRuleBaseExtractor.pm
