1package Log::Procmail;
2
3require 5.005;
4use strict;
5use IO::File;
6use IO::Select;
7use Carp;
8use UNIVERSAL ();
9
10use vars qw/ $VERSION /;
11local $^W = 1;
12
13$VERSION = '0.12';
14
15my %month;
16@month{qw/ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec /} = ( 0 .. 11 );
17
18my $DATE = qr/(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ([ \d]\d) (\d\d):(\d\d):(\d\d) .*(\d\d\d\d)/;
19
20sub new {
21    my $class = shift;
22    return bless {
23        fh     => new IO::File,
24        files  => [@_],
25        errors => 0,
26        buffer => [],
27    }, $class;
28}
29
30sub next {
31    my $log = shift;    # who needs $self?
32
33    # try to read a record (3 lines)
34    my $fh  = $log->fh();
35  READ:
36    {
37        my $read;
38
39      LINE:
40        while (<$fh>) {
41            $read++;
42
43            # should carp if doesn't get what's expected
44            # (From, then Subject, then Folder)
45
46            # From create a new Abstract
47            /^From (.+?) +($DATE)$/o && do {
48                push @{$log->{buffer}}, Log::Procmail::Abstract->new();
49
50                # assert: $read == 1;
51                $log->{buffer}[-1]->from($1);
52                $log->{buffer}[-1]->date($2);
53
54                # return ASAP
55                last READ if @{$log->{buffer}} > 1;
56                next LINE;
57            };
58
59            # assert: $read == 2;
60            /^ Subject: (.*)/i && do {
61                push @{$log->{buffer}}, Log::Procmail::Abstract->new()
62                    unless @{$log->{buffer}};
63                $log->{buffer}[0]->subject($1);
64                next LINE;
65            };
66
67            # procmail tabulates with tabs and spaces... :-(
68            # assert: $read == 3;
69            # Folder means the end of this record
70            /^  Folder: (.*?)\s+(\d+)$/ && do {
71                push @{$log->{buffer}}, Log::Procmail::Abstract->new()
72                  unless @{$log->{buffer}};
73
74                # assert: $read == 3;
75                $log->{buffer}[0]->folder($1);
76                $log->{buffer}[0]->size($2);
77                last READ;
78            };
79
80            # fall through: some error message
81            # shall we ignore it?
82            next LINE unless $log->{errors};
83
84            # or return it?
85            chomp;
86            push @{$log->{buffer}}, $_;
87            last LINE;
88        }
89
90        # in case we couldn't read the first line
91        if ( !$read or @{$log->{buffer}} == 0 ) {
92
93            # return ASAP
94            last READ if @{$log->{buffer}};
95
96            # go to next file
97            redo READ if $log->_open_next;
98
99            # unless it's the last one
100            return;
101        }
102    }
103
104    # we have an abstract
105    my $rec = shift @{$log->{buffer}};
106    if(UNIVERSAL::isa( $rec, 'Log::Procmail::Abstract')) {
107        # the folder field is required
108        goto READ unless defined $rec->folder;
109        $rec->{source} = $log->{source};
110    }
111
112    return $rec;
113}
114
115sub push {
116    my $log = shift;
117    push @{ $log->{files} }, @_;
118}
119
120sub errors {
121    my $self = shift;
122    return @_ ? $self->{errors} = shift() : $self->{errors};
123}
124
125sub fh {
126    my $log = shift;
127    $log->_open_next unless $log->{fh}->opened();
128    return $log->{fh};
129}
130
131sub select {
132    my $log = shift;
133    $log->fh(); # make sure the file is correctly opened and select is updated
134    return $log->{select};
135}
136
137# *internal method*
138# opens a file or replace the old filehandle by the new one
139# push() can therefore accept refs to typeglobs, IO::Handle, or filenames
140sub _open_next {
141    my ( $log ) = @_;
142    my $file;
143
144    if ( @{ $log->{files} } ) {
145        $file = shift @{ $log->{files} };
146    } else { return 0 };
147
148    if ( ref $file eq 'GLOB' ) {
149        $log->{fh} = *$file{IO};
150        carp "Closed filehandle $log->{fh}" unless $log->{fh}->opened;
151    }
152    elsif ( ref $file && $file->isa('IO::Handle') ) {
153        $log->{fh} = $file;
154    }
155    else {
156        $log->{fh}->open($file) or carp "Can't open $file: $!";
157    }
158    $log->{source} = $file;
159    $log->{select} = ( grep $^O eq $_, qw(MSWin32 NetWare dos VMS riscos beos) )
160                   ? undef
161                   : IO::Select->new( $log->{fh} );
162    1;
163}
164
165sub DESTROY {
166    my $self = shift;
167    if ( $self->{fh} && $self->{fh}->opened ) { $self->{fh}->close }
168}
169
170#
171# a small class for the abstracts themselves
172#
173package Log::Procmail::Abstract;
174
175use Carp;
176
177sub new {
178    my $class = shift;
179    return bless {@_}, $class;
180}
181
182for my $attr (qw( from date subject size folder source ) ) {
183    no strict 'refs';
184    *$attr = sub {
185        my $self = shift;
186        @_ ? $self->{$attr} = shift: $self->{$attr};
187    }
188}
189
190sub ymd {
191    my $self = shift;
192    croak("Log::Procmail::Abstract::ymd cannot be used to set the date")
193      if @_;
194    return undef unless defined $self->{date};
195    $self->{date} =~ /^$DATE$/o;
196    return undef unless $1;
197    return sprintf( "%04d%02d%02d$3$4$5", $6, $month{$1} + 1, $2 );
198}
199
2001;
201
202__END__
203
204=encoding iso-8859-1
205
206=head1 NAME
207
208Log::Procmail - Perl extension for reading procmail logfiles.
209
210=head1 SYNOPSIS
211
212    use Log::Procmail;
213
214    my $log = new Log::Procmail 'procmail.log';
215
216    # loop on every abstract
217    while(my $rec = $log->next) {
218        # do something with $rec->folder, $rec->size, etc.
219    }
220
221=head1 DESCRIPTION
222
223=head2 Log::Procmail
224
225Log::Procmail reads procmail(1) logfiles and returns the abstracts one by one.
226
227=over 4
228
229=item $log = Log::Procmail->new( @files );
230
231Constructor for the procmail log reader.  Returns a reference to a
232Log::Procmail object.
233
234The constructor accepts a list of file as parameter. This allows you to
235read records from several files in a row:
236
237    $log = Log::Procmail->new( "$ENV{HOME}/.procmail/log.2",
238                               "$ENV{HOME}/.procmail/log.1",
239                               "$ENV{HOME}/.procmail/log", );
240
241When $log reaches the end of the file "log", it doesn't close the file.
242So, after B<procmail> processes some incoming mail, the next call to next()
243will return the new records.
244
245=item $rec = $log->next
246
247Return a Log::Procmail::Abstract object that represent an entry in the log
248file. Return undef if there is no record left in the file.
249
250When the Log::Procmail object reaches the end of a file, and this file is
251not the last of the stack, it closes the current file and opens the next
252one.
253
254When it reaches the end of the last file, the file is not closed. Next
255time the record method is called, it will check again in case new abstracts
256were appended.
257
258Procmail(1) log look like the following:
259
260    From karen644552@btinternet.com  Fri Feb  8 20:37:24 2002
261     Subject: Stock Market Volatility Beating You Up? (18@2)
262      Folder: /var/spool/mail/book						   2840
263
264Some informational messages can be put by procmail(1) in the log file.
265If the C<errors> attribute is true, these lines are returned one at a time.
266
267With errors enabled, you have to check that next() actually returns a
268Log::Procmail::Abstract object. Here is an example:
269
270    $log->errors(1);
271
272    # fetch data
273    while ( $rec = $log->next ) {
274
275        # if it's an error line
276        if ( !ref $rec ) {
277            # this is not a log, but an informational message
278            # do something with it
279            next;
280        }
281
282        # normal log processing
283    }
284
285=item $log->push( $file [, $file2 ...] );
286
287Push one or more files on top of the list of log files to examine.
288When Log::Procmail runs out of abstracts to return (i.e. it reaches the
289end of the file), it transparently opens the next file (if there is one)
290and keeps returning new abstracts.
291
292=item $log->errors( [bool] );
293
294Set or get the error flag. If set, when the next() method will return
295the string found in the log file, instead of ignoring it. Be careful:
296it is a simple string, not a Log::Procmail::Abstract object.
297
298Default is to return no error.
299
300=item $fh = $log->fh()
301
302Returns the currently opened filehandle, from which the next call to
303C<next()> will try to read a record.
304
305=item $select = $log->select()
306
307Return a IO::Select object that watches the currently opened filehandle.
308
309B<You are not supposed to use C<add()> or C<remove()> on the returned
310IO::Select object.>
311
312B<Additional warning for C<MSWin32>, C<NetWare>, C<dos>, C<VMS>, C<riscos>
313and C<beos>:> on those systems, C<select()> returns C<undef>.
314(Check F<ext/IO/t/io_sel.t> in the Perl sources for details.
315Hint: look for the message I<4-arg select is only valid on sockets>.)
316
317=back
318
319=head2 Log::Procmail::Abstract
320
321Log::Procmail::Abstract is a class that hold the abstract information.
322Since the abstract hold From, Date, Subject, Folder and Size information,
323all this can be accessed and modified through the from(), date(), subject(),
324folder() and size() methods.
325
326Log::Procmail::next() returns a Log::Procmail::Abstract object.
327
328=over 4
329
330=item Log::Procmail::Abstract accessors
331
332The Log::Procmail::Abstract object accessors are named from(), date(),
333subject(), folder() and size(). They return the relevant information
334when called without argument, and set it to their first argument
335otherwise.
336
337    # count mail received per folder
338    while( $rec = $log->next ) { $folder{ $rec->folder }++ }
339
340The source() accessor returns the name of the log file or the string
341representation of the handle, if a filehandle was given.
342
343=item $rec->ymd()
344
345Return the date in the form C<yyyymmmddhhmmss> where each field is what
346you think it is. C<;-)> This method is read-only.
347
348=back
349
350=head1 EXAMPLES
351
352Here is an example procmail biff-like script, courtesy of Ian Langworth:
353
354    #/usr/bin/perl -w
355    use strict;
356    use Log::Procmail;
357
358    use constant LOGFILE       => "$ENV{HOME}/procmail.log";
359    use constant VALID_FOLDERS => [qw( agent inbox perl systems )];
360    my $format = "\%8s: \%-30.30s / %s\n";
361
362    my $log = Log::Procmail->new( LOGFILE );
363    $log->errors(1);
364
365    while ( $log->select->can_read ) {
366        my $rec = $log->next;
367
368        # error?
369        warn "$rec\n", next unless ref $rec;
370
371        # ignore mailboxes we don't care about
372        next unless grep { $_ eq $rec->folder } @{ VALID_FOLDERS() };
373
374        # print data
375        printf $format, From    => $rec->from;
376        printf $format, Subject => $rec->subject, $rec->folder;
377    }
378
379=head1 TODO
380
381The Log::Procmail object should be able to read from STDIN.
382
383=head1 BUGS
384
385=over 4
386
387=item *
388
389Sometimes procmail(1) logs are mixed up. When this happens, I've chosen
390to accept them the way mailstat(1) does: they are discarded unless they
391have a C<Folder> line.
392
393=item *
394
395If you use Log::Procmail and the select() method to follow a live logfile
396as in the above example, please not that Log::Procmail will not detect
397when the file is rotated.
398
399=back
400
401Please report all bugs through the rt.cpan.org interface:
402
403L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Log-Procmail>
404
405=head1 AUTHOR
406
407Philippe "BooK" Bruhat <book@cpan.org>.
408
409=head1 ACKNOWLEDGMENTS
410
411Thanks to Briac "Oeufmayo" Pilpr� and David "Sniper" Rigaudiere for early
412comments on irc. Thanks to Olivier "rs" Poitrey for giving me his huge
413procmail log file (51 Mb spanning over a two-year period) and for probably
414being the first user of this module. Many thanks to Michael Schwern for
415insisting so much on the importance of tests and documentation.
416
417Many thanks to "Les Mongueurs de Perl" for making cvs.mongueurs.net
418available for Log::Procmail and many other projects.
419
420=head1 COPYRIGHT
421
422Copyright (c) 2002-2013, Philippe Bruhat. All Rights Reserved.
423
424=head1 LICENSE
425
426This module is free software. It may be used, redistributed
427and/or modified under the terms of the Perl Artistic License
428(see http://www.perl.com/perl/misc/Artistic.html)
429
430=head1 SEE ALSO
431
432perl(1), procmail(1).
433
434=cut
435
436