File Coverage

blib/lib/Log/Handler/Output/Email.pm
Criterion Covered Total %
statement 60 134 44.7
branch 10 70 14.2
condition 1 12 8.3
subroutine 13 16 81.2
pod 7 7 100.0
total 91 239 38.0


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Log::Handler::Output::Email - Log messages as email (via Net::SMTP).
4              
5             =head1 SYNOPSIS
6              
7             use Log::Handler::Output::Email;
8              
9             my $email = Log::Handler::Output::Email->new(
10             host => "mx.bar.example",
11             hello => "EHLO my.domain.example",
12             timeout => 120,
13             debug => 0,
14             from => 'bar@foo.example',
15             to => 'foo@bar.example',
16             subject => "your subject",
17             buffer => 0
18             );
19              
20             $email->log(message => $message);
21              
22             =head1 DESCRIPTION
23              
24             With this output module it's possible to log messages via email and it used
25             Net::SMTP to do it. The date for the email is generated with C.
26              
27             Net::SMTP is from Graham Barr and it does it's job very well.
28              
29             =head1 METHODS
30              
31             =head2 new()
32              
33             Call C to create a new Log::Handler::Output::Email object.
34              
35             The following opts are possible:
36              
37             =over 4
38              
39             =item B
40              
41             With this option you has to define the SMTP host to connect to.
42              
43             host => "mx.host.com"
44              
45             # or
46              
47             host => [ "mx.host.example", "mx.host-backup.example" ]
48              
49             =item B
50              
51             Identify yourself with a HELO. The default is set to C.
52              
53             =item B
54              
55             With this option you can set the maximum time in seconds to wait for a
56             response from the SMTP server. The default is set to 120 seconds.
57              
58             =item B
59              
60             The sender address (MAIL FROM).
61              
62             =item B
63              
64             The receipient address (RCPT TO).
65              
66             Additional options are B and B.
67              
68             =item B
69              
70             The subject of the mail.
71              
72             The default subject is "Log message from $progname".
73              
74             =item B
75              
76             This opts exists only for security. The thing is that it would be very bad
77             if something wents wrong in your program and hundreds of mails would be send.
78             For this reason you can set a buffer to take care.
79              
80             With the buffer you can set the maximum size of the buffer in lines. If you set
81              
82             buffer => 10
83              
84             then 10 messages would be buffered. Set C to 0 if you want to disable
85             the buffer.
86              
87             The default buffer size is set to 20.
88              
89             =item B
90              
91             With this option it's possible to enable debugging. The information can be
92             intercepted with $SIG{__WARN__}.
93              
94             =back
95              
96             =head2 log()
97              
98             Call C if you want to log a message as email.
99              
100             If you set a buffer size then the message will be pushed into the buffer first.
101              
102             Example:
103              
104             $email->log(message => "this message will be mailed");
105              
106             If you pass the level then its placed into the subject:
107              
108             $email->log(message => "foo", level => "INFO");
109             $email->log(message => "bar", level => "ERROR");
110             $email->log(message => "baz", level => "DEBUG");
111              
112             The lowest level is used:
113              
114             Subject: ERROR: ...
115              
116             You can pass the level with C by setting
117              
118             message_pattern => '%L'
119              
120             =head2 flush()
121              
122             Call C if you want to flush the buffered lines.
123              
124             =head2 sendmail()
125              
126             Call C if you want to send an email.
127              
128             The difference to C is that the message won't be buffered.
129              
130             =head2 validate()
131              
132             Validate a configuration.
133              
134             =head2 reload()
135              
136             Reload with a new configuration.
137              
138             =head2 errstr()
139              
140             This function returns the last error message.
141              
142             =head1 DESTROY
143              
144             C is defined and called C.
145              
146             =head1 PREREQUISITES
147              
148             Carp
149             Email::Date
150             Net::SMTP
151             Params::Validate
152              
153             =head1 EXPORTS
154              
155             No exports.
156              
157             =head1 REPORT BUGS
158              
159             Please report all bugs to .
160              
161             If you send me a mail then add Log::Handler into the subject.
162              
163             =head1 AUTHOR
164              
165             Jonny Schulz .
166              
167             =head1 COPYRIGHT
168              
169             Copyright (C) 2007-2009 by Jonny Schulz. All rights reserved.
170              
171             This program is free software; you can redistribute it and/or
172             modify it under the same terms as Perl itself.
173              
174             =cut
175              
176             package Log::Handler::Output::Email;
177              
178 1     1   190509 use strict;
  1         9  
  1         30  
