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