SOURCES: exipick.pl (NEW) - from http://jetmore.org/john/code/exipick
pawelz
pawelz at pld-linux.org
Sun Feb 22 23:35:22 CET 2009
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 <jj33\@pobox.com>
+
+ 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
+ at 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>>
More information about the pld-cvs-commit
mailing list