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