4751f76570e46dc3d36bade6ea99f5a4ff8d8360
[exim.git] / src / src / exipick.src
1 #!PERL_COMMAND
2
3 # This variables should be set by the building process
4 my $spool = 'SPOOL_DIRECTORY';  # may be overridden later
5 my $exim  = 'BIN_DIRECTORY/exim';
6
7 # Need to set this dynamically during build, but it's not used right now anyway.
8 my $charset = 'ISO-8859-1';
9
10 # use 'exipick --help' to view documentation for this program.
11 # Documentation also viewable online at
12 #       http://www.exim.org/eximwiki/ToolExipickManPage
13
14 use strict;
15 BEGIN { pop @INC if $INC[-1] eq '.' };
16 use Getopt::Long;
17
18 my($p_name)   = $0 =~ m|/?([^/]+)$|;
19 my $p_version = "20100323.0";
20 my $p_usage   = "Usage: $p_name [--help|--version] (see --help for details)";
21 my $p_cp      = <<EOM;
22         Copyright (c) 2003-2010 John Jetmore <jj33\@pobox.com>
23
24     This program is free software; you can redistribute it and/or modify
25     it under the terms of the GNU General Public License as published by
26     the Free Software Foundation; either version 2 of the License, or
27     (at your option) any later version.
28
29     This program is distributed in the hope that it will be useful,
30     but WITHOUT ANY WARRANTY; without even the implied warranty of
31     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
32     GNU General Public License for more details.
33
34     You should have received a copy of the GNU General Public License
35     along with this program; if not, write to the Free Software
36     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
37 EOM
38 ext_usage(); # before we do anything else, check for --help
39
40 $| = 1; # unbuffer STDOUT
41
42 Getopt::Long::Configure("bundling_override");
43 GetOptions(
44   'spool=s'     => \$G::spool,      # exim spool dir
45   'C|Config=s'  => \$G::config,     # use alternative Exim configuration file
46   'input-dir=s' => \$G::input_dir,  # name of the "input" dir
47   'finput'      => \$G::finput,     # same as "--input-dir Finput"
48   'bp'          => \$G::mailq_bp,   # List the queue (noop - default)
49   'bpa'         => \$G::mailq_bpa,  # ... with generated address as well
50   'bpc'         => \$G::mailq_bpc,  # ... but just show a count of messages
51   'bpr'         => \$G::mailq_bpr,  # ... do not sort
52   'bpra'        => \$G::mailq_bpra, # ... with generated addresses, unsorted
53   'bpru'        => \$G::mailq_bpru, # ... only undelivered addresses, unsorted
54   'bpu'         => \$G::mailq_bpu,  # ... only undelivered addresses
55   'and'         => \$G::and,        # 'and' the criteria (default)
56   'or'          => \$G::or,         # 'or' the criteria
57   'f=s'         => \$G::qgrep_f,    # from regexp
58   'r=s'         => \$G::qgrep_r,    # recipient regexp
59   's=s'         => \$G::qgrep_s,    # match against size field
60   'y=s'         => \$G::qgrep_y,    # message younger than (secs)
61   'o=s'         => \$G::qgrep_o,    # message older than (secs)
62   'z'           => \$G::qgrep_z,    # frozen only
63   'x'           => \$G::qgrep_x,    # non-frozen only
64   'c'           => \$G::qgrep_c,    # display match count
65   'l'           => \$G::qgrep_l,    # long format (default)
66   'i'           => \$G::qgrep_i,    # message ids only
67   'b'           => \$G::qgrep_b,    # brief format
68   'size'        => \$G::size_only,  # sum the size of the matching msgs
69   'not'         => \$G::negate,     # flip every test
70   'R|reverse'   => \$G::reverse,    # reverse output (-R is qgrep option)
71   'sort=s'      => \@G::sort,       # allow you to choose variables to sort by
72   'freeze=s'    => \$G::freeze,     # freeze data in this file
73   'thaw=s'      => \$G::thaw,       # thaw data from this file
74   'unsorted'    => \$G::unsorted,   # unsorted, regardless of output format
75   'random'      => \$G::random,     # (poorly) randomize evaluation order
76   'flatq'       => \$G::flatq,      # brief format
77   'caseful'     => \$G::caseful,    # in '=' criteria, respect case
78   'caseless'    => \$G::caseless,   #   ...ignore case (default)
79   'charset=s'   => \$charset,       # charset for $bh and $h variables
80   'show-vars=s' => \$G::show_vars,  # display the contents of these vars
81   'just-vars'   => \$G::just_vars,  # only display vars, no other info
82   'show-rules'  => \$G::show_rules, # display compiled match rules
83   'show-tests'  => \$G::show_tests  # display tests as applied to each message
84 ) || exit(1);
85
86 # if both freeze and thaw specified, only thaw as it is less destructive
87 $G::freeze = undef               if ($G::freeze && $G::thaw);
88 freeze_start()                   if ($G::freeze);
89 thaw_start()                     if ($G::thaw);
90
91 # massage sort options (make '$var,Var:' be 'var','var')
92 for (my $i = scalar(@G::sort)-1; $i >= 0; $i--) {
93   $G::sort[$i] = lc($G::sort[$i]);
94   $G::sort[$i] =~ s/[\$:\s]//g;
95   if ((my @vars = split(/,/, $G::sort[$i])) > 1) {
96     $G::sort[$i] = $vars[0]; shift(@vars); # replace current slot w/ first var
97     splice(@G::sort, $i+1, 0, @vars);      # add other vars after current pos
98   }
99 }
100 push(@G::sort, "message_exim_id") if (@G::sort);
101 die "empty value provided to --sort not allowed, exiting\n"
102     if (grep /^\s*$/, @G::sort);
103
104 # massage the qgrep options into standard criteria
105 push(@ARGV, "\$sender_address     =~ /$G::qgrep_f/") if ($G::qgrep_f);
106 push(@ARGV, "\$recipients         =~ /$G::qgrep_r/") if ($G::qgrep_r);
107 push(@ARGV, "\$shown_message_size eq $G::qgrep_s")   if ($G::qgrep_s);
108 push(@ARGV, "\$message_age        <  $G::qgrep_y")   if ($G::qgrep_y);
109 push(@ARGV, "\$message_age        >  $G::qgrep_o")   if ($G::qgrep_o);
110 push(@ARGV, "\$deliver_freeze")                      if ($G::qgrep_z);
111 push(@ARGV, "!\$deliver_freeze")                     if ($G::qgrep_x);
112
113 $G::mailq_bp        = $G::mailq_bp;        # shut up -w
114 $G::and             = $G::and;             # shut up -w
115 $G::msg_ids         = {};                  # short circuit when crit is only MID
116 $G::caseless        = $G::caseful ? 0 : 1; # nocase by default, case if both
117 @G::recipients_crit = ();                  # holds per-recip criteria
118 $spool              = defined $G::spool ? $G::spool
119                       : do { chomp($_ = `$exim @{[defined $G::config ? "-C $G::config" : '']} -n -bP spool_directory`)
120                              and $_ or $spool };
121 my $input_dir       = $G::input_dir || ($G::finput ? "Finput" : "input");
122 my $count_only      = 1 if ($G::mailq_bpc  || $G::qgrep_c);
123 my $unsorted        = 1 if ($G::mailq_bpr  || $G::mailq_bpra ||
124                             $G::mailq_bpru || $G::unsorted);
125 my $msg             = $G::thaw ? thaw_message_list()
126                                : get_all_msgs($spool, $input_dir, $unsorted,
127                                               $G::reverse, $G::random);
128 die "Problem accessing thaw file\n" if ($G::thaw && !$msg);
129 my $crit            = process_criteria(\@ARGV);
130 my $e               = Exim::SpoolFile->new();
131 my $tcount          = 0 if ($count_only);  # holds count of all messages
132 my $mcount          = 0 if ($count_only);  # holds count of matching messages
133 my $total_size      = 0 if ($G::size_only);
134 $e->set_undelivered_only(1)      if ($G::mailq_bpru || $G::mailq_bpu);
135 $e->set_show_generated(1)        if ($G::mailq_bpra || $G::mailq_bpa);
136 $e->output_long()                if ($G::qgrep_l);
137 $e->output_idonly()              if ($G::qgrep_i);
138 $e->output_brief()               if ($G::qgrep_b);
139 $e->output_flatq()               if ($G::flatq);
140 $e->output_vars_only()           if ($G::just_vars && $G::show_vars);
141 $e->set_show_vars($G::show_vars) if ($G::show_vars);
142 $e->set_spool($spool, $input_dir);
143
144 MSG:
145 foreach my $m (@$msg) {
146   next if (scalar(keys(%$G::msg_ids)) && !$G::or
147                                       && !$G::msg_ids->{$m->{message}});
148   if ($G::thaw) {
149     my $data = thaw_data();
150     if (!$e->restore_state($data)) {
151       warn "Couldn't thaw $data->{_message}: ".$e->error()."\n";
152       next MSG;
153     }
154   } else {
155     if (!$e->parse_message($m->{message}, $m->{path})) {
156       warn "Couldn't parse $m->{message}: ".$e->error()."\n";
157       next MSG;
158     }
159   }
160   $tcount++;
161   my $match = 0;
162   my @local_crit = ();
163   foreach my $c (@G::recipients_crit) {              # handle each_recip* vars
164     foreach my $addr (split(/, /, $e->get_var($c->{var}))) {
165       my %t = ( 'cmp' => $c->{cmp}, 'var' => $c->{var} );
166       $t{cmp} =~ s/"?\$var"?/'$addr'/;
167       push(@local_crit, \%t);
168     }
169   }
170   if ($G::show_tests) { print $e->get_var('message_exim_id'), "\n"; }
171   CRITERIA:
172   foreach my $c (@$crit, @local_crit) {
173     my $var = $e->get_var($c->{var});
174     my $ret = eval($c->{cmp});
175     if ($G::show_tests) {
176       printf "  %25s =  '%s'\n  %25s => $ret\n",$c->{var},$var,$c->{cmp},$ret;
177     }
178     if ($@) {
179       print STDERR "Error in eval '$c->{cmp}': $@\n";
180       next MSG;
181     } elsif ($ret) {
182       $match = 1;
183       if ($G::or) { last CRITERIA; }
184       else        { next CRITERIA; }
185     } else { # no match
186       if ($G::or) { next CRITERIA; }
187       else        { next MSG;      }
188     }
189   }
190
191   # skip this message if any criteria were supplied and it didn't match
192   next MSG if ((scalar(@$crit) || scalar(@local_crit)) && !$match);
193
194   if ($count_only || $G::size_only) {
195     $mcount++;
196     $total_size += $e->get_var('message_size');
197   } else {
198     if (@G::sort) {
199       # if we are defining criteria to sort on, save the message here.  If
200       # we don't save here and do the sort later, we have a chicken/egg
201       # problem
202       push(@G::to_print, { vars => {}, output => "" });
203       foreach my $var (@G::sort) {
204         # save any values we want to sort on.  I don't like doing the internal
205         # struct access here, but calling get_var a bunch can be _slow_ =(
206         $G::sort_type{$var} ||= '<=>';
207         $G::to_print[-1]{vars}{$var} = $e->{_vars}{$var};
208         $G::sort_type{$var} = 'cmp' if ($G::to_print[-1]{vars}{$var} =~ /\D/);
209       }
210       $G::to_print[-1]{output} = $e->format_message();
211     } else {
212       print $e->format_message();
213     }
214   }
215
216   if ($G::freeze) {
217     freeze_data($e->get_state());
218     push(@G::frozen_msgs, $m);
219   }
220 }
221
222 if (@G::to_print) {
223   msg_sort(\@G::to_print, \@G::sort, $G::reverse);
224   foreach my $msg (@G::to_print) {
225     print $msg->{output};
226   }
227 }
228
229 if ($G::qgrep_c) {
230   print "$mcount matches out of $tcount messages" .
231         ($G::size_only ? " ($total_size)" : "") . "\n";
232 } elsif ($G::mailq_bpc) {
233   print "$mcount" .  ($G::size_only ? " ($total_size)" : "") . "\n";
234 } elsif ($G::size_only) {
235   print "$total_size\n";
236 }
237
238 if ($G::freeze) {
239   freeze_message_list(\@G::frozen_msgs);
240   freeze_end();
241 } elsif ($G::thaw) {
242   thaw_end();
243 }
244
245 exit;
246
247 # sender_address_domain,shown_message_size
248 sub msg_sort {
249   my $msgs    = shift;
250   my $vars    = shift;
251   my $reverse = shift;
252
253   my @pieces = ();
254   foreach my $v (@G::sort) {
255     push(@pieces, "\$a->{vars}{\"$v\"} $G::sort_type{$v} \$b->{vars}{\"$v\"}");
256   }
257   my $sort_str = join(" || ", @pieces);
258
259   @$msgs = sort { eval $sort_str } (@$msgs);
260   @$msgs = reverse(@$msgs) if ($reverse);
261 }
262
263 sub try_load {
264   my $mod = shift;
265
266   eval("use $mod");
267   return $@ ? 0 : 1;
268 }
269
270 # FREEZE FILE FORMAT:
271 # message_data_bytes
272 # message_data
273 # <...>
274 # EOM
275 # message_list
276 # message_list_bytes <- 10 bytes, zero-packed, plus \n
277
278 sub freeze_start {
279   eval("use Storable");
280   die "Storable module not found: $@\n" if ($@);
281   open(O, ">$G::freeze") || die "Can't open freeze file $G::freeze: $!\n";
282   $G::freeze_handle = \*O;
283 }
284
285 sub freeze_end {
286   close($G::freeze_handle);
287 }
288
289 sub thaw_start {
290   eval("use Storable");
291   die "Storable module not found: $@\n" if ($@);
292   open(I, "<$G::thaw") || die "Can't open freeze file $G::thaw: $!\n";
293   $G::freeze_handle = \*I;
294 }
295
296 sub thaw_end {
297   close($G::freeze_handle);
298 }
299
300 sub freeze_data {
301   my $h = Storable::freeze($_[0]);
302   print $G::freeze_handle length($h)+1, "\n$h\n";
303 }
304
305 sub freeze_message_list {
306   my $h = Storable::freeze($_[0]);
307   my $l = length($h) + 1;
308   printf $G::freeze_handle "EOM\n$l\n$h\n%010d\n", $l+11+length($l)+1;
309 }
310
311 sub thaw_message_list {
312   my $orig_pos = tell($G::freeze_handle);
313   seek($G::freeze_handle, -11, 2);
314   chomp(my $bytes = <$G::freeze_handle>);
315   seek($G::freeze_handle, $bytes * -1, 2);
316   my $obj = thaw_data();
317   seek($G::freeze_handle, 0, $orig_pos);
318   return($obj);
319 }
320
321 sub thaw_data {
322   my $obj;
323   chomp(my $bytes = <$G::freeze_handle>);
324   return(undef) if (!$bytes || $bytes eq 'EOM');
325   my $read = read(I, $obj, $bytes);
326   die "Format error in thaw file (expected $bytes bytes, got $read)\n"
327       if ($bytes != $read);
328   chomp($obj);
329   return(Storable::thaw($obj));
330 }
331
332 sub process_criteria {
333   my $a = shift;
334   my @c = ();
335   my $e = 0;
336
337   foreach (@$a) {
338     foreach my $t ('@') { s/$t/\\$t/g; }
339     if (/^(.*?)\s+(<=|>=|==|!=|<|>)\s+(.*)$/) {
340       #print STDERR "found as integer\n";
341       my $v = $1; my $o = $2; my $n = $3;
342       if    ($n =~ /^(-?[\d\.]+)M$/)  { $n = $1 * 1024 * 1024; }
343       elsif ($n =~ /^(-?[\d\.]+)K$/)  { $n = $1 * 1024; }
344       elsif ($n =~ /^(-?[\d\.]+)B?$/) { $n = $1; }
345       elsif ($n =~ /^(-?[\d\.]+)d$/)  { $n = $1 * 60 * 60 * 24; }
346       elsif ($n =~ /^(-?[\d\.]+)h$/)  { $n = $1 * 60 * 60; }
347       elsif ($n =~ /^(-?[\d\.]+)m$/)  { $n = $1 * 60; }
348       elsif ($n =~ /^(-?[\d\.]+)s?$/) { $n = $1; }
349       else {
350         print STDERR "Expression $_ did not parse: numeric comparison with ",
351                      "non-number\n";
352         $e = 1;
353         next;
354       }
355       push(@c, { var => lc($v), cmp => "(\$var $o $n)" });
356     } elsif (/^(.*?)\s+(=~|!~)\s+(.*)$/) {
357       #print STDERR "found as string regexp\n";
358       push(@c, { var => lc($1), cmp => "(\"\$var\" $2 $3)" });
359     } elsif (/^(.*?)\s+=\s+(.*)$/) {
360       #print STDERR "found as bare string regexp\n";
361       my $case = $G::caseful ? '' : 'i';
362       push(@c, { var => lc($1), cmp => "(\"\$var\" =~ /$2/$case)" });
363       # quote special characters in perl text string
364       #foreach my $t ('@') { $c[-1]{cmp} =~ s/$t/\\$t/g; }
365     } elsif (/^(.*?)\s+(eq|ne)\s+(.*)$/) {
366       #print STDERR "found as string cmp\n";
367       my $var = lc($1); my $op = $2; my $val = $3;
368       $val =~ s|^(['"])(.*)\1$|$2|;
369       push(@c, { var => $var, cmp => "(\"\$var\" $op \"$val\")" });
370       if (($var eq 'message_id' || $var eq 'message_exim_id') && $op eq "eq") {
371         #print STDERR "short circuit @c[-1]->{cmp} $val\n";
372         $G::msg_ids->{$val} = 1;
373       }
374       #foreach my $t ('@') { $c[-1]{cmp} =~ s/$t/\\$t/g; }
375     } elsif (/^(\S+)$/) {
376       #print STDERR "found as boolean\n";
377       push(@c, { var => lc($1), cmp => "(\$var)" });
378     } else {
379       print STDERR "Expression $_ did not parse\n";
380       $e = 1;
381       next;
382     }
383     # assign the results of the cmp test here (handle "!" negation)
384     # also handle global --not negation
385     if ($c[-1]{var} =~ s|^!||) {
386       $c[-1]{cmp} .= $G::negate ? " ? 1 : 0" : " ? 0 : 1";
387     } else {
388       $c[-1]{cmp} .= $G::negate ? " ? 0 : 1" : " ? 1 : 0";
389     }
390     # support the each_* psuedo variables.  Steal the criteria off of the
391     # queue for special processing later
392     if ($c[-1]{var} =~ /^each_(recipients(_(un)?del)?)$/) {
393       my $var = $1;
394       push(@G::recipients_crit,pop(@c));
395       $G::recipients_crit[-1]{var} = $var; # remove each_ from the variable
396     }
397   }
398
399   exit(1) if ($e);
400
401   if ($G::show_rules) { foreach (@c) { print "$_->{var}\t$_->{cmp}\n"; } }
402
403   return(\@c);
404 }
405
406 sub get_all_msgs {
407   my $d = shift();
408   my $i = shift();
409   my $u = shift; # don't sort
410   my $r = shift; # right before returning, reverse order
411   my $o = shift; # if true, randomize list order before returning
412   my @m = ();
413
414   if ($i =~ m|^/|) { $d = $i; } else { $d = $d . '/' . $i; }
415
416   opendir(D, "$d") || die "Couldn't opendir $d: $!\n";
417   foreach my $e (grep !/^\./, readdir(D)) {
418     if ($e =~ /^[a-zA-Z0-9]$/) {
419       opendir(DD, "$d/$e") || next;
420       foreach my $f (grep !/^\./, readdir(DD)) {
421         push(@m, { message => $1, path => "$d/$e" }) if ($f =~ /^(.{16})-H$/);
422       }
423       closedir(DD);
424     } elsif ($e =~ /^(.{16})-H$/) {
425       push(@m, { message => $1, path => $d });
426     }
427   }
428   closedir(D);
429
430   if ($o) {
431     my $c = scalar(@m);
432     # loop twice to pretend we're doing a good job of mixing things up
433     for (my $i = 0; $i < 2 * $c; $i++) {
434       my $rand = int(rand($c));
435       ($m[$i % $c],$m[$rand]) = ($m[$rand],$m[$i % $c]);
436     }
437   } elsif (!$u) {
438     @m = sort { $a->{message} cmp $b->{message} } @m;
439   }
440   @m = reverse(@m) if ($r);
441
442   return(\@m);
443 }
444
445 BEGIN {
446
447 package Exim::SpoolFile;
448
449 # versions 4.61 and higher will not need these variables anymore, but they
450 # are left for handling legacy installs
451 $Exim::SpoolFile::ACL_C_MAX_LEGACY = 10;
452 #$Exim::SpoolFile::ACL_M_MAX _LEGACY= 10;
453
454 sub new {
455   my $class = shift;
456   my $self  = {};
457   bless($self, $class);
458
459   $self->{_spool_dir}        = '';
460   $self->{_input_path}       = '';
461   $self->{_undelivered_only} = 0;
462   $self->{_show_generated}   = 0;
463   $self->{_output_long}      = 1;
464   $self->{_output_idonly}    = 0;
465   $self->{_output_brief}     = 0;
466   $self->{_output_flatq}     = 0;
467   $self->{_output_vars_only} = 0;
468   $self->{_show_vars}        = [];
469
470   $self->_reset();
471   return($self);
472 }
473
474 sub output_long {
475   my $self = shift;
476
477   $self->{_output_long}      = 1;
478   $self->{_output_idonly}    = 0;
479   $self->{_output_brief}     = 0;
480   $self->{_output_flatq}     = 0;
481   $self->{_output_vars_only} = 0;
482 }
483
484 sub output_idonly {
485   my $self = shift;
486
487   $self->{_output_long}      = 0;
488   $self->{_output_idonly}    = 1;
489   $self->{_output_brief}     = 0;
490   $self->{_output_flatq}     = 0;
491   $self->{_output_vars_only} = 0;
492 }
493
494 sub output_brief {
495   my $self = shift;
496
497   $self->{_output_long}      = 0;
498   $self->{_output_idonly}    = 0;
499   $self->{_output_brief}     = 1;
500   $self->{_output_flatq}     = 0;
501   $self->{_output_vars_only} = 0;
502 }
503
504 sub output_flatq {
505   my $self = shift;
506
507   $self->{_output_long}      = 0;
508   $self->{_output_idonly}    = 0;
509   $self->{_output_brief}     = 0;
510   $self->{_output_flatq}     = 1;
511   $self->{_output_vars_only} = 0;
512 }
513
514 sub output_vars_only {
515   my $self = shift;
516
517   $self->{_output_long}      = 0;
518   $self->{_output_idonly}    = 0;
519   $self->{_output_brief}     = 0;
520   $self->{_output_flatq}     = 0;
521   $self->{_output_vars_only} = 1;
522 }
523
524 sub set_show_vars {
525   my $self = shift;
526   my $s    = shift;
527
528   foreach my $v (split(/\s*,\s*/, $s)) {
529     push(@{$self->{_show_vars}}, $v);
530   }
531 }
532
533 sub set_show_generated {
534   my $self = shift;
535   $self->{_show_generated} = shift;
536 }
537
538 sub set_undelivered_only {
539   my $self = shift;
540   $self->{_undelivered_only} = shift;
541 }
542
543 sub error {
544   my $self = shift;
545   return $self->{_error};
546 }
547
548 sub _error {
549   my $self = shift;
550   $self->{_error} = shift;
551   return(undef);
552 }
553
554 sub _reset {
555   my $self = shift;
556
557   $self->{_error}       = '';
558   $self->{_delivered}   = 0;
559   $self->{_message}     = '';
560   $self->{_path}        = '';
561   $self->{_vars}        = {};
562   $self->{_vars_raw}    = {};
563
564   $self->{_numrecips}   = 0;
565   $self->{_udel_tree}   = {};
566   $self->{_del_tree}    = {};
567   $self->{_recips}      = {};
568
569   return($self);
570 }
571
572 sub parse_message {
573   my $self = shift;
574
575   $self->_reset();
576   $self->{_message} = shift || return(0);
577   $self->{_path}    = shift; # optional path to message
578   return(0) if (!$self->{_input_path});
579   if (!$self->{_path} && !$self->_find_path()) {
580     # assume the message was delivered from under us and ignore
581     $self->{_delivered} = 1;
582     return(1);
583   }
584   $self->_parse_header() || return(0);
585
586   return(1);
587 }
588
589 # take the output of get_state() and set up a message internally like
590 # parse_message (except from a saved data struct, not by parsing the
591 # files on disk).
592 sub restore_state {
593   my $self = shift;
594   my $h    = shift;
595
596   return(1) if ($h->{_delivered});
597   $self->_reset();
598   $self->{_message} = $h->{_message} || return(0);
599   return(0) if (!$self->{_input_path});
600
601   $self->{_path}      = $h->{_path};
602   $self->{_vars}      = $h->{_vars};
603   $self->{_numrecips} = $h->{_numrecips};
604   $self->{_udel_tree} = $h->{_udel_tree};
605   $self->{_del_tree}  = $h->{_del_tree};
606   $self->{_recips}    = $h->{_recips};
607
608   $self->{_vars}{message_age} = time() - $self->{_vars}{received_time};
609   return(1);
610 }
611
612 # This returns the state data for a specific message in a format that can
613 # be later frozen back in to regain state
614 #
615 # after calling this function, this specific state is not expect to be
616 # reused.  That's because we're returning direct references to specific
617 # internal structures.  We're also modifying the structure ourselves
618 # by deleting certain internal message variables.
619 sub get_state {
620   my $self = shift;
621   my $h    = {};    # this is the hash ref we'll be returning.
622
623   $h->{_delivered} = $self->{_delivered};
624   $h->{_message}   = $self->{_message};
625   $h->{_path}      = $self->{_path};
626   $h->{_vars}      = $self->{_vars};
627   $h->{_numrecips} = $self->{_numrecips};
628   $h->{_udel_tree} = $self->{_udel_tree};
629   $h->{_del_tree}  = $self->{_del_tree};
630   $h->{_recips}    = $self->{_recips};
631
632   # delete some internal variables that we will rebuild later if needed
633   delete($h->{_vars}{message_body});
634   delete($h->{_vars}{message_age});
635
636   return($h);
637 }
638
639 # keep this sub as a feature if we ever break this module out, but do away
640 # with its use in exipick (pass it in from caller instead)
641 sub _find_path {
642   my $self = shift;
643
644   return(0) if (!$self->{_message});
645   return(0) if (!$self->{_input_path});
646
647   # test split spool first on the theory that people concerned about
648   # performance will have split spool set =).
649   foreach my $f (substr($self->{_message}, 5, 1).'/', '') {
650     if (-f "$self->{_input_path}/$f$self->{_message}-H") {
651       $self->{_path} = "$self->{_input_path}}/$f";
652       return(1);
653     }
654   }
655   return(0);
656 }
657
658 sub set_spool {
659   my $self = shift;
660   $self->{_spool_dir} = shift;
661   $self->{_input_path} = shift;
662   if ($self->{_input_path} !~ m|^/|) {
663     $self->{_input_path} = $self->{_spool_dir} . '/' . $self->{_input_path};
664   }
665 }
666
667 sub get_matching_vars {
668   my $self = shift;
669   my $e    = shift;
670
671   if ($e =~ /^\^/) {
672     my @r = ();
673     foreach my $v (keys %{$self->{_vars}}) { push(@r, $v) if ($v =~ /$e/); }
674     return(@r);
675   } else {
676     return($e);
677   }
678 }
679
680 # accepts a variable with or without leading '$' or trailing ':'
681 sub get_var {
682   my $self = shift;
683   my $var  = lc(shift); $var =~ s/^\$//; $var =~ s/:$//;
684
685   if ($var eq 'message_body' && !defined($self->{_vars}{message_body})) {
686     $self->_parse_body()
687   } elsif ($var =~ s|^([rb]?h)(eader)?_|${1}eader_| &&
688            exists($self->{_vars}{$var}) && !defined($self->{_vars}{$var}))
689   {
690     if ((my $type = $1) eq 'rh') {
691       $self->{_vars}{$var} = join('', @{$self->{_vars_raw}{$var}{vals}});
692     } else {
693       # both bh_ and h_ build their strings from rh_.  Do common work here
694       my $rh = $var; $rh =~ s|^b?|r|;
695       my $comma = 1 if ($self->{_vars_raw}{$rh}{type} =~ /^[BCFRST]$/);
696       foreach (@{$self->{_vars_raw}{$rh}{vals}}) {
697         my $x = $_; # editing $_ here would change the original, which is bad
698         $x =~ s|^\s+||;
699         $x =~ s|\s+$||;
700         if ($comma) { chomp($x); $self->{_vars}{$var} .= "$x,\n"; }
701         else        { $self->{_vars}{$var} .= $x; }
702       }
703       $self->{_vars}{$var} =~ s|[\s\n]*$||;
704       $self->{_vars}{$var} =~ s|,$|| if ($comma);
705       # ok, that's the preprocessing, not do specific processing for h type
706       if ($type eq 'bh') {
707         $self->{_vars}{$var} = $self->_decode_2047($self->{_vars}{$var});
708       } else {
709         $self->{_vars}{$var} =
710             $self->_decode_2047($self->{_vars}{$var}, $charset);
711       }
712     }
713   }
714   elsif ($var eq 'received_count' && !defined($self->{_vars}{received_count}))
715   {
716     $self->{_vars}{received_count} =
717         scalar(@{$self->{_vars_raw}{rheader_received}{vals}});
718   }
719   elsif ($var eq 'message_headers' && !defined($self->{_vars}{message_headers}))
720   {
721     $self->{_vars}{$var} =
722         $self->_decode_2047($self->{_vars}{message_headers_raw}, $charset);
723     chomp($self->{_vars}{$var});
724   }
725   elsif ($var eq 'reply_address' && !defined($self->{_vars}{reply_address}))
726   {
727     $self->{_vars}{reply_address} = exists($self->{_vars}{"header_reply-to"})
728         ? $self->get_var("header_reply-to") : $self->get_var("header_from");
729   }
730
731   #chomp($self->{_vars}{$var}); # I think this was only for headers, obsolete
732   return $self->{_vars}{$var};
733 }
734
735 sub _decode_2047 {
736   my $self = shift;
737   my $s    = shift; # string to decode
738   my $c    = shift; # target charset.  If empty, just decode, don't convert
739   my $t    = '';    # the translated string
740   my $e    = 0;     # set to true if we get an error in here anywhere
741
742   return($s) if ($s !~ /=\?/); # don't even bother to look if there's no sign
743
744   my @p = ();
745   foreach my $mw (split(/(=\?[^\?]{3,}\?[BQ]\?[^\?]{1,74}\?=)/i, $s)) {
746     next if ($mw eq '');
747     if ($mw =~ /=\?([^\?]{3,})\?([BQ])\?([^\?]{1,74})\?=/i) {
748       push(@p, { data => $3, encoding => uc($2), charset => uc($1),
749                  is_mime => 1 });
750       if ($p[-1]{encoding} eq 'Q') {
751         my @ow = split('', $p[-1]{data});
752         my @nw = ();
753         for (my $i = 0; $i < @ow; $i++) {
754           if ($ow[$i] eq '_') { push(@nw, ' '); }
755           elsif ($ow[$i] eq '=') {
756             if (scalar(@ow) - ($i+1) < 2) {  # ran out of characters
757               $e = 1; last;
758             } elsif ($ow[$i+1] !~ /[\dA-F]/i || $ow[$i+2] !~ /[\dA-F]/i) {
759               $e = 1; last;
760             } else {
761               #push(@nw, chr('0x'.$ow[$i+1].$ow[$i+2]));
762               push(@nw, pack("C", hex($ow[$i+1].$ow[$i+2])));
763               $i += 2;
764             }
765           }
766           elsif ($ow[$i] =~ /\s/) { # whitespace is illegal
767             $e = 1;
768             last;
769           }
770           else { push(@nw, $ow[$i]); }
771         }
772         $p[-1]{data} = join('', @nw);
773       } elsif ($p[-1]{encoding} eq 'B') {
774         my $x = $p[-1]{data};
775         $x    =~ tr#A-Za-z0-9+/##cd;
776         $x    =~ s|=+$||;
777         $x    =~ tr#A-Za-z0-9+/# -_#;
778         my $r = '';
779         while ($x =~ s/(.{1,60})//s) {
780           $r .= unpack("u", chr(32 + int(length($1)*3/4)) . $1);
781         }
782         $p[-1]{data} = $r;
783       }
784     } else {
785       push(@p, { data => $mw, is_mime => 0,
786                  is_ws => ($mw =~ m|^[\s\n]+|sm) ? 1 : 0 });
787     }
788   }
789
790   for (my $i = 0; $i < @p; $i++) {
791     # mark entities we want to skip (whitespace between consecutive mimewords)
792     if ($p[$i]{is_mime} && $p[$i+1]{is_ws} && $p[$i+2]{is_mime}) {
793       $p[$i+1]{skip} = 1;
794     }
795
796     # if word is a mimeword and we have access to Encode and charset was
797     # specified, try to convert text
798     # XXX _cannot_ get consistent conversion results in perl, can't get them
799     # to return same conversions that exim performs.  Until I can figure this
800     # out, don't attempt any conversions (header_ will return same value as
801     # bheader_).
802     #if ($c && $p[$i]{is_mime} && $self->_try_load('Encode')) {
803     #  # XXX not sure how to catch errors here
804     #  Encode::from_to($p[$i]{data}, $p[$i]{charset}, $c);
805     #}
806
807     # replace binary zeros w/ '?' in decoded text
808     if ($p[$i]{is_mime}) { $p[$i]{data} =~ s|\x00|?|g; }
809   }
810
811   if ($e) {
812     return($s);
813   } else {
814     return(join('', map { $_->{data} } grep { !$_->{skip} } @p));
815   }
816 }
817
818 # This isn't a class func but I'm tired
819 sub _try_load {
820   my $self = shift;
821   my $mod  = shift;
822
823   eval("use $mod");
824   return $@ ? 0 : 1;
825 }
826
827 sub _parse_body {
828   my $self = shift;
829   my $f    = $self->{_path} . '/' . $self->{_message} . '-D';
830   $self->{_vars}{message_body} = ""; # define var so we only come here once
831
832   open(I, "<$f") || return($self->_error("Couldn't open $f: $!"));
833   chomp($_ = <I>);
834   return(0) if ($self->{_message}.'-D' ne $_);
835
836   $self->{_vars}{message_body} = join('', <I>);
837   close(I);
838   $self->{_vars}{message_body} =~ s/\n/ /g;
839   $self->{_vars}{message_body} =~ s/\000/ /g;
840   return(1);
841 }
842
843 sub _parse_header {
844   my $self = shift;
845   my $f    = $self->{_path} . '/' . $self->{_message} . '-H';
846   $self->{_vars}{header_path} = $f;
847   $self->{_vars}{data_path}   = $self->{_path} . '/' . $self->{_message} . '-D';
848
849   if (!open(I, "<$f")) {
850     # assume message went away and silently ignore
851     $self->{_delivered} = 1;
852     return(1);
853   }
854
855   # There are a few numeric variables that should explicitly be set to
856   # zero if they aren't found in the header.  Technically an empty value
857   # works just as well, but might as well be pedantic
858   $self->{_vars}{body_zerocount}           = 0;
859   $self->{_vars}{host_lookup_deferred}     = 0;
860   $self->{_vars}{host_lookup_failed}       = 0;
861   $self->{_vars}{tls_certificate_verified} = 0;
862
863   chomp($_ = <I>);
864   return(0) if ($self->{_message}.'-H' ne $_);
865   $self->{_vars}{message_id}       = $self->{_message};
866   $self->{_vars}{message_exim_id}  = $self->{_message};
867
868   # line 2
869   chomp($_ = <I>);
870   return(0) if (!/^(.+)\s(\-?\d+)\s(\-?\d+)$/);
871   $self->{_vars}{originator_login} = $1;
872   $self->{_vars}{originator_uid}   = $2;
873   $self->{_vars}{originator_gid}   = $3;
874
875   # line 3
876   chomp($_ = <I>);
877   return(0) if (!/^<(.*)>$/);
878   $self->{_vars}{sender_address}   = $1;
879   $self->{_vars}{sender_address_domain} = $1;
880   $self->{_vars}{sender_address_local_part} = $1;
881   $self->{_vars}{sender_address_domain} =~ s/^.*\@//;
882   $self->{_vars}{sender_address_local_part} =~ s/^(.*)\@.*$/$1/;
883
884   # line 4
885   chomp($_ = <I>);
886   return(0) if (!/^(\d+)\s(\d+)$/);
887   $self->{_vars}{received_time}    = $1;
888   $self->{_vars}{warning_count}    = $2;
889   $self->{_vars}{message_age}      = time() - $self->{_vars}{received_time};
890
891   while (<I>) {
892     chomp();
893     if (/^(-\S+)\s*(.*$)/) {
894       my $tag = $1;
895       my $arg = $2;
896       if ($tag eq '-acl') {
897         my $t;
898         return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
899         if ($1 < $Exim::SpoolFile::ACL_C_MAX_LEGACY) {
900           $t = "acl_c$1";
901         } else {
902           $t = "acl_m" . ($1 - $Exim::SpoolFile::ACL_C_MAX_LEGACY);
903         }
904         read(I, $self->{_vars}{$t}, $2+1) || return(0);
905         chomp($self->{_vars}{$t});
906       } elsif ($tag eq '-aclc') {
907         #return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
908         return(0) if ($arg !~ /^(\S+)\s(\d+)$/);
909         my $t = "acl_c$1";
910         read(I, $self->{_vars}{$t}, $2+1) || return(0);
911         chomp($self->{_vars}{$t});
912       } elsif ($tag eq '-aclm') {
913         #return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
914         return(0) if ($arg !~ /^(\S+)\s(\d+)$/);
915         my $t = "acl_m$1";
916         read(I, $self->{_vars}{$t}, $2+1) || return(0);
917         chomp($self->{_vars}{$t});
918       } elsif ($tag eq '-local') {
919         $self->{_vars}{sender_local} = 1;
920       } elsif ($tag eq '-localerror') {
921         $self->{_vars}{local_error_message} = 1;
922       } elsif ($tag eq '-local_scan') {
923         $self->{_vars}{local_scan_data} = $arg;
924       } elsif ($tag eq '-spam_score_int') {
925         $self->{_vars}{spam_score_int} = $arg;
926         $self->{_vars}{spam_score}     = $arg / 10;
927       } elsif ($tag eq '-bmi_verdicts') {
928         $self->{_vars}{bmi_verdicts} = $arg;
929       } elsif ($tag eq '-host_lookup_deferred') {
930         $self->{_vars}{host_lookup_deferred} = 1;
931       } elsif ($tag eq '-host_lookup_failed') {
932         $self->{_vars}{host_lookup_failed} = 1;
933       } elsif ($tag eq '-body_linecount') {
934         $self->{_vars}{body_linecount} = $arg;
935       } elsif ($tag eq '-max_received_linelength') {
936         $self->{_vars}{max_received_linelength} = $arg;
937       } elsif ($tag eq '-body_zerocount') {
938         $self->{_vars}{body_zerocount} = $arg;
939       } elsif ($tag eq '-frozen') {
940         $self->{_vars}{deliver_freeze} = 1;
941         $self->{_vars}{deliver_frozen_at} = $arg;
942       } elsif ($tag eq '-allow_unqualified_recipient') {
943         $self->{_vars}{allow_unqualified_recipient} = 1;
944       } elsif ($tag eq '-allow_unqualified_sender') {
945         $self->{_vars}{allow_unqualified_sender} = 1;
946       } elsif ($tag eq '-deliver_firsttime') {
947         $self->{_vars}{deliver_firsttime} = 1;
948         $self->{_vars}{first_delivery} = 1;
949       } elsif ($tag eq '-manual_thaw') {
950         $self->{_vars}{deliver_manual_thaw} = 1;
951         $self->{_vars}{manually_thawed} = 1;
952       } elsif ($tag eq '-auth_id') {
953         $self->{_vars}{authenticated_id} = $arg;
954       } elsif ($tag eq '-auth_sender') {
955         $self->{_vars}{authenticated_sender} = $arg;
956       } elsif ($tag eq '-sender_set_untrusted') {
957         $self->{_vars}{sender_set_untrusted} = 1;
958       } elsif ($tag eq '-tls_certificate_verified') {
959         $self->{_vars}{tls_certificate_verified} = 1;
960       } elsif ($tag eq '-tls_cipher') {
961         $self->{_vars}{tls_cipher} = $arg;
962       } elsif ($tag eq '-tls_peerdn') {
963         $self->{_vars}{tls_peerdn} = $arg;
964       } elsif ($tag eq '-tls_sni') {
965         $self->{_vars}{tls_sni} = $arg;
966       } elsif ($tag eq '-host_address') {
967         $self->{_vars}{sender_host_port} = $self->_get_host_and_port(\$arg);
968         $self->{_vars}{sender_host_address} = $arg;
969       } elsif ($tag eq '-interface_address') {
970         $self->{_vars}{received_port} =
971             $self->{_vars}{interface_port} = $self->_get_host_and_port(\$arg);
972         $self->{_vars}{received_ip_address} =
973             $self->{_vars}{interface_address} = $arg;
974       } elsif ($tag eq '-active_hostname') {
975         $self->{_vars}{smtp_active_hostname} = $arg;
976       } elsif ($tag eq '-host_auth') {
977         $self->{_vars}{sender_host_authenticated} = $arg;
978       } elsif ($tag eq '-host_name') {
979         $self->{_vars}{sender_host_name} = $arg;
980       } elsif ($tag eq '-helo_name') {
981         $self->{_vars}{sender_helo_name} = $arg;
982       } elsif ($tag eq '-ident') {
983         $self->{_vars}{sender_ident} = $arg;
984       } elsif ($tag eq '-received_protocol') {
985         $self->{_vars}{received_protocol} = $arg;
986       } elsif ($tag eq '-N') {
987         $self->{_vars}{dont_deliver} = 1;
988       } else {
989         # unrecognized tag, save it for reference
990         $self->{$tag} = $arg;
991       }
992     } else {
993       last;
994     }
995   }
996
997   # when we drop out of the while loop, we have the first line of the
998   # delivered tree in $_
999   do {
1000     if ($_ eq 'XX') {
1001       ; # noop
1002     } elsif ($_ =~ s/^[YN][YN]\s+//) {
1003       $self->{_del_tree}{$_} = 1;
1004     } else {
1005       return(0);
1006     }
1007     chomp($_ = <I>);
1008   } while ($_ !~ /^\d+$/);
1009
1010   $self->{_numrecips} = $_;
1011   $self->{_vars}{recipients_count} = $self->{_numrecips};
1012   for (my $i = 0; $i < $self->{_numrecips}; $i++) {
1013     chomp($_ = <I>);
1014     return(0) if (/^$/);
1015     my $addr = '';
1016     if (/^(.*)\s\d+,(\d+),\d+$/) {
1017       #print STDERR "exim3 type (untested): $_\n";
1018       $self->{_recips}{$1} = { pno => $2 };
1019       $addr = $1;
1020     } elsif (/^(.*)\s(\d+)$/) {
1021       #print STDERR "exim4 original type (untested): $_\n";
1022       $self->{_recips}{$1} = { pno => $2 };
1023       $addr = $1;
1024     } elsif (/^(.*)\s(.*)\s(\d+),(\d+)#1$/) {
1025       #print STDERR "exim4 new type #1 (untested): $_\n";
1026       return($self->_error("incorrect format: $_")) if (length($2) != $3);
1027       $self->{_recips}{$1} = { pno => $4, errors_to => $2 };
1028       $addr = $1;
1029     } elsif (/^(\S*)\s(\S*)\s(\d+),(\d+)\s(\S*)\s(\d+),(-?\d+)#3$/) {
1030       #print STDERR "exim4 new type #3 DSN (untested): $_\n";
1031       return($self->_error("incorrect format: $_"))
1032         if ((length($2) != $3) || (length($5) != $6));
1033       $self->{_recips}{$1} = { pno => $7, errors_to => $5 };
1034       $addr = $1;
1035     } elsif (/^.*#(\d+)$/) {
1036       #print STDERR "exim4 #$1 style (unimplemented): $_\n";
1037       $self->_error("exim4 #$1 style (unimplemented): $_");
1038     } else {
1039       #print STDERR "default type: $_\n";
1040       $self->{_recips}{$_} = {};
1041       $addr = $_;
1042     }
1043     $self->{_udel_tree}{$addr} = 1 if (!$self->{_del_tree}{$addr});
1044   }
1045   $self->{_vars}{recipients}         = join(', ', keys(%{$self->{_recips}}));
1046   $self->{_vars}{recipients_del}     = join(', ', keys(%{$self->{_del_tree}}));
1047   $self->{_vars}{recipients_undel}   = join(', ', keys(%{$self->{_udel_tree}}));
1048   $self->{_vars}{recipients_undel_count} = scalar(keys(%{$self->{_udel_tree}}));
1049   $self->{_vars}{recipients_del_count}   = 0;
1050   foreach my $r (keys %{$self->{_del_tree}}) {
1051     next if (!$self->{_recips}{$r});
1052     $self->{_vars}{recipients_del_count}++;
1053   }
1054
1055   # blank line
1056   $_ = <I>;
1057   return(0) if (!/^$/);
1058
1059   # start reading headers
1060   while (read(I, $_, 3) == 3) {
1061     my $t = getc(I);
1062     return(0) if (!length($t));
1063     while ($t =~ /^\d$/) {
1064       $_ .= $t;
1065       $t  = getc(I);
1066     }
1067     my $hdr_flag  = $t;
1068     my $hdr_bytes = $_;
1069     $t            = getc(I);              # strip the space out of the file
1070     return(0) if (read(I, $_, $hdr_bytes) != $hdr_bytes);
1071     if ($hdr_flag ne '*') {
1072       $self->{_vars}{message_linecount} += (tr/\n//);
1073       $self->{_vars}{message_size}      += $hdr_bytes;
1074     }
1075
1076     # mark (rb)?header_ vars as existing and store raw value.  They'll be
1077     # processed further in get_var() if needed
1078     my($v,$d) = split(/:/, $_, 2);
1079     $v = "header_" . lc($v);
1080     $self->{_vars}{$v} = $self->{_vars}{"b$v"} = $self->{_vars}{"r$v"} = undef;
1081     push(@{$self->{_vars_raw}{"r$v"}{vals}}, $d);
1082     $self->{_vars_raw}{"r$v"}{type} = $hdr_flag;
1083     $self->{_vars}{message_headers_raw} .= $_;
1084   }
1085   close(I);
1086
1087   $self->{_vars}{message_body_size} =
1088       (stat($self->{_path}.'/'.$self->{_message}.'-D'))[7] - 19;
1089   if ($self->{_vars}{message_body_size} < 0) {
1090     $self->{_vars}{message_size} = 0;
1091     $self->{_vars}{message_body_missing} = 1;
1092   } else {
1093     $self->{_vars}{message_size} += $self->{_vars}{message_body_size} + 1;
1094   }
1095
1096   $self->{_vars}{message_linecount} += $self->{_vars}{body_linecount};
1097
1098   my $i = $self->{_vars}{message_size};
1099   if ($i == 0)          { $i = ""; }
1100   elsif ($i < 1024)     { $i = sprintf("%d",    $i);                    }
1101   elsif ($i < 10240)    { $i = sprintf("%.1fK", $i / 1024);             }
1102   elsif ($i < 1048576)  { $i = sprintf("%dK",   ($i+512)/1024);         }
1103   elsif ($i < 10485760) { $i = sprintf("%.1fM", $i/1048576);            }
1104   else                  { $i = sprintf("%dM",   ($i + 524288)/1048576); }
1105   $self->{_vars}{shown_message_size} = $i;
1106
1107   return(1);
1108 }
1109
1110 # mimic exim's host_extract_port function - receive a ref to a scalar,
1111 # strip it of port, return port
1112 sub _get_host_and_port {
1113   my $self = shift;
1114   my $host = shift; # scalar ref, be careful
1115
1116   if ($$host =~ /^\[([^\]]+)\](?:\:(\d+))?$/) {
1117     $$host = $1;
1118     return($2 || 0);
1119   } elsif ($$host =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})(?:\.(\d+))?$/) {
1120     $$host = $1;
1121     return($2 || 0);
1122   } elsif ($$host =~ /^([\d\:]+)(?:\.(\d+))?$/) {
1123     $$host = $1;
1124     return($2 || 0);
1125   }
1126   # implicit else
1127   return(0);
1128 }
1129
1130 # honoring all formatting preferences, return a scalar variable of the
1131 # information for the single message matching what exim -bp would show.
1132 # We can print later if we want.
1133 sub format_message {
1134   my $self = shift;
1135   my $o    = '';
1136   return if ($self->{_delivered});
1137
1138   # define any vars we want to print out for this message.  The requests
1139   # can be regexps, and the defined vars can change for each message, so we
1140   # have to build this list for each message
1141   my @vars = ();
1142   if (@{$self->{_show_vars}}) {
1143     my %t = ();
1144     foreach my $e (@{$self->{_show_vars}}) {
1145       foreach my $v ($self->get_matching_vars($e)) {
1146         next if ($t{$v}); $t{$v}++; push(@vars, $v);
1147       }
1148     }
1149   }
1150
1151   if ($self->{_output_idonly}) {
1152     $o .= $self->{_message};
1153     foreach my $v (@vars) { $o .= " $v='" . $self->get_var($v) . "'"; }
1154     $o .= "\n";
1155     return $o;
1156   } elsif ($self->{_output_vars_only}) {
1157     foreach my $v (@vars) { $o .= $self->get_var($v) . "\n"; }
1158     return $o;
1159   }
1160
1161   if ($self->{_output_long} || $self->{_output_flatq}) {
1162     my $i = int($self->{_vars}{message_age} / 60);
1163     if ($i > 90) {
1164       $i = int(($i+30)/60);
1165       if ($i > 72) { $o .= sprintf "%2dd ", int(($i+12)/24); }
1166       else { $o .= sprintf "%2dh ", $i; }
1167     } else { $o .= sprintf "%2dm ", $i; }
1168
1169     if ($self->{_output_flatq} && @vars) {
1170         $o .= join(';', map { "$_='".$self->get_var($_)."'" } (@vars)
1171                   );
1172     } else {
1173       $o .= sprintf "%5s", $self->{_vars}{shown_message_size};
1174     }
1175     $o .= " ";
1176   }
1177   $o .= "$self->{_message} ";
1178   $o .= "From: " if ($self->{_output_brief});
1179   $o .= "<$self->{_vars}{sender_address}>";
1180
1181   if ($self->{_output_long}) {
1182     $o .= " ($self->{_vars}{originator_login})"
1183         if ($self->{_vars}{sender_set_untrusted});
1184
1185     # XXX exim contains code here to print spool format errors
1186     $o .= " *** frozen ***" if ($self->{_vars}{deliver_freeze});
1187     $o .= "\n";
1188
1189     foreach my $v (@vars) {
1190       $o .= sprintf "  %25s = '%s'\n", $v, $self->get_var($v);
1191     }
1192
1193     foreach my $r (keys %{$self->{_recips}}) {
1194       next if ($self->{_del_tree}{$r} && $self->{_undelivered_only});
1195       $o .= sprintf "        %s %s\n", $self->{_del_tree}{$r} ? "D" : " ", $r;
1196     }
1197     if ($self->{_show_generated}) {
1198       foreach my $r (keys %{$self->{_del_tree}}) {
1199         next if ($self->{_recips}{$r});
1200         $o .= sprintf "       +D %s\n", $r;
1201       }
1202     }
1203   } elsif ($self->{_output_brief}) {
1204     my @r = ();
1205     foreach my $r (keys %{$self->{_recips}}) {
1206       next if ($self->{_del_tree}{$r});
1207       push(@r, $r);
1208     }
1209     $o .= " To: " . join(';', @r);
1210     if (scalar(@vars)) {
1211       $o .= " Vars: ".join(';',map { "$_='".$self->get_var($_)."'" } (@vars));
1212     }
1213   } elsif ($self->{_output_flatq}) {
1214     $o .= " *** frozen ***" if ($self->{_vars}{deliver_freeze});
1215     my @r = ();
1216     foreach my $r (keys %{$self->{_recips}}) {
1217       next if ($self->{_del_tree}{$r});
1218       push(@r, $r);
1219     }
1220     $o .= " " . join(' ', @r);
1221   }
1222
1223   $o .= "\n";
1224   return($o);
1225 }
1226
1227 sub print_message {
1228   my $self = shift;
1229   my $fh   = shift || \*STDOUT;
1230   return if ($self->{_delivered});
1231
1232   print $fh $self->format_message();
1233 }
1234
1235 sub dump {
1236   my $self = shift;
1237
1238   foreach my $k (sort keys %$self) {
1239     my $r = ref($self->{$k});
1240     if ($r eq 'ARRAY') {
1241       printf "%20s <<EOM\n", $k;
1242       print @{$self->{$k}}, "EOM\n";
1243     } elsif ($r eq 'HASH') {
1244       printf "%20s <<EOM\n", $k;
1245       foreach (sort keys %{$self->{$k}}) {
1246         printf "%20s %s\n", $_, $self->{$k}{$_};
1247       }
1248       print "EOM\n";
1249     } else {
1250       printf "%20s %s\n", $k, $self->{$k};
1251     }
1252   }
1253 }
1254
1255 } # BEGIN
1256
1257 sub ext_usage {
1258   if ($ARGV[0] =~ /^--help$/i) {
1259     require Config;
1260     $ENV{PATH} .= ":" unless $ENV{PATH} eq "";
1261     $ENV{PATH} = "$ENV{PATH}$Config::Config{'installscript'}";
1262     #exec("perldoc", "-F", "-U", $0) || exit 1;
1263     $< = $> = 1 if ($> == 0 || $< == 0);
1264     exec("perldoc", $0) || exit 1;
1265     # make parser happy
1266     %Config::Config = ();
1267   } elsif ($ARGV[0] =~ /^--version$/i) {
1268     print "$p_name version $p_version\n\n$p_cp\n";
1269   } else {
1270     return;
1271   }
1272
1273   exit(0);
1274 }
1275
1276 __END__
1277
1278 =head1 NAME
1279
1280 exipick - selectively display messages from an Exim queue
1281
1282 =head1 SYNOPSIS
1283
1284 exipick [<options>] [<criterion> [<criterion> ...]]
1285
1286 =head1 DESCRIPTION
1287
1288 exipick is a tool to display messages in an Exim queue.  It is very similar to exiqgrep and is, in fact, a drop in replacement for exiqgrep.  exipick allows you to select messages to be displayed using any piece of data stored in an Exim spool file.  Matching messages can be displayed in a variety of formats.
1289
1290 =head1 QUICK START
1291
1292 Delete every frozen message from queue:
1293     exipick -zi | xargs exim -Mrm
1294
1295 Show only messages which have not yet been virus scanned:
1296     exipick '$received_protocol ne virus-scanned'
1297
1298 Run the queue in a semi-random order:
1299     exipick -i --random | xargs exim -M
1300
1301 Show the count and total size of all messages which either originated from localhost or have a received protocol of 'local':
1302     exipick --or --size --bpc \
1303             '$sender_host_address eq 127.0.0.1' \
1304             '$received_protocol eq local'
1305
1306 Display all messages received on the MSA port, ordered first by the sender's email domain and then by the size of the emails:
1307     exipick --sort sender_address_domain,message_size \
1308             '$received_port == 587'
1309
1310 Display only messages whose every recipient is in the example.com domain, also listing the IP address of the sending host:
1311     exipick --show-vars sender_host_address \
1312             '$each_recipients = example.com'
1313
1314 Same as above, but show values for all defined variables starting with sender_ and the number of recipients:
1315     exipick --show-vars ^sender_,recipients_count \
1316             '$each_recipients = example.com'
1317
1318 =head1 OPTIONS
1319
1320 =over 4
1321
1322 =item --and
1323
1324 Display messages matching all criteria (default)
1325
1326 =item -b
1327
1328 Display messages in brief format (exiqgrep)
1329
1330 =item -bp
1331
1332 Display messages in standard mailq format (default)
1333
1334 =item -bpa
1335
1336 Same as -bp, show generated addresses also (exim)
1337
1338 =item -bpc
1339
1340 Show a count of matching messages (exim)
1341
1342 =item -bpr
1343
1344 Same as '-bp --unsorted' (exim)
1345
1346 =item -bpra
1347
1348 Same as '-bpa --unsorted' (exim)
1349
1350 =item -bpru
1351
1352 Same as '-bpu --unsorted' (exim)
1353
1354 =item -bpu
1355
1356 Same as -bp, but only show undelivered messages (exim)
1357
1358 =item -C | --config <config>
1359
1360 Use <config> to determine the proper spool directory. (See C<--spool>
1361 or C<--input> for alternative ways to specify the directories to operate on.)
1362
1363 =item -c
1364
1365 Show a count of matching messages (exiqgrep)
1366
1367 =item --caseful
1368
1369 Make operators involving '=' honor case
1370
1371 =item --charset
1372
1373 Override the default local character set for $header_ decoding
1374
1375 =item -f <regexp>
1376
1377 Same as '$sender_address =~ /<regexp>/' (exiqgrep).  Note that this preserves the default case sensitivity of exiqgrep's interface.
1378
1379 =item --finput
1380
1381 Same as '--input-dir Finput'.  'Finput' is where exim copies frozen messages when compiled with SUPPORT_MOVE_FROZEN_MESSAGES.
1382
1383 =item --flatq
1384
1385 Use a single-line output format
1386
1387 =item --freeze <cache file>
1388
1389 Save queue information in an quickly retrievable format
1390
1391 =item --help
1392
1393 Display this output
1394
1395 =item -i
1396
1397 Display only the message IDs (exiqgrep)
1398
1399 =item --input-dir <inputname>
1400
1401 Set the name of the directory under the spool directory.  By default this is "input".  If this starts with '/', the value of --spool is ignored.  See also --finput.
1402
1403 =item -l
1404
1405 Same as -bp (exiqgrep)
1406
1407 =item --not
1408
1409 Negate all tests.
1410
1411 =item -o <seconds>
1412
1413 Same as '$message_age > <seconds>' (exiqgrep)
1414
1415 =item --or
1416
1417 Display messages matching any criteria
1418
1419 =item -R
1420
1421 Same as --reverse (exiqgrep)
1422
1423 =item -r <regexp>
1424
1425 Same as '$recipients =~ /<regexp>/' (exiqgrep).  Note that this preserves the default case sensitivity of exiqgrep's interface.
1426
1427 =item --random
1428
1429 Display messages in random order
1430
1431 =item --reverse
1432
1433 Display messages in reverse order
1434
1435 =item -s <string>
1436
1437 Same as '$shown_message_size eq <string>' (exiqgrep)
1438
1439 =item --spool <path>
1440
1441 Set the path to the exim spool to use.  This value will have the argument to --input or 'input' appended, or be ignored if --input is a full path. If not specified, exipick uses the value from C<exim [-C config] -n -bP spool_directory>, and if this call fails, the  F</opt/exim/spool> from build time (F<Local/Makefile>) is used. See also --config.
1442
1443 =item --show-rules
1444
1445 Show the internal representation of each criterion specified
1446
1447 =item --show-tests
1448
1449 Show the result of each criterion on each message
1450
1451 =item --show-vars <variable>[,<variable>...]
1452
1453 Show the value for <variable> for each displayed message.  <variable> will be a regular expression if it begins with a circumflex.
1454
1455 =item --size
1456
1457 Show the total bytes used by each displayed message
1458
1459 =item --thaw <cache file>
1460
1461 Read queue information cached from a previous --freeze run
1462
1463 =item --sort <variable>[,<variable>...]
1464
1465 Display matching messages sorted according to <variable>
1466
1467 =item --unsorted
1468
1469 Do not apply any sorting to output
1470
1471 =item --version
1472
1473 Display the version of this command
1474
1475 =item -x
1476
1477 Same as '!$deliver_freeze' (exiqgrep)
1478
1479 =item -y
1480
1481 Same as '$message_age < <seconds>' (exiqgrep)
1482
1483 =item -z
1484
1485 Same as '$deliver_freeze' (exiqgrep)
1486
1487 =back
1488
1489 =head1 CRITERIA
1490
1491 Exipick decides which messages to display by applying a test against each message.  The rules take the general form of 'VARIABLE OPERATOR VALUE'.  For example, '$message_age > 60'.  When exipick is deciding which messages to display, it checks the $message_age variable for each message.  If a message's age is greater than 60, the message will be displayed.  If the message's age is 60 or less seconds, it will not be displayed.
1492
1493 Multiple criteria can be used.  The order they are specified does not matter.  By default all criteria must evaluate to true for a message to be displayed.  If the --or option is used, a message is displayed as long as any of the criteria evaluate to true.
1494
1495 See the VARIABLES and OPERATORS sections below for more details
1496
1497 =head1 OPERATORS
1498
1499 =over 4
1500
1501 =item BOOLEAN
1502
1503 Boolean variables are checked simply by being true or false.  There is no real operator except negation.  Examples of valid boolean tests:
1504   '$deliver_freeze'
1505   '!$deliver_freeze'
1506
1507 =item NUMERIC
1508
1509 Valid comparisons are <, <=, >, >=, ==, and !=.  Numbers can be integers or floats.  Any number in a test suffixed with d, h, m, s, M, K, or B will be multiplied by 86400, 3600, 60, 1, 1048576, 1024, or 1 respectively.  Examples of valid numeric tests:
1510   '$message_age >= 3d'
1511   '$local_interface == 587'
1512   '$message_size < 30K'
1513
1514 =item STRING
1515
1516 The string operators are =, eq, ne, =~, and !~.  With the exception of '=', the operators all match the functionality of the like-named perl operators.  eq and ne match a string exactly.  !~, =~, and = apply a perl regular expression to a string.  The '=' operator behaves just like =~ but you are not required to place // around the regular expression.  Examples of valid string tests:
1517   '$received_protocol eq esmtp'
1518   '$sender_address = example.com'
1519   '$each_recipients =~ /^a[a-z]{2,3}@example.com$/'
1520
1521 =item NEGATION
1522
1523 There are many ways to negate tests, each having a reason for existing.  Many tests can be negated using native operators.  For instance, >1 is the opposite of <=1 and eq and ne are opposites.  In addition, each individual test can be negated by adding a ! at the beginning of the test.  For instance, '!$acl_m1 =~ /^DENY$/' is the same as '$acl_m1 !~ /^DENY$/'.  Finally, every test can be specified by using the command line argument --not.  This is functionally equivalent to adding a ! to the beginning of every test.
1524
1525 =back
1526
1527 =head1 VARIABLES
1528
1529 With a few exceptions the available variables match Exim's internal expansion variables in both name and exact contents.  There are a few notable additions and format deviations which are noted below.  Although a brief explanation is offered below, Exim's spec.txt should be consulted for full details.  It is important to remember that not every variable will be defined for every message.  For example, $sender_host_port is not defined for messages not received from a remote host.
1530
1531 Internally, all variables are represented as strings, meaning any operator will work on any variable.  This means that '$sender_host_name > 4' is a legal criterion, even if it does not produce meaningful results.  Variables in the list below are marked with a 'type' to help in choosing which types of operators make sense to use.
1532
1533   Identifiers
1534     B - Boolean variables
1535     S - String variables
1536     N - Numeric variables
1537     . - Standard variable matching Exim's content definition
1538     # - Standard variable, contents differ from Exim's definition
1539     + - Non-standard variable
1540
1541 =over 4
1542
1543 =item S . $acl_c0-$acl_c9, $acl_m0-$acl_m9
1544
1545 User definable variables.
1546
1547 =item B + $allow_unqualified_recipient
1548
1549 TRUE if unqualified recipient addresses are permitted in header lines.
1550
1551 =item B + $allow_unqualified_sender
1552
1553 TRUE if unqualified sender addresses are permitted in header lines.
1554
1555 =item S . $authenticated_id
1556
1557 Optional saved information from authenticators, or the login name of the calling process for locally submitted messages.
1558
1559 =item S . $authenticated_sender
1560
1561 The value of AUTH= param for smtp messages, or a generated value from the calling processes login and qualify domain for locally submitted messages.
1562
1563 =item S . $bheader_*, $bh_*
1564
1565 Value of the header(s) with the same name with any RFC2047 words decoded if present.  See section 11.5 of Exim's spec.txt for full details.
1566
1567 =item S + $bmi_verdicts
1568
1569 The verdict string provided by a Brightmail content scan
1570
1571 =item N . $body_linecount
1572
1573 The number of lines in the message's body.
1574
1575 =item N . $body_zerocount
1576
1577 The number of binary zero bytes in the message's body.
1578
1579 =item S + $data_path
1580
1581 The path to the body file's location in the filesystem.
1582
1583 =item B + $deliver_freeze
1584
1585 TRUE if the message is currently frozen.
1586
1587 =item N + $deliver_frozen_at
1588
1589 The epoch time at which message was frozen.
1590
1591 =item B + $dont_deliver
1592
1593 TRUE if, under normal circumstances, Exim will not try to deliver the message.
1594
1595 =item S + $each_recipients
1596
1597 This is a psuedo variable which allows you to apply a test against each address in $recipients individually.  Whereas '$recipients =~ /@aol.com/' will match if any recipient address contains aol.com, '$each_recipients =~ /@aol.com$/' will only be true if every recipient matches that pattern.  Note that this obeys --and or --or being set.  Using it with --or is very similar to just matching against $recipients, but with the added benefit of being able to use anchors at the beginning and end of each recipient address.
1598
1599 =item S + $each_recipients_del
1600
1601 Like $each_recipients, but for $recipients_del
1602
1603 =item S + $each_recipients_undel
1604
1605 Like $each_recipients, but for $recipients_undel
1606
1607 =item B . $first_delivery
1608
1609 TRUE if the message has never been deferred.
1610
1611 =item S . $header_*, $h_*
1612
1613 This will always match the contents of the corresponding $bheader_* variable currently (the same behaviour Exim displays when iconv is not installed).
1614
1615 =item S + $header_path
1616
1617 The path to the header file's location in the filesystem.
1618
1619 =item B . $host_lookup_deferred
1620
1621 TRUE if there was an attempt to look up the host's name from its IP address, but an error occurred that during the attempt.
1622
1623 =item B . $host_lookup_failed
1624
1625 TRUE if there was an attempt to look up the host's name from its IP address, but the attempt returned a negative result.
1626
1627 =item B + $local_error_message
1628
1629 TRUE if the message is a locally-generated error message.
1630
1631 =item S . $local_scan_data
1632
1633 The text returned by the local_scan() function when a message is received.
1634
1635 =item B . $manually_thawed
1636
1637 TRUE when the message has been manually thawed.
1638
1639 =item N . $max_received_linelength
1640
1641 The number of bytes in the longest line that was received as part of the message, not counting line termination characters.
1642
1643 =item N . $message_age
1644
1645 The number of seconds since the message was received.
1646
1647 =item S # $message_body
1648
1649 The message's body.  Unlike Exim's variable of the same name, this variable contains the entire message body.  Newlines and nulls are replaced by spaces.
1650
1651 =item B + $message_body_missing
1652
1653 TRUE is a message's spool data file (-D file) is missing or unreadable.
1654
1655 =item N . $message_body_size
1656
1657 The size of the body in bytes.
1658
1659 =item S . $message_exim_id, $message_id
1660
1661 The unique message id that is used by Exim to identify the message.  $message_id is deprecated as of Exim 4.53.
1662
1663 =item S . $message_headers
1664
1665 A concatenation of all the header lines except for lines added by routers or transports.  RFC2047 decoding is performed
1666
1667 =item S . $message_headers_raw
1668
1669 A concatenation of all the header lines except for lines added by routers or transports.  No decoding or translation is performed.
1670
1671 =item N . $message_linecount
1672
1673 The number of lines in the entire message (body and headers).
1674
1675 =item N . $message_size
1676
1677 The size of the message in bytes.
1678
1679 =item N . $originator_gid
1680
1681 The group id under which the process that called Exim was running as when the message was received.
1682
1683 =item S + $originator_login
1684
1685 The login of the process which called Exim.
1686
1687 =item N . $originator_uid
1688
1689 The user id under which the process that called Exim was running as when the message was received.
1690
1691 =item S . $received_ip_address, $interface_address
1692
1693 The address of the local IP interface for network-originated messages.  $interface_address is deprecated as of Exim 4.64
1694
1695 =item N . $received_port, $interface_port
1696
1697 The local port number if network-originated messages.  $interface_port is deprecated as of Exim 4.64
1698
1699 =item N . $received_count
1700
1701 The number of Received: header lines in the message.
1702
1703 =item S . $received_protocol
1704
1705 The name of the protocol by which the message was received.
1706
1707 =item N . $received_time
1708
1709 The epoch time at which the message was received.
1710
1711 =item S # $recipients
1712
1713 The list of envelope recipients for a message.  Unlike Exim's version, this variable always contains every recipient of the message.  The recipients are separated by a comma and a space.  See also $each_recipients.
1714
1715 =item N . $recipients_count
1716
1717 The number of envelope recipients for the message.
1718
1719 =item S + $recipients_del
1720
1721 The list of delivered envelope recipients for a message.  This non-standard variable is in the same format as $recipients and contains the list of already-delivered recipients including any generated addresses.  See also $each_recipients_del.
1722
1723 =item N + $recipients_del_count
1724
1725 The number of envelope recipients for the message which have already been delivered.  Note that this is the count of original recipients to which the message has been delivered.  It does not include generated addresses so it is possible that this number will be less than the number of addresses in the $recipients_del string.
1726
1727 =item S + $recipients_undel
1728
1729 The list of undelivered envelope recipients for a message.  This non-standard variable is in the same format as $recipients and contains the list of undelivered recipients.  See also $each_recipients_undel.
1730
1731 =item N + $recipients_undel_count
1732
1733 The number of envelope recipients for the message which have not yet been delivered.
1734
1735 =item S . $reply_address
1736
1737 The contents of the Reply-To: header line if one exists and it is not empty, or otherwise the contents of the From: header line.
1738
1739 =item S . $rheader_*, $rh_*
1740
1741 The value of the message's header(s) with the same name.  See section 11.5 of Exim's spec.txt for full description.
1742
1743 =item S . $sender_address
1744
1745 The sender's address that was received in the message's envelope.  For bounce messages, the value of this variable is the empty string.
1746
1747 =item S . $sender_address_domain
1748
1749 The domain part of $sender_address.
1750
1751 =item S . $sender_address_local_part
1752
1753 The local part of $sender_address.
1754
1755 =item S . $sender_helo_name
1756
1757 The HELO or EHLO value supplied for smtp or bsmtp messages.
1758
1759 =item S . $sender_host_address
1760
1761 The remote host's IP address.
1762
1763 =item S . $sender_host_authenticated
1764
1765 The name of the authenticator driver which successfully authenticated the client from which the message was received.
1766
1767 =item S . $sender_host_name
1768
1769 The remote host's name as obtained by looking up its IP address.
1770
1771 =item N . $sender_host_port
1772
1773 The port number that was used on the remote host for network-originated messages.
1774
1775 =item S . $sender_ident
1776
1777 The identification received in response to an RFC 1413 request for remote messages, the login name of the user that called Exim for locally generated messages.
1778
1779 =item B + $sender_local
1780
1781 TRUE if the message was locally generated.
1782
1783 =item B + $sender_set_untrusted
1784
1785 TRUE if the envelope sender of this message was set by an untrusted local caller.
1786
1787 =item S + $shown_message_size
1788
1789 This non-standard variable contains the formatted size string.  That is, for a message whose $message_size is 66566 bytes, $shown_message_size is 65K.
1790
1791 =item S . $smtp_active_hostname
1792
1793 The value of the active host name when the message was received, as specified by the "smtp_active_hostname" option.
1794
1795 =item S . $spam_score
1796
1797 The spam score of the message, for example '3.4' or '30.5'.  (Requires exiscan or WITH_CONTENT_SCAN)
1798
1799 =item S . $spam_score_int
1800
1801 The spam score of the message, multiplied by ten, as an integer value.  For instance '34' or '305'.  (Requires exiscan or WITH_CONTENT_SCAN)
1802
1803 =item B . $tls_certificate_verified
1804
1805 TRUE if a TLS certificate was verified when the message was received.
1806
1807 =item S . $tls_cipher
1808
1809 The cipher suite that was negotiated for encrypted SMTP connections.
1810
1811 =item S . $tls_peerdn
1812
1813 The value of the Distinguished Name of the certificate if Exim is configured to request one
1814
1815 =item S . $tls_sni
1816
1817 The value of the Server Name Indication TLS extension sent by a client, if one was sent.
1818
1819 =item N + $warning_count
1820
1821 The number of delay warnings which have been sent for this message.
1822
1823 =back
1824
1825 =head1 CONTACT
1826
1827 =over 4
1828
1829 =item EMAIL: proj-exipick@jetmore.net
1830
1831 =item HOME: jetmore.org/john/code/#exipick
1832
1833 =back
1834
1835 =cut