File Coverage

blib/lib/No/Worries/Die.pm
Criterion Covered Total %
statement 27 52 51.9
branch 2 20 10.0
condition 0 3 0.0
subroutine 8 11 72.7
pod 2 2 100.0
total 39 88 44.3


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: No/Worries/Die.pm #
4             # #
5             # Description: error handling without worries #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package No::Worries::Die;
14 19     19   69602 use strict;
  19         49  
  19         595  
15 19     19   434 use warnings;
  19         46  
  19         1503  
16             our $VERSION = "1.7";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 19     19   129 use Carp qw(shortmess longmess);
  19         37  
  19         1250  
24 19     19   1748 use No::Worries qw($ProgramName);
  19         41  
  19         107  
25 19     19   135 use No::Worries::Export qw(export_control);
  19         37  
  19         109  
26 19     19   8841 use No::Worries::String qw(string_trim);
  19         62  
  19         133  
27              
28             #
29             # global variables
30             #
31              
32             our($Prefix, $Syslog);
33              
34             #
35             # kind of die() with sprintf()-like API
36             #
37              
38             sub dief ($@) {
39 31     31 1 6408 my($message, @arguments) = @_;
40              
41 31 100       172 $message = sprintf($message, @arguments) if @arguments;
42 31         112 die(string_trim($message) . "\n");
43             }
44              
45             #
46             # reasonable die() handler
47             #
48              
49             sub handler ($) {
50 0     0 1 0 my($message) = @_;
51              
52             # do nothing if called parsing a module/eval or executing an eval
53 0 0 0     0 return if not defined($^S) or $^S;
54             # handle a "normal" error
55 0         0 $message = string_trim($message);
56 0 0       0 if ($ENV{NO_WORRIES}) {
57 0 0       0 if ($ENV{NO_WORRIES} =~ /\b(confess)\b/) {
58 0         0 $message = longmess($message);
59 0         0 goto done;
60             }
61 0 0       0 if ($ENV{NO_WORRIES} =~ /\b(croak)\b/) {
62 0         0 $message = shortmess($message);
63 0         0 goto done;
64             }
65             }
66 0         0 $message .= "\n";
67             done:
68 0 0       0 if ($Syslog) {
69 0 0       0 unless (defined(&No::Worries::Syslog::syslog_error)) {
70 0         0 eval { require No::Worries::Syslog };
  0         0  
71 0 0       0 if ($@) {
72 0         0 warn($@);
73 0         0 $Syslog = 0;
74             }
75             }
76 0 0       0 if ($Syslog) {
77 0         0 eval { No::Worries::Syslog::syslog_error($message) };
  0         0  
78 0 0       0 warn($@) if $@;
79             }
80             }
81 0         0 die($Prefix . " " . $message);
82             }
83              
84             #
85             # module initialization
86             #
87              
88             # we tell Carp to treat our package as being internal
89             $Carp::Internal{ (__PACKAGE__) }++;
90              
91             # we set a default prefix
92             $Prefix = length($ProgramName) ? "$ProgramName\:" : "***";
93              
94             #
95             # export control
96             #
97              
98             sub import : method {
99 57     57   138 my($pkg, %exported);
100              
101 57         122 $pkg = shift(@_);
102 57         213 grep($exported{$_}++, qw(dief));
103 57     0   257 $exported{"handler"} = sub { $SIG{__DIE__} = \&handler };
  0         0  
104 57     0   183 $exported{"syslog"} = sub { $Syslog = 1 };
  0         0  
105 57         237 export_control(scalar(caller()), $pkg, \%exported, @_);
106             }
107              
108             1;
109              
110             __DATA__