2 # $Cambridge: exim/src/src/exipick.src,v 1.12 2006/07/21 16:48:43 jetmore Exp $
4 # This variable should be set by the building process to Exim's spool directory.
5 my $spool = 'SPOOL_DIRECTORY';
7 # use 'exipick --help' to view documentation for this program.
8 # Documentation also viewable online at
9 # http://www.exim.org/eximwiki/ToolExipickManPage
14 my($p_name) = $0 =~ m|/?([^/]+)$|;
15 my $p_version = "20060721.2";
16 my $p_usage = "Usage: $p_name [--help|--version] (see --help for details)";
18 Copyright (c) 2003-2006 John Jetmore <jj33\@pobox.com>
20 This program is free software; you can redistribute it and/or modify
21 it under the terms of the GNU General Public License as published by
22 the Free Software Foundation; either version 2 of the License, or
23 (at your option) any later version.
25 This program is distributed in the hope that it will be useful,
26 but WITHOUT ANY WARRANTY; without even the implied warranty of
27 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
28 GNU General Public License for more details.
30 You should have received a copy of the GNU General Public License
31 along with this program; if not, write to the Free Software
32 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
34 ext_usage(); # before we do anything else, check for --help
36 $| = 1; # unbuffer STDOUT
38 Getopt::Long::Configure("bundling_override");
40 'spool:s' => \$G::spool, # exim spool dir
41 'bp' => \$G::mailq_bp, # List the queue (noop - default)
42 'bpa' => \$G::mailq_bpa, # ... with generated address as well
43 'bpc' => \$G::mailq_bpc, # ... but just show a count of messages
44 'bpr' => \$G::mailq_bpr, # ... do not sort
45 'bpra' => \$G::mailq_bpra, # ... with generated addresses, unsorted
46 'bpru' => \$G::mailq_bpru, # ... only undelivered addresses, unsorted
47 'bpu' => \$G::mailq_bpu, # ... only undelivered addresses
48 'and' => \$G::and, # 'and' the criteria (default)
49 'or' => \$G::or, # 'or' the criteria
50 'f:s' => \$G::qgrep_f, # from regexp
51 'r:s' => \$G::qgrep_r, # recipient regexp
52 's:s' => \$G::qgrep_s, # match against size field
53 'y:s' => \$G::qgrep_y, # message younger than (secs)
54 'o:s' => \$G::qgrep_o, # message older than (secs)
55 'z' => \$G::qgrep_z, # frozen only
56 'x' => \$G::qgrep_x, # non-frozen only
57 'c' => \$G::qgrep_c, # display match count
58 'l' => \$G::qgrep_l, # long format (default)
59 'i' => \$G::qgrep_i, # message ids only
60 'b' => \$G::qgrep_b, # brief format
61 'size' => \$G::size_only, # sum the size of the matching msgs
62 'not' => \$G::negate, # flip every test
63 'R|reverse' => \$G::reverse, # reverse output (-R is qgrep option)
64 'sort:s' => \@G::sort, # allow you to choose variables to sort by
65 'freeze:s' => \$G::freeze, # freeze data in this file
66 'thaw:s' => \$G::thaw, # thaw data from this file
67 'unsorted' => \$G::unsorted, # unsorted, regardless of output format
68 'random' => \$G::random, # (poorly) randomize evaluation order
69 'flatq' => \$G::flatq, # brief format
70 'caseful' => \$G::caseful, # in '=' criteria, respect case
71 'caseless' => \$G::caseless, # ...ignore case (default)
72 'show-vars:s' => \$G::show_vars, # display the contents of these vars
73 'show-rules' => \$G::show_rules, # display compiled match rules
74 'show-tests' => \$G::show_tests # display tests as applied to each message
77 # if both freeze and thaw specified, only thaw as it is less desctructive
78 $G::freeze = undef if ($G::freeze && $G::thaw);
79 freeze_start() if ($G::freeze);
80 thaw_start() if ($G::thaw);
82 # massage sort options (make '$var,Var:' be 'var','var')
83 for (my $i = scalar(@G::sort)-1; $i >= 0; $i--) {
84 $G::sort[$i] = lc($G::sort[$i]);
85 $G::sort[$i] =~ s/[\$:\s]//g;
86 if ((my @vars = split(/,/, $G::sort[$i])) > 1) {
87 $G::sort[$i] = $vars[0]; shift(@vars); # replace current slot w/ first var
88 splice(@G::sort, $i+1, 0, @vars); # add other vars after current pos
91 push(@G::sort, "message_exim_id") if (@G::sort);
92 die "empty value provided to --sort not allowed, exiting\n"
93 if (grep /^\s*$/, @G::sort);
95 # massage the qgrep options into standard criteria
96 push(@ARGV, "\$sender_address =~ /$G::qgrep_f/") if ($G::qgrep_f);
97 push(@ARGV, "\$recipients =~ /$G::qgrep_r/") if ($G::qgrep_r);
98 push(@ARGV, "\$shown_message_size eq $G::qgrep_s") if ($G::qgrep_s);
99 push(@ARGV, "\$message_age < $G::qgrep_y") if ($G::qgrep_y);
100 push(@ARGV, "\$message_age > $G::qgrep_o") if ($G::qgrep_o);
101 push(@ARGV, "\$deliver_freeze") if ($G::qgrep_z);
102 push(@ARGV, "!\$deliver_freeze") if ($G::qgrep_x);
104 $G::mailq_bp = $G::mailq_bp; # shut up -w
105 $G::and = $G::and; # shut up -w
106 $G::msg_ids = {}; # short circuit when crit is only MID
107 $G::caseless = $G::caseful ? 0 : 1; # nocase by default, case if both
108 @G::recipients_crit = (); # holds per-recip criteria
109 $spool = $G::spool if ($G::spool);
110 my $count_only = 1 if ($G::mailq_bpc || $G::qgrep_c);
111 my $unsorted = 1 if ($G::mailq_bpr || $G::mailq_bpra ||
112 $G::mailq_bpru || $G::unsorted);
113 my $msg = $G::thaw ? thaw_message_list()
114 : get_all_msgs($spool, $unsorted,
115 $G::reverse, $G::random);
116 die "Problem accessing thaw file\n" if ($G::thaw && !$msg);
117 my $crit = process_criteria(\@ARGV);
118 my $e = Exim::SpoolFile->new();
119 my $tcount = 0 if ($count_only); # holds count of all messages
120 my $mcount = 0 if ($count_only); # holds count of matching messages
121 my $total_size = 0 if ($G::size_only);
122 $e->set_undelivered_only(1) if ($G::mailq_bpru || $G::mailq_bpu);
123 $e->set_show_generated(1) if ($G::mailq_bpra || $G::mailq_bpa);
124 $e->output_long() if ($G::qgrep_l);
125 $e->output_idonly() if ($G::qgrep_i);
126 $e->output_brief() if ($G::qgrep_b);
127 $e->output_flatq() if ($G::flatq);
128 $e->set_show_vars($G::show_vars) if ($G::show_vars);
129 $e->set_spool($spool);
132 foreach my $m (@$msg) {
133 next if (scalar(keys(%$G::msg_ids)) && !$G::or
134 && !$G::msg_ids->{$m->{message}});
136 my $data = thaw_data();
137 if (!$e->restore_state($data)) {
138 warn "Couldn't thaw $data->{_message}: ".$e->error()."\n";
142 if (!$e->parse_message($m->{message}, $m->{path})) {
143 warn "Couldn't parse $m->{message}: ".$e->error()."\n";
150 foreach my $c (@G::recipients_crit) { # handle each_recip* vars
151 foreach my $addr (split(/, /, $e->get_var($c->{var}))) {
152 my %t = ( 'cmp' => $c->{cmp}, 'var' => $c->{var} );
153 $t{cmp} =~ s/"?\$var"?/'$addr'/;
154 push(@local_crit, \%t);
157 if ($G::show_tests) { print $e->get_var('message_exim_id'), "\n"; }
159 foreach my $c (@$crit, @local_crit) {
160 my $var = $e->get_var($c->{var});
161 my $ret = eval($c->{cmp});
162 if ($G::show_tests) {
163 printf " %25s = '%s'\n %25s => $ret\n",$c->{var},$var,$c->{cmp},$ret;
166 print STDERR "Error in eval '$c->{cmp}': $@\n";
170 if ($G::or) { last CRITERIA; }
171 else { next CRITERIA; }
173 if ($G::or) { next CRITERIA; }
178 # skip this message if any criteria were supplied and it didn't match
179 next MSG if ((scalar(@$crit) || scalar(@local_crit)) && !$match);
181 if ($count_only || $G::size_only) {
183 $total_size += $e->get_var('message_size');
186 # if we are defining criteria to sort on, save the message here. If
187 # we don't save here and do the sort later, we have a chicken/egg
189 push(@G::to_print, { vars => {}, output => "" });
190 foreach my $var (@G::sort) {
191 # save any values we want to sort on. I don't like doing the internal
192 # struct access here, but calling get_var a bunch can be _slow_ =(
193 $G::sort_type{$var} ||= '<=>';
194 $G::to_print[-1]{vars}{$var} = $e->{_vars}{$var};
195 $G::sort_type{$var} = 'cmp' if ($G::to_print[-1]{vars}{$var} =~ /\D/);
197 $G::to_print[-1]{output} = $e->format_message();
199 print $e->format_message();
204 freeze_data($e->get_state());
205 push(@G::frozen_msgs, $m);
210 msg_sort(\@G::to_print, \@G::sort, $G::reverse);
211 foreach my $msg (@G::to_print) {
212 print $msg->{output};
217 print "$mcount matches out of $tcount messages" .
218 ($G::size_only ? " ($total_size)" : "") . "\n";
219 } elsif ($G::mailq_bpc) {
220 print "$mcount" . ($G::size_only ? " ($total_size)" : "") . "\n";
221 } elsif ($G::size_only) {
222 print "$total_size\n";
226 freeze_message_list(\@G::frozen_msgs);
234 # sender_address_domain,shown_message_size
241 foreach my $v (@G::sort) {
242 push(@pieces, "\$a->{vars}{\"$v\"} $G::sort_type{$v} \$b->{vars}{\"$v\"}");
244 my $sort_str = join(" || ", @pieces);
246 @$msgs = sort { eval $sort_str } (@$msgs);
247 @$msgs = reverse(@$msgs) if ($reverse);
257 # FREEZE FILE FORMAT:
263 # message_list_bytes <- 10 bytes, zero-packed, plus \n
266 eval("use Storable");
267 die "Storable module not found: $@\n" if ($@);
268 open(O, ">$G::freeze") || die "Can't open freeze file $G::freeze: $!\n";
269 $G::freeze_handle = \*O;
273 close($G::freeze_handle);
277 eval("use Storable");
278 die "Storable module not found: $@\n" if ($@);
279 open(I, "<$G::thaw") || die "Can't open freeze file $G::thaw: $!\n";
280 $G::freeze_handle = \*I;
284 close($G::freeze_handle);
288 my $h = Storable::freeze($_[0]);
289 print $G::freeze_handle length($h)+1, "\n$h\n";
292 sub freeze_message_list {
293 my $h = Storable::freeze($_[0]);
294 my $l = length($h) + 1;
295 printf $G::freeze_handle "EOM\n$l\n$h\n%010d\n", $l+11+length($l)+1;
298 sub thaw_message_list {
299 my $orig_pos = tell($G::freeze_handle);
300 seek($G::freeze_handle, -11, 2);
301 chomp(my $bytes = <$G::freeze_handle>);
302 seek($G::freeze_handle, $bytes * -1, 2);
303 my $obj = thaw_data();
304 seek($G::freeze_handle, 0, $orig_pos);
310 chomp(my $bytes = <$G::freeze_handle>);
311 return(undef) if (!$bytes || $bytes eq 'EOM');
312 my $read = read(I, $obj, $bytes);
313 die "Format error in thaw file (expected $bytes bytes, got $read)\n"
314 if ($bytes != $read);
316 return(Storable::thaw($obj));
319 sub process_criteria {
325 foreach my $t ('@') { s/$t/\\$t/g; }
326 if (/^(.*?)\s+(<=|>=|==|!=|<|>)\s+(.*)$/) {
327 #print STDERR "found as integer\n";
328 my $v = $1; my $o = $2; my $n = $3;
329 if ($n =~ /^([\d\.]+)M$/) { $n = $1 * 1024 * 1024; }
330 elsif ($n =~ /^([\d\.]+)K$/) { $n = $1 * 1024; }
331 elsif ($n =~ /^([\d\.]+)B?$/) { $n = $1; }
332 elsif ($n =~ /^([\d\.]+)d$/) { $n = $1 * 60 * 60 * 24; }
333 elsif ($n =~ /^([\d\.]+)h$/) { $n = $1 * 60 * 60; }
334 elsif ($n =~ /^([\d\.]+)m$/) { $n = $1 * 60; }
335 elsif ($n =~ /^([\d\.]+)s?$/) { $n = $1; }
337 print STDERR "Expression $_ did not parse: numeric comparison with ",
342 #push(@c, { var => lc($v), cmp => "(\$var $o $n) ? 1 : 0" });
343 push(@c, { var => lc($v), cmp => "(\$var $o $n)" });
344 } elsif (/^(.*?)\s+(=~|!~)\s+(.*)$/) {
345 #print STDERR "found as string regexp\n";
346 push(@c, { var => lc($1), cmp => "(\"\$var\" $2 $3)" });
347 } elsif (/^(.*?)\s+=\s+(.*)$/) {
348 #print STDERR "found as bare string regexp\n";
349 my $case = $G::caseful ? '' : 'i';
350 push(@c, { var => lc($1), cmp => "(\"\$var\" =~ /$2/$case)" });
351 # quote special characters in perl text string
352 #foreach my $t ('@') { $c[-1]{cmp} =~ s/$t/\\$t/g; }
353 } elsif (/^(.*?)\s+(eq|ne)\s+(.*)$/) {
354 #print STDERR "found as string cmp\n";
355 my $var = lc($1); my $op = $2; my $val = $3;
356 $val =~ s|^(['"])(.*)\1$|$2|;
357 push(@c, { var => $var, cmp => "(\"\$var\" $op \"$val\")" });
358 if (($var eq 'message_id' || $var eq 'message_exim_id') && $op eq "eq") {
359 #print STDERR "short circuit @c[-1]->{cmp} $val\n";
360 $G::msg_ids->{$val} = 1;
362 #foreach my $t ('@') { $c[-1]{cmp} =~ s/$t/\\$t/g; }
363 } elsif (/^(\S+)$/) {
364 #print STDERR "found as boolean\n";
365 push(@c, { var => lc($1), cmp => "(\$var)" });
367 print STDERR "Expression $_ did not parse\n";
370 # assign the results of the cmp test here (handle "!" negation)
371 # also handle global --not negation
372 if ($c[-1]{var} =~ s|^!||) {
373 $c[-1]{cmp} .= $G::negate ? " ? 1 : 0" : " ? 0 : 1";
375 $c[-1]{cmp} .= $G::negate ? " ? 0 : 1" : " ? 1 : 0";
377 # support the each_* psuedo variables. Steal the criteria off of the
378 # queue for special processing later
379 if ($c[-1]{var} =~ /^each_(recipients(_(un)?del)?)$/) {
381 push(@G::recipients_crit,pop(@c));
382 $G::recipients_crit[-1]{var} = $var; # remove each_ from the variable
388 if ($G::show_rules) { foreach (@c) { print "$_->{var}\t$_->{cmp}\n"; } }
394 my $d = shift() . '/input';
395 my $u = shift; # don't sort
396 my $r = shift; # right before returning, reverse order
397 my $o = shift; # if true, randomize list order before returning
400 opendir(D, "$d") || die "Couldn't opendir $d: $!\n";
401 foreach my $e (grep !/^\./, readdir(D)) {
402 if ($e =~ /^[a-zA-Z0-9]$/) {
403 opendir(DD, "$d/$e") || next;
404 foreach my $f (grep !/^\./, readdir(DD)) {
405 push(@m, { message => $1, path => "$d/$e" }) if ($f =~ /^(.{16})-H$/);
408 } elsif ($e =~ /^(.{16})-H$/) {
409 push(@m, { message => $1, path => $d });
416 # loop twice to pretend we're doing a good job of mixing things up
417 for (my $i = 0; $i < 2 * $c; $i++) {
418 my $rand = int(rand($c));
419 ($m[$i % $c],$m[$rand]) = ($m[$rand],$m[$i % $c]);
422 @m = sort { $a->{message} cmp $b->{message} } @m;
424 @m = reverse(@m) if ($r);
431 package Exim::SpoolFile;
433 # versions 4.61 and higher will not need these variables anymore, but they
434 # are left for handling legacy installs
435 $Exim::SpoolFile::ACL_C_MAX_LEGACY = 10;
436 #$Exim::SpoolFile::ACL_M_MAX _LEGACY= 10;
441 bless($self, $class);
443 $self->{_spool_dir} = '';
444 $self->{_undelivered_only} = 0;
445 $self->{_show_generated} = 0;
446 $self->{_output_long} = 1;
447 $self->{_output_idonly} = 0;
448 $self->{_output_brief} = 0;
449 $self->{_output_flatq} = 0;
450 $self->{_show_vars} = [];
459 $self->{_output_long} = 1;
460 $self->{_output_idonly} = 0;
461 $self->{_output_brief} = 0;
462 $self->{_output_flatq} = 0;
468 $self->{_output_long} = 0;
469 $self->{_output_idonly} = 1;
470 $self->{_output_brief} = 0;
471 $self->{_output_flatq} = 0;
477 $self->{_output_long} = 0;
478 $self->{_output_idonly} = 0;
479 $self->{_output_brief} = 1;
480 $self->{_output_flatq} = 0;
486 $self->{_output_long} = 0;
487 $self->{_output_idonly} = 0;
488 $self->{_output_brief} = 0;
489 $self->{_output_flatq} = 1;
496 foreach my $v (split(/\s*,\s*/, $s)) {
497 push(@{$self->{_show_vars}}, $v);
501 sub set_show_generated {
503 $self->{_show_generated} = shift;
506 sub set_undelivered_only {
508 $self->{_undelivered_only} = shift;
513 return $self->{_error};
518 $self->{_error} = shift;
525 $self->{_error} = '';
526 $self->{_delivered} = 0;
527 $self->{_message} = '';
531 $self->{_numrecips} = 0;
532 $self->{_udel_tree} = {};
533 $self->{_del_tree} = {};
534 $self->{_recips} = {};
543 $self->{_message} = shift || return(0);
544 $self->{_path} = shift; # optional path to message
545 return(0) if (!$self->{_spool_dir});
546 if (!$self->{_path} && !$self->_find_path()) {
547 # assume the message was delivered from under us and ignore
548 $self->{_delivered} = 1;
551 $self->_parse_header() || return(0);
556 # take the output of get_state() and set up a message internally like
557 # parse_message (except from a saved data struct, not by parsing the
563 return(1) if ($h->{_delivered});
565 $self->{_message} = $h->{_message} || return(0);
566 return(0) if (!$self->{_spool_dir});
568 $self->{_path} = $h->{_path};
569 $self->{_vars} = $h->{_vars};
570 $self->{_numrecips} = $h->{_numrecips};
571 $self->{_udel_tree} = $h->{_udel_tree};
572 $self->{_del_tree} = $h->{_del_tree};
573 $self->{_recips} = $h->{_recips};
575 $self->{_vars}{message_age} = time() - $self->{_vars}{received_time};
579 # This returns the state data for a specific message in a format that can
580 # be later frozen back in to regain state
582 # after calling this function, this specific state is not expect to be
583 # reused. That's because we're returning direct references to specific
584 # internal structures. We're also modifying the structure ourselves
585 # by deleting certain internal message variables.
588 my $h = {}; # this is the hash ref we'll be returning.
590 $h->{_delivered} = $self->{_delivered};
591 $h->{_message} = $self->{_message};
592 $h->{_path} = $self->{_path};
593 $h->{_vars} = $self->{_vars};
594 $h->{_numrecips} = $self->{_numrecips};
595 $h->{_udel_tree} = $self->{_udel_tree};
596 $h->{_del_tree} = $self->{_del_tree};
597 $h->{_recips} = $self->{_recips};
599 # delete some internal variables that we will rebuild later if needed
600 delete($h->{_vars}{message_body});
601 delete($h->{_vars}{message_age});
606 # keep this sub as a feature if we ever break this module out, but do away
607 # with its use in exipick (pass it in from caller instead)
611 return(0) if (!$self->{_message});
612 return(0) if (!$self->{_spool_dir});
614 # test split spool first on the theory that people concerned about
615 # performance will have split spool set =).
616 foreach my $f (substr($self->{_message}, 5, 1).'/', '') {
617 if (-f "$self->{_spool_dir}/input/$f$self->{_message}-H") {
618 $self->{_path} = $self->{_spool_dir} . "/input/$f";
627 $self->{_spool_dir} = shift;
630 # accepts a variable with or without leading '$' or trailing ':'
639 if ($var eq 'message_body' && !$self->{_vars}{message_body});
641 chomp($self->{_vars}{$var});
642 return $self->{_vars}{$var};
647 my $f = $self->{_path} . '/' . $self->{_message} . '-D';
649 open(I, "<$f") || return($self->_error("Couldn't open $f: $!"));
651 return(0) if ($self->{_message}.'-D' ne $_);
653 $self->{_vars}{message_body} = join('', <I>);
655 $self->{_vars}{message_body} =~ s/\n/ /g;
656 $self->{_vars}{message_body} =~ s/\000/ /g;
662 my $f = $self->{_path} . '/' . $self->{_message} . '-H';
664 if (!open(I, "<$f")) {
665 # assume message went away and silently ignore
666 $self->{_delivered} = 1;
671 return(0) if ($self->{_message}.'-H' ne $_);
672 $self->{_vars}{message_id} = $self->{_message};
673 $self->{_vars}{message_exim_id} = $self->{_message};
677 return(0) if (!/^(.+)\s(\-?\d+)\s(\-?\d+)$/);
678 $self->{_vars}{originator_login} = $1;
679 $self->{_vars}{originator_uid} = $2;
680 $self->{_vars}{originator_gid} = $3;
684 return(0) if (!/^<(.*)>$/);
685 $self->{_vars}{sender_address} = $1;
686 $self->{_vars}{sender_address_domain} = $1;
687 $self->{_vars}{sender_address_local_part} = $1;
688 $self->{_vars}{sender_address_domain} =~ s/^.*\@//;
689 $self->{_vars}{sender_address_local_part} =~ s/^(.*)\@.*$/$1/;
693 return(0) if (!/^(\d+)\s(\d+)$/);
694 $self->{_vars}{received_time} = $1;
695 $self->{_vars}{warning_count} = $2;
696 $self->{_vars}{message_age} = time() - $self->{_vars}{received_time};
700 if (/^(-\S+)\s*(.*$)/) {
703 if ($tag eq '-acl') {
705 return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
706 if ($1 < $Exim::SpoolFile::ACL_C_MAX_LEGACY) {
709 $t = "acl_m" . ($1 - $Exim::SpoolFile::ACL_C_MAX_LEGACY);
711 read(I, $self->{_vars}{$t}, $2+1) || return(0);
712 chomp($self->{_vars}{$t});
713 } elsif ($tag eq '-aclc') {
714 return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
716 read(I, $self->{_vars}{$t}, $2+1) || return(0);
717 chomp($self->{_vars}{$t});
718 } elsif ($tag eq '-aclm') {
719 return(0) if ($arg !~ /^(\d+)\s(\d+)$/);
721 read(I, $self->{_vars}{$t}, $2+1) || return(0);
722 chomp($self->{_vars}{$t});
723 } elsif ($tag eq '-local') {
724 $self->{_vars}{sender_local} = 1;
725 } elsif ($tag eq '-localerror') {
726 $self->{_vars}{local_error_message} = 1;
727 } elsif ($tag eq '-local_scan') {
728 $self->{_vars}{local_scan_data} = $arg;
729 } elsif ($tag eq '-spam_score_int') {
730 $self->{_vars}{spam_score_int} = $arg;
731 $self->{_vars}{spam_score} = $arg / 10;
732 } elsif ($tag eq '-bmi_verdicts') {
733 $self->{_vars}{bmi_verdicts} = $arg;
734 } elsif ($tag eq '-host_lookup_deferred') {
735 $self->{_vars}{host_lookup_deferred} = 1;
736 } elsif ($tag eq '-host_lookup_failed') {
737 $self->{_vars}{host_lookup_failed} = 1;
738 } elsif ($tag eq '-body_linecount') {
739 $self->{_vars}{body_linecount} = $arg;
740 } elsif ($tag eq '-body_zerocount') {
741 $self->{_vars}{body_zerocount} = $arg;
742 } elsif ($tag eq '-frozen') {
743 $self->{_vars}{deliver_freeze} = 1;
744 $self->{_vars}{deliver_frozen_at} = $arg;
745 } elsif ($tag eq '-allow_unqualified_recipient') {
746 $self->{_vars}{allow_unqualified_recipient} = 1;
747 } elsif ($tag eq '-allow_unqualified_sender') {
748 $self->{_vars}{allow_unqualified_sender} = 1;
749 } elsif ($tag eq '-deliver_firsttime') {
750 $self->{_vars}{deliver_firsttime} = 1;
751 $self->{_vars}{first_delivery} = 1;
752 } elsif ($tag eq '-manual_thaw') {
753 $self->{_vars}{deliver_manual_thaw} = 1;
754 $self->{_vars}{manually_thawed} = 1;
755 } elsif ($tag eq '-auth_id') {
756 $self->{_vars}{authenticated_id} = $arg;
757 } elsif ($tag eq '-auth_sender') {
758 $self->{_vars}{authenticated_sender} = $arg;
759 } elsif ($tag eq '-sender_set_untrusted') {
760 $self->{_vars}{sender_set_untrusted} = 1;
761 } elsif ($tag eq '-tls_certificate_verified') {
762 $self->{_vars}{tls_certificate_verified} = 1;
763 } elsif ($tag eq '-tls_cipher') {
764 $self->{_vars}{tls_cipher} = $arg;
765 } elsif ($tag eq '-tls_peerdn') {
766 $self->{_vars}{tls_peerdn} = $arg;
767 } elsif ($tag eq '-host_address') {
768 $self->{_vars}{sender_host_port} = $self->_get_host_and_port(\$arg);
769 $self->{_vars}{sender_host_address} = $arg;
770 } elsif ($tag eq '-interface_address') {
771 $self->{_vars}{interface_port} = $self->_get_host_and_port(\$arg);
772 $self->{_vars}{interface_address} = $arg;
773 } elsif ($tag eq '-active_hostname') {
774 $self->{_vars}{smtp_active_hostname} = $arg;
775 } elsif ($tag eq '-host_auth') {
776 $self->{_vars}{sender_host_authenticated} = $arg;
777 } elsif ($tag eq '-host_name') {
778 $self->{_vars}{sender_host_name} = $arg;
779 } elsif ($tag eq '-helo_name') {
780 $self->{_vars}{sender_helo_name} = $arg;
781 } elsif ($tag eq '-ident') {
782 $self->{_vars}{sender_ident} = $arg;
783 } elsif ($tag eq '-received_protocol') {
784 $self->{_vars}{received_protocol} = $arg;
785 } elsif ($tag eq '-N') {
786 $self->{_vars}{dont_deliver} = 1;
788 # unrecognized tag, save it for reference
789 $self->{$tag} = $arg;
796 # when we drop out of the while loop, we have the first line of the
797 # delivered tree in $_
801 } elsif ($_ =~ s/^[YN][YN]\s+//) {
802 $self->{_del_tree}{$_} = 1;
807 } while ($_ !~ /^\d+$/);
809 $self->{_numrecips} = $_;
810 $self->{_vars}{recipients_count} = $self->{_numrecips};
811 for (my $i = 0; $i < $self->{_numrecips}; $i++) {
815 if (/^(.*)\s\d+,(\d+),\d+$/) {
816 #print STDERR "exim3 type (untested): $_\n";
817 $self->{_recips}{$1} = { pno => $2 };
819 } elsif (/^(.*)\s(\d+)$/) {
820 #print STDERR "exim4 original type (untested): $_\n";
821 $self->{_recips}{$1} = { pno => $2 };
823 } elsif (/^(.*)\s(.*)\s(\d+),(\d+)#1$/) {
824 #print STDERR "exim4 new type #1 (untested): $_\n";
825 return($self->_error("incorrect format: $_")) if (length($2) != $3);
826 $self->{_recips}{$1} = { pno => $4, errors_to => $2 };
828 } elsif (/^.*#(\d+)$/) {
829 #print STDERR "exim4 #$1 style (unimplemented): $_\n";
830 $self->_error("exim4 #$1 style (unimplemented): $_");
832 #print STDERR "default type: $_\n";
833 $self->{_recips}{$_} = {};
836 $self->{_udel_tree}{$addr} = 1 if (!$self->{_del_tree}{$addr});
838 $self->{_vars}{recipients} = join(', ', keys(%{$self->{_recips}}));
839 $self->{_vars}{recipients_del} = join(', ', keys(%{$self->{_del_tree}}));
840 $self->{_vars}{recipients_undel} = join(', ', keys(%{$self->{_udel_tree}}));
841 $self->{_vars}{recipients_undel_count} = scalar(keys(%{$self->{_udel_tree}}));
842 $self->{_vars}{recipients_del_count} = 0;
843 foreach my $r (keys %{$self->{_del_tree}}) {
844 next if (!$self->{_recips}{$r});
845 $self->{_vars}{recipients_del_count}++;
850 return(0) if (!/^$/);
852 # start reading headers
853 while (read(I, $_, 3) == 3) {
855 return(0) if (!length($t));
856 while ($t =~ /^\d$/) {
860 # ok, right here $t contains the header flag and $_ contains the number of
861 # bytes to read. If we ever use the header flag, grab it here.
862 $self->{_vars}{message_size} += $_ if ($t ne '*');
863 $t = getc(I); # strip the space out of the file
865 return(0) if (read(I, $_, $bytes) != $bytes);
866 $self->{_vars}{message_linecount} += (tr/\n//) if ($t ne '*');
868 # build the $header_ variable, following exim's rules (sort of)
869 my($v,$d) = split(/:/, $_, 2);
870 $v = "header_" . lc($v);
873 $self->{_vars}{$v} .= "$d\n";
874 $self->{_vars}{received_count}++ if ($v eq 'header_received');
875 # push header onto $message_headers var, following exim's rules
876 $self->{_vars}{message_headers} .= $_;
879 # remove trailing newline from $message_headers
880 chomp($self->{_vars}{message_headers});
882 if (length($self->{_vars}{"header_reply-to"}) > 0) {
883 $self->{_vars}{reply_address} = $self->{_vars}{"header_reply-to"};
885 $self->{_vars}{reply_address} = $self->{_vars}{header_from};
888 $self->{_vars}{message_body_size} =
889 (stat($self->{_path}.'/'.$self->{_message}.'-D'))[7] - 19;
890 if ($self->{_vars}{message_body_size} < 0) {
891 $self->{_vars}{message_size} = 0;
893 $self->{_vars}{message_size} += $self->{_vars}{message_body_size} + 1;
896 $self->{_vars}{message_linecount} += $self->{_vars}{body_linecount};
898 my $i = $self->{_vars}{message_size};
899 if ($i == 0) { $i = ""; }
900 elsif ($i < 1024) { $i = sprintf("%d", $i); }
901 elsif ($i < 10240) { $i = sprintf("%.1fK", $i / 1024); }
902 elsif ($i < 1048576) { $i = sprintf("%dK", ($i+512)/1024); }
903 elsif ($i < 10485760) { $i = sprintf("%.1fM", $i/1048576); }
904 else { $i = sprintf("%dM", ($i + 524288)/1048576); }
905 $self->{_vars}{shown_message_size} = $i;
910 # mimic exim's host_extract_port function - receive a ref to a scalar,
911 # strip it of port, return port
912 sub _get_host_and_port {
914 my $host = shift; # scalar ref, be careful
916 if ($$host =~ /^\[([^\]]+)\](?:\:(\d+))?$/) {
919 } elsif ($$host =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})(?:\.(\d+))?$/) {
922 } elsif ($$host =~ /^([\d\:]+)(?:\.(\d+))?$/) {
930 # honoring all formatting preferences, return a scalar variable of the
931 # information for the single message matching what exim -bp would show.
932 # We can print later if we want.
936 return if ($self->{_delivered});
938 if ($self->{_output_idonly}) {
939 $o .= $self->{_message};
940 foreach my $v (@{$self->{_show_vars}}) {
941 $o .= " $v='" . $self->get_var($v) . "'";
947 if ($self->{_output_long} || $self->{_output_flatq}) {
948 my $i = int($self->{_vars}{message_age} / 60);
950 $i = int(($i+30)/60);
951 if ($i > 72) { $o .= sprintf "%2dd ", int(($i+12)/24); }
952 else { $o .= sprintf "%2dh ", $i; }
953 } else { $o .= sprintf "%2dm ", $i; }
955 if ($self->{_output_flatq} && $self->{_show_vars}) {
956 $o .= join(';', map { "$_='".$self->get_var($_)."'" }
957 (@{$self->{_show_vars}})
960 $o .= sprintf "%5s", $self->{_vars}{shown_message_size};
964 $o .= "$self->{_message} ";
965 $o .= "From: " if ($self->{_output_brief});
966 $o .= "<$self->{_vars}{sender_address}>";
968 if ($self->{_output_long}) {
969 $o .= " ($self->{_vars}{originator_login})"
970 if ($self->{_vars}{sender_set_untrusted});
972 # XXX exim contains code here to print spool format errors
973 $o .= " *** frozen ***" if ($self->{_vars}{deliver_freeze});
976 foreach my $v (@{$self->{_show_vars}}) {
977 $o .= sprintf " %25s = '%s'\n", $v, $self->get_var($v);
980 foreach my $r (keys %{$self->{_recips}}) {
981 next if ($self->{_del_tree}{$r} && $self->{_undelivered_only});
982 $o .= sprintf " %s %s\n", $self->{_del_tree}{$r} ? "D" : " ", $r;
984 if ($self->{_show_generated}) {
985 foreach my $r (keys %{$self->{_del_tree}}) {
986 next if ($self->{_recips}{$r});
987 $o .= sprintf " +D %s\n", $r;
990 } elsif ($self->{_output_brief}) {
992 foreach my $r (keys %{$self->{_recips}}) {
993 next if ($self->{_del_tree}{$r});
996 $o .= " To: " . join(';', @r);
997 if ($self->{_show_vars} && scalar(@{$self->{_show_vars}})) {
998 $o .= " Vars: " . join(';', map { "$_='".$self->get_var($_)."'" }
999 (@{$self->{_show_vars}})
1002 } elsif ($self->{_output_flatq}) {
1003 $o .= " *** frozen ***" if ($self->{_vars}{deliver_freeze});
1005 foreach my $r (keys %{$self->{_recips}}) {
1006 next if ($self->{_del_tree}{$r});
1009 $o .= " " . join(' ', @r);
1018 my $fh = shift || \*STDOUT;
1019 return if ($self->{_delivered});
1021 print $fh $self->format_message();
1027 foreach my $k (sort keys %$self) {
1028 my $r = ref($self->{$k});
1029 if ($r eq 'ARRAY') {
1030 printf "%20s <<EOM\n", $k;
1031 print @{$self->{$k}}, "EOM\n";
1032 } elsif ($r eq 'HASH') {
1033 printf "%20s <<EOM\n", $k;
1034 foreach (sort keys %{$self->{$k}}) {
1035 printf "%20s %s\n", $_, $self->{$k}{$_};
1039 printf "%20s %s\n", $k, $self->{$k};
1047 if ($ARGV[0] =~ /^--help$/i) {
1049 $ENV{PATH} .= ":" unless $ENV{PATH} eq "";
1050 $ENV{PATH} = "$ENV{PATH}$Config::Config{'installscript'}";
1051 #exec("perldoc", "-F", "-U", $0) || exit 1;
1052 $< = $> = 1 if ($> == 0 || $< == 0);
1053 exec("perldoc", $0) || exit 1;
1055 %Config::Config = ();
1056 } elsif ($ARGV[0] =~ /^--version$/i) {
1057 print "$p_name version $p_version\n\n$p_cp\n";
1069 exipick - selectively display messages from an Exim queue
1073 exipick [<options>] [<criterion> [<criterion> ...]]
1077 exipick is a tool to display messages in an Exim queue. It is very similar to exiqgrep and is, in fact, a drop in replacement for exiqgrep. exipick allows you to select messages to be displayed using any piece of data stored in an Exim spool file. Matching messages can be displayed in a variety of formats.
1081 Delete every frozen message from queue:
1082 exipick -zi | xargs exim -Mrm
1084 Show only messages which have not yet been virus scanned:
1085 exipick '$received_protocol ne virus-scanned'
1087 Run the queue in a semi-random order:
1088 exipick -i --random | xargs exim -M
1090 Show the count and total size of all messages which either originated from localhost or have a received protocol of 'local':
1091 exipick --or --size --bpc \
1092 '$sender_host_address eq 127.0.0.1' \
1093 '$received_protocol eq local'
1095 Display all messages received on the MSA port, ordered first by the sender's email domain and then by the size of the emails:
1096 exipick --sort sender_address_domain,message_size \
1097 '$interface_port == 587'
1099 Display only messages whose every recipient is in the example.com domain, also listing the IP address of the sending host:
1100 exipick --show-vars sender_host_address \
1101 '$each_recipients = example.com'
1109 Display messages matching all criteria (default)
1113 Display messages in brief format (exiqgrep)
1117 Display messages in standard mailq format (default)
1121 Same as -bp, show generated addresses also (exim)
1125 Show a count of matching messages (exim)
1129 Same as '-bp --unsorted' (exim)
1133 Same as '-bpr --unsorted' (exim)
1137 Same as '-bpu --unsorted' (exim)
1141 Same as -bp, but only show undelivered messages (exim)
1145 Show a count of matching messages (exiqgrep)
1149 Make operators involving '=' honor case
1153 Same as '$sender_address = <regexp>' (exiqgrep)
1157 Use a single-line output format
1159 =item --freeze <cache file>
1161 Save queue information in an quickly retrievable format
1169 Display only the message IDs (exiqgrep)
1173 Same as -bp (exiqgrep)
1181 Same as '$message_age > <seconds>' (exiqgrep)
1185 Display messages matching any criteria
1189 Same as --reverse (exiqgrep)
1193 Same as '$recipients = <regexp>' (exiqgrep)
1197 Display messages in random order
1201 Display messages in reverse order
1205 Same as '$shown_message_size eq <string>' (exiqgrep)
1207 =item --spool <path>
1209 Set the path to the exim spool to use
1213 Show the internal representation of each criterion specified
1217 Show the result of each criterion on each message
1219 =item --show-vars <variable>[,<variable>...]
1221 Show the value for <variable> for each displayed message
1225 Show the total bytes used by each displayed message
1227 =item --thaw <cache file>
1229 Read queue information cached from a previous --freeze run
1231 =item --sort <variable>[,<variable>...]
1233 Display matching messages sorted according to <variable>
1237 Do not apply any sorting to output
1241 Display the version of this command
1245 Same as '!$deliver_freeze' (exiqgrep)
1249 Same as '$message_age < <seconds>' (exiqgrep)
1253 Same as '$deliver_freeze' (exiqgrep)
1259 Exipick decides which messages to display by applying a test against each message. The rules take the general form of 'VARIABLE OPERATOR VALUE'. For example, '$message_age > 60'. When exipick is deciding which messages to display, it checks the $message_age variable for each message. If a message's age is greater than 60, the message will be displayed. If the message's age is 60 or less seconds, it will not be displayed.
1261 Multiple criteria can be used. The order they are specified does not matter. By default all criteria must evaluate to true for a message to be displayed. If the --or option is used, a message is displayed as long as any of the criteria evaluate to true.
1263 See the VARIABLES and OPERATORS sections below for more details
1271 Boolean variables are checked simply by being true or false. There is no real operator except negation. Examples of valid boolean tests:
1277 Valid comparisons are <, <=, >, >=, ==, and !=. Numbers can be integers or floats. Any number in a test suffixed with d, h, m, s, M, K, or B will be mulitplied by 86400, 3600, 60, 1, 1048576, 1024, or 1 respectively. Examples of valid numeric tests:
1278 '$message_age >= 3d'
1279 '$local_interface == 587'
1280 '$message_size < 30K'
1284 The string operators are =, eq, ne, =~, and !~. With the exception of '=', the operators all match the functionality of the like-named perl operators. eq and ne match a string exactly. !~, =~, and = apply a perl regular expression to a string. The '=' operator behaves just like =~ but you are not required to place // around the regular expression. Examples of valid string tests:
1285 '$received_protocol eq esmtp'
1286 '$sender_address = example.com'
1287 '$each_recipients =~ /^a[a-z]{2,3}@example.com$/'
1291 There are many ways to negate tests, each having a reason for existing. Many tests can be negated using native operators. For instance, >1 is the opposite of <=1 and eq and ne are opposites. In addition, each individual test can be negated by adding a ! at the beginning of the test. For instance, '!$acl_m1 =~ /^DENY$/' is the same as '$acl_m1 !~ /^DENY$/'. Finally, every test can be specified by using the command line argument --not. This is functionally equivilant to adding a ! to the beginning of every test.
1297 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.
1299 Internally, all variables are represented as strings, meaning any operator will work on any variable. This means that '$sender_host_name > 4' is a legal criterion, even if it does not produce meaningful results. Variables in the list below are marked with a 'type' to help in choosing which types of operators make sense to use.
1302 B - Boolean variables
1303 S - String variables
1304 N - Numeric variables
1305 . - Standard variable matching Exim's content definition
1306 # - Standard variable, contents differ from Exim's definition
1307 + - Non-standard variable
1311 =item S . $acl_c0-$acl_c9, $acl_m0-$acl_m9
1313 User definable variables.
1315 =item B + $allow_unqualified_recipient
1317 TRUE if unqualified recipient addresses are permitted in header lines.
1319 =item B + $allow_unqualified_sender
1321 TRUE if unqualified sender addresses are permitted in header lines.
1323 =item S . $authenticated_id
1325 Optional saved information from authenticators, or the login name of the calling process for locally submitted messages.
1327 =item S . $authenticated_sender
1329 The value of AUTH= param for smtp messages, or a generated value from the calling processes login and qualify domain for locally submitted messages.
1331 =item S + $bmi_verdicts
1333 The verdict string provided by a Brightmail content scan
1335 =item N . $body_linecount
1337 The number of lines in the message's body.
1339 =item N . $body_zerocount
1341 The number of binary zero bytes in the message's body.
1343 =item B + $deliver_freeze
1345 TRUE if the message is currently frozen.
1347 =item N + $deliver_frozen_at
1349 The epoch time at which message was frozen.
1351 =item B + $dont_deliver
1353 TRUE if, under normal circumstances, Exim will not try to deliver the message.
1355 =item S + $each_recipients
1357 This is a psuedo variable which allows you to apply a test against each address in $recipients individually. Whereas '$recipients =~ /@aol.com/' will match if any recipient address contains aol.com, '$each_recipients =~ /@aol.com$/' will only be true if every recipient matches that pattern. Note that this obeys --and or --or being set. Using it with --or is very similar to just matching against $recipients, but with the added benefit of being able to use anchors at the beginning and end of each recipient address.
1359 =item S + $each_recipients_del
1361 Like $each_recipients, but for $recipients_del
1363 =item S + $each_recipients_undel
1365 Like $each_recipients, but for $recipients_undel
1367 =item B . $first_delivery
1369 TRUE if the message has never been deferred.
1373 The value of the same named message header. These variables are really closer to Exim's rheader_* variables, with the exception that leading and trailing space is removed.
1375 =item B . $host_lookup_deferred
1377 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.
1379 =item B . $host_lookup_failed
1381 TRUE if there was an attempt to look up the host's name from its IP address, but the attempt returned a negative result.
1383 =item S . $interface_address
1385 The address of the local IP interface for network-originated messages.
1387 =item N . $interface_port
1389 The local port number if network-originated messages.
1391 =item B + $local_error_message
1393 TRUE if the message is a locally-generated error message.
1395 =item S . $local_scan_data
1397 The text returned by the local_scan() function when a message is received.
1399 =item B . $manually_thawed
1401 TRUE when the message has been manually thawed.
1403 =item N . $message_age
1405 The number of seconds since the message was received.
1407 =item S # $message_body
1409 The message's body. Unlike Exim's variable of the same name, this variable contains the entire message body. Newlines and nulls are replaced by spaces.
1411 =item N . $message_body_size
1413 The size of the body in bytes.
1415 =item S . $message_exim_id, $message_id
1417 The unique message id that is used by Exim to identify the message. $message_id is deprecated as of Exim 4.53.
1419 =item S . $message_headers
1421 A concatenation of all the header lines except for lines added by routers or transports.
1423 =item N . $message_linecount
1425 The number of lines in the entire message (body and headers).
1427 =item N . $message_size
1429 The size of the message in bytes.
1431 =item N . $originator_gid
1433 The group id under which the process that called Exim was running as when the message was received.
1435 =item S + $originator_login
1437 The login of the process which called Exim.
1439 =item N . $originator_uid
1441 The user id under which the process that called Exim was running as when the message was received.
1443 =item N . $received_count
1445 The number of Received: header lines in the message.
1447 =item S . $received_protocol
1449 The name of the protocol by which the message was received.
1451 =item N . $received_time
1453 The epoch time at which the message was received.
1455 =item S # $recipients
1457 The list of envelope recipients for a message. Unlike Exim's version, this variable always contains every recipient of the message. The recipients are seperated by a comma and a space. See also $each_recipients.
1459 =item N . $recipients_count
1461 The number of envelope recipients for the message.
1463 =item S + $recipients_del
1465 The list of delivered envelope recipients for a message. This non-standard variable is in the same format as $recipients and contains the list of already-delivered recipients including any generated addresses. See also $each_recipients_del.
1467 =item N + $recipients_del_count
1469 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.
1471 =item S + $recipients_undel
1473 The list of undelivered envelope recipients for a message. This non-standard variable is in the same format as $recipients and contains the list of undelivered recipients. See also $each_recipients_undel.
1475 =item N + $recipients_undel_count
1477 The number of envelope recipients for the message which have not yet been delivered.
1479 =item S . $reply_address
1481 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.
1483 =item S . $sender_address
1485 The sender's address that was received in the message's envelope. For bounce messages, the value of this variable is the empty string.
1487 =item S . $sender_address_domain
1489 The domain part of $sender_address.
1491 =item S . $sender_address_local_part
1493 The local part of $sender_address.
1495 =item S . $sender_helo_name
1497 The HELO or EHLO value supplied for smtp or bsmtp messages.
1499 =item S . $sender_host_address
1501 The remote host's IP address.
1503 =item S . $sender_host_authenticated
1505 The name of the authenticator driver which successfully authenticated the client from which the message was received.
1507 =item S . $sender_host_name
1509 The remote host's name as obtained by looking up its IP address.
1511 =item N . $sender_host_port
1513 The port number that was used on the remote host for network-originated messages.
1515 =item S . $sender_ident
1517 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.
1519 =item B + $sender_local
1521 TRUE if the message was locally generated.
1523 =item B + $sender_set_untrusted
1525 TRUE if the envelope sender of this message was set by an untrusted local caller.
1527 =item S + $shown_message_size
1529 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.
1531 =item S . $smtp_active_hostname
1533 The value of the active host name when the message was received, as specified by the "smtp_active_hostname" option.
1535 =item S . $spam_score
1537 The spam score of the message, for example '3.4' or '30.5'. (Requires exiscan or WITH_CONTENT_SCAN)
1539 =item S . $spam_score_int
1541 The spam score of the message, multiplied by ten, as an integer value. For instance '34' or '305'. (Requires exiscan or WITH_CONTENT_SCAN)
1543 =item B . $tls_certificate_verified
1545 TRUE if a TLS certificate was verified when the message was received.
1547 =item S . $tls_cipher
1549 The cipher suite that was negotiated for encrypted SMTP connections.
1551 =item S . $tls_peerdn
1553 The value of the Distinguished Name of the certificate if Exim is configured to request one
1555 =item N + $warning_count
1557 The number of delay warnings which have been sent for this message.
1565 =item EMAIL: proj-exipick@jetmore.net
1567 =item HOME: jetmore.org/john/code/#exipick