SUPPORT_TRANSLATE_IP_ADDRESS didn't cause any output from -bV.
[exim.git] / src / src / exiqgrep.src
1 #!PERL_COMMAND
2 # $Cambridge: exim/src/src/exiqgrep.src,v 1.1 2004/10/07 10:39:01 ph10 Exp $
3
4 # Utility for searching and displaying queue information.
5 # Written by Matt Hubbard 15 August 2002
6
7 # Except when they appear in comments, the following placeholders in this
8 # source are replaced when it is turned into a runnable script:
9 #
10 # BIN_DIRECTORY
11 # PERL_COMMAND
12
13 # PROCESSED_FLAG
14
15
16 # Routine for extracting the UTC timestamp from message ID
17 # lifted from eximstat utility
18
19 # Version 1.1
20
21 use strict;
22 use Getopt::Std;
23
24 # Have this variable point to your exim binary.
25 my $exim = 'BIN_DIRECTORY/exim';
26 my $eargs = '-bpu';
27 my %id;
28 my %opt;
29 my $count = 0;
30 my $mcount = 0;
31 my @tab62 =
32   (0,1,2,3,4,5,6,7,8,9,0,0,0,0,0,0,     # 0-9
33    0,10,11,12,13,14,15,16,17,18,19,20,  # A-K
34   21,22,23,24,25,26,27,28,29,30,31,32,  # L-W
35   33,34,35, 0, 0, 0, 0, 0,              # X-Z
36    0,36,37,38,39,40,41,42,43,44,45,46,  # a-k
37   47,48,49,50,51,52,53,54,55,56,57,58,  # l-w
38   59,60,61);                            # x-z
39
40 my $base;
41 if ($^O eq 'darwin') { # aka MacOS X
42   $base = 36;
43  } else {
44   $base = 62;
45 };
46
47 getopts('hf:r:y:o:s:zxlibRc',\%opt);
48 if ($opt{h}) { &help; exit;}
49
50 # Read message queue output into hash
51 &collect();
52 # Identify which messages match selection criteria
53 &selection();
54 # Print matching data according to display option.
55 &display();
56 exit;
57
58
59 sub help() {
60         print <<'EOF'
61 Exim message queue display utility.
62
63         -h              This help message.
64
65 Selection criteria:
66         -f <regexp>     Match sender address sender (field is "< >" wrapped)
67         -r <regexp>     Match recipient address
68         -s <regexp>     Match against the size field from long output
69         -y <seconds>    Message younger than
70         -o <seconds>    Message older than
71         -z              Frozen messages only (exclude non-frozen)
72         -x              Non-frozen messages only (exclude frozen)
73
74 [ NB: for regexps, provided string sits in /<string>/ ]
75
76 Display options:
77         -c              Display match count
78         -l              Long Format [Default]
79         -i              Message IDs only
80         -b              Brief Format
81         -R              Reverse order
82 EOF
83 }
84
85 sub collect() {
86         open(QUEUE,"$exim $eargs |") or die("Error openning pipe: $!\n");
87         while(<QUEUE>) {
88                 chomp();
89                 my $line = $_;
90                 #Should be 1st line of record, if not error.
91                 if ($line =~ /^\s*(\w+)\s+(\S+)\s+(\w{6}-\w{6}-\w{2})\s+(<.*?>)/) {
92                         my $msg = $3;
93                         $id{$msg}{age} = $1;
94                         $id{$msg}{size} = $2;
95                         $id{$msg}{from} = $4;
96                         $id{$msg}{birth} = &msg_utc($msg);
97                         $id{$msg}{ages} = time - $id{$msg}{birth};
98                         if ($line =~ /\*\*\* frozen \*\*\*$/) {
99                                 $id{$msg}{frozen} = 1;
100                         } else {
101                                 $id{$msg}{frozen} = 0;
102                         }
103                         while(<QUEUE> =~ /\s+(.*?\@.*)$/) {
104                                 push(@{$id{$msg}{rcpt}},$1);
105                         }
106                         # Increment message counter.
107                         $count++;
108                 } else {
109                         print STDERR "Line mismatch: $line\n"; exit 1;
110                 }
111         }
112         close(QUEUE) or die("Error closing pipe: $!\n");
113 }
114
115 sub selection() {
116         foreach my $msg (keys(%id)) {
117                 if ($opt{f}) {
118                         # Match sender address
119                         next unless ($id{$msg}{from} =~ /$opt{f}/);
120                 }
121                 if ($opt{r}) {
122                         # Match any recipient address
123                         my $match = 0;
124                         foreach my $rcpt (@{$id{$msg}{rcpt}}) {
125                                 $match++ if ($rcpt =~ /$opt{r}/);
126                         }
127                         next unless ($match);
128                 }
129                 if ($opt{s}) {
130                         # Match against the size string.
131                         next unless ($id{$msg}{size} =~ /$opt{s}/);
132                 }
133                 if ($opt{y}) {
134                         # Match younger than
135                         next unless ($id{$msg}{ages} < $opt{y});
136                 }
137                 if ($opt{o}) {
138                         # Match older than
139                         next unless ($id{$msg}{ages} > $opt{o});
140                 }
141                 if ($opt{z}) {
142                         # Exclude non frozen
143                         next unless ($id{$msg}{frozen});
144                 }
145                 if ($opt{x}) {
146                         # Exclude frozen
147                         next if ($id{$msg}{frozen});
148                 }
149                 # Here's what we do to select the record.
150                 # Should only get this far if the message passed all of
151                 # the active tests.
152                 $id{$msg}{d} = 1;
153                 # Increment match counter.
154                 $mcount++;
155         }
156 }
157
158 sub display() {
159         if ($opt{c}) {
160                 printf("%d matches out of %d messages\n",$mcount,$count);
161                 exit;
162         }
163         foreach my $msg (sort { $opt{R} ? $id{$b}{birth} <=> $id{$a}{birth} : $id{$a}{birth} <=> $id{$b}{birth} } keys(%id) ) {
164                 if (exists($id{$msg}{d})) {
165                         if ($opt{i}) {
166                                 # Just the msg ID
167                                 print $msg, "\n";
168                         } elsif ($opt{b}) {
169                                 # Brief format
170                                 printf("%s From: %s To: %s\n",$msg,$id{$msg}{from},join(';',@{$id{$msg}{rcpt}}))
171                         } else {
172                                 # Otherwise Long format attempted duplication of original format.
173                                 printf("%3s %5s %s %s%s\n",$id{$msg}{age},$id{$msg}{size},$msg,$id{$msg}{from},$id{$msg}{frozen} ? " *** frozen ***" : "");
174                                 foreach my $rcpt (@{$id{$msg}{rcpt}}) {
175                                         printf("          %s\n",$rcpt);
176                                 }
177                                 print "\n";
178                         }
179                 }
180         }
181 }
182
183 sub report() {
184         foreach my $msg (keys(%id)) {
185                 print "$id{$msg}{birth} $msg\tAge: $id{$msg}{age}\tSize: $id{$msg}{size}\tFrom: $id{$msg}{from}\tTo: " . join(" ",@{$id{$msg}{rcpt}}). "\n";
186         }
187 }
188
189 sub msg_utc() {
190         my $id = substr((pop @_), 0, 6);
191         my $s = 0;
192         my @c = split(//, $id);
193         while($#c >= 0) { $s = $s * $base + $tab62[ord(shift @c) - ord('0')] }
194         return $s;
195 }