179 1     1   5 use warnings;
  1         2  
  1         25  
180 1     1   5 use Carp;
  1         2  
  1         48  
181 1     1   6 use Email::Date;
  1         1  
  1         40  
182 1     1   16 use Net::SMTP;
  1         3  
  1         44  
183 1     1   588 use Params::Validate qw();
  1         9130  
  1         1411  
184              
185             our $VERSION = "0.08";
186             our $ERRSTR = "";
187             our $TEST = 0; # is needed to disable flush() for tests
188              
189             my %LEVEL_BY_STRING = (
190             DEBUG => 7,
191             INFO => 6,
192             NOTICE => 5,
193             WARNING => 4,
194             ERROR => 3,
195             CRITICAL => 2,
196             ALERT => 1,
197             EMERGENCY => 0,
198             FATAL => 0,
199             );
200              
201             sub new {
202 1     1 1 999 my $class = shift;
203 1         6 my $opts = $class->_validate(@_);
204 1         4 return bless $opts, $class;
205             }
206              
207             sub log {
208 10     10 1 407 my $self = shift;
209 10 50       27 my $message = @_ > 1 ? {@_} : shift;
210 10         18 my $buffer = $self->{message_buffer};
211              
212 10 50       22 if ($self->{buffer} == 0) {
213 0         0 return $self->sendmail($message);
214             }
215              
216 10 50       20 if (@$buffer < $self->{buffer}) {
217 10         16 push @$buffer, $message;
218             }
219              
220 10 50       19 if (@$buffer == $self->{buffer}) {
221 0         0 return $self->flush;
222             }
223              
224 10         17 return 1;
225             }
226              
227             sub flush {
228 2     2 1 12 my $self = shift;
229 2         5 my $string = ();
230 2         7 my $buffer = $self->{message_buffer};
231              
232 2 50 33     8 if ($TEST || !@$buffer) {
233 2         134 return 1;
234             }
235              
236             # Safe the last message because the newest subject is used
237 0         0 my $message = pop @$buffer;
238              
239 0         0 while (my $buf = shift @$buffer) {
240 0 0 0     0 if ($buf->{level} && !$message->{level}) {
    0 0        
241 0         0 $message->{level} = $buf->{level};
242             } elsif ($buf->{level} && $message->{level}) {
243 0         0 my $blevel = $buf->{level};
244 0         0 my $mlevel = $message->{level};
245 0 0       0 if ($LEVEL_BY_STRING{$mlevel} > $LEVEL_BY_STRING{$blevel}) {
246 0         0 $message->{level} = $buf->{level};
247             }
248             }
249              
250 0         0 $string .= $buf->{message};
251             }
252              
253 0 0       0 if (defined $string) {
254 0         0 $message->{message} = $string . $message->{message};
255             }
256              
257 0         0 return $self->sendmail($message);
258             }
259              
260             sub sendmail {
261 0     0 1 0 my $self = shift;
262 0 0       0 my $message = @_ > 1 ? {@_} : shift;
263 0   0     0 my $subject = $message->{subject} || $self->{subject};
264 0         0 my $date = Email::Date::format_date();
265 0         0 my $smtp = ();
266 0         0 my $expect = 10;
267 0         0 my $success = 0;
268              
269 0 0       0 if ($message->{level}) {
270 0         0 $subject = "$message->{level}: $subject";
271             }
272              
273 0         0 foreach my $host (@{$self->{host}}) {
  0         0  
274             $smtp = Net::SMTP->new(
275             Host => $host,
276             Hello => $self->{hello},
277             Timeout => $self->{timeout},
278             Debug => $self->{debug},
279 0         0 );
280 0 0       0 last if $smtp;
281             }
282              
283 0 0       0 if (!$smtp) {
284 0         0 return $self->_raise_error("smtp error: unable to connect to ".join(", ", @{$self->{host}}));
  0         0  
285             }
286              
287 0 0       0 if ($smtp->mail($self->{from})) {
288 0         0 $success++;
289             }
290              
291 0 0       0 if ($smtp->to($self->{to})) {
292 0         0 $success++;
293             }
294              
295 0 0       0 if ($self->{cc}) {
296 0 0       0 if ($smtp->cc($self->{cc})) {
297 0         0 $success++;
298             }
299 0         0 $expect++;
300             }
301              
302 0 0       0 if ($self->{bcc}) {
303 0 0       0 if ($smtp->bcc($self->{bcc})) {
304 0         0 $success++;
305             }
306 0         0 $expect++;
307             }
308              
309 0 0       0 if ($smtp->data) {
310 0         0 $success++;
311             }
312              
313 0 0       0 if ($smtp->datasend("From: $self->{from}\n")) {
314 0         0 $success++;
315             }
316              
317 0 0       0 if ($smtp->datasend("To: $self->{to}\n")) {
318 0         0 $success++;
319             }
320              
321 0 0       0 if ($self->{cc}) {
322 0 0       0 if ($smtp->datasend("Cc: $self->{cc}\n")) {
323 0         0 $success++;
324             }
325 0         0 $expect++;
326             }
327              
328 0 0       0 if ($smtp->datasend("Subject: $subject\n")) {
329 0         0 $success++;
330             }
331              
332 0 0       0 if ($smtp->datasend("Date: $date\n")) {
333 0         0 $success++;
334             }
335              
336 0 0       0 if ($smtp->datasend($message->{message}."\n")) {
337 0         0 $success++;
338             }
339              
340 0 0       0 if ($smtp->dataend) {
341 0         0 $success++;
342             }
343              
344 0 0       0 if ($smtp->quit) {
345 0         0 $success++;
346             }
347              
348 0 0       0 if ($success != $expect) {
349 0         0 return $self->_raise_error("smtp error($success): unable to send mail to $self->{to}");
350             }
351              
352 0         0 return 1;
353             }
354              
355             sub validate {
356 1     1 1 3 my $self = shift;
357 1         3 my $opts = ();
358              
359 1         3 eval { $opts = $self->_validate(@_) };
  1         4  
360              
361 1 50       6 if ($@) {
362 0         0 return $self->_raise_error($@);
363             }
364              
365 1         3 return $opts;
366             }
367              
368             sub reload {
369 1     1 1 665 my $self = shift;
370 1         20 my $opts = $self->validate(@_);
371              
372 1 50       3 if (!$opts) {
373 0         0 return undef;
374             }
375              
376 1         4 $self->flush;
377              
378 1         6 foreach my $key (keys %$opts) {
379 9         19 $self->{$key} = $opts->{$key};
380             }
381              
382 1         5 return 1;
383             }
384              
385             sub errstr {
386 0     0 1 0 return $ERRSTR;
387             }
388              
389             sub DESTROY {
390 1     1   326 my $self = shift;
391 1         4 $self->flush;
392             }
393              
394             #
395             # private stuff
396             #
397              
398             sub _validate {
399 2     2   5 my $class = shift;
400              
401 2         6 my $progname = $0;
402 2         22 $progname =~ s@.*[/\\]@@;
403              
404 2         88 my %opts = Params::Validate::validate(@_, {
405             host => {
406             type => Params::Validate::ARRAYREF | Params::Validate::SCALAR,
407             },
408             hello => {
409             type => Params::Validate::SCALAR,
410             default => "EHLO BELO",
411             },
412             timeout => {
413             type => Params::Validate::SCALAR,
414             regex => qr/^\d+\z/,
415             default => 120,
416             },
417             debug => {
418             type => Params::Validate::SCALAR,
419             regex => qr/^[01]\z/,
420             default => 0,
421             },
422             from => {
423             type => Params::Validate::SCALAR,
424             },
425             to => {
426             type => Params::Validate::SCALAR,
427             },
428             cc => {
429             type => Params::Validate::SCALAR,
430             optional => 1,
431             },
432             bcc => {
433             type => Params::Validate::SCALAR,
434             optional => 1,
435             },
436             subject => {
437             type => Params::Validate::SCALAR,
438             default => "Log message from $progname",
439             },
440             buffer => {
441             type => Params::Validate::SCALAR,
442             default => 20,
443             },
444             });
445              
446 2 50       108 if (!ref($opts{host})) {
447 0         0 $opts{host} = [ $opts{host} ];
448             }
449              
450 2 50       8 if ($opts{subject}) {
451 2         5 $opts{subject} =~ s/\n/ /g;
452 2         5 $opts{subject} =~ s/(.{78})/$1\n /g;
453              
454 2 50       7 if (length($opts{subject}) > 998) {
455 0         0 warn "Subject to long for email!";
456 0         0 $opts{subject} = substr($opts{subject}, 0, 998);
457             }
458             }
459              
460 2         5 $opts{message_buffer} = [ ];
461 2         6 return \%opts;
462             }
463              
464             sub _raise_error {
465 0     0     my $self = shift;
466 0           $ERRSTR = shift;
467 0           return undef;
468             }
469              
470             1;