2 # $Cambridge: exim/src/src/exipick.src,v 1.8 2005/12/15 17:58:23 jetmore Exp $
4 # This variable should be set by the building process to Exim's spool directory.
5 my $spool = 'SPOOL_DIRECTORY';
10 my($p_name) = $0 =~ m|/?([^/]+)$|;
11 my $p_version = "20051215.3";
12 my $p_usage = "Usage: $p_name [--help|--version] (see --help for details)";
14 Copyright (c) 2003-2005 John Jetmore <jj33\@pobox.com>
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.
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.
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
30 ext_usage(); # before we do anything else, check for --help
32 $| = 1; # unbuffer STDOUT
34 Getopt::Long::Configure("bundling_override");
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 'flatq' => \$G::flatq, # brief format
58 'caseful' => \$G::caseful, # in '=' criteria, respect case
59 'caseless' => \$G::caseless, # ...ignore case (default)
60 'show-vars:s' => \$G::show_vars, # display the contents of these vars
61 'show-rules' => \$G::show_rules, # display compiled match rules
62 'show-tests' => \$G::show_tests # display tests as applied to each message
65 push(@ARGV, "\$sender_address =~ /$G::qgrep_f/") if ($G::qgrep_f);
66 push(@ARGV, "\$recipients =~ /$G::qgrep_r/") if ($G::qgrep_r);
67 push(@ARGV, "\$shown_message_size eq $G::qgrep_s") if ($G::qgrep_s);
68 push(@ARGV, "\$message_age < $G::qgrep_y") if ($G::qgrep_y);
69 push(@ARGV, "\$message_age > $G::qgrep_o") if ($G::qgrep_o);
70 push(@ARGV, "\$deliver_freeze") if ($G::qgrep_z);
71 push(@ARGV, "!\$deliver_freeze") if ($G::qgrep_x);
72 $G::mailq_bp = $G::mailq_bp; # shut up -w
73 $G::and = $G::and; # shut up -w
74 $G::msg_ids = {}; # short circuit when crit is only MID
75 $G::caseless = $G::caseful ? 0 : 1; # nocase by default, case if both
76 @G::recipients_crit = (); # holds per-recip criteria
77 $spool = $G::spool if ($G::spool);
78 my $count_only = 1 if ($G::mailq_bpc || $G::qgrep_c);
79 my $unsorted = 1 if ($G::mailq_bpr || $G::mailq_bpra || $G::mailq_bpru);
80 my $msg = get_all_msgs($spool, $unsorted);
81 my $crit = process_criteria(\@ARGV);
82 my $e = Exim::SpoolFile->new();
83 my $tcount = 0 if ($count_only); # holds count of all messages
84 my $mcount = 0 if ($count_only); # holds count of matching messages
85 $e->set_undelivered_only(1) if ($G::mailq_bpru || $G::mailq_bpu);
86 $e->set_show_generated(1) if ($G::mailq_bpra || $G::mailq_bpa);
87 $e->output_long() if ($G::qgrep_l);
88 $e->output_idonly() if ($G::qgrep_i);
89 $e->output_brief() if ($G::qgrep_b);
90 $e->output_flatq() if ($G::flatq);
91 $e->set_show_vars($G::show_vars) if ($G::show_vars);
92 $e->set_spool($spool);
95 foreach my $m (@$msg) {
96 next if (scalar(keys(%$G::msg_ids)) && !$G::or
97 && !$G::msg_ids->{$m->{message}});
98 if (!$e->parse_message($m->{message})) {
99 warn "Couldn't parse $m->{message}: ".$e->error()."\n";
105 foreach my $c (@G::recipients_crit) { # handle each_recip* vars
106 foreach my $addr (split(/, /, $e->get_var($c->{var}))) {
107 my %t = ( 'cmp' => $c->{cmp}, 'var' => $c->{var} );
108 $t{cmp} =~ s/"?\$var"?/'$addr'/;
109 push(@local_crit, \%t);
112 if ($G::show_tests) { print $e->get_var('message_exim_id'), "\n"; }
114 foreach my $c (@$crit, @local_crit) {
115 my $var = $e->get_var($c->{var});
116 my $ret = eval($c->{cmp});
117 if ($G::show_tests) {
118 printf " %25s = '%s'\n %25s => $ret\n",$c->{var},$var,$c->{cmp},$ret;
121 print STDERR "Error in eval '$c->{cmp}': $@\n";
125 if ($G::or) { last(CRITERIA); }
126 else { next(CRITERIA); }
128 if ($G::or) { next(CRITERIA); }
133 # skip this message if any criteria were supplied and it didn't match
134 next(MSG) if ((scalar(@$crit) || scalar(@local_crit)) && !$match);
139 $e->print_message(\*STDOUT);
145 } elsif ($G::qgrep_c) {
146 print "$mcount matches out of $tcount messages\n";
151 sub process_criteria {
157 foreach my $t ('@') { s/$t/\\$t/g; } # '$'
158 if (/^(.*?)\s+(<=|>=|==|!=|<|>)\s+(.*)$/) {
159 #print STDERR "found as integer\n";
160 my $v = $1; my $o = $2; my $n = $3;
161 if ($n =~ /^([\d\.]+)M$/) { $n = $1 * 1024 * 1024; }
162 elsif ($n =~ /^([\d\.]+)K$/) { $n = $1 * 1024; }
163 elsif ($n =~ /^([\d\.]+)B?$/) { $n = $1; }
164 elsif ($n =~ /^([\d\.]+)d$/) { $n = $1 * 60 * 60 * 24; }
165 elsif ($n =~ /^([\d\.]+)h$/) { $n = $1 * 60 * 60; }
166 elsif ($n =~ /^([\d\.]+)m$/) { $n = $1 * 60; }
167 elsif ($n =~ /^([\d\.]+)s?$/) { $n = $1; }
169 print STDERR "Expression $_ did not parse: numeric comparison with ",
174 push(@c, { var => lc($v), cmp => "(\$var $o $n) ? 1 : 0" });
175 } elsif (/^(.*?)\s+(=~|!~)\s+(.*)$/) {
176 #print STDERR "found as string regexp\n";
177 push(@c, { var => lc($1), cmp => "(\"\$var\" $2 $3) ? 1 : 0" });
178 } elsif (/^(.*?)\s+=\s+(.*)$/) {
179 #print STDERR "found as bare string regexp\n";
180 my $case = $G::caseful ? '' : 'i';
181 push(@c, { var => lc($1), cmp => "(\"\$var\" =~ /$2/$case) ? 1 : 0" });
182 } elsif (/^(.*?)\s+(eq|ne)\s+(.*)$/) {
183 #print STDERR "found as string cmp\n";
184 my $var = lc($1); my $op = $2; my $val = $3;
185 $val =~ s|^(['"])(.*)\1$|$2|;
186 push(@c, { var => $var, cmp => "(\"\$var\" $op \"$val\") ? 1 : 0" });
187 if (($var eq 'message_id' || $var eq 'message_exim_id') && $op eq "eq") {
188 #print STDERR "short circuit @c[-1]->{cmp} $val\n";
189 $G::msg_ids->{$val} = 1;
191 } elsif (/^(!)?(\S+)$/) {
192 #print STDERR "found as boolean\n";
193 push(@c, { var => lc($2), cmp => "($1\$var) ? 1 : 0" });
195 print STDERR "Expression $_ did not parse\n";
198 # support the each_* psuedo variables. Steal the criteria off of the
199 # queue for special processing later
200 if ($c[-1]{var} =~ /^each_(recipients(_(un)?del)?)$/) {
202 push(@G::recipients_crit,pop(@c));
203 $G::recipients_crit[-1]{var} = $var; # remove each_ from the variable
209 if ($G::show_rules) { foreach (@c) { print "$_->{var}\t$_->{cmp}\n"; } }
215 my $d = shift() . '/input';
219 opendir(D, "$d") || die "Couldn't opendir $d: $!\n";
220 foreach my $e (grep !/^\./, readdir(D)) {
221 if ($e =~ /^[a-zA-Z0-9]$/) {
222 opendir(DD, "$d/$e") || next;
223 foreach my $f (grep !/^\./, readdir(DD)) {
224 push(@m, { message => $1, path => "$e/$1" }) if ($f =~ /^(.{16})-H$/);
227 } elsif ($e =~ /^(.{16})-H$/) {
228 push(@m, { message => $1, path => $1 });
233 return($u ? \@m : [ sort { $a->{message} cmp $b->{message} } @m ]);
238 package Exim::SpoolFile;
240 # versions 4.61 and higher will not need these variables anymore, but they
241 # are left for handling legacy installs
242 $Exim::SpoolFile::ACL_C_MAX_LEGACY = 10;
243 #$Exim::SpoolFile::ACL_M_MAX _LEGACY= 10;
248 bless($self, $class);
250 $self->{_spool_dir} = '';
251 $self->{_undelivered_only} = 0;
252 $self->{_show_generated} = 0;
253 $self->{_output_long} = 1;
254 $self->{_output_idonly} = 0;
255 $self->{_output_brief} = 0;
256 $self->{_output_flatq} = 0;
257 $self->{_show_vars} = [];
266 $self->{_output_long} = 1;
267 $self->{_output_idonly} = 0;
268 $self->{_output_brief} = 0;
269 $self->{_output_flatq} = 0;
275 $self->{_output_long} = 0;
276 $self->{_output_idonly} = 1;
277 $self->{_output_brief} = 0;
278 $self->{_output_flatq} = 0;
284 $self->{_output_long} = 0;
285 $self->{_output_idonly} = 0;
286 $self->{_output_brief} = 1;
287 $self->{_output_flatq} = 0;
293 $self->{_output_long} = 0;
294 $self->{_output_idonly} = 0;
295 $self->{_output_brief} = 0;
296 $self->{_output_flatq} = 1;
303 foreach my $v (split(/\s*,\s*/, $s)) {
304 push(@{$self->{_show_vars}}, $v);
308 sub set_show_generated {
310 $self->{_show_generated} = shift;
313 sub set_undelivered_only {
315 $self->{_undelivered_only} = shift;
320 return $self->{_error};
325 $self->{_error} = shift;
332 $self->{_error} = '';
333 $self->{_delivered} = 0;
334 $self->{_message} = '';
338 $self->{_numrecips} = 0;
339 $self->{_udel_tree} = {};
340 $self->{_del_tree} = {};
341 $self->{_recips} = {};
350 $self->{_message} = shift || return(0);
351 return(0) if (!$self->{_spool_dir});
352 if (!$self->_find_path()) {
353 # assume the message was delivered from under us and ignore
354 $self->{_delivered} = 1;
357 $self->_parse_header() || return(0);
365 return(0) if (!$self->{_message});
366 return(0) if (!$self->{_spool_dir});
368 foreach my $f ('', substr($self->{_message}, 5, 1).'/') {
369 if (-f $self->{_spool_dir} . "/input/$f" . $self->{_message} . '-H') {
370 $self->{_path} = $self->{_spool_dir} . "/input/$f";
379 $self->{_spool_dir} = shift;
382 # accepts a variable with or without leading '$' or trailing ':'
391 if ($var eq 'message_body' && !$self->{_vars}{message_body});
393 return $self->{_vars}{$var};
398 my $f = $self->{_path} . '/' . $self->{_message} . '-D';
400 open(I, "<$f") || return($self->_error("Couldn't open $f: $!"));
402 return(0) if ($self->{_message}.'-D' ne $_);
404 $self->{_vars}{message_body} = join('', <I>);
406 $self->{_vars}{message_body} =~ s/\n/ /g;
407 $self->{_vars}{message_body} =~ s/\000/ /g;
413 my $f = $self->{_path} . '/' . $self->{_message} . '-H';
415 open(I, "<$f") || return($self->_error("Couldn't open $f: $!"));
417 return(0) if ($self->{_message}.'-H' ne $_);
418 $self->{_vars}{message_id} = $self->{_message};
419 $self->{_vars}{message_exim_id} = $self->{_message};
423 return(0) if (!/^(.+)\s(\-?\d+)\s(\-?\d+)$/);
424 $self->{_vars}{originator_login} = $1;
425 $self->{_vars}{originator_uid} = $2;
426 $self->{_vars}{originator_gid} = $3;
430 return(0) if (!/^<(.*)>$/);
431 $self->{_vars}{sender_address} = $1;
432 $self->{_vars}{sender_address_domain} = $1;
433 $self->{_vars}{sender_address_local_part} = $1;
434 $self->{_vars}{sender_address_domain} =~ s/^.*\@//;
435 $self->{_vars}{sender_address_local_part} =~ s/^(.*)\@.*$/$1/;
439 return(0) if (!/^(\d+)\s(\d+)$/);
440 $self->{_vars}{received_time} = $1;
441 $self->{_vars}{warning_count} = $2;
442 $self->{_vars}{message_age} = time() - $self->{_vars}{received_time};
446 if (/^(-\S+)\s*(.*$)/) {
449 if ($tag eq '-acl') {
451 return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
452 if ($1 < $Exim::SpoolFile::ACL_C_MAX_LEGACY) {
455 $t = "acl_m" . ($1 - $Exim::SpoolFile::ACL_C_MAX_LEGACY);
457 read(I, $self->{_vars}{$t}, $2+1) || return(0);
458 chomp($self->{_vars}{$t});
459 } elsif ($tag eq '-aclc') {
460 return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
462 read(I, $self->{_vars}{$t}, $2+1) || return(0);
463 chomp($self->{_vars}{$t});
464 } elsif ($tag eq '-aclm') {
465 return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
467 read(I, $self->{_vars}{$t}, $2+1) || return(0);
468 chomp($self->{_vars}{$t});
469 } elsif ($tag eq '-local') {
470 $self->{_vars}{sender_local} = 1;
471 } elsif ($tag eq '-localerror') {
472 $self->{_vars}{local_error_message} = 1;
473 } elsif ($tag eq '-local_scan') {
474 $self->{_vars}{local_scan_data} = $arg;
475 } elsif ($tag eq '-spam_score_int') {
476 $self->{_vars}{spam_score_int} = $arg;
477 $self->{_vars}{spam_score} = $arg / 10;
478 } elsif ($tag eq '-bmi_verdicts') {
479 $self->{_vars}{bmi_verdicts} = $arg;
480 } elsif ($tag eq '-host_lookup_deferred') {
481 $self->{_vars}{host_lookup_deferred} = 1;
482 } elsif ($tag eq '-host_lookup_failed') {
483 $self->{_vars}{host_lookup_failed} = 1;
484 } elsif ($tag eq '-body_linecount') {
485 $self->{_vars}{body_linecount} = $arg;
486 } elsif ($tag eq '-body_zerocount') {
487 $self->{_vars}{body_zerocount} = $arg;
488 } elsif ($tag eq '-frozen') {
489 $self->{_vars}{deliver_freeze} = 1;
490 $self->{_vars}{deliver_frozen_at} = $arg;
491 } elsif ($tag eq '-allow_unqualified_recipient') {
492 $self->{_vars}{allow_unqualified_recipient} = 1;
493 } elsif ($tag eq '-allow_unqualified_sender') {
494 $self->{_vars}{allow_unqualified_sender} = 1;
495 } elsif ($tag eq '-deliver_firsttime') {
496 $self->{_vars}{deliver_firsttime} = 1;
497 $self->{_vars}{first_delivery} = 1;
498 } elsif ($tag eq '-manual_thaw') {
499 $self->{_vars}{deliver_manual_thaw} = 1;
500 $self->{_vars}{manually_thawed} = 1;
501 } elsif ($tag eq '-auth_id') {
502 $self->{_vars}{authenticated_id} = $arg;
503 } elsif ($tag eq '-auth_sender') {
504 $self->{_vars}{authenticated_sender} = $arg;
505 } elsif ($tag eq '-sender_set_untrusted') {
506 $self->{_vars}{sender_set_untrusted} = 1;
507 } elsif ($tag eq '-tls_certificate_verified') {
508 $self->{_vars}{tls_certificate_verified} = 1;
509 } elsif ($tag eq '-tls_cipher') {
510 $self->{_vars}{tls_cipher} = $arg;
511 } elsif ($tag eq '-tls_peerdn') {
512 $self->{_vars}{tls_peerdn} = $arg;
513 } elsif ($tag eq '-host_address') {
514 $self->{_vars}{sender_host_port} = $self->_get_host_and_port(\$arg);
515 $self->{_vars}{sender_host_address} = $arg;
516 } elsif ($tag eq '-interface_address') {
517 $self->{_vars}{interface_port} = $self->_get_host_and_port(\$arg);
518 $self->{_vars}{interface_address} = $arg;
519 } elsif ($tag eq '-active_hostname') {
520 $self->{_vars}{smtp_active_hostname} = $arg;
521 } elsif ($tag eq '-host_auth') {
522 $self->{_vars}{sender_host_authenticated} = $arg;
523 } elsif ($tag eq '-host_name') {
524 $self->{_vars}{sender_host_name} = $arg;
525 } elsif ($tag eq '-helo_name') {
526 $self->{_vars}{sender_helo_name} = $arg;
527 } elsif ($tag eq '-ident') {
528 $self->{_vars}{sender_ident} = $arg;
529 } elsif ($tag eq '-received_protocol') {
530 $self->{_vars}{received_protocol} = $arg;
531 } elsif ($tag eq '-N') {
532 $self->{_vars}{dont_deliver} = 1;
534 # unrecognized tag, save it for reference
535 $self->{$tag} = $arg;
542 # when we drop out of the while loop, we have the first line of the
543 # delivered tree in $_
547 } elsif ($_ =~ s/^[YN][YN]\s+//) {
548 $self->{_del_tree}{$_} = 1;
553 } while ($_ !~ /^\d+$/);
555 $self->{_numrecips} = $_;
556 $self->{_vars}{recipients_count} = $self->{_numrecips};
557 for (my $i = 0; $i < $self->{_numrecips}; $i++) {
561 if (/^(.*)\s\d+,(\d+),\d+$/) {
562 #print STDERR "exim3 type (untested): $_\n";
563 $self->{_recips}{$1} = { pno => $2 };
565 } elsif (/^(.*)\s(\d+)$/) {
566 #print STDERR "exim4 original type (untested): $_\n";
567 $self->{_recips}{$1} = { pno => $2 };
569 } elsif (/^(.*)\s(.*)\s(\d+),(\d+)#1$/) {
570 #print STDERR "exim4 new type #1 (untested): $_\n";
571 return($self->_error("incorrect format: $_")) if (length($2) != $3);
572 $self->{_recips}{$1} = { pno => $4, errors_to => $2 };
574 } elsif (/^.*#(\d+)$/) {
575 #print STDERR "exim4 #$1 style (unimplemented): $_\n";
576 $self->_error("exim4 #$1 style (unimplemented): $_");
578 #print STDERR "default type: $_\n";
579 $self->{_recips}{$_} = {};
582 $self->{_udel_tree}{$addr} = 1 if (!$self->{_del_tree}{$addr});
584 $self->{_vars}{recipients} = join(', ', keys(%{$self->{_recips}}));
585 $self->{_vars}{recipients_del} = join(', ', keys(%{$self->{_del_tree}}));
586 $self->{_vars}{recipients_undel} = join(', ', keys(%{$self->{_udel_tree}}));
587 $self->{_vars}{recipients_undel_count} = scalar(keys(%{$self->{_udel_tree}}));
588 $self->{_vars}{recipients_del_count} = 0;
589 foreach my $r (keys %{$self->{_del_tree}}) {
590 next if (!$self->{_recips}{$r});
591 $self->{_vars}{recipients_del_count}++;
596 return(0) if (!/^$/);
598 # start reading headers
599 while (read(I, $_, 3) == 3) {
601 return(0) if (!length($t));
602 while ($t =~ /^\d$/) {
606 # ok, right here $t contains the header flag and $_ contains the number of
607 # bytes to read. If we ever use the header flag, grab it here.
608 $self->{_vars}{message_size} += $_ if ($t ne '*');
609 $t = getc(I); # strip the space out of the file
611 return(0) if (read(I, $_, $bytes) != $bytes);
612 chomp(); # may regret this later
613 $self->{_vars}{message_linecount} += scalar(split(/\n/)) if ($t ne '*');
614 # build the $header_ variable, following exim's rules (sort of)
615 if (/^([^ :]+):(.*)$/s) {
616 my $v = "header_" . lc($1);
620 $self->{_vars}{$v} .= (defined($self->{_vars}{$v}) ? "\n" : '') . $d;
621 $self->{_vars}{received_count}++ if ($v eq 'header_received');
623 # push header onto $message_headers var, following exim's rules
624 $self->{_vars}{message_headers} .=
625 (defined($self->{_vars}{message_headers}) ? "\n" : '') . $_;
629 if (length($self->{_vars}{"header_reply-to"}) > 0) {
630 $self->{_vars}{reply_address} = $self->{_vars}{"header_reply-to"};
632 $self->{_vars}{reply_address} = $self->{_vars}{header_from};
635 $self->{_vars}{message_body_size} =
636 (stat($self->{_path}.'/'.$self->{_message}.'-D'))[7] - 19;
637 if ($self->{_vars}{message_body_size} < 0) {
638 $self->{_vars}{message_size} = 0;
640 $self->{_vars}{message_size} += $self->{_vars}{message_body_size} + 1;
643 $self->{_vars}{message_linecount} += $self->{_vars}{body_linecount};
645 my $i = $self->{_vars}{message_size};
646 if ($i == 0) { $i = ""; }
647 elsif ($i < 1024) { $i = sprintf("%d", $i); }
648 elsif ($i < 10*1024) { $i = sprintf("%.1fK", $i / 1024); }
649 elsif ($i < 1024*1024) { $i = sprintf("%dK", ($i+512)/1024); }
650 elsif ($i < 10*1024*1024) { $i = sprintf("%.1fM", $i/(1024*1024)); }
651 else { $i = sprintf("%dM", ($i + 512 * 1024)/(1024*1024)); }
652 $self->{_vars}{shown_message_size} = $i;
657 # mimic exim's host_extract_port function - receive a ref to a scalar,
658 # strip it of port, return port
659 sub _get_host_and_port {
661 my $host = shift; # scalar ref, be careful
663 if ($$host =~ /^\[([^\]]+)\](?:\:(\d+))?$/) {
666 } elsif ($$host =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})(?:\.(\d+))?$/) {
669 } elsif ($$host =~ /^([\d\:]+)(?:\.(\d+))?$/) {
679 my $fh = shift || \*STDOUT;
680 return if ($self->{_delivered});
682 if ($self->{_output_idonly}) {
683 print $fh $self->{_message};
684 foreach my $v (@{$self->{_show_vars}}) {
685 print $fh " $v='", $self->get_var($v), "'";
691 if ($self->{_output_long} || $self->{_output_flatq}) {
692 my $i = int($self->{_vars}{message_age} / 60);
694 $i = int(($i+30)/60);
695 if ($i > 72) { printf $fh "%2dd ", int(($i+12)/24); }
696 else { printf $fh "%2dh ", $i; }
697 } else { printf $fh "%2dm ", $i; }
699 if ($self->{_output_flatq} && $self->{_show_vars}) {
701 map { "$_='".$self->get_var($_)."'" }
702 (@{$self->{_show_vars}})
705 printf $fh "%5s", $self->{_vars}{shown_message_size};
709 print $fh "$self->{_message} ";
710 print $fh "From: " if ($self->{_output_brief});
711 print $fh "<$self->{_vars}{sender_address}>";
713 if ($self->{_output_long}) {
714 print $fh " ($self->{_vars}{originator_login})"
715 if ($self->{_vars}{sender_set_untrusted});
717 # XXX exim contains code here to print spool format errors
718 print $fh " *** frozen ***" if ($self->{_vars}{deliver_freeze});
721 foreach my $v (@{$self->{_show_vars}}) {
722 printf $fh " %25s = '%s'\n", $v, $self->get_var($v);
725 foreach my $r (keys %{$self->{_recips}}) {
726 next if ($self->{_del_tree}{$r} && $self->{_undelivered_only});
727 printf $fh " %s %s\n", $self->{_del_tree}{$r} ? "D" : " ", $r;
729 if ($self->{_show_generated}) {
730 foreach my $r (keys %{$self->{_del_tree}}) {
731 next if ($self->{_recips}{$r});
732 printf $fh " +D %s\n", $r;
735 } elsif ($self->{_output_brief}) {
737 foreach my $r (keys %{$self->{_recips}}) {
738 next if ($self->{_del_tree}{$r});
741 print $fh " To: ", join(';', @r);
742 if ($self->{_show_vars} && scalar(@{$self->{_show_vars}})) {
743 print $fh " Vars: ", join(';',
744 map { "$_='".$self->get_var($_)."'" }
745 (@{$self->{_show_vars}})
748 } elsif ($self->{_output_flatq}) {
749 print $fh " *** frozen ***" if ($self->{_vars}{deliver_freeze});
751 foreach my $r (keys %{$self->{_recips}}) {
752 next if ($self->{_del_tree}{$r});
755 print $fh " ", join(' ', @r);
764 foreach my $k (sort keys %$self) {
765 my $r = ref($self->{$k});
767 printf "%20s <<EOM\n", $k;
768 print @{$self->{$k}}, "EOM\n";
769 } elsif ($r eq 'HASH') {
770 printf "%20s <<EOM\n", $k;
771 foreach (sort keys %{$self->{$k}}) {
772 printf "%20s %s\n", $_, $self->{$k}{$_};
776 printf "%20s %s\n", $k, $self->{$k};
784 if ($ARGV[0] =~ /^--help$/i) {
786 $ENV{PATH} .= ":" unless $ENV{PATH} eq "";
787 $ENV{PATH} = "$ENV{PATH}$Config::Config{'installscript'}";
788 #exec("perldoc", "-F", "-U", $0) || exit 1;
789 $< = $> = 1 if ($> == 0 || $< == 0);
790 exec("perldoc", $0) || exit 1;
792 %Config::Config = ();
793 } elsif ($ARGV[0] =~ /^--version$/i) {
794 print "$p_name version $p_version\n\n$p_cp\n";
806 exipick - display messages from Exim queue based on a variety of criteria
810 exipick [--help|--version] | [-spool <spool>] [-and|-or] [-bp|-bpa|-bpc|-bpr|-bpra|-bpru|-bpu] [<criterion> [<criterion> ...]]
814 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.
822 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.
826 A message will be displayed only if it matches all of the specified criteria. This is the default.
830 A message will be displayed if it matches any of the specified criteria.
834 By default criteria using the '=' operator are caseless. Specifying this option make them respect case.
836 =item --show-vars <variable>[,<variable>...]
838 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.
842 If specified the internal representation of each message criteria is shown. This is primarily used for debugging purposes.
846 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.
850 Change format of output so that every message is on a single line. Useful for parsing with tools such as sed, awk, cut, etc.
852 =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:
854 =item -bp display the matching messages in 'mailq' format.
856 =item -bpa ... with generated addresses as well.
858 =item -bpc ... just show a count of messages.
860 =item -bpr ... do not sort.
862 =item -bpra ... with generated addresses, unsorted.
864 =item -bpru ... only undelivered addresses, unsorted.
866 =item -bpu ... only undelivered addresses.
868 Please see Exim's spec.txt for details on the format and information displayed with each option.
870 =item The following options are included for compatibility with the 'exiqgrep' utility:
872 =item -f <regexp> Same as '$sender_address = <regexp>'
874 =item -r <regexp> Same as '$recipients = <regexp>'
876 =item -s <string> Same as '$shown_message_size eq <string>'
878 =item -y <seconds> Same as '$message_age < <seconds>'
880 =item -o <seconds> Same as '$message_age > <seconds>'
882 =item -z Same as '$deliver_freeze'
884 =item -x Same as '!$deliver_freeze'
886 =item -c Display count of matches only
888 =item -l Display in long format (default)
890 =item -i Display message IDs only
892 =item -b Display brief format only
894 Please see the 'exiqgrep' documentation for more details on the behaviour and output format produced by these options
898 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.
900 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.
902 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')
914 =head1 VARIABLE TYPES
916 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.
922 Variable of the numeric type can be of integer or float. Valid comparisons are <, <=, >, >=, ==, and !=.
924 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'.
928 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.
932 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.
934 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.
936 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".
938 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.
944 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.
946 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.
948 =head2 Boolean variables
952 =item + $allow_unqualified_recipient
954 TRUE if unqualified recipient addresses are permitted in header lines.
956 =item + $allow_unqualified_sender
958 TRUE if unqualified sender addresses are permitted in header lines.
960 =item + $deliver_freeze
962 TRUE if the message is currently frozen.
964 =item . $first_delivery
966 TRUE if the message has never been deferred.
968 =item . $manually_thawed
970 TRUE when the message has been manually thawed.
972 =item + $dont_deliver
974 TRUE if, under normal circumstances, Exim will not try to deliver the message.
976 =item . $host_lookup_deferred
978 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.
980 =item . $host_lookup_failed
982 TRUE if there was an attempt to look up the host's name from its IP address, but the attempt returned a negative result.
984 =item + $local_error_message
986 TRUE if the message is a locally-generated error message.
988 =item + $sender_local
990 TRUE if the message was locally generated.
992 =item + $sender_set_untrusted
994 TRUE if the envelope sender of this message was set by an untrusted local caller.
996 =item . $tls_certificate_verified
998 TRUE if a TLS certificate was verified when the message was received.
1002 =head2 Numeric variables
1006 =item . $body_linecount
1008 The number of lines in the message's body.
1010 =item . $body_zerocount
1012 The number of binary zero bytes in the message's body.
1014 =item + $deliver_frozen_at
1016 The epoch time at which message was frozen.
1018 =item . $interface_port
1020 The local port number if network-originated messages.
1022 =item . $message_age
1024 The number of seconds since the message was received.
1026 =item . $message_body_size
1028 The size of the body in bytes.
1030 =item . $message_linecount
1032 The number of lines in the entire message (body and headers).
1034 =item . $message_size
1036 The size of the message in bytes.
1038 =item . $originator_gid
1040 The group id under which the process that called Exim was running as when the message was received.
1042 =item . $originator_uid
1044 The user id under which the process that called Exim was running as when the message was received.
1046 =item . $received_count
1048 The number of Received: header lines in the message.
1050 =item . $received_time
1052 The epoch time at which the message was received.
1054 =item . $recipients_count
1056 The number of envelope recipients for the message.
1058 =item + $recipients_del_count
1060 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.
1062 =item + $recipients_undel_count
1064 The number of envelope recipients for the message which have not yet been delivered.
1066 =item . $sender_host_port
1068 The port number that was used on the remote host for network-originated messages.
1070 =item + $warning_count
1072 The number of delay warnings which have been sent for this message.
1076 =head2 String variables
1080 =item . $acl_c0-$acl_c9, $acl_m0-$acl_m9
1082 User definable variables.
1084 =item . $authenticated_id
1086 Optional saved information from authenticators, or the login name of the calling process for locally submitted messages.
1088 =item . $authenticated_sender
1090 The value of AUTH= param for smtp messages, or a generated value from the calling processes login and qualify domain for locally submitted messages.
1092 =item + $bmi_verdicts
1094 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).
1096 =item + $each_recipients
1098 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.
1100 =item + $each_recipients_del
1102 Like $each_recipients, but for the $recipients_del variable.
1104 =item + $each_recipients_undel
1106 Like $each_recipients, but for the $recipients_undel variable.
1110 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.
1112 =item . $interface_address
1114 The address of the local IP interface for network-originated messages.
1116 =item . $local_scan_data
1118 The text returned by the local_scan() function when a message is received.
1120 =item # $message_body
1122 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.
1124 =item . $message_headers
1126 A concatenation of all the header lines except for lines added by routers or transports.
1128 =item . $message_exim_id, $message_id
1130 The unique message id that is used by Exim to identify the message. $message_id is deprecated as of Exim 4.53.
1132 =item + $originator_login
1134 The login of the process which called Exim.
1136 =item . $received_protocol
1138 The name of the protocol by which the message was received.
1142 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.
1144 =item + $recipients_del
1146 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.
1148 =item + $recipients_undel
1150 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.
1152 =item . $reply_address
1154 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.
1156 =item . $sender_address
1158 The sender's address that was received in the message's envelope. For bounce messages, the value of this variable is the empty string.
1160 =item . $sender_address_domain
1162 The domain part of $sender_address.
1164 =item . $sender_address_local_part
1166 The local part of $sender_address.
1168 =item . $sender_helo_name
1170 The HELO or EHLO value supplied for smtp or bsmtp messages.
1172 =item . $sender_host_address
1174 The remote host's IP address.
1176 =item . $sender_host_authenticated
1178 The name of the authenticator driver which successfully authenticated the client from which the message was received.
1180 =item . $sender_host_name
1182 The remote host's name as obtained by looking up its IP address.
1184 =item . $sender_ident
1186 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.
1188 =item + $shown_message_size
1190 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.
1192 =item . $smtp_active_hostname
1194 The value of the active host name when the message was received, as specified by the "smtp_active_hostname" option.
1198 The spam score of the message, for example '3.4' or '30.5'. (Requires exiscan or WITH_CONTENT_SCAN)
1200 =item . $spam_score_int
1202 The spam score of the message, multiplied by ten, as an integer value. For instance '34' or '305'. (Requires exiscan or WITH_CONTENT_SCAN)
1206 The cipher suite that was negotiated for encrypted SMTP connections.
1210 The value of the Distinguished Name of the certificate if Exim is configured to request one.
1218 =item exipick '$deliver_freeze'
1220 Display only frozen messages.
1222 =item exipick '$received_protocol eq asmtp' '$message_age < 20m'
1224 Display only messages which were delivered over an authenticated smtp session in the last 20 minutes.
1226 =item exipick -bpc '$message_size > 200K'
1228 Display a count of messages in the queue which are over 200 kilobytes in size.
1230 =item exipick -or '$sender_helo_name =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/' '$sender_helo_name = _'
1232 Display message which have a HELO string which either is an IP address or contains an underscore.
1238 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).
1240 =head1 ACKNOWLEDGEMENTS
1242 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.
1244 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.
1250 =item EMAIL: proj-exipick@jetmore.net
1252 =item HOME: jetmore.org/john/code/#exipick