1package Log::Dispatch::Email; 2{ 3 $Log::Dispatch::Email::VERSION = '2.34'; 4} 5 6use strict; 7use warnings; 8 9use Log::Dispatch::Output; 10 11use base qw( Log::Dispatch::Output ); 12 13use Params::Validate qw(validate SCALAR ARRAYREF BOOLEAN); 14Params::Validate::validation_options( allow_extra => 1 ); 15 16# need to untaint this value 17my ($program) = $0 =~ /(.+)/; 18 19sub new { 20 my $proto = shift; 21 my $class = ref $proto || $proto; 22 23 my %p = validate( 24 @_, { 25 subject => { 26 type => SCALAR, 27 default => "$program: log email" 28 }, 29 to => { type => SCALAR | ARRAYREF }, 30 from => { 31 type => SCALAR, 32 optional => 1 33 }, 34 buffered => { 35 type => BOOLEAN, 36 default => 1 37 }, 38 } 39 ); 40 41 my $self = bless {}, $class; 42 43 $self->_basic_init(%p); 44 45 $self->{subject} = $p{subject} || "$0: log email"; 46 $self->{to} = ref $p{to} ? $p{to} : [ $p{to} ]; 47 $self->{from} = $p{from}; 48 49 # Default to buffered for obvious reasons! 50 $self->{buffered} = $p{buffered}; 51 52 $self->{buffer} = [] if $self->{buffered}; 53 54 return $self; 55} 56 57sub log_message { 58 my $self = shift; 59 my %p = @_; 60 61 if ( $self->{buffered} ) { 62 push @{ $self->{buffer} }, $p{message}; 63 } 64 else { 65 $self->send_email(@_); 66 } 67} 68 69sub send_email { 70 my $self = shift; 71 my $class = ref $self; 72 73 die "The send_email method must be overridden in the $class subclass"; 74} 75 76sub flush { 77 my $self = shift; 78 79 if ( $self->{buffered} && @{ $self->{buffer} } ) { 80 my $message = join '', @{ $self->{buffer} }; 81 82 $self->send_email( message => $message ); 83 $self->{buffer} = []; 84 } 85} 86 87sub DESTROY { 88 my $self = shift; 89 90 $self->flush; 91} 92 931; 94 95# ABSTRACT: Base class for objects that send log messages via email 96 97__END__ 98 99=pod 100 101=head1 NAME 102 103Log::Dispatch::Email - Base class for objects that send log messages via email 104 105=head1 VERSION 106 107version 2.34 108 109=head1 SYNOPSIS 110 111 package Log::Dispatch::Email::MySender; 112 113 use Log::Dispatch::Email; 114 use base qw( Log::Dispatch::Email ); 115 116 sub send_email { 117 my $self = shift; 118 my %p = @_; 119 120 # Send email somehow. Message is in $p{message} 121 } 122 123=head1 DESCRIPTION 124 125This module should be used as a base class to implement 126Log::Dispatch::* objects that send their log messages via email. 127Implementing a subclass simply requires the code shown in the 128L<SYNOPSIS> with a real implementation of the C<send_email()> method. 129 130=head1 CONSTRUCTOR 131 132The constructor takes the following parameters in addition to the standard 133parameters documented in L<Log::Dispatch::Output>: 134 135=over 4 136 137=item * subject ($) 138 139The subject of the email messages which are sent. Defaults to "$0: 140log email" 141 142=item * to ($ or \@) 143 144Either a string or a list reference of strings containing email 145addresses. Required. 146 147=item * from ($) 148 149A string containing an email address. This is optional and may not 150work with all mail sending methods. 151 152=item * buffered (0 or 1) 153 154This determines whether the object sends one email per message it is 155given or whether it stores them up and sends them all at once. The 156default is to buffer messages. 157 158=back 159 160=head1 METHODS 161 162=over 4 163 164=item * send_email(%p) 165 166This is the method that must be subclassed. For now the only 167parameter in the hash is 'message'. 168 169=item * flush 170 171If the object is buffered, then this method will call the 172C<send_email()> method to send the contents of the buffer and then 173clear the buffer. 174 175=item * DESTROY 176 177On destruction, the object will call C<flush()> to send any pending 178email. 179 180=back 181 182=head1 AUTHOR 183 184Dave Rolsky <autarch@urth.org> 185 186=head1 COPYRIGHT AND LICENSE 187 188This software is Copyright (c) 2011 by Dave Rolsky. 189 190This is free software, licensed under: 191 192 The Artistic License 2.0 (GPL Compatible) 193 194=cut 195