File Coverage

blib/lib/Exception/Reporter/Sender/Email.pm
Criterion Covered Total %
statement 91 92 98.9
branch 18 24 75.0
condition 8 18 44.4
subroutine 19 20 95.0
pod 2 7 28.5
total 138 161 85.7


line stmt bran cond sub pod time code
1 1     1   376 use strict;
  1         1  
  1         35  
2 1     1   4 use warnings;
  1         1  
  1         39  
3             package Exception::Reporter::Sender::Email;
4             # ABSTRACT: a report sender that sends detailed dumps via email
5             $Exception::Reporter::Sender::Email::VERSION = '0.014';
6 1     1   3 use parent 'Exception::Reporter::Sender';
  1         1  
  1         18  
7              
8             #pod =head1 SYNOPSIS
9             #pod
10             #pod my $sender = Exception::Reporter::Sender::Email->new({
11             #pod from => 'root',
12             #pod to => 'Beloved SysAdmins ',
13             #pod });
14             #pod
15             #pod =head1 OVERVIEW
16             #pod
17             #pod This is the only report sender you'll probably ever need.
18             #pod
19             #pod It turns the report into a multipart email message and sends it via email.
20             #pod
21             #pod Each set of summaries is turned into a MIME message part. If a dumpable has
22             #pod become more than one summary, its summaries will be children of a
23             #pod C part. Otherwise, its summary will become a part of the
24             #pod kind indicated in the summary.
25             #pod
26             #pod The C of the first summary will be used for the subject of the message.
27             #pod
28             #pod The GUID of the exception report (the thing returned by the reporter's
29             #pod C method) is used as the local part of the email message's
30             #pod Message-ID.
31             #pod
32             #pod Every reported message has a In-Reply-To header formed by combining a
33             #pod slightly-munged version of the C and the C. This means that
34             #pod similar exception report emails will thread together in a thread-capable email
35             #pod reader.
36             #pod
37             #pod =cut
38              
39 1     1   53 use Digest::MD5 ();
  1         1  
  1         10  
40 1     1   419 use Email::Address ();
  1         19357  
  1         34  
41 1     1   420 use Email::MIME::Creator ();
  1         20714  
  1         15  
42 1     1   6 use Email::MessageID ();
  1         1  
  1         11  
43 1     1   380 use Email::Sender::Simple ();
  1         68032  
  1         18  
44 1     1   6 use String::Truncate;
  1         1  
  1         9  
45 1     1   142 use Try::Tiny;
  1         1  
  1         887  
