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