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