46              
47             sub new {
48 2     2 0 1235 my ($class, $arg) = @_;
49              
50 2   33     7 my $from = $arg->{from} || Carp::confess("missing 'from' argument");
51 2   33     12 my $to = $arg->{to} || Carp::confess("missing 'to' argument"),
52              
53             ($from) = Email::Address->parse($from);
54 2 50       77 ($to) = [ map {; Email::Address->parse($_) } (ref $to ? @$to : $to) ];
  2         5  
55              
56             # Allow mail from a simple, bare local-part like "root" -- rjbs, 2012-07-03
57             $from = Email::Address->new(undef, $arg->{from})
58 2 50 33     621 if ! $from and $arg->{from} =~ /\A[-.0-9a-zA-Z]+\z/;
59              
60 2 50       15 Carp::confess("couldn't interpret $arg->{from} as an email address")
61             unless $from;
62              
63 2   33     54 my $env_from = $arg->{env_from} || $from->address;
64 2   50     15 my $env_to = $arg->{env_to} || [ map {; $_->address } @$to ];
65              
66 2 50       13 $env_to = [ $env_to ] unless ref $env_to;
67              
68 2         18 return bless {
69             from => $from,
70             to => $to,
71             env_to => $env_to,
72             env_from => $env_from,
73             }, $class;
74             }
75              
76             sub from_header {
77 3     3 0 3 my ($self) = @_;
78 3         15 return $self->{from}->as_string;
79             }
80              
81             sub to_header {
82 3     3 0 51 my ($self) = @_;
83 3         4 return join q{, }, map {; $_->as_string } @{ $self->{to} };
  3         9  
  3         5  
84             }
85              
86             sub env_from {
87 3     3 0 4 my ($self) = @_;
88 3         6 return $self->{env_from};
89             }
90              
91             sub env_to {
92 3     3 0 3 my ($self) = @_;
93 3         4 return @{ $self->{env_to} };
  3         4  
94             }
95              
96             #pod =head2 send_report
97             #pod
98             #pod $email_reporter->send_report(\@summaries, \%arg, \%internal_arg);
99             #pod
100             #pod This method builds a multipart email message from the given summaries and
101             #pod sends it.
102             #pod
103             #pod C<%arg> is the same set of arguments given to Exception::Reporter's
104             #pod C method. Arguments that will have an effect include:
105             #pod
106             #pod extra_rcpts - an arrayref of extra envelope recipients
107             #pod reporter - the name of the program reporting the exception
108             #pod handled - if true, the reported exception was handled and the user
109             #pod saw a simple error message; sets X-Exception-Handled header
110             #pod and adds a text part at the beginning of the report,
111             #pod calling out the "handled" status"
112             #pod
113             #pod C<%internal_arg> contains data produced by the Exception::Reporter using this
114             #pod object. It includes the C of the report and the C calling the
115             #pod reporter.
116             #pod
117             #pod The mail is sent with the L> method, which can be replaced in a
118             #pod subclass.
119             #pod
120             #pod The return value of C is not defined.
121             #pod
122             #pod =cut
123              
124             sub send_report {
125 3     3 1 4 my ($self, $summaries, $arg, $internal_arg) = @_;
126              
127             # ?!? Presumably this can't really happen, but... you know what they say
128             # about zero-summary incidents, right? -- rjbs, 2012-07-03
129 3 50       6 Carp::confess("can't report a zero-summary incident!") unless @$summaries;
130              
131 3         5 my $email = $self->_build_email($summaries, $arg, $internal_arg);
132              
133             # Maybe we should try{} to sanity check the extra rcpts first. -- rjbs,
134             # 2012-07-05
135             $self->send_email(
136             $email,
137             {
138             from => $self->env_from,
139 3 50       7 to => [ $self->env_to, @{ $arg->{extra_rcpts} || [] } ],
  3         19  
140             }
141             );
142              
143 3         12 return;
144             }
145              
146             #pod =method send_email
147             #pod
148             #pod $sender->send_email($email, \%env);
149             #pod
150             #pod This method expects an email object (such as can be handled by
151             #pod L) and a a hashref that will have these two keys:
152             #pod
153             #pod from - an envelope sender
154             #pod to - an arrayref of envelope recipients
155             #pod
156             #pod It sends the email. It should not throw an exception on failure. The default
157             #pod implementation uses Email::Sender. If the email injection fails, a warning is
158             #pod issued.
159             #pod
160             #pod =cut
161              
162             sub send_email {
163 3     3 1 4 my ($self, $email, $env) = @_;
164              
165             try {
166 3     3   85 Email::Sender::Simple->send($email, $env);
167             } catch {
168 0     0   0 Carp::cluck "failed to send exception report: $_";
169 3         15 };
170              
171 3         7668 return;
172             }
173              
174             sub _build_email {
175 3     3   4 my ($self, $summaries, $arg, $internal_arg) = @_;
176              
177 3         2 my @parts;
178 3         5 GROUP: for my $summary (@$summaries) {
179 9         544 my @these_parts;
180 9         6 for my $summary (@{ $summary->[1] }) {
  9         14  
181             push @these_parts, Email::MIME->create(
182             ($summary->{body_is_bytes} ? 'body' : 'body_str') => $summary->{body},
183             attributes => {
184             filename => $summary->{filename},
185             content_type => $summary->{mimetype},
186             encoding => 'quoted-printable',
187              
188             ($summary->{body_is_bytes}
189             ? ($summary->{charset} ? (charset => $summary->{charset}) : ())
190 11 100 100     115 : (charset => $summary->{charset} || 'utf-8')),
    100          
    100          
191             },
192             );
193              
194 11         8148 $these_parts[-1]->header_set(Date=>);
195 11         272 $these_parts[-1]->header_set('MIME-Version'=>);
196             }
197              
198 9 100       172 if (@these_parts == 1) {
199 8         11 push @parts, @these_parts;
200             } else {
201 1         5 push @parts, Email::MIME->create(
202             attributes => { content_type => 'multipart/related' },
203             parts => \@these_parts,
204             );
205 1         3001 $parts[-1]->header_set(Date=>);
206 1         25 $parts[-1]->header_set('MIME-Version'=>);
207             }
208              
209 9         34 $parts[-1]->name_set($summary->[0]);
210             }
211              
212 3 100       280 if ($arg->{handled}) {
213 1         5 unshift @parts, Email::MIME->create(
214             body_str => "DON'T PANIC!\n"
215             . "THIS EXCEPTION WAS CAUGHT AND EXECUTION CONTINUED\n"
216             . "THIS REPORT IS PROVIDED FOR INFORMATIONAL PURPOSES\n",
217             attributes => {
218             content_type => "text/plain",
219             charset => 'utf-8',
220             encoding => 'quoted-printable',
221             name => 'prelude',
222             },
223             );
224 1         815 $parts[-1]->header_set(Date=>);
225 1         18 $parts[-1]->header_set('MIME-Version'=>);
226             }
227              
228             my $ident = $summaries->[0][1][0]{ident} && $summaries->[0][1][0]{ident}
229 3   50     30 || "(unknown exception)";;
230              
231 3         7 ($ident) = split /\n/, $ident;
232 3         16 $ident =~ s/\s+(?:at .+?)? ?line\s\d+\.?$//;
233              
234 3         4 my $digest_ident = $ident;
235 3         3 $digest_ident =~ s/\(.+//g;
236              
237 3         3 my ($package, $filename, $line) = @{ $internal_arg->{caller} };
  3         4  
238              
239 3         4 my $reporter = $arg->{reporter};
240              
241             my $email = Email::MIME->create(
242             attributes => { content_type => 'multipart/mixed' },
243             parts => \@parts,
244             header_str => [
245             From => $self->from_header,
246             To => $self->to_header,
247             Subject => String::Truncate::elide("$reporter: $ident", 65),
248             'X-Mailer' => (ref $self),
249             'Message-Id' => Email::MessageID->new(user => $internal_arg->{guid})
250             ->in_brackets,
251             'In-Reply-To'=> Email::MessageID->new(
252             user => Digest::MD5::md5_hex($digest_ident),
253             host => $reporter,
254             )->in_brackets,
255             'X-Exception-Reporter-Reporter' => $arg->{reporter},
256             'X-Exception-Reporter-Caller' => "$filename line $line ($package)",
257              
258 3 100       15 ($arg->{handled} ? ('X-Exception-Reporter-Handled' => 1) : ()),
259             ],
260             );
261              
262 3         7218 return $email;
263             }
264              
265             1;
266              
267             __END__