src/exipick.src

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