File Coverage

blib/lib/Carp/Notify.pm
Criterion Covered Total %
statement 93 205 45.3
branch 28 100 28.0
condition 0 17 0.0
subroutine 14 20 70.0
pod 11 11 100.0
total 146 353 41.3


line stmt bran cond sub pod time code
1 1     1   741 use 5.005;
  1         3  
2 1     1   5 use strict;
  1         1  
  1         24  
3 1     1   11 use warnings;
  1         2  
  1         161  
4              
5             package Carp::Notify;
6             $Carp::Notify::VERSION = '1.12';
7             # ABSTRACT: Loudly complain in lots of places when things break badly
8              
9             my %def = (
10             "smtp" => 'your.smtp.com', # IMPORTANT! Set this! I mean it!
11             "domain" => 'smtp.com', # IMPORTANT! Set this! I mean it!
12             "port" => 25,
13              
14             "email_it" => 1, # should we email by default? true/false
15             "email" => 'someone@your.smtp.com', # who are we emailing by default?
16             "return" => 'someone@your.smtp.com', # who is the error coming from?
17             "subject" => 'Ye Gods! An error!',
18              
19             "log_it" => 1, # should we log by default?
20             "log_file" => '/tmp/error.log', # default error log for notifys and explodes
21              
22             "log_explode" => 0, # should we log explodes by default?
23             "explode_log" => '/tmp/explode.log', # default error log for explodes ONLY
24              
25             "log_notify" => 0, # should we log notifys by default?
26             "notify_log" => '/tmp/notify.log', # default error log for notifys ONLY
27              
28             "store_vars" => 1, # should we store variables by default? true/false
29             "stack_trace" => 1, # should we do a stack trace by default? true/false
30             "store_env" => 1, # should we store our environment by default? true/false
31              
32             "die_to_stdout" => 0, # should we send our death_message to STDOUT by default? true/false
33             "die_everywhere" => 0, # should we send our death_message to STDOUT and STDERR by default? true/false
34             "die_quietly" => 0, # should we not print our death_message anywhere? true/false
35              
36             "error_function" => '', # function to call if Carp::Notify encounters an error
37             "death_function" => '', # function to call upon termination, used in place of death_message
38              
39             # What would you like to die with? This is probably the message that's going to your user in
40             # his browser, so make it something nice. You'll have to set the content type yourself, though.
41             # Why's that, you ask? I wanted to be sure that you had the option of easily redirecting to
42             # a different page if you'd prefer.
43              
44             "death_message" => <<'eoE'
45             Content-type:text/plain\n\n
46              
47             We're terribly sorry, but some horrid internal error seems to have occurred. We are actively
48             looking into the problem and hope to repair the error shortly. We're sorry for any inconvenience.
49              
50             eoE
51             );
52             # end defaults. Don't mess with anything else! I mean it!
53              
54             my $settables = "(?:" . join('|', keys %def) . ')';
55              
56             $Carp::Notify::fatal = 1;
57              
58             {
59             my $calling_package = undef;
60              
61             my %storable_vars = ();
62              
63             my @storable_vars = ();
64             my %init = ();
65              
66             sub import {
67             # this wants rework, badly
68 1     1   5 no strict 'refs';
  1         1  
  1         262  
69 9     9   19653 my ($package, $file, $line) = caller;
70 9         15 $calling_package = $package;
71              
72 9         12 *{$package . "::explode"} = \&Carp::Notify::explode;
  9         38  
73 9         11 *{$package . "::notify"} = \&Carp::Notify::notify;
  9         20  
74              
75 9         352 while (defined (my $var = shift)){
76 25 50       35 if ($var eq ""){die ("Error...tried to import undefined value in $file, Line $line\n")};
  0         0  
77              
78 25 50       153 if ($var =~ /^$settables$/o){
79 0         0 $def{$var} = shift;
80 0         0 next;
81             };
82              
83 25 100       51 push @storable_vars, $var if $var =~ /^[\$@%&]/;
84 25 100       42 push @{$storable_vars{$calling_package}}, $var if $var =~ /^[\$@%&]/;
  8         11  
85              
86             # see if we want to overload croak or export anything while we're at it.
87              
88 25 100       41 *{$package . "::croak"} = \&Carp::Notify::explode if $var eq "croak";
  2         5  
89 25 100       37 *{$package . "::carp"} = \&Carp::Notify::notify if $var eq "carp";
  2         7  
90 25 100       32 *{$package . "::make_storable"} = \&Carp::Notify::make_storable if $var eq "make_storable";
  2         5  
91 25 100       127 *{$package . "::make_unstorable"} = \&Carp::Notify::make_unstorable if $var eq "make_unstorable";
  2         24  
92             };
93             };
94              
95             sub store_vars {
96             # this wants rework
97 1     1   5 no strict 'refs';
  1         1  
  1         765  
98              
99 3     3 1 1734 my $stored_vars = "";
100 3         13 my $calling_package = (caller(1))[0]; # eek! This may not always work
101              
102 3         6 foreach my $storable_var (@{$storable_vars{$calling_package}}){
  3         8  
103 12         11 my $type = '';
104 12 100       39 $type = $1 if $storable_var =~ s/([\$@%&])//;
105              
106 12         14 my $package = $calling_package . "::";
107 12 50       22 $package = $1 if $storable_var =~ s/(.+::)//;
108              
109 12 100       43 if ($type eq '$') {
    100          
    100          
    100          
110 2         2 my $storable_val = ${$package . "$storable_var"};
  2         8  
111 2         7 $stored_vars .= "\t\$${package}$storable_var : $storable_val\n";next;
  2         4  
112             }
113             elsif ($type eq '@') {
114 2         3 my @storable_val = @{$package . "$storable_var"};
  2         7  
115 2         8 $stored_vars .= "\t\@${package}$storable_var : (@storable_val)\n";next;
  2         19  
116             }
117             elsif ($type eq '%') {
118 2         3 my %temp_hash = %{$package . "$storable_var"};
  2         10  
119 2         5 my @storable_val = map {"\n\t\t$_ => $temp_hash{$_}"} keys %temp_hash;
  4         11  
120 2         8 $stored_vars .= "\t\%${package}$storable_var : @storable_val\n";next;
  2         4  
121             }
122             elsif ($type eq '&'){
123 2         3 my $storable_val = &{$package . "$storable_var"};
  2         8  
124 2         10 $stored_vars .= "\t\&${package}$storable_var : $storable_val\n";next;
  2         4  
125             };
126             };
127              
128 3         7 return $stored_vars;
129             };
130              
131             sub make_storable {
132 1     1 1 221 foreach my $var (@_){
133 4 50       14 push @storable_vars, $var if $var =~ /^[\$@%&]/;;
134             };
135 1         7 return 1;
136             };
137              
138             sub make_unstorable {
139 1     1 1 4 my $no_store = join("|", map {quotemeta} @_);
  4         10  
140 1         2 @storable_vars = grep {!/^(?:$no_store)$/} @storable_vars;
  12         120  
141 1         4 return 1;
142             };
143              
144             # hee hee! Remember, a notification is just an explosion that isn't fatal. So we use our nifty handy dandy
145             # fatal class variable to tell explode that it's not a fatal error. explode() will set fatal back to 1 once
146             # it realizes that errors are non-fatal. That way a future explosion will still be fatal.
147             #
148             # and then goto &explode makes perl think it just started at the explode function. Even caller can't catch it!
149             sub notify {
150 0     0 1 0 $Carp::Notify::fatal = 0;
151 0         0 goto &explode;
152             };
153              
154             sub explode {
155 0     0 1 0 my $errors = undef;
156              
157 0         0 my %init = ();
158              
159 0         0 while (defined (my $arg = shift)) {
160 0 0       0 if ($arg =~ /^$settables$/o){
161 0         0 $init{$arg} = shift;
162             }
163 0         0 else {$errors .= "\t$arg\n"};
164             };
165              
166 0         0 %init = (%def, %init);
167              
168 0         0 my( $stored_vars, $stack, $environment ) = ( '', '', '' );
169              
170 0 0       0 $stored_vars = store_vars() if $init{'store_vars'};
171 0 0       0 $stack = stack_trace() if $init{'stack_trace'};
172 0 0       0 $environment = store_env() if $init{'store_env'};
173              
174 0         0 my $message = "";
175              
176 0 0       0 my $method = $Carp::Notify::fatal ? 'explosion' : 'notification';
177              
178 0         0 $message .= "An error via $method occurred on " . today() . "\n";
179              
180 0 0       0 $message .= "\n>>>>>>>>>\nERROR MESSAGES\n>>>>>>>>>\n\n$errors\n<<<<<<<<<\nEND ERROR MESSAGES\n<<<<<<<<<\n" if $errors;
181 0 0       0 $message .= "\n>>>>>>>>>\nSTORED VARIABLES\n>>>>>>>>>\n\n$stored_vars\n<<<<<<<<<\nEND STORED VARIABLES\n<<<<<<<<<\n" if $stored_vars;
182 0 0       0 $message .= "\n>>>>>>>>>\nCALL STACK TRACE\n>>>>>>>>>\n\n$stack\n<<<<<<<<<\nEND CALL STACK TRACE\n<<<<<<<<<\n" if $init{'stack_trace'};
183 0 0       0 $message .= "\n>>>>>>>>>\nENVIRONMENT\n>>>>>>>>>\n\n$environment\n<<<<<<<<<\nEND ENVIRONMENT\n<<<<<<<<<\n" if $init{'store_env'};
184              
185             log_it(
186             "log_it" => $init{'log_it'},
187             "log_file" => $init{'log_file'},
188              
189             "log_explode" => $Carp::Notify::fatal && $init{"log_explode"} ? $init{"log_explode"} : 0,
190             "explode_log" => $init{'explode_log'},
191              
192             "log_notify" => ! $Carp::Notify::fatal && $init{"log_notify"} ? $init{"log_notify"} : 0,
193             "notify_log" => $init{"notify_log"},
194              
195             "message" => $message,
196 0 0 0     0 "error_function" => $init{'error_function'}
    0 0        
197             );
198              
199             simple_smtp_mailer(
200             "email" => $init{'email'},
201             "return" => $init{'return'},
202             "message" => $message,
203             "subject" => $init{'subject'},
204             "smtp" => $init{'smtp'},
205             "port" => $init{'port'},
206             "error_function" => $init{'error_function'}
207 0 0       0 ) if $init{'email_it'};
208              
209 0 0       0 if ($Carp::Notify::fatal){
210 0 0       0 if ($init{'die_quietly'}){
    0          
211 0         0 exit;
212             }
213             elsif ($init{'death_function'}){
214 0 0       0 if (ref $init{'death_function'} eq 'CODE'){
215 0         0 $init{'death_function'}->(%init, 'errors' => $errors);
216             }
217             else {
218             # this wants rework, badly
219 1     1   6 no strict 'vars';
  1         1  
  1         582  
220 0         0 my ($calling_package) = (caller)[0];
221 0         0 my $package = $calling_package . "::";
222 0 0       0 $package = $1 if $init{'death_function'} =~ s/(.+::)//;
223 0         0 $init{'death_function'} =~ s/^&//;
224 0         0 &{$package . $init{'death_function'}}(%init, 'errors' => $errors);
  0         0  
225 0         0 exit;
226             };
227             }
228             else {
229 0 0       0 if ($init{'die_to_stdout'}){
230 0 0       0 print STDERR $init{'death_message'} if $init{'die_everywhere'};
231 0         0 print $init{'death_message'};
232 0         0 exit;
233             }
234             else {
235 0 0       0 print $init{'death_message'} if $init{'die_everywhere'};
236 0         0 die $init{'death_message'};
237             };
238             };
239             }
240             else {
241 0         0 $Carp::Notify::fatal = 1;
242 0         0 return;
243             };
244             };
245             };
246              
247              
248             # psst! If you're looking for store_vars, it's up at the top wrapped up with import!
249              
250             sub store_env {
251 1     1 1 2414 my $env = '';
252 1         19 foreach (sort keys %ENV){
253 22         36 $env .= "\t$_ : $ENV{$_}\n";
254             };
255 1         4 return $env;
256             };
257              
258             sub stack_trace {
259 0     0 1 0 my $caller_count = 1;
260 0         0 my $caller_stack = undef;
261 0         0 my @verbose_caller = ("Package: ", "Filename: ", "Line number: ", "Subroutine: ", "Has Args? : ", "Want array? : ", "Evaltext: ", "Is require? : ");
262              
263 0 0       0 push @verbose_caller, ("Hints: ", "Bitmask: ") if $] >= 5.006; # 5.6 has a more verbose caller stack.
264              
265 0         0 while (my @caller = caller($caller_count++)){
266 0         0 $caller_stack .= "\t---------\n";
267 0         0 foreach (0..$#caller){
268 0 0       0 $caller_stack .= "\t\t$verbose_caller[$_]$caller[$_]\n" if $caller[$_];
269             };
270             };
271              
272 0         0 $caller_stack .= "\t---------\n";
273 0         0 return $caller_stack;
274             };
275              
276             sub log_it {
277 0     0 1 0 my %init = @_;
278              
279 0         0 my $message = $init{message};
280              
281 0         0 local *LOG;
282              
283 0         0 my %pairs = (
284             "log_notify" => "notify_log",
285             "log_explode" => "explode_log",
286             "log_it" => "log_file"
287             );
288              
289 0         0 foreach my $permission (grep {$init{$_}} keys %pairs) {
  0         0  
290 0         0 my $file = $init{$pairs{$permission}};
291 0 0       0 if (ref $file){
292 0         0 print $file "\n__________________\n$message\n__________________\n";
293             }
294             else {
295 0 0       0 open (LOG, ">>$file") or error($init{'error_function'},"Cannot open log file: $!");
296 0         0 print LOG "\n__________________\n$message\n__________________\n";
297 0 0       0 close LOG or error($init{'error_function'},"Cannot close log file: $!");
298             };
299             };
300             };
301              
302             sub simple_smtp_mailer {
303 0     0 1 0 my %init = @_;
304 0         0 my $message = $init{"message"};
305              
306 1     1   700 use Socket;
  1         3069  
  1         1025  
307              
308 0         0 local *MAIL;
309 0         0 my $response = undef;
310 0         0 my ($s_tries, $c_tries) = (5, 5);
311 0         0 local $\ = "\015\012";
312 0         0 local $/ = "\015\012";
313              
314             # connect to the server
315 0   0     0 1 while ($s_tries-- && ! socket(MAIL, PF_INET, SOCK_STREAM, getprotobyname('tcp')));
316 0 0       0 return error($init{'error_function'}, "Socket error $!") if $s_tries < 0;
317              
318 0         0 my $remote_address = inet_aton($init{'smtp'});
319 0         0 my $paddr = sockaddr_in($init{'port'}, $remote_address);
320 0   0     0 1 while ! connect(MAIL, $paddr) && $c_tries--;
321 0 0       0 return error($init{'error_function'}, "Connect error $!") if $c_tries < 0;
322              
323             # keep our bulk pipes piping hot.
324 0         0 select((select(MAIL), $| = 1)[0]);
325             # connected
326              
327             # build the envelope
328 0         0 my @conversation =
329             (
330             ["", "No response from server: ?"],
331             ["HELO $def{'domain'}", "Mean ole' server won't say HELO: ?"],
332             ["RSET", "Cannot reset connection: ?"],
333             ["MAIL FROM:<$def{'return'}>", "Invalid Sender: ?"],
334             ["RCPT TO:<$init{'email'}>", "Invalid Recipient: ?"],
335             ["DATA", "Not ready to accept data: ?"]
336             );
337              
338 0         0 while (my $array_ref = shift @conversation){
339 0         0 my ($i_say, $i_die) = @{$array_ref};
  0         0  
340 0 0       0 print MAIL $i_say if $i_say;
341 0   0     0 my $response = || "";
342              
343 0 0 0     0 if (! $response || $response =~ /^[45]/){
344 0         0 $i_die =~ s/\?/$response/;
345 0         0 return error($init{'error_function'}, $i_die);
346             };
347 0 0       0 return error($init{'error_function'}, "Server disconnected: $response") if $response =~ /^221/;
348              
349             };
350             # built
351              
352             # send the data
353 0         0 print MAIL "Date: ", today();
354 0         0 print MAIL "From: $init{'return'}";
355 0         0 print MAIL "Subject: $init{'subject'}";
356 0         0 print MAIL "To: $init{'email'}";
357 0         0 print MAIL "X-Priority:2 (High)";
358 0         0 print MAIL "X-Carp-Notify: $Carp::Notify::VERSION";
359              
360 0         0 print MAIL "";
361              
362 0         0 $message =~ s/^\./../gm;
363 0         0 $message =~ s/(\r?\n|\r)/\015\012/g;
364              
365 0         0 print MAIL $message;
366              
367 0         0 print MAIL ".";
368             # sent
369              
370 0         0 return 1; # yay!
371             };
372              
373             sub today {
374 1     1 1 3200 my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
375 1         5 my @days = qw(Sun Mon Tue Wed Thu Fri Sat);
376              
377 1         23 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
378 1         3 $year += 1900;
379 1         8 my ($gmin, $ghour, $gsdst) = (gmtime(time))[1,2, -1];
380              
381 1         3 my $diffhour = $hour - $ghour;
382 1 50       4 $diffhour = 12 - $diffhour if $diffhour > 12;
383 1 50       3 $diffhour = 12 + $diffhour if $diffhour < -12;
384              
385 1         9 ($diffhour = sprintf("%03d", $diffhour)) =~ s/^0/\+/;
386              
387 1         11 return sprintf("%s, %02d %s %04d %02d:%02d:%02d %05s",
388             $days[$wday], $mday, $months[$mon], $year, $hour, $min, $sec, $diffhour . sprintf("%02d", $min - $gmin));
389             };
390              
391             # error does nothing unless you specify the error_function, in that case it's called with the error provided.
392             sub error {
393 0     0 1   my ($func, $error) = @_;
394 0 0         if (ref $func eq 'CODE'){
    0          
395 0           $func->($error);
396             }
397             elsif ($func){
398             # this wants reworked
399 1     1   7 no strict 'refs';
  1         1  
  1         113  
400 0           my ($calling_package) = (caller)[0];
401 0           my $package = $calling_package . "::";
402 0 0         $package = $1 if $$func =~ s/(.+::)//;
403 0           &{$package . $func}($error);
  0            
404             }
405             else {
406 0           return;
407             };
408             };
409              
410              
411             1;
412              
413             __END__