Author: pawelz Date: Sun Feb 22 22:35:22 2009 GMT Module: SOURCES Tag: HEAD ---- Log message: - from http://jetmore.org/john/code/exipick
---- Files affected: SOURCES: exipick.pl (NONE -> 1.1) (NEW) ---- Diffs: ================================================================ Index: SOURCES/exipick.pl diff -u /dev/null SOURCES/exipick.pl:1.1 --- /dev/null Sun Feb 22 23:35:23 2009 +++ SOURCES/exipick.pl Sun Feb 22 23:35:17 2009 @@ -0,0 +1,1777 @@ +#!/usr/bin/perl + +# SET THIS TO THE PATH TO YOUR SPOOL DIR! +my $spool = '/var/spool/exim'; +# SET THIS TO THE DEFAULT HEADER CHARACTER SET! +my $charset = 'ISO-8859-1'; + +# use 'exipick --help' to view documentation for this program. +# Documentation also viewable online at +# http://www.exim.org/eximwiki/ToolExipickManPage + +use strict; +use Getopt::Long; + +my($p_name) = $0 =~ m|/?([^/]+)$|; +my $p_version = "20061117.2"; +my $p_usage = "Usage: $p_name [--help|--version] (see --help for details)"; +my $p_cp = <<EOM; + Copyright (c) 2003-2006 John Jetmore <[email protected]> + + 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 2 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, write to the Free Software + Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. +EOM +ext_usage(); # before we do anything else, check for --help + +$| = 1; # unbuffer STDOUT + +Getopt::Long::Configure("bundling_override"); +GetOptions( + 'spool=s' => \$G::spool, # exim spool dir + 'bp' => \$G::mailq_bp, # List the queue (noop - default) + 'bpa' => \$G::mailq_bpa, # ... with generated address as well + 'bpc' => \$G::mailq_bpc, # ... but just show a count of messages + 'bpr' => \$G::mailq_bpr, # ... do not sort + 'bpra' => \$G::mailq_bpra, # ... with generated addresses, unsorted + 'bpru' => \$G::mailq_bpru, # ... only undelivered addresses, unsorted + 'bpu' => \$G::mailq_bpu, # ... only undelivered addresses + 'and' => \$G::and, # 'and' the criteria (default) + 'or' => \$G::or, # 'or' the criteria + 'f=s' => \$G::qgrep_f, # from regexp + 'r=s' => \$G::qgrep_r, # recipient regexp + 's=s' => \$G::qgrep_s, # match against size field + 'y=s' => \$G::qgrep_y, # message younger than (secs) + 'o=s' => \$G::qgrep_o, # message older than (secs) + 'z' => \$G::qgrep_z, # frozen only + 'x' => \$G::qgrep_x, # non-frozen only + 'c' => \$G::qgrep_c, # display match count + 'l' => \$G::qgrep_l, # long format (default) + 'i' => \$G::qgrep_i, # message ids only + 'b' => \$G::qgrep_b, # brief format + 'size' => \$G::size_only, # sum the size of the matching msgs + 'not' => \$G::negate, # flip every test + 'R|reverse' => \$G::reverse, # reverse output (-R is qgrep option) + 'sort=s' => \...@g::sort, # allow you to choose variables to sort by + 'freeze=s' => \$G::freeze, # freeze data in this file + 'thaw=s' => \$G::thaw, # thaw data from this file + 'unsorted' => \$G::unsorted, # unsorted, regardless of output format + 'random' => \$G::random, # (poorly) randomize evaluation order + 'flatq' => \$G::flatq, # brief format + 'caseful' => \$G::caseful, # in '=' criteria, respect case + 'caseless' => \$G::caseless, # ...ignore case (default) + 'charset=s' => \$charset, # charset for $bh and $h variables + 'show-vars=s' => \$G::show_vars, # display the contents of these vars + 'just-vars' => \$G::just_vars, # only display vars, no other info + 'show-rules' => \$G::show_rules, # display compiled match rules + 'show-tests' => \$G::show_tests # display tests as applied to each message +) || exit(1); + +# if both freeze and thaw specified, only thaw as it is less desctructive +$G::freeze = undef if ($G::freeze && $G::thaw); +freeze_start() if ($G::freeze); +thaw_start() if ($G::thaw); + +# massage sort options (make '$var,Var:' be 'var','var') +for (my $i = scalar(@G::sort)-1; $i >= 0; $i--) { + $G::sort[$i] = lc($G::sort[$i]); + $G::sort[$i] =~ s/[\$:\s]//g; + if ((my @vars = split(/,/, $G::sort[$i])) > 1) { + $G::sort[$i] = $vars[0]; shift(@vars); # replace current slot w/ first var + splice(@G::sort, $i+1, 0, @vars); # add other vars after current pos + } +} +push(@G::sort, "message_exim_id") if (@G::sort); +die "empty value provided to --sort not allowed, exiting\n" + if (grep /^\s*$/, @G::sort); + +# massage the qgrep options into standard criteria +push(@ARGV, "\$sender_address =~ /$G::qgrep_f/") if ($G::qgrep_f); +push(@ARGV, "\$recipients =~ /$G::qgrep_r/") if ($G::qgrep_r); +push(@ARGV, "\$shown_message_size eq $G::qgrep_s") if ($G::qgrep_s); +push(@ARGV, "\$message_age < $G::qgrep_y") if ($G::qgrep_y); +push(@ARGV, "\$message_age > $G::qgrep_o") if ($G::qgrep_o); +push(@ARGV, "\$deliver_freeze") if ($G::qgrep_z); +push(@ARGV, "!\$deliver_freeze") if ($G::qgrep_x); + +$G::mailq_bp = $G::mailq_bp; # shut up -w +$G::and = $G::and; # shut up -w +$G::msg_ids = {}; # short circuit when crit is only MID +$G::caseless = $G::caseful ? 0 : 1; # nocase by default, case if both +...@g::recipients_crit = (); # holds per-recip criteria +$spool = $G::spool if ($G::spool); +my $count_only = 1 if ($G::mailq_bpc || $G::qgrep_c); +my $unsorted = 1 if ($G::mailq_bpr || $G::mailq_bpra || + $G::mailq_bpru || $G::unsorted); +my $msg = $G::thaw ? thaw_message_list() + : get_all_msgs($spool, $unsorted, + $G::reverse, $G::random); +die "Problem accessing thaw file\n" if ($G::thaw && !$msg); +my $crit = process_criteria(\...@argv); +my $e = Exim::SpoolFile->new(); +my $tcount = 0 if ($count_only); # holds count of all messages +my $mcount = 0 if ($count_only); # holds count of matching messages +my $total_size = 0 if ($G::size_only); +$e->set_undelivered_only(1) if ($G::mailq_bpru || $G::mailq_bpu); +$e->set_show_generated(1) if ($G::mailq_bpra || $G::mailq_bpa); +$e->output_long() if ($G::qgrep_l); +$e->output_idonly() if ($G::qgrep_i); +$e->output_brief() if ($G::qgrep_b); +$e->output_flatq() if ($G::flatq); +$e->output_vars_only() if ($G::just_vars && $G::show_vars); +$e->set_show_vars($G::show_vars) if ($G::show_vars); +$e->set_spool($spool); + +MSG: +foreach my $m (@$msg) { + next if (scalar(keys(%$G::msg_ids)) && !$G::or + && !$G::msg_ids->{$m->{message}}); + if ($G::thaw) { + my $data = thaw_data(); + if (!$e->restore_state($data)) { + warn "Couldn't thaw $data->{_message}: ".$e->error()."\n"; + next MSG; + } + } else { + if (!$e->parse_message($m->{message}, $m->{path})) { + warn "Couldn't parse $m->{message}: ".$e->error()."\n"; + next MSG; + } + } + $tcount++; + my $match = 0; + my @local_crit = (); + foreach my $c (@G::recipients_crit) { # handle each_recip* vars + foreach my $addr (split(/, /, $e->get_var($c->{var}))) { + my %t = ( 'cmp' => $c->{cmp}, 'var' => $c->{var} ); + $t{cmp} =~ s/"?\$var"?/'$addr'/; + push(@local_crit, \%t); + } + } + if ($G::show_tests) { print $e->get_var('message_exim_id'), "\n"; } + CRITERIA: + foreach my $c (@$crit, @local_crit) { + my $var = $e->get_var($c->{var}); + my $ret = eval($c->{cmp}); + if ($G::show_tests) { + printf " %25s = '%s'\n %25s => $ret\n",$c->{var},$var,$c->{cmp},$ret; + } + if ($@) { + print STDERR "Error in eval '$c->{cmp}': $...@\n"; + next MSG; + } elsif ($ret) { + $match = 1; + if ($G::or) { last CRITERIA; } + else { next CRITERIA; } + } else { # no match + if ($G::or) { next CRITERIA; } + else { next MSG; } + } + } + + # skip this message if any criteria were supplied and it didn't match + next MSG if ((scalar(@$crit) || scalar(@local_crit)) && !$match); + + if ($count_only || $G::size_only) { + $mcount++; + $total_size += $e->get_var('message_size'); + } else { + if (@G::sort) { + # if we are defining criteria to sort on, save the message here. If + # we don't save here and do the sort later, we have a chicken/egg + # problem + push(@G::to_print, { vars => {}, output => "" }); + foreach my $var (@G::sort) { + # save any values we want to sort on. I don't like doing the internal + # struct access here, but calling get_var a bunch can be _slow_ =( + $G::sort_type{$var} ||= '<=>'; + $G::to_print[-1]{vars}{$var} = $e->{_vars}{$var}; + $G::sort_type{$var} = 'cmp' if ($G::to_print[-1]{vars}{$var} =~ /\D/); + } + $G::to_print[-1]{output} = $e->format_message(); + } else { + print $e->format_message(); + } + } + + if ($G::freeze) { + freeze_data($e->get_state()); + push(@G::frozen_msgs, $m); + } +} + +if (@G::to_print) { + msg_sort(\...@g::to_print, \...@g::sort, $G::reverse); + foreach my $msg (@G::to_print) { + print $msg->{output}; + } +} + +if ($G::qgrep_c) { + print "$mcount matches out of $tcount messages" . + ($G::size_only ? " ($total_size)" : "") . "\n"; +} elsif ($G::mailq_bpc) { + print "$mcount" . ($G::size_only ? " ($total_size)" : "") . "\n"; +} elsif ($G::size_only) { + print "$total_size\n"; +} + +if ($G::freeze) { + freeze_message_list(\...@g::frozen_msgs); + freeze_end(); +} elsif ($G::thaw) { + thaw_end(); +} + +exit; + +# sender_address_domain,shown_message_size +sub msg_sort { + my $msgs = shift; + my $vars = shift; + my $reverse = shift; + + my @pieces = (); + foreach my $v (@G::sort) { + push(@pieces, "\$a->{vars}{\"$v\"} $G::sort_type{$v} \$b->{vars}{\"$v\"}"); + } + my $sort_str = join(" || ", @pieces); + + @$msgs = sort { eval $sort_str } (@$msgs); + @$msgs = reverse(@$msgs) if ($reverse); +} + +sub try_load { + my $mod = shift; + + eval("use $mod"); + return $@ ? 0 : 1; +} + +# FREEZE FILE FORMAT: +# message_data_bytes +# message_data +# <...> +# EOM +# message_list +# message_list_bytes <- 10 bytes, zero-packed, plus \n + +sub freeze_start { + eval("use Storable"); + die "Storable module not found: $...@\n" if ($@); + open(O, ">$G::freeze") || die "Can't open freeze file $G::freeze: $!\n"; + $G::freeze_handle = \*O; +} + +sub freeze_end { + close($G::freeze_handle); +} + +sub thaw_start { + eval("use Storable"); + die "Storable module not found: $...@\n" if ($@); + open(I, "<$G::thaw") || die "Can't open freeze file $G::thaw: $!\n"; + $G::freeze_handle = \*I; +} + +sub thaw_end { + close($G::freeze_handle); +} + +sub freeze_data { + my $h = Storable::freeze($_[0]); + print $G::freeze_handle length($h)+1, "\n$h\n"; +} + +sub freeze_message_list { + my $h = Storable::freeze($_[0]); + my $l = length($h) + 1; + printf $G::freeze_handle "EOM\n$l\n$h\n%010d\n", $l+11+length($l)+1; +} + +sub thaw_message_list { + my $orig_pos = tell($G::freeze_handle); + seek($G::freeze_handle, -11, 2); + chomp(my $bytes = <$G::freeze_handle>); + seek($G::freeze_handle, $bytes * -1, 2); + my $obj = thaw_data(); + seek($G::freeze_handle, 0, $orig_pos); + return($obj); +} + +sub thaw_data { + my $obj; + chomp(my $bytes = <$G::freeze_handle>); + return(undef) if (!$bytes || $bytes eq 'EOM'); + my $read = read(I, $obj, $bytes); + die "Format error in thaw file (expected $bytes bytes, got $read)\n" + if ($bytes != $read); + chomp($obj); + return(Storable::thaw($obj)); +} + +sub process_criteria { + my $a = shift; + my @c = (); + my $e = 0; + + foreach (@$a) { + foreach my $t ('@') { s/$t/\\$t/g; } + if (/^(.*?)\s+(<=|>=|==|!=|<|>)\s+(.*)$/) { + #print STDERR "found as integer\n"; + my $v = $1; my $o = $2; my $n = $3; + if ($n =~ /^(-?[\d\.]+)M$/) { $n = $1 * 1024 * 1024; } + elsif ($n =~ /^(-?[\d\.]+)K$/) { $n = $1 * 1024; } + elsif ($n =~ /^(-?[\d\.]+)B?$/) { $n = $1; } + elsif ($n =~ /^(-?[\d\.]+)d$/) { $n = $1 * 60 * 60 * 24; } + elsif ($n =~ /^(-?[\d\.]+)h$/) { $n = $1 * 60 * 60; } + elsif ($n =~ /^(-?[\d\.]+)m$/) { $n = $1 * 60; } + elsif ($n =~ /^(-?[\d\.]+)s?$/) { $n = $1; } + else { + print STDERR "Expression $_ did not parse: numeric comparison with ", + "non-number\n"; + $e = 1; + next; + } + push(@c, { var => lc($v), cmp => "(\$var $o $n)" }); + } elsif (/^(.*?)\s+(=~|!~)\s+(.*)$/) { + #print STDERR "found as string regexp\n"; + push(@c, { var => lc($1), cmp => "(\"\$var\" $2 $3)" }); + } elsif (/^(.*?)\s+=\s+(.*)$/) { + #print STDERR "found as bare string regexp\n"; + my $case = $G::caseful ? '' : 'i'; + push(@c, { var => lc($1), cmp => "(\"\$var\" =~ /$2/$case)" }); + # quote special characters in perl text string + #foreach my $t ('@') { $c[-1]{cmp} =~ s/$t/\\$t/g; } + } elsif (/^(.*?)\s+(eq|ne)\s+(.*)$/) { + #print STDERR "found as string cmp\n"; + my $var = lc($1); my $op = $2; my $val = $3; + $val =~ s|^(['"])(.*)\1$|$2|; + push(@c, { var => $var, cmp => "(\"\$var\" $op \"$val\")" }); + if (($var eq 'message_id' || $var eq 'message_exim_id') && $op eq "eq") { + #print STDERR "short circuit @c[-1]->{cmp} $val\n"; + $G::msg_ids->{$val} = 1; + } + #foreach my $t ('@') { $c[-1]{cmp} =~ s/$t/\\$t/g; } + } elsif (/^(\S+)$/) { + #print STDERR "found as boolean\n"; + push(@c, { var => lc($1), cmp => "(\$var)" }); + } else { + print STDERR "Expression $_ did not parse\n"; + $e = 1; + next; + } + # assign the results of the cmp test here (handle "!" negation) + # also handle global --not negation + if ($c[-1]{var} =~ s|^!||) { + $c[-1]{cmp} .= $G::negate ? " ? 1 : 0" : " ? 0 : 1"; + } else { + $c[-1]{cmp} .= $G::negate ? " ? 0 : 1" : " ? 1 : 0"; + } + # support the each_* psuedo variables. Steal the criteria off of the + # queue for special processing later + if ($c[-1]{var} =~ /^each_(recipients(_(un)?del)?)$/) { + my $var = $1; + push(@G::recipients_crit,pop(@c)); + $G::recipients_crit[-1]{var} = $var; # remove each_ from the variable + } + } + + exit(1) if ($e); + + if ($G::show_rules) { foreach (@c) { print "$_->{var}\t$_->{cmp}\n"; } } + + return(\...@c); +} + +sub get_all_msgs { + my $d = shift() . '/input'; + my $u = shift; # don't sort + my $r = shift; # right before returning, reverse order + my $o = shift; # if true, randomize list order before returning + my @m = (); + + opendir(D, "$d") || die "Couldn't opendir $d: $!\n"; + foreach my $e (grep !/^\./, readdir(D)) { + if ($e =~ /^[a-zA-Z0-9]$/) { + opendir(DD, "$d/$e") || next; + foreach my $f (grep !/^\./, readdir(DD)) { + push(@m, { message => $1, path => "$d/$e" }) if ($f =~ /^(.{16})-H$/); + } + closedir(DD); + } elsif ($e =~ /^(.{16})-H$/) { + push(@m, { message => $1, path => $d }); + } + } + closedir(D); + + if ($o) { + my $c = scalar(@m); + # loop twice to pretend we're doing a good job of mixing things up + for (my $i = 0; $i < 2 * $c; $i++) { + my $rand = int(rand($c)); + ($m[$i % $c],$m[$rand]) = ($m[$rand],$m[$i % $c]); + } + } elsif (!$u) { + @m = sort { $a->{message} cmp $b->{message} } @m; + } + @m = reverse(@m) if ($r); + + return(\...@m); +} + +BEGIN { + +package Exim::SpoolFile; + +# versions 4.61 and higher will not need these variables anymore, but they +# are left for handling legacy installs +$Exim::SpoolFile::ACL_C_MAX_LEGACY = 10; +#$Exim::SpoolFile::ACL_M_MAX _LEGACY= 10; + +sub new { + my $class = shift; + my $self = {}; + bless($self, $class); + + $self->{_spool_dir} = ''; + $self->{_undelivered_only} = 0; + $self->{_show_generated} = 0; + $self->{_output_long} = 1; + $self->{_output_idonly} = 0; + $self->{_output_brief} = 0; + $self->{_output_flatq} = 0; + $self->{_output_vars_only} = 0; + $self->{_show_vars} = []; + + $self->_reset(); + return($self); +} + +sub output_long { + my $self = shift; + + $self->{_output_long} = 1; + $self->{_output_idonly} = 0; + $self->{_output_brief} = 0; + $self->{_output_flatq} = 0; + $self->{_output_vars_only} = 0; +} + +sub output_idonly { + my $self = shift; + + $self->{_output_long} = 0; + $self->{_output_idonly} = 1; + $self->{_output_brief} = 0; + $self->{_output_flatq} = 0; + $self->{_output_vars_only} = 0; +} + +sub output_brief { + my $self = shift; + + $self->{_output_long} = 0; + $self->{_output_idonly} = 0; + $self->{_output_brief} = 1; + $self->{_output_flatq} = 0; + $self->{_output_vars_only} = 0; +} + +sub output_flatq { + my $self = shift; + + $self->{_output_long} = 0; + $self->{_output_idonly} = 0; + $self->{_output_brief} = 0; + $self->{_output_flatq} = 1; + $self->{_output_vars_only} = 0; +} + +sub output_vars_only { + my $self = shift; + + $self->{_output_long} = 0; + $self->{_output_idonly} = 0; + $self->{_output_brief} = 0; + $self->{_output_flatq} = 0; + $self->{_output_vars_only} = 1; +} + +sub set_show_vars { + my $self = shift; + my $s = shift; + + foreach my $v (split(/\s*,\s*/, $s)) { + push(@{$self->{_show_vars}}, $v); + } +} + +sub set_show_generated { + my $self = shift; + $self->{_show_generated} = shift; +} + +sub set_undelivered_only { + my $self = shift; + $self->{_undelivered_only} = shift; +} + +sub error { + my $self = shift; + return $self->{_error}; +} + +sub _error { + my $self = shift; + $self->{_error} = shift; + return(undef); +} + +sub _reset { + my $self = shift; + + $self->{_error} = ''; + $self->{_delivered} = 0; + $self->{_message} = ''; + $self->{_path} = ''; + $self->{_vars} = {}; + $self->{_vars_raw} = {}; + + $self->{_numrecips} = 0; + $self->{_udel_tree} = {}; + $self->{_del_tree} = {}; + $self->{_recips} = {}; + + return($self); +} + +sub parse_message { + my $self = shift; + + $self->_reset(); + $self->{_message} = shift || return(0); + $self->{_path} = shift; # optional path to message + return(0) if (!$self->{_spool_dir}); + if (!$self->{_path} && !$self->_find_path()) { + # assume the message was delivered from under us and ignore + $self->{_delivered} = 1; + return(1); + } + $self->_parse_header() || return(0); + + return(1); +} + +# take the output of get_state() and set up a message internally like +# parse_message (except from a saved data struct, not by parsing the +# files on disk). +sub restore_state { + my $self = shift; + my $h = shift; + + return(1) if ($h->{_delivered}); + $self->_reset(); + $self->{_message} = $h->{_message} || return(0); + return(0) if (!$self->{_spool_dir}); + + $self->{_path} = $h->{_path}; + $self->{_vars} = $h->{_vars}; + $self->{_numrecips} = $h->{_numrecips}; + $self->{_udel_tree} = $h->{_udel_tree}; <<Diff was trimmed, longer than 597 lines>> _______________________________________________ pld-cvs-commit mailing list [email protected] http://lists.pld-linux.org/mailman/listinfo/pld-cvs-commit
