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