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