9826aaffdbdcab9e97a1e356cb09c05e7fd08380
[exim.git] / src / src / exipick.src
1 #!PERL_COMMAND
2 # $Cambridge: exim/src/src/exipick.src,v 1.10 2006/03/07 20:58:55 jetmore Exp $
3
4 # This variable should be set by the building process to Exim's spool directory.
5 my $spool = 'SPOOL_DIRECTORY';
6
7 use strict;
8 use Getopt::Long;
9
10 my($p_name)   = $0 =~ m|/?([^/]+)$|;
11 my $p_version = "20060307.0";
12 my $p_usage   = "Usage: $p_name [--help|--version] (see --help for details)";
13 my $p_cp      = <<EOM;
14         Copyright (c) 2003-2006 John Jetmore <jj33\@pobox.com>
15
16     This program is free software; you can redistribute it and/or modify
17     it under the terms of the GNU General Public License as published by
18     the Free Software Foundation; either version 2 of the License, or
19     (at your option) any later version.
20
21     This program is distributed in the hope that it will be useful,
22     but WITHOUT ANY WARRANTY; without even the implied warranty of
23     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24     GNU General Public License for more details.
25
26     You should have received a copy of the GNU General Public License
27     along with this program; if not, write to the Free Software
28     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
29 EOM
30 ext_usage(); # before we do anything else, check for --help
31
32 $| = 1; # unbuffer STDOUT
33
34 Getopt::Long::Configure("bundling_override");
35 GetOptions(
36   'spool:s'     => \$G::spool,      # exim spool dir
37   'bp'          => \$G::mailq_bp,   # List the queue (noop - default)
38   'bpa'         => \$G::mailq_bpa,  # ... with generated address as well
39   'bpc'         => \$G::mailq_bpc,  # ... but just show a count of messages
40   'bpr'         => \$G::mailq_bpr,  # ... do not sort
41   'bpra'        => \$G::mailq_bpra, # ... with generated addresses, unsorted
42   'bpru'        => \$G::mailq_bpru, # ... only undelivered addresses, unsorted
43   'bpu'         => \$G::mailq_bpu,  # ... only undelivered addresses
44   'and'         => \$G::and,        # 'and' the criteria (default)
45   'or'          => \$G::or,         # 'or' the criteria
46   'f:s'         => \$G::qgrep_f,    # from regexp
47   'r:s'         => \$G::qgrep_r,    # recipient regexp
48   's:s'         => \$G::qgrep_s,    # match against size field
49   'y:s'         => \$G::qgrep_y,    # message younger than (secs)
50   'o:s'         => \$G::qgrep_o,    # message older than (secs)
51   'z'           => \$G::qgrep_z,    # frozen only
52   'x'           => \$G::qgrep_x,    # non-frozen only
53   'c'           => \$G::qgrep_c,    # display match count
54   'l'           => \$G::qgrep_l,    # long format (default)
55   'i'           => \$G::qgrep_i,    # message ids only
56   'b'           => \$G::qgrep_b,    # brief format
57   'freeze:s'    => \$G::freeze,     # freeze data in this file
58   'thaw:s'      => \$G::thaw,       # thaw data from this file
59   'unsorted'    => \$G::unsorted,   # unsorted, regardless of output format
60   'flatq'       => \$G::flatq,      # brief format
61   'caseful'     => \$G::caseful,    # in '=' criteria, respect case
62   'caseless'    => \$G::caseless,   #   ...ignore case (default)
63   'show-vars:s' => \$G::show_vars,  # display the contents of these vars
64   'show-rules'  => \$G::show_rules, # display compiled match rules
65   'show-tests'  => \$G::show_tests  # display tests as applied to each message
66 ) || exit(1);
67
68 # if both freeze and thaw specified, only thaw as it is less desctructive
69 $G::freeze = undef               if ($G::freeze && $G::thaw);
70 freeze_start()                   if ($G::freeze);
71 thaw_start()                     if ($G::thaw);
72
73 push(@ARGV, "\$sender_address     =~ /$G::qgrep_f/") if ($G::qgrep_f);
74 push(@ARGV, "\$recipients         =~ /$G::qgrep_r/") if ($G::qgrep_r);
75 push(@ARGV, "\$shown_message_size eq $G::qgrep_s")   if ($G::qgrep_s);
76 push(@ARGV, "\$message_age        <  $G::qgrep_y")   if ($G::qgrep_y);
77 push(@ARGV, "\$message_age        >  $G::qgrep_o")   if ($G::qgrep_o);
78 push(@ARGV, "\$deliver_freeze")                      if ($G::qgrep_z);
79 push(@ARGV, "!\$deliver_freeze")                     if ($G::qgrep_x);
80 $G::mailq_bp        = $G::mailq_bp;        # shut up -w
81 $G::and             = $G::and;             # shut up -w
82 $G::msg_ids         = {};                  # short circuit when crit is only MID
83 $G::caseless        = $G::caseful ? 0 : 1; # nocase by default, case if both
84 @G::recipients_crit = ();                  # holds per-recip criteria
85 $spool              = $G::spool if ($G::spool);
86 my $count_only      = 1 if ($G::mailq_bpc  || $G::qgrep_c);
87 my $unsorted        = 1 if ($G::mailq_bpr  || $G::mailq_bpra ||
88                             $G::mailq_bpru || $G::unsorted);
89 my $msg             = $G::thaw ? thaw_message_list()
90                                : get_all_msgs($spool,$unsorted);
91 die "Problem accessing thaw file\n" if ($G::thaw && !$msg);
92 my $crit            = process_criteria(\@ARGV);
93 my $e               = Exim::SpoolFile->new();
94 my $tcount          = 0 if ($count_only);  # holds count of all messages
95 my $mcount          = 0 if ($count_only);  # holds count of matching messages
96 $e->set_undelivered_only(1)      if ($G::mailq_bpru || $G::mailq_bpu);
97 $e->set_show_generated(1)        if ($G::mailq_bpra || $G::mailq_bpa);
98 $e->output_long()                if ($G::qgrep_l);
99 $e->output_idonly()              if ($G::qgrep_i);
100 $e->output_brief()               if ($G::qgrep_b);
101 $e->output_flatq()               if ($G::flatq);
102 $e->set_show_vars($G::show_vars) if ($G::show_vars);
103 $e->set_spool($spool);
104
105
106 MSG:
107 foreach my $m (@$msg) {
108   next if (scalar(keys(%$G::msg_ids)) && !$G::or
109                                       && !$G::msg_ids->{$m->{message}});
110   if ($G::thaw) {
111     my $data = thaw_data();
112     if (!$e->restore_state($data)) {
113       warn "Couldn't thaw $data->{_message}: ".$e->error()."\n";
114       next MSG;
115     }
116   } else {
117     if (!$e->parse_message($m->{message}, $m->{path})) {
118       warn "Couldn't parse $m->{message}: ".$e->error()."\n";
119       next MSG;
120     }
121   }
122   $tcount++;
123   my $match = 0;
124   my @local_crit = ();
125   foreach my $c (@G::recipients_crit) {              # handle each_recip* vars
126     foreach my $addr (split(/, /, $e->get_var($c->{var}))) {
127       my %t = ( 'cmp' => $c->{cmp}, 'var' => $c->{var} );
128       $t{cmp} =~ s/"?\$var"?/'$addr'/;
129       push(@local_crit, \%t);
130     }
131   }
132   if ($G::show_tests) { print $e->get_var('message_exim_id'), "\n"; }
133   CRITERIA:
134   foreach my $c (@$crit, @local_crit) {
135     my $var = $e->get_var($c->{var});
136     my $ret = eval($c->{cmp});
137     if ($G::show_tests) {
138       printf "  %25s =  '%s'\n  %25s => $ret\n",$c->{var},$var,$c->{cmp},$ret;
139     }
140     if ($@) {
141       print STDERR "Error in eval '$c->{cmp}': $@\n";
142       next MSG;
143     } elsif ($ret) {
144       $match = 1;
145       if ($G::or) { last CRITERIA; }
146       else        { next CRITERIA; }
147     } else { # no match
148       if ($G::or) { next CRITERIA; }
149       else        { next MSG;      }
150     }
151   }
152
153   # skip this message if any criteria were supplied and it didn't match
154   next MSG if ((scalar(@$crit) || scalar(@local_crit)) && !$match);
155
156   if ($count_only) {
157     $mcount++;
158   } else {
159     $e->print_message(\*STDOUT);
160   }
161
162   if ($G::freeze) {
163     freeze_data($e->get_state());
164     push(@G::frozen_msgs, $m);
165   }
166 }
167
168 if ($G::mailq_bpc) {
169   print "$mcount\n";
170 } elsif ($G::qgrep_c) {
171   print "$mcount matches out of $tcount messages\n";
172 }
173
174 if ($G::freeze) {
175   freeze_message_list(\@G::frozen_msgs);
176   freeze_end();
177 } elsif ($G::thaw) {
178   thaw_end();
179 }
180
181 exit;
182
183 # FREEZE FILE FORMAT:
184 # message_data_bytes
185 # message_data
186 # <...>
187 # EOM
188 # message_list
189 # message_list_bytes <- 10 bytes, zero-packed, plus \n
190
191 sub freeze_start {
192   eval("use Storable");
193   die "Storable module not found: $@\n" if ($@);
194   open(O, ">$G::freeze") || die "Can't open freeze file $G::freeze: $!\n";
195   $G::freeze_handle = \*O;
196 }
197
198 sub freeze_end {
199   close($G::freeze_handle);
200 }
201
202 sub thaw_start {
203   eval("use Storable");
204   die "Storable module not found: $@\n" if ($@);
205   open(I, "<$G::thaw") || die "Can't open freeze file $G::thaw: $!\n";
206   $G::freeze_handle = \*I;
207 }
208
209 sub thaw_end {
210   close($G::freeze_handle);
211 }
212
213 sub freeze_data {
214   my $h = Storable::freeze($_[0]);
215   print $G::freeze_handle length($h)+1, "\n$h\n";
216 }
217
218 sub freeze_message_list {
219   my $h = Storable::freeze($_[0]);
220   my $l = length($h) + 1;
221   printf $G::freeze_handle "EOM\n$l\n$h\n%010d\n", $l+11+length($l)+1;
222 }
223
224 sub thaw_message_list {
225   my $orig_pos = tell($G::freeze_handle);
226   seek($G::freeze_handle, -11, 2);
227   chomp(my $bytes = <$G::freeze_handle>);
228   seek($G::freeze_handle, $bytes * -1, 2);
229   my $obj = thaw_data();
230   seek($G::freeze_handle, 0, $orig_pos);
231   return($obj);
232 }
233
234 sub thaw_data {
235   my $obj;
236   chomp(my $bytes = <$G::freeze_handle>);
237   return(undef) if (!$bytes || $bytes eq 'EOM');
238   my $read = read(I, $obj, $bytes);
239   die "Format error in thaw file (expected $bytes bytes, got $read)\n"
240       if ($bytes != $read);
241   chomp($obj);
242   return(Storable::thaw($obj));
243 }
244
245 sub process_criteria {
246   my $a = shift;
247   my @c = ();
248   my $e = 0;
249
250   foreach (@$a) {
251     foreach my $t ('@') { s/$t/\\$t/g; } # '$'
252     if (/^(.*?)\s+(<=|>=|==|!=|<|>)\s+(.*)$/) {
253       #print STDERR "found as integer\n";
254       my $v = $1; my $o = $2; my $n = $3;
255       if    ($n =~ /^([\d\.]+)M$/)  { $n = $1 * 1024 * 1024; }
256       elsif ($n =~ /^([\d\.]+)K$/)  { $n = $1 * 1024; }
257       elsif ($n =~ /^([\d\.]+)B?$/) { $n = $1; }
258       elsif ($n =~ /^([\d\.]+)d$/)  { $n = $1 * 60 * 60 * 24; }
259       elsif ($n =~ /^([\d\.]+)h$/)  { $n = $1 * 60 * 60; }
260       elsif ($n =~ /^([\d\.]+)m$/)  { $n = $1 * 60; }
261       elsif ($n =~ /^([\d\.]+)s?$/) { $n = $1; }
262       else {
263         print STDERR "Expression $_ did not parse: numeric comparison with ",
264                      "non-number\n";
265         $e = 1;
266         next;
267       }
268       #push(@c, { var => lc($v), cmp => "(\$var $o $n) ? 1 : 0" });
269       push(@c, { var => lc($v), cmp => "(\$var $o $n)" });
270     } elsif (/^(.*?)\s+(=~|!~)\s+(.*)$/) {
271       #print STDERR "found as string regexp\n";
272       push(@c, { var => lc($1), cmp => "(\"\$var\" $2 $3)" });
273     } elsif (/^(.*?)\s+=\s+(.*)$/) {
274       #print STDERR "found as bare string regexp\n";
275       my $case = $G::caseful ? '' : 'i';
276       push(@c, { var => lc($1), cmp => "(\"\$var\" =~ /$2/$case)" });
277     } elsif (/^(.*?)\s+(eq|ne)\s+(.*)$/) {
278       #print STDERR "found as string cmp\n";
279       my $var = lc($1); my $op = $2; my $val = $3;
280       $val =~ s|^(['"])(.*)\1$|$2|;
281       push(@c, { var => $var, cmp => "(\"\$var\" $op \"$val\")" });
282       if (($var eq 'message_id' || $var eq 'message_exim_id') && $op eq "eq") {
283         #print STDERR "short circuit @c[-1]->{cmp} $val\n";
284         $G::msg_ids->{$val} = 1;
285       }
286     } elsif (/^(\S+)$/) {
287       #print STDERR "found as boolean\n";
288       push(@c, { var => lc($1), cmp => "(\$var)" });
289     } else {
290       print STDERR "Expression $_ did not parse\n";
291       $e = 1;
292     }
293     # assign the results of the cmp test here (handle "!" negation)
294     if ($c[-1]{var} =~ s|^!||) {
295       $c[-1]{cmp} .= " ? 0 : 1";
296     } else {
297       $c[-1]{cmp} .= " ? 1 : 0";
298     }
299     # support the each_* psuedo variables.  Steal the criteria off of the
300     # queue for special processing later
301     if ($c[-1]{var} =~ /^each_(recipients(_(un)?del)?)$/) {
302       my $var = $1;
303       push(@G::recipients_crit,pop(@c));
304       $G::recipients_crit[-1]{var} = $var; # remove each_ from the variable
305     }
306   }
307
308   exit(1) if ($e);
309
310   if ($G::show_rules) { foreach (@c) { print "$_->{var}\t$_->{cmp}\n"; } }
311
312   return(\@c);
313 }
314
315 sub get_all_msgs {
316   my $d = shift() . '/input';
317   my $u = shift;
318   my @m = ();
319
320   opendir(D, "$d") || die "Couldn't opendir $d: $!\n";
321   foreach my $e (grep !/^\./, readdir(D)) {
322     if ($e =~ /^[a-zA-Z0-9]$/) {
323       opendir(DD, "$d/$e") || next;
324       foreach my $f (grep !/^\./, readdir(DD)) {
325         push(@m, { message => $1, path => "$d/$e" }) if ($f =~ /^(.{16})-H$/);
326       }
327       closedir(DD);
328     } elsif ($e =~ /^(.{16})-H$/) {
329       push(@m, { message => $1, path => $d });
330     }
331   }
332   closedir(D);
333
334   return($u ? \@m : [ sort { $a->{message} cmp $b->{message} } @m ]);
335 }
336
337 BEGIN {
338
339 package Exim::SpoolFile;
340
341 # versions 4.61 and higher will not need these variables anymore, but they
342 # are left for handling legacy installs
343 $Exim::SpoolFile::ACL_C_MAX_LEGACY = 10;
344 #$Exim::SpoolFile::ACL_M_MAX _LEGACY= 10;
345
346 sub new {
347   my $class = shift;
348   my $self  = {};
349   bless($self, $class);
350
351   $self->{_spool_dir}        = '';
352   $self->{_undelivered_only} = 0;
353   $self->{_show_generated}   = 0;
354   $self->{_output_long}      = 1;
355   $self->{_output_idonly}    = 0;
356   $self->{_output_brief}     = 0;
357   $self->{_output_flatq}     = 0;
358   $self->{_show_vars}        = [];
359
360   $self->_reset();
361   return($self);
362 }
363
364 sub output_long {
365   my $self = shift;
366
367   $self->{_output_long}      = 1;
368   $self->{_output_idonly}    = 0;
369   $self->{_output_brief}     = 0;
370   $self->{_output_flatq}     = 0;
371 }
372
373 sub output_idonly {
374   my $self = shift;
375
376   $self->{_output_long}      = 0;
377   $self->{_output_idonly}    = 1;
378   $self->{_output_brief}     = 0;
379   $self->{_output_flatq}     = 0;
380 }
381
382 sub output_brief {
383   my $self = shift;
384
385   $self->{_output_long}      = 0;
386   $self->{_output_idonly}    = 0;
387   $self->{_output_brief}     = 1;
388   $self->{_output_flatq}     = 0;
389 }
390
391 sub output_flatq {
392   my $self = shift;
393
394   $self->{_output_long}      = 0;
395   $self->{_output_idonly}    = 0;
396   $self->{_output_brief}     = 0;
397   $self->{_output_flatq}     = 1;
398 }
399
400 sub set_show_vars {
401   my $self = shift;
402   my $s    = shift;
403
404   foreach my $v (split(/\s*,\s*/, $s)) {
405     push(@{$self->{_show_vars}}, $v);
406   }
407 }
408
409 sub set_show_generated {
410   my $self = shift;
411   $self->{_show_generated} = shift;
412 }
413
414 sub set_undelivered_only {
415   my $self = shift;
416   $self->{_undelivered_only} = shift;
417 }
418
419 sub error {
420   my $self = shift;
421   return $self->{_error};
422 }
423
424 sub _error {
425   my $self = shift;
426   $self->{_error} = shift;
427   return(undef);
428 }
429
430 sub _reset {
431   my $self = shift;
432
433   $self->{_error}       = '';
434   $self->{_delivered}   = 0;
435   $self->{_message}     = '';
436   $self->{_path}        = '';
437   $self->{_vars}        = {};
438
439   $self->{_numrecips}   = 0;
440   $self->{_udel_tree}   = {};
441   $self->{_del_tree}    = {};
442   $self->{_recips}      = {};
443
444   return($self);
445 }
446
447 sub parse_message {
448   my $self = shift;
449
450   $self->_reset();
451   $self->{_message} = shift || return(0);
452   $self->{_path}    = shift; # optional path to message
453   return(0) if (!$self->{_spool_dir});
454   if (!$self->{_path} && !$self->_find_path()) {
455     # assume the message was delivered from under us and ignore
456     $self->{_delivered} = 1;
457     return(1);
458   }
459   $self->_parse_header() || return(0);
460
461   return(1);
462 }
463
464 # take the output of get_state() and set up a message internally like
465 # parse_message (except from a saved data struct, not by parsing the
466 # files on disk).
467 sub restore_state {
468   my $self = shift;
469   my $h    = shift;
470
471   return(1) if ($h->{_delivered});
472   $self->_reset();
473   $self->{_message} = $h->{_message} || return(0);
474   return(0) if (!$self->{_spool_dir});
475
476   $self->{_path}      = $h->{_path};
477   $self->{_vars}      = $h->{_vars};
478   $self->{_numrecips} = $h->{_numrecips};
479   $self->{_udel_tree} = $h->{_udel_tree};
480   $self->{_del_tree}  = $h->{_del_tree};
481   $self->{_recips}    = $h->{_recips};
482
483   $self->{_vars}{message_age} = time() - $self->{_vars}{received_time};
484   return(1);
485 }
486
487 # This returns the state data for a specific message in a format that can
488 # be later frozen back in to regain state
489 #
490 # after calling this function, this specific state is not expect to be
491 # reused.  That's because we're returning direct references to specific
492 # internal structures.  We're also modifying the structure ourselves
493 # by deleting certain internal message variables.
494 sub get_state {
495   my $self = shift;
496   my $h    = {};    # this is the hash ref we'll be returning.
497
498   $h->{_delivered} = $self->{_delivered};
499   $h->{_message}   = $self->{_message};
500   $h->{_path}      = $self->{_path};
501   $h->{_vars}      = $self->{_vars};
502   $h->{_numrecips} = $self->{_numrecips};
503   $h->{_udel_tree} = $self->{_udel_tree};
504   $h->{_del_tree}  = $self->{_del_tree};
505   $h->{_recips}    = $self->{_recips};
506
507   # delete some internal variables that we will rebuild later if needed
508   delete($h->{_vars}{message_body});
509   delete($h->{_vars}{message_age});
510
511   return($h);
512 }
513
514 # keep this sub as a feature if we ever break this module out, but do away
515 # with its use in exipick (pass it in from caller instead)
516 sub _find_path {
517   my $self = shift;
518
519   return(0) if (!$self->{_message});
520   return(0) if (!$self->{_spool_dir});
521
522   # test split spool first on the theory that people concerned about
523   # performance will have split spool set =).
524   foreach my $f (substr($self->{_message}, 5, 1).'/', '') {
525     if (-f "$self->{_spool_dir}/input/$f$self->{_message}-H") {
526       $self->{_path} = $self->{_spool_dir} . "/input/$f";
527       return(1);
528     }
529   }
530   return(0);
531 }
532
533 sub set_spool {
534   my $self = shift;
535   $self->{_spool_dir} = shift;
536 }
537
538 # accepts a variable with or without leading '$' or trailing ':'
539 sub get_var {
540   my $self = shift;
541   my $var  = lc(shift);
542
543   $var =~ s/^\$//;
544   $var =~ s/:$//;
545
546   $self->_parse_body()
547       if ($var eq 'message_body' && !$self->{_vars}{message_body});
548
549   chomp($self->{_vars}{$var});
550   return $self->{_vars}{$var};
551 }
552
553 sub _parse_body {
554   my $self = shift;
555   my $f    = $self->{_path} . '/' . $self->{_message} . '-D';
556
557   open(I, "<$f") || return($self->_error("Couldn't open $f: $!"));
558   chomp($_ = <I>);
559   return(0) if ($self->{_message}.'-D' ne $_);
560
561   $self->{_vars}{message_body} = join('', <I>);
562   close(I);
563   $self->{_vars}{message_body} =~ s/\n/ /g;
564   $self->{_vars}{message_body} =~ s/\000/ /g;
565 print "returning (1)\n";
566   return(1);
567 }
568
569 sub _parse_header {
570   my $self = shift;
571   my $f    = $self->{_path} . '/' . $self->{_message} . '-H';
572
573   if (!open(I, "<$f")) {
574     # assume message went away and silently ignore
575     $self->{_delivered} = 1;
576     return(1);
577   }
578
579   chomp($_ = <I>);
580   return(0) if ($self->{_message}.'-H' ne $_);
581   $self->{_vars}{message_id}       = $self->{_message};
582   $self->{_vars}{message_exim_id}  = $self->{_message};
583
584   # line 2
585   chomp($_ = <I>);
586   return(0) if (!/^(.+)\s(\-?\d+)\s(\-?\d+)$/);
587   $self->{_vars}{originator_login} = $1;
588   $self->{_vars}{originator_uid}   = $2;
589   $self->{_vars}{originator_gid}   = $3;
590
591   # line 3
592   chomp($_ = <I>);
593   return(0) if (!/^<(.*)>$/);
594   $self->{_vars}{sender_address}   = $1;
595   $self->{_vars}{sender_address_domain} = $1;
596   $self->{_vars}{sender_address_local_part} = $1;
597   $self->{_vars}{sender_address_domain} =~ s/^.*\@//;
598   $self->{_vars}{sender_address_local_part} =~ s/^(.*)\@.*$/$1/;
599
600   # line 4
601   chomp($_ = <I>);
602   return(0) if (!/^(\d+)\s(\d+)$/);
603   $self->{_vars}{received_time}    = $1;
604   $self->{_vars}{warning_count}    = $2;
605   $self->{_vars}{message_age}      = time() - $self->{_vars}{received_time};
606
607   while (<I>) {
608     chomp();
609     if (/^(-\S+)\s*(.*$)/) {
610       my $tag = $1;
611       my $arg = $2;
612       if ($tag eq '-acl') {
613         my $t;
614         return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
615         if ($1 < $Exim::SpoolFile::ACL_C_MAX_LEGACY) {
616           $t = "acl_c$1";
617         } else {
618           $t = "acl_m" . ($1 - $Exim::SpoolFile::ACL_C_MAX_LEGACY);
619         }
620         read(I, $self->{_vars}{$t}, $2+1) || return(0);
621         chomp($self->{_vars}{$t});
622       } elsif ($tag eq '-aclc') {
623         return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
624         my $t = "acl_c$1";
625         read(I, $self->{_vars}{$t}, $2+1) || return(0);
626         chomp($self->{_vars}{$t});
627       } elsif ($tag eq '-aclm') {
628         return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
629         my $t = "acl_m$1";
630         read(I, $self->{_vars}{$t}, $2+1) || return(0);
631         chomp($self->{_vars}{$t});
632       } elsif ($tag eq '-local') {
633         $self->{_vars}{sender_local} = 1;
634       } elsif ($tag eq '-localerror') {
635         $self->{_vars}{local_error_message} = 1;
636       } elsif ($tag eq '-local_scan') {
637         $self->{_vars}{local_scan_data} = $arg;
638       } elsif ($tag eq '-spam_score_int') {
639         $self->{_vars}{spam_score_int} = $arg;
640         $self->{_vars}{spam_score}     = $arg / 10;
641       } elsif ($tag eq '-bmi_verdicts') {
642         $self->{_vars}{bmi_verdicts} = $arg;
643       } elsif ($tag eq '-host_lookup_deferred') {
644         $self->{_vars}{host_lookup_deferred} = 1;
645       } elsif ($tag eq '-host_lookup_failed') {
646         $self->{_vars}{host_lookup_failed} = 1;
647       } elsif ($tag eq '-body_linecount') {
648         $self->{_vars}{body_linecount} = $arg;
649       } elsif ($tag eq '-body_zerocount') {
650         $self->{_vars}{body_zerocount} = $arg;
651       } elsif ($tag eq '-frozen') {
652         $self->{_vars}{deliver_freeze} = 1;
653         $self->{_vars}{deliver_frozen_at} = $arg;
654       } elsif ($tag eq '-allow_unqualified_recipient') {
655         $self->{_vars}{allow_unqualified_recipient} = 1;
656       } elsif ($tag eq '-allow_unqualified_sender') {
657         $self->{_vars}{allow_unqualified_sender} = 1;
658       } elsif ($tag eq '-deliver_firsttime') {
659         $self->{_vars}{deliver_firsttime} = 1;
660         $self->{_vars}{first_delivery} = 1;
661       } elsif ($tag eq '-manual_thaw') {
662         $self->{_vars}{deliver_manual_thaw} = 1;
663         $self->{_vars}{manually_thawed} = 1;
664       } elsif ($tag eq '-auth_id') {
665         $self->{_vars}{authenticated_id} = $arg;
666       } elsif ($tag eq '-auth_sender') {
667         $self->{_vars}{authenticated_sender} = $arg;
668       } elsif ($tag eq '-sender_set_untrusted') {
669         $self->{_vars}{sender_set_untrusted} = 1;
670       } elsif ($tag eq '-tls_certificate_verified') {
671         $self->{_vars}{tls_certificate_verified} = 1;
672       } elsif ($tag eq '-tls_cipher') {
673         $self->{_vars}{tls_cipher} = $arg;
674       } elsif ($tag eq '-tls_peerdn') {
675         $self->{_vars}{tls_peerdn} = $arg;
676       } elsif ($tag eq '-host_address') {
677         $self->{_vars}{sender_host_port} = $self->_get_host_and_port(\$arg);
678         $self->{_vars}{sender_host_address} = $arg;
679       } elsif ($tag eq '-interface_address') {
680         $self->{_vars}{interface_port} = $self->_get_host_and_port(\$arg);
681         $self->{_vars}{interface_address} = $arg;
682       } elsif ($tag eq '-active_hostname') {
683         $self->{_vars}{smtp_active_hostname} = $arg;
684       } elsif ($tag eq '-host_auth') {
685         $self->{_vars}{sender_host_authenticated} = $arg;
686       } elsif ($tag eq '-host_name') {
687         $self->{_vars}{sender_host_name} = $arg;
688       } elsif ($tag eq '-helo_name') {
689         $self->{_vars}{sender_helo_name} = $arg;
690       } elsif ($tag eq '-ident') {
691         $self->{_vars}{sender_ident} = $arg;
692       } elsif ($tag eq '-received_protocol') {
693         $self->{_vars}{received_protocol} = $arg;
694       } elsif ($tag eq '-N') {
695         $self->{_vars}{dont_deliver} = 1;
696       } else {
697         # unrecognized tag, save it for reference
698         $self->{$tag} = $arg;
699       }
700     } else {
701       last;
702     }
703   }
704
705   # when we drop out of the while loop, we have the first line of the
706   # delivered tree in $_
707   do {
708     if ($_ eq 'XX') {
709       ; # noop
710     } elsif ($_ =~ s/^[YN][YN]\s+//) {
711       $self->{_del_tree}{$_} = 1;
712     } else {
713       return(0);
714     }
715     chomp($_ = <I>);
716   } while ($_ !~ /^\d+$/);
717
718   $self->{_numrecips} = $_;
719   $self->{_vars}{recipients_count} = $self->{_numrecips};
720   for (my $i = 0; $i < $self->{_numrecips}; $i++) {
721     chomp($_ = <I>);
722     return(0) if (/^$/);
723     my $addr = '';
724     if (/^(.*)\s\d+,(\d+),\d+$/) {
725       #print STDERR "exim3 type (untested): $_\n";
726       $self->{_recips}{$1} = { pno => $2 };
727       $addr = $1;
728     } elsif (/^(.*)\s(\d+)$/) {
729       #print STDERR "exim4 original type (untested): $_\n";
730       $self->{_recips}{$1} = { pno => $2 };
731       $addr = $1;
732     } elsif (/^(.*)\s(.*)\s(\d+),(\d+)#1$/) {
733       #print STDERR "exim4 new type #1 (untested): $_\n";
734       return($self->_error("incorrect format: $_")) if (length($2) != $3);
735       $self->{_recips}{$1} = { pno => $4, errors_to => $2 };
736       $addr = $1;
737     } elsif (/^.*#(\d+)$/) {
738       #print STDERR "exim4 #$1 style (unimplemented): $_\n";
739       $self->_error("exim4 #$1 style (unimplemented): $_");
740     } else {
741       #print STDERR "default type: $_\n";
742       $self->{_recips}{$_} = {};
743       $addr = $_;
744     }
745     $self->{_udel_tree}{$addr} = 1 if (!$self->{_del_tree}{$addr});
746   }
747   $self->{_vars}{recipients}         = join(', ', keys(%{$self->{_recips}}));
748   $self->{_vars}{recipients_del}     = join(', ', keys(%{$self->{_del_tree}}));
749   $self->{_vars}{recipients_undel}   = join(', ', keys(%{$self->{_udel_tree}}));
750   $self->{_vars}{recipients_undel_count} = scalar(keys(%{$self->{_udel_tree}}));
751   $self->{_vars}{recipients_del_count}   = 0;
752   foreach my $r (keys %{$self->{_del_tree}}) {
753     next if (!$self->{_recips}{$r});
754     $self->{_vars}{recipients_del_count}++;
755   }
756
757   # blank line
758   $_ = <I>;
759   return(0) if (!/^$/);
760
761   # start reading headers
762   while (read(I, $_, 3) == 3) {
763     my $t = getc(I);
764     return(0) if (!length($t));
765     while ($t =~ /^\d$/) {
766       $_ .= $t;
767       $t  = getc(I);
768     }
769     # ok, right here $t contains the header flag and $_ contains the number of
770     # bytes to read.  If we ever use the header flag, grab it here.
771     $self->{_vars}{message_size} += $_ if ($t ne '*');
772     $t = getc(I); # strip the space out of the file
773     my $bytes = $_;
774     return(0) if (read(I, $_, $bytes) != $bytes);
775     $self->{_vars}{message_linecount} += (tr/\n//) if ($t ne '*');
776
777     # build the $header_ variable, following exim's rules (sort of)
778     my($v,$d) = split(/:/, $_, 2);
779     $v = "header_" . lc($v);
780     $d =~ s/^\s+//;
781     $d =~ s/\s+$//;
782     $self->{_vars}{$v} .= "$d\n";
783     $self->{_vars}{received_count}++ if ($v eq 'header_received');
784     # push header onto $message_headers var, following exim's rules
785     $self->{_vars}{message_headers} .= $_;
786   }
787   close(I);
788   # remove trailing newline from $message_headers
789   chomp($self->{_vars}{message_headers});
790
791   if (length($self->{_vars}{"header_reply-to"}) > 0) {
792     $self->{_vars}{reply_address} = $self->{_vars}{"header_reply-to"};
793   } else {
794     $self->{_vars}{reply_address} = $self->{_vars}{header_from};
795   }
796
797   $self->{_vars}{message_body_size} =
798       (stat($self->{_path}.'/'.$self->{_message}.'-D'))[7] - 19;
799   if ($self->{_vars}{message_body_size} < 0) {
800     $self->{_vars}{message_size} = 0;
801   } else {
802     $self->{_vars}{message_size} += $self->{_vars}{message_body_size} + 1;
803   }
804
805   $self->{_vars}{message_linecount} += $self->{_vars}{body_linecount};
806
807   my $i = $self->{_vars}{message_size};
808   if ($i == 0)          { $i = ""; }
809   elsif ($i < 1024)     { $i = sprintf("%d",    $i);                    }
810   elsif ($i < 10240)    { $i = sprintf("%.1fK", $i / 1024);             }
811   elsif ($i < 1048576)  { $i = sprintf("%dK",   ($i+512)/1024);         }
812   elsif ($i < 10485760) { $i = sprintf("%.1fM", $i/1048576);            }
813   else                  { $i = sprintf("%dM",   ($i + 524288)/1048576); }
814   $self->{_vars}{shown_message_size} = $i;
815
816   return(1);
817 }
818
819 # mimic exim's host_extract_port function - receive a ref to a scalar,
820 # strip it of port, return port
821 sub _get_host_and_port {
822   my $self = shift;
823   my $host = shift; # scalar ref, be careful
824
825   if ($$host =~ /^\[([^\]]+)\](?:\:(\d+))?$/) {
826     $$host = $1;
827     return($2 || 0);
828   } elsif ($$host =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})(?:\.(\d+))?$/) {
829     $$host = $1;
830     return($2 || 0);
831   } elsif ($$host =~ /^([\d\:]+)(?:\.(\d+))?$/) {
832     $$host = $1;
833     return($2 || 0);
834   }
835   # implicit else
836   return(0);
837 }
838
839 sub print_message {
840   my $self = shift;
841   my $fh   = shift || \*STDOUT;
842   return if ($self->{_delivered});
843
844   if ($self->{_output_idonly}) {
845     print $fh $self->{_message};
846     foreach my $v (@{$self->{_show_vars}}) {
847       print $fh " $v='", $self->get_var($v), "'";
848     }
849     print $fh "\n";
850     return;
851   }
852
853   if ($self->{_output_long} || $self->{_output_flatq}) {
854     my $i = int($self->{_vars}{message_age} / 60);
855     if ($i > 90) {
856       $i = int(($i+30)/60);
857       if ($i > 72) { printf $fh "%2dd ", int(($i+12)/24); }
858       else { printf $fh "%2dh ", $i; }
859     } else { printf $fh "%2dm ", $i; }
860
861     if ($self->{_output_flatq} && $self->{_show_vars}) {
862         print $fh join(';',
863                        map { "$_='".$self->get_var($_)."'" }
864                            (@{$self->{_show_vars}})
865                       );
866     } else {
867       printf $fh "%5s", $self->{_vars}{shown_message_size};
868     }
869     print $fh " ";
870   }
871   print $fh "$self->{_message} ";
872   print $fh "From: " if ($self->{_output_brief});
873   print $fh "<$self->{_vars}{sender_address}>";
874
875   if ($self->{_output_long}) {
876     print $fh " ($self->{_vars}{originator_login})"
877         if ($self->{_vars}{sender_set_untrusted});
878
879     # XXX exim contains code here to print spool format errors
880     print $fh " *** frozen ***" if ($self->{_vars}{deliver_freeze});
881     print $fh "\n";
882
883     foreach my $v (@{$self->{_show_vars}}) {
884       printf $fh "  %25s = '%s'\n", $v, $self->get_var($v);
885     }
886
887     foreach my $r (keys %{$self->{_recips}}) {
888       next if ($self->{_del_tree}{$r} && $self->{_undelivered_only});
889       printf $fh "        %s %s\n", $self->{_del_tree}{$r} ? "D" : " ", $r;
890     }
891     if ($self->{_show_generated}) {
892       foreach my $r (keys %{$self->{_del_tree}}) {
893         next if ($self->{_recips}{$r});
894         printf $fh "       +D %s\n", $r;
895       }
896     }
897   } elsif ($self->{_output_brief}) {
898     my @r = ();
899     foreach my $r (keys %{$self->{_recips}}) {
900       next if ($self->{_del_tree}{$r});
901       push(@r, $r);
902     }
903     print $fh " To: ", join(';', @r);
904     if ($self->{_show_vars} && scalar(@{$self->{_show_vars}})) {
905       print $fh " Vars: ", join(';',
906                                 map { "$_='".$self->get_var($_)."'" }
907                                     (@{$self->{_show_vars}})
908                                );
909     }
910   } elsif ($self->{_output_flatq}) {
911     print $fh " *** frozen ***" if ($self->{_vars}{deliver_freeze});
912     my @r = ();
913     foreach my $r (keys %{$self->{_recips}}) {
914       next if ($self->{_del_tree}{$r});
915       push(@r, $r);
916     }
917     print $fh " ", join(' ', @r);
918   }
919
920   print $fh "\n";
921 }
922
923 sub dump {
924   my $self = shift;
925
926   foreach my $k (sort keys %$self) {
927     my $r = ref($self->{$k});
928     if ($r eq 'ARRAY') {
929       printf "%20s <<EOM\n", $k;
930       print @{$self->{$k}}, "EOM\n";
931     } elsif ($r eq 'HASH') {
932       printf "%20s <<EOM\n", $k;
933       foreach (sort keys %{$self->{$k}}) {
934         printf "%20s %s\n", $_, $self->{$k}{$_};
935       }
936       print "EOM\n";
937     } else {
938       printf "%20s %s\n", $k, $self->{$k};
939     }
940   }
941 }
942
943 } # BEGIN
944
945 sub ext_usage {
946   if ($ARGV[0] =~ /^--help$/i) {
947     require Config;
948     $ENV{PATH} .= ":" unless $ENV{PATH} eq "";
949     $ENV{PATH} = "$ENV{PATH}$Config::Config{'installscript'}";
950     #exec("perldoc", "-F", "-U", $0) || exit 1;
951     $< = $> = 1 if ($> == 0 || $< == 0);
952     exec("perldoc", $0) || exit 1;
953     # make parser happy
954     %Config::Config = ();
955   } elsif ($ARGV[0] =~ /^--version$/i) {
956     print "$p_name version $p_version\n\n$p_cp\n";
957   } else {
958     return;
959   }
960
961   exit(0);
962 }
963
964 __END__
965
966 =head1 NAME
967
968 exipick - display messages from Exim queue based on a variety of criteria
969
970 =head1 USAGE
971
972 exipick [--help|--version] | [-spool <spool>] [-and|-or] [-bp|-bpa|-bpc|-bpr|-bpra|-bpru|-bpu] [<criterion> [<criterion> ...]]
973
974 =head1 DESCRIPTION
975
976 exipick is designed to display the contents of a Exim mail spool based on user-specified criteria.  It is designed to mimic the output of 'exim -bp' (or any of the other -bp* options) and Exim's spec.txt should be used to learn more about the exact format of the output.  The criteria are formed by creating comparisons against characteristics of the messages, for instance $message_size, $sender_helo_name, or $message_headers.
977
978 =head1 OPTIONS
979
980 =over 4
981
982 =item --spool
983
984 The path to Exim's spool directory.  In general usage you should set the $spool variable in the script to your site's main spool directory (and if exipick was installed from the Exim distribution, this is done by default), but this option is useful for alternate installs, or installs on NFS servers, etc.
985
986 =item --and
987
988 A message will be displayed only if it matches all of the specified criteria.  This is the default.
989
990 =item --or
991
992 A message will be displayed if it matches any of the specified criteria.
993
994 =item --caseful
995
996 By default criteria using the '=' operator are caseless.  Specifying this option make them respect case.
997
998 =item --show-vars <variable>[,<variable>...]
999
1000 Cause the value of each specified variable to be displayed for every message dispayed.  For instance, the command "exipick --show-vars '$sender_ident' 'sender_host_address eq 127.0.01'" will show the ident string for every message submitted via localhost.  How exactly the variable value is diplayed changes according to what output format you specify.
1001
1002 =item --show-rules
1003
1004 If specified the internal representation of each message criteria is shown.  This is primarily used for debugging purposes.
1005
1006 ==item --show-tests
1007
1008 If specified, for every message (regardless of matching criteria) the criteria's actual value is shown and the compiled internal eval is shown.  This is used primarily for debugging purposes.
1009
1010 =item --flatq
1011
1012 Change format of output so that every message is on a single line.  Useful for parsing with tools such as sed, awk, cut, etc.
1013
1014 =item --unsorted
1015
1016 This prevents sorting the messages according to their age when they are displayed.  While there were exim-clone options that enabled this functionality (-bpr, -bpra, etc) they only worked in the standard output format.  --unsorted works in all output formats, including the exiqgrep clone output and --flatq.
1017
1018 =item The -bp* options all control how much information is displayed and in what manner.  They all match the functionality of the options of the same name in Exim.  Briefly:
1019
1020 =item -bp   display the matching messages in 'mailq' format.
1021
1022 =item -bpa    ... with generated addresses as well.
1023
1024 =item -bpc    ... just show a count of messages.
1025
1026 =item -bpr    ... do not sort.
1027
1028 =item -bpra   ... with generated addresses, unsorted.
1029
1030 =item -bpru   ... only undelivered addresses, unsorted.
1031
1032 =item -bpu    ... only undelivered addresses.
1033
1034 Please see Exim's spec.txt for details on the format and information displayed with each option.
1035
1036 =item The following options are included for compatibility with the 'exiqgrep' utility:
1037
1038 =item -f <regexp>  Same as '$sender_address = <regexp>'
1039
1040 =item -r <regexp>  Same as '$recipients = <regexp>'
1041
1042 =item -s <string>  Same as '$shown_message_size eq <string>'
1043
1044 =item -y <seconds> Same as '$message_age < <seconds>'
1045
1046 =item -o <seconds> Same as '$message_age > <seconds>'
1047
1048 =item -z           Same as '$deliver_freeze'
1049
1050 =item -x           Same as '!$deliver_freeze'
1051
1052 =item -c           Display count of matches only
1053
1054 =item -l           Display in long format (default)
1055
1056 =item -i           Display message IDs only
1057
1058 =item -b           Display brief format only
1059
1060 Please see the 'exiqgrep' documentation for more details on the behaviour and output format produced by these options
1061
1062 =item <criterion>
1063
1064 The criteria are used to determine whether or not a given message should be displayed.  The criteria are built using variables containing information about the individual messages (see VARIABLES section for list and descriptions of available variables).  Each criterion is evaluated for each message in the spool and if all (by default) criteria match or (if --or option is specified) any criterion matches, the message is displayed.  See VARIABLE TYPES for explanation of types of variables and the evaluations that can be performed on them and EXAMPLES section for complete examples.
1065
1066 The format of a criterion is explained in detail below, but a key point to make is that the variable being compared must always be on the left side of the comparison.
1067
1068 If no criteria are provided all messages in the queue are displayed (in this case the output of exipick should be identical to the output of 'exim -bp')
1069
1070 =item --freeze <cache file>, --thaw <cache file>
1071
1072 Every time exipick runs, it has to rescan the input directory, open every file, and correctly parse the contents of every file.  While this isn't very time consuming on with a small queue or a lightly loaded server, it can take a great deal of time on heavily loaded machines or large queues.  Unfortunately, one of the best times to use exipick is diagnosing large mail queues.
1073
1074 To speed run times in these situations, you can use --freeze to save a cache of the message information.  --thaw can then be used to read from the cache rather than directly from the spool.  Over time, of course, the information in the cache will drift further and further out of date, but this is not a significant problem over short runs, but do keep in mind that any deliveries made or messages removed from the queue after the cache file is made will not be reflected in the output when using --thaw.
1075
1076 All message variables are saved to the cache except $message_body and $message_age.  $message_age is skipped because it is recalculated dynamically at every running of exipick.  $message_body is skipped because of the potentially large storage requirements.  If $message_body is referenced in any criteria when using --thaw, the data will be looked up from the spool file if the message is still in the spool.
1077
1078 If criteria are specified when using --freeze, only matching messages will be written to the cache file.  Subsequent runs of exipick --thaw using that cache file will not need the original criteria specified.
1079
1080 There are tradeoffs when using this system, time and space.  The cache file will take disk space to write.  The size of the file depends on the type of mail the server handles, but it ranges between 2KB and 5KB per message.  The run of exipick which creates the cache file will take longer to run than a standard run, perhaps as much as 50% longer, but the subsequent runs readng from the cache file will take as little as 10-20% of the time it would take for a run of exipick without --freeze/--thaw.  In other words, if a system is in a state where it takes 30 seconds to run exipick, making a cache file will take around 45 second, but subsequent reads of the cache will take around 5 seconds.  The size needed for the cache file decrease and the performance gains on the --thaw runs increase if criteria which limits the number of messages written to the cache file are used on the --freeze run.
1081
1082 =item --help
1083
1084 This screen.
1085
1086 =item --version
1087
1088 Version info.
1089
1090 =back
1091
1092 =head1 VARIABLE TYPES
1093
1094 Although there are variable types defined, they are defined only by the type of data that gets put into them.  They are internally typeless.  Because of this it is perfectly legal to perform a numeric comparison against a string variable, although the results will probably be meaningless.
1095
1096 =over 4
1097
1098 =item NUMERIC
1099
1100 Variable of the numeric type can be of integer or float.  Valid comparisons are <, <=, >, >=, ==, and !=.
1101
1102 The numbers specified in the criteria can have a suffix of d, h, m, s, M, K, or B, in which case the number will be mulitplied by 86400, 3600, 60, 1, 1048576, 1024, or 1 respectively.  These suffixes are case sensitive.  While these are obviously designed to aid in date and size calculations, they are not restricted to variables of their respective types.  That is, though it's odd it's legal to create a criterion of a message being around for 3 kiloseconds: '$message_age >= 3K'.
1103
1104 =item BOOLEAN
1105
1106 Variables of the boolean type are very easy to use in criteria.  The format is either the variable by itself or the variable negated with a ! sign.  For instance, '$deliver_freeze' matches if the message in question is frozen, '!$deliver_freeze' matches if message is not frozen.
1107
1108 =item STRING
1109
1110 String variables are basically defined as those that are neither numeric nor boolean and can contain any data.  The string operators are =, eq, ne, =~, and !~.  With the exception of '=', the operators all match the functionality of the like-named perl operators.
1111
1112 The simplest form is a bare string regular expression, represented by the operator '='.  The value used for the comparison will be evaluated as a regular expression and can be as simple or as complex as desired.  For instance '$sender_helo_name = example' on the simple end or '$sender_helo_name = ^aol\.com$' on the more complex end.  This comparison is caseless by default, but see the --caseful option to change this.
1113
1114 Slightly more complex is the string comparison with the operators 'eq' and 'ne' for equal and not equal, respectively.  '$sender_helo_name eq hotmail.com' is true for messages with the exact helo string "hotmail.com", while '$sender_helo_name ne hotmail.com' is true for any message with a helo string other than "hotmail.com".
1115
1116 The most complex and the most flexible format are straight regular expressions with the operators '=~' and '!~'.  The value in the criteria is expected to be a correctly formatted perl regular expression B<including the regexp delimiters (usually //)>.  The criterion '$sender_helo_name !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/' matches for any message which does not have an IP address for its helo string.
1117
1118 =item NEGATION
1119
1120 In addition to standard logical negation available with the operators above (== vs !=, < vs >=, etc) any criteria can be whole negated by prepending an exclamation mark ("!") to the variable name.  This is required for negating boolean variables, and very convenient for negating the simple '=' operator (previously, the opposite of '$var = foo' was '$var !~ /foo/'.  This can now be written '!$var = foo').
1121
1122 =back
1123
1124 =head1 VARIABLES
1125
1126 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.
1127
1128 In the list below, '.' denotes standard messages with contents matching Exim's variable, '#' denotes standard variables with non-standard contents, and '+' denotes a non-standard variable.
1129
1130 =head2 Boolean variables
1131
1132 =over 4
1133
1134 =item + $allow_unqualified_recipient
1135
1136 TRUE if unqualified recipient addresses are permitted in header lines.
1137
1138 =item + $allow_unqualified_sender
1139
1140 TRUE if unqualified sender addresses are permitted in header lines.
1141
1142 =item + $deliver_freeze
1143
1144 TRUE if the message is currently frozen.
1145
1146 =item . $first_delivery
1147
1148 TRUE if the message has never been deferred.
1149
1150 =item . $manually_thawed
1151
1152 TRUE when the message has been manually thawed.
1153
1154 =item + $dont_deliver
1155
1156 TRUE if, under normal circumstances, Exim will not try to deliver the message.
1157
1158 =item . $host_lookup_deferred
1159
1160 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.
1161
1162 =item . $host_lookup_failed
1163
1164 TRUE if there was an attempt to look up the host's name from its IP address, but the attempt returned a negative result.
1165
1166 =item + $local_error_message
1167
1168 TRUE if the message is a locally-generated error message.
1169
1170 =item + $sender_local
1171
1172 TRUE if the message was locally generated.
1173
1174 =item + $sender_set_untrusted
1175
1176 TRUE if the envelope sender of this message was set by an untrusted local caller.
1177
1178 =item . $tls_certificate_verified
1179
1180 TRUE if a TLS certificate was verified when the message was received.
1181
1182 =back
1183
1184 =head2 Numeric variables
1185
1186 =over 4
1187
1188 =item . $body_linecount
1189
1190 The number of lines in the message's body.
1191
1192 =item . $body_zerocount
1193
1194 The number of binary zero bytes in the message's body.
1195
1196 =item + $deliver_frozen_at
1197
1198 The epoch time at which message was frozen.
1199
1200 =item . $interface_port
1201
1202 The local port number if network-originated messages.
1203
1204 =item . $message_age
1205
1206 The number of seconds since the message was received.
1207
1208 =item . $message_body_size
1209
1210 The size of the body in bytes.
1211
1212 =item . $message_linecount
1213
1214 The number of lines in the entire message (body and headers).
1215
1216 =item . $message_size
1217
1218 The size of the message in bytes.
1219
1220 =item . $originator_gid
1221
1222 The group id under which the process that called Exim was running as when the message was received.
1223
1224 =item . $originator_uid
1225
1226 The user id under which the process that called Exim was running as when the message was received.
1227
1228 =item . $received_count
1229
1230 The number of Received: header lines in the message.
1231
1232 =item . $received_time
1233
1234 The epoch time at which the message was received.
1235
1236 =item . $recipients_count
1237
1238 The number of envelope recipients for the message.
1239
1240 =item + $recipients_del_count
1241
1242 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.
1243
1244 =item + $recipients_undel_count
1245
1246 The number of envelope recipients for the message which have not yet been delivered.
1247
1248 =item . $sender_host_port
1249
1250 The port number that was used on the remote host for network-originated messages.
1251
1252 =item + $warning_count
1253
1254 The number of delay warnings which have been sent for this message.
1255
1256 =back
1257
1258 =head2 String variables
1259
1260 =over 4
1261
1262 =item . $acl_c0-$acl_c9, $acl_m0-$acl_m9
1263
1264 User definable variables.
1265
1266 =item . $authenticated_id
1267
1268 Optional saved information from authenticators, or the login name of the calling process for locally submitted messages.
1269
1270 =item . $authenticated_sender
1271
1272 The value of AUTH= param for smtp messages, or a generated value from the calling processes login and qualify domain for locally submitted messages.
1273
1274 =item + $bmi_verdicts
1275
1276 I honestly don't know what the format of this variable is.  It only exists if you have Exim compiled with WITH_CONTENT_SCAN and EXPERIMENTAL_BRIGHTMAIL (and, you know, pay Symantec/Brightmail a bunch of money for the client libs and a server to use them with).
1277
1278 =item + $each_recipients
1279
1280 This is a psuedo variable which allows you to apply a criterion against each address in $recipients individually.  This allows you to create criteria against which every individual recipient is tested.  For instance, '$recipients =~ /aol.com/' will match if any of the recipient addresses contain the string "aol.com".  However, with the criterion '$each_recipients =~ /@aol.com$/', a message will only match if B<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.
1281
1282 =item + $each_recipients_del
1283
1284 Like $each_recipients, but for the $recipients_del variable.
1285
1286 =item + $each_recipients_undel
1287
1288 Like $each_recipients, but for the $recipients_undel variable.
1289
1290 =item # $header_*
1291
1292 The value of the same named message header, for example header_to or header_reply-to.  These variables are really closer to Exim's rheader_* variables, with the exception that leading and trailing space is removed.
1293
1294 =item . $interface_address
1295
1296 The address of the local IP interface for network-originated messages.
1297
1298 =item . $local_scan_data
1299
1300 The text returned by the local_scan() function when a message is received.
1301
1302 =item # $message_body
1303
1304 The message's body.  Unlike Exim's variable of the same name, this variable contains the entire message body.  The logic behind this is that the message body is not read unless it is specifically referenced, so under normal circumstances it is not a penalty, but when you need the entire body you need the entire body.  Like Exim's copy, newlines and nulls are replaced by spaces.
1305
1306 =item . $message_headers
1307
1308 A concatenation of all the header lines except for lines added by routers or transports.
1309
1310 =item . $message_exim_id, $message_id
1311
1312 The unique message id that is used by Exim to identify the message.  $message_id is deprecated as of Exim 4.53.
1313
1314 =item + $originator_login
1315
1316 The login of the process which called Exim.
1317
1318 =item . $received_protocol
1319
1320 The name of the protocol by which the message was received.
1321
1322 =item # $recipients
1323
1324 The list of envelope recipients for a message.  Unlike Exim's version, this variable always contains every envelope recipient of the message.  The recipients are separated by a comma and a space.
1325
1326 =item + $recipients_del
1327
1328 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.
1329
1330 =item + $recipients_undel
1331
1332 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.
1333
1334 =item . $reply_address
1335
1336 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.
1337
1338 =item . $sender_address
1339
1340 The sender's address that was received in the message's envelope.  For bounce messages, the value of this variable is the empty string.
1341
1342 =item . $sender_address_domain
1343
1344 The domain part of $sender_address.
1345
1346 =item . $sender_address_local_part
1347
1348 The local part of $sender_address.
1349
1350 =item . $sender_helo_name
1351
1352 The HELO or EHLO value supplied for smtp or bsmtp messages.
1353
1354 =item . $sender_host_address
1355
1356 The remote host's IP address.
1357
1358 =item . $sender_host_authenticated
1359
1360 The name of the authenticator driver which successfully authenticated the client from which the message was received.
1361
1362 =item . $sender_host_name
1363
1364 The remote host's name as obtained by looking up its IP address.
1365
1366 =item . $sender_ident
1367
1368 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.
1369
1370 =item + $shown_message_size
1371
1372 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.
1373
1374 =item . $smtp_active_hostname
1375
1376 The value of the active host name when the message was received, as specified by the "smtp_active_hostname" option.
1377
1378 =item . $spam_score
1379
1380 The spam score of the message, for example '3.4' or '30.5'.  (Requires exiscan or WITH_CONTENT_SCAN)
1381
1382 =item . $spam_score_int
1383
1384 The spam score of the message, multiplied by ten, as an integer value.  For instance '34' or '305'.  (Requires exiscan or WITH_CONTENT_SCAN)
1385
1386 =item . $tls_cipher
1387
1388 The cipher suite that was negotiated for encrypted SMTP connections.
1389
1390 =item . $tls_peerdn
1391
1392 The value of the Distinguished Name of the certificate if Exim is configured to request one.
1393
1394 =back
1395
1396 =head1 EXAMPLES
1397
1398 =over 4
1399
1400 =item exipick '$deliver_freeze'
1401
1402 Display only frozen messages.
1403
1404 =item exipick '$received_protocol eq asmtp' '$message_age < 20m'
1405
1406 Display only messages which were delivered over an authenticated smtp session in the last 20 minutes.
1407
1408 =item exipick -bpc '$message_size > 200K'
1409
1410 Display a count of messages in the queue which are over 200 kilobytes in size.
1411
1412 =item exipick -or '$sender_helo_name =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/' '$sender_helo_name = _'
1413
1414 Display message which have a HELO string which either is an IP address or contains an underscore.
1415
1416 =back
1417
1418 =head1 REQUIREMENTS
1419
1420 None that I know of, except an Exim installation.  Your life will also be a lot easier if you set $spool at the top of the script to your install's spool directory (assuming this was not done automatically by the Exim install process).
1421
1422 =head1 ACKNOWLEDGEMENTS
1423
1424 Although I conceived of the concept for this program independently, the name 'exipick' was taken from the Exim WishList and was suggested by Jeffrey Goldberg.
1425
1426 Thank you to Philip Hazel for writing Exim.  Of course this program exists because of Exim, but more specifically the message parsing code is based on Exim's and some of this documentation was copy/pasted from Exim's.
1427
1428 =head1 CONTACT
1429
1430 =over 4
1431
1432 =item EMAIL: proj-exipick@jetmore.net
1433
1434 =item HOME: jetmore.org/john/code/#exipick
1435
1436 =back
1437
1438 =cut