From a91932723f3ac1c57c72874e09914b42c0a1f421 Mon Sep 17 00:00:00 2001 From: epg <> Date: Sat, 28 Dec 2002 22:28:31 +0000 Subject: [PATCH] Implement Doug's two killer features: 1) store all occurrences of a header, not just the last, 2) use pure ordered structure for the filters, allowing inter-mixing of filters (i.e. you can have some List-Id filters followed by some X-Mailing-List filters followed by more List-Id filters and they will all be matched in the correct order). Earlier i was using Tie::IxHash to make the filters hash ordered, but i wasn't using it for the internal hashes so it was incomplete. I didn't need hashes in teh first place; switching to nested arrays for the filters structure solves this problem as well as Doug's killer feature and as a bonus removes the Tie::IxHash dependency. README: Remove Tie::IxHash from list of non-standard modules. minc: Drop Tie::IxHash. FILTERS and %headers become more complex structures (code and documentation changes). For now, use .mincfilter2 instead of .mincfilter (will change back as soon as the new code has had a good shake-down). (log_headers): Adapt for new %headers structure and add comment cross-referencing the get_headers comment explaining the structure. (get_headers): Document the %headers structure. Build and return the new structure, preserving multiple occurrences of the same header. (find_mh_folder): Use the new @FILTERS structure. (MAIN): Use @FILTERS instead of %FILTERS. In the closing pod section, fix the EXAMPLES section and add a section documenting @FILTERS. --- README | 1 - minc | 128 +++++++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 92 insertions(+), 37 deletions(-) diff --git a/README b/README index db88751..b3b33db 100644 --- a/README +++ b/README @@ -3,7 +3,6 @@ $Id$ minc requires the following non-standard Perl modules and headers: Log::Dispatch -Tie::IxHash sysexits.ph Log::Dispatch is available on CPAN. You will almost certainly have to diff --git a/minc b/minc index 6efc7fd..c95bec2 100755 --- a/minc +++ b/minc @@ -36,7 +36,6 @@ use Getopt::Std; use Log::Dispatch; use Log::Dispatch::File; use POSIX qw(strftime WEXITSTATUS WIFEXITED); -use Tie::IxHash; =head1 OPTIONS @@ -44,7 +43,7 @@ use Tie::IxHash; =item B<-d> -Dump (using Data::Dumper) the FILTERS hash and exit. This is useful +Dump (using Data::Dumper) the FILTERS list and exit. This is useful for testing the syntax of .mincfilter. =item B<-f> @@ -132,7 +131,7 @@ if (not $MAILDIR) { =item $HOME/.mincfilter This file is Perl code (included via the 'require' directive) which is -expected to define the FILTERS hash. +expected to define the FILTERS list. =item $HOME/.mincspam @@ -173,9 +172,8 @@ marked unseen. =cut -our %FILTERS; -tie(%FILTERS, 'Tie::IxHash'); -require "$HOME/.mincfilter"; +our @FILTERS; +require "$HOME/.mincfilter2"; if (-f "$HOME/.mincspam") { require "$HOME/.mincspam"; @@ -253,10 +251,12 @@ sub logerr { mylog('error', ERRORCHAR, @_); } sub log_headers { my %headers = @_; - logincoming('From: ', $headers{'return-path'}); - logincoming('To: ', $headers{'to'}); - logincoming('Subject: ', $headers{'subject'}); - logincoming('Message-Id: ', $headers{'message-id'}); + # For an explanation of the %headers structure, see the + # get_headers function below. + logincoming('From: ', @{$headers{'return-path'}}[-1]); + logincoming('To: ', @{$headers{'to'}}[-1]); + logincoming('Subject: ', @{$headers{'subject'}}[-1]); + logincoming('Message-Id: ', @{$headers{'message-id'}}[-1]); } @@ -460,11 +460,19 @@ sub store_message { } } +# Parse a message file into a structure describing the headers. The +# structure is a hash of arrays. The hash keys are the names of the +# headers found in the message, made all lower-case. Each item in +# the hash is an array of header text. The array has one element +# per occurrence of the header. Most headers will only have a single +# element because they occur only once. The Received header is the +# most common header with multiple texts. sub get_headers { my $msg = shift; my %headers; my $current; # current header, used for unfolding lines my $fieldname; # unmolested header name + my $contents; # contents of header open(MSG, $msg); while () { @@ -481,11 +489,19 @@ sub get_headers { return (); } - $headers{$current} .= $_; + @{$headers{$current}}[-1] .= $_; } else { ($fieldname) = split(/:/); $current = lc($fieldname); - (undef, $headers{$current}) = split(/^\Q$fieldname\E:\s*/); + (undef, $contents) = split(/^\Q$fieldname\E:\s*/); + + if (defined($headers{$current})) { + # multiple occurence of same header + push(@{$headers{$current}}, $contents); + } else { + # first occurence of a header + $headers{$current} = [$contents]; + } } } close(MSG); @@ -527,11 +543,14 @@ sub kill_spam { sub find_mh_folder { my $msg = shift; my %headers; + my $filterref; + my @filter; my $header; my $contents; - my $regex; - my $subst; - my $try; + my $pair; + my $match; + my $expression; + my $result; %headers = get_headers($msg); if (not %headers) { @@ -540,17 +559,22 @@ sub find_mh_folder { log_headers(%headers); - foreach $header (keys(%FILTERS)) { - $contents = $headers{lc($header)}; - - if (defined($contents)) { - foreach $regex (keys(%{$FILTERS{$header}})) { - $subst = $FILTERS{$header}->{$regex}; - - $try = '$contents =~'; - $try .= " s|$regex|$subst|is"; - if (eval $try) { - return $contents; + # Walk the list of filters. This structure is documented in + # pod at the end of the program. + foreach $filterref (@FILTERS) { + @filter = @$filterref; + $header = shift(@filter); + + # Walk the list of message headers matching the filter's + # specified header. + foreach $contents (@{$headers{lc($header)}}) { + # Walk the filter's list of match/expression pairs. + foreach $pair (@filter) { + ($match, $expression) = @$pair; + if ($contents =~ /$match/) { + if (eval "\$result = \"$expression\"") { + return $result; + } } } } @@ -576,7 +600,7 @@ MAIN: { if ($dumpfilters) { $Data::Dumper::Indent = 1; - print(Dumper(\%FILTERS)); + print(Dumper(\@FILTERS)); exit(&EX_OK); } @@ -593,19 +617,51 @@ MAIN: { __END__ +=head1 THE FILTERS STRUCTURE + +The user's .mincfilter file must define the @FILTERS structure. This +structure is an array. Each element of @FILTERS is a filter. A +filter is itself an array. The first element of a filter is a string, +the name of the header this filter acts upon. The header name is not +case-sensitive. Each subsequent element of a filter is a pair (i.e. a +two-element array): first, a regular expression B uses to +determine whether this filter matches or not, and second, an +expression which B evaluates to get the folder name. + +B decides where to store a message by iterating over the +@FILTERS array. It tests each regexp of each filter against all +headers matching that filter's specified header. As soon as a match +is found, B evaluates the second part of the pair. This part +may contain positional parameters from the matched regexp ($1, $2, +etc.). The result of this expression is used as the folder name. + +Multiple occurrences of the same header are preserved and tested +individually against the filters. That means, for example, that +filters can search all the Received headers for a certain string. + +It is important to note that all the arrays of the @FILTERS structure +are traversed I. This means the filters can be arranged so +that some have priority over others. XXX: get Doug to write an +example of having the same header matched more than once. + =head1 EXAMPLES -%FILTERS = - ('List-Id:'=> - {'.*<([[:graph:]]+)-([[:graph:]]+)\.lists\.sourceforge\.net>.*'=>'l/$1/$2', - '.*<([[:graph:]]+?)(-list)?\.freedesktop\.org>.*'=>'l/freedesktop/$1', - '.*.*'=>'l/swig'}, +@FILTERS = ( + + ['List-Id', + ['<([[:graph:]]+)-([[:graph:]]+)\.lists\.sourceforge\.net>', 'l/$1/$2'], + ['<([[:graph:]]+?)(-list)?\.freedesktop\.org>', 'l/freedesktop/$1'], + ['', 'l/swig'], + ], - 'List-Post:'=> - {''=>'l/apache/$2/$1'}, + ['List-Post', + ['', 'l/apache/$2/$1'], + ], - 'To:'=> - {'root'=>'root'}); + ['To', + ['root', 'root'], + ], +); The first List-Id filter is a surprisingly effective one which creates appropriate folder names (such as l/htdig/updates and l/rox/devel) for -- 2.56.0