File Coverage

blib/lib/CGI/Ex/Die.pm
Criterion Covered Total %
statement 28 84 33.3
branch 13 68 19.1
condition 1 14 7.1
subroutine 6 8 75.0
pod 0 1 0.0
total 48 175 27.4


line stmt bran cond sub pod time code
1             package CGI::Ex::Die;
2              
3             =head1 NAME
4              
5             CGI::Ex::Die - A CGI::Carp::FatalsToBrowser type utility.
6              
7             =head1 VERSION
8              
9             version 2.54
10              
11             =cut
12              
13             ###----------------------------------------------------------------###
14             # Copyright - Paul Seamons #
15             # Distributed under the Perl Artistic License without warranty #
16             ###----------------------------------------------------------------###
17              
18 1     1   599 use strict;
  1         2  
  1         28  
19 1     1   4 use vars qw($EXTENDED_ERRORS $SHOW_TRACE $IGNORE_EVAL);
  1         1  
  1         47  
20 1     1   400 use CGI::Ex;
  1         1  
  1         39  
21 1     1   315 use CGI::Ex::Dump qw(debug ctrace dex_html);
  1         2  
  1         103  
22              
23             our $VERSION = '2.54'; # VERSION
24             our $no_recurse;
25             our $ERROR_TEMPLATE;
26             our $LOG_HANDLER;
27             our $FINAL_HANDLER;
28              
29             BEGIN {
30 1 50   1   4 $SHOW_TRACE = 0 if ! defined $SHOW_TRACE;
31 1 50       2 $IGNORE_EVAL = 0 if ! defined $IGNORE_EVAL;
32 1 50       862 $EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;
33             }
34              
35             ###----------------------------------------------------------------###
36              
37             sub import {
38 2     2   427 my $class = shift;
39 2 100       5 if ($#_ != -1) {
40 1 50       7 if (($#_ + 1) % 2) {
41 0         0 require Carp;
42 0         0 &Carp::croak("Usage: use ".__PACKAGE__." register => 1");
43             }
44 1         2 my %args = @_;
45             ### may be called as
46             # use CGI::Ex::Die register => 1;
47             # OR
48             # use CGI::Ex::Die register => [qw(die)];
49 1 50 33     4 if (! ref($args{register}) || grep {/die/} @{ $args{register} }) {
  0         0  
  0         0  
50 1         4 $SIG{__DIE__} = \&die_handler;
51             }
52 1 50       3 $SHOW_TRACE = $args{'show_trace'} if exists $args{'show_trace'};
53 1 50       2 $IGNORE_EVAL = $args{'ignore_eval'} if exists $args{'ignore_eval'};
54 1 50       3 $EXTENDED_ERRORS = $args{'extended_errors'} if exists $args{'extended_errors'};
55 1 50       2 $ERROR_TEMPLATE = $args{'error_template'} if exists $args{'error_template'};
56 1 50       2 $LOG_HANDLER = $args{'log_handler'} if exists $args{'log_handler'};
57 1 50       2 $FINAL_HANDLER = $args{'final_handler'} if exists $args{'final_handler'};
58             }
59 2         9 return 1;
60             }
61              
62             ###----------------------------------------------------------------###
63              
64             sub die_handler {
65 0     0 0   my $err = shift;
66              
67 0 0         die $err if $no_recurse;
68 0           local $no_recurse = 1;
69              
70             ### test for eval - if eval - propogate it up
71 0 0         if (! $IGNORE_EVAL) {
72 0 0         if (! $ENV{MOD_PERL}) {
73 0           my $n = 0;
74 0           while (my $sub = (caller(++$n))[3]) {
75 0 0         next if $sub !~ /eval/;
76 0           die $err; # die and let the eval catch it
77             }
78              
79             ### test for eval in a mod_perl environment
80             } else {
81 0           my $n = 0;
82 0           my $found = 0;
83 0           while (my $sub = (caller(++$n))[3]) {
84 0 0 0       $found = $n if ! $found && $sub =~ /eval/;
85 0 0         last if $sub =~ /^(Apache|ModPerl)::(PerlRun|Registry)/;
86             }
87 0 0 0       if ($found && $n - 1 != $found) {
88 0           die $err;
89             }
90             }
91             }
92              
93             ### decode the message
94 0 0 0       if (ref $err) {
    0          
95              
96             } elsif ($EXTENDED_ERRORS && $err) {
97 0           my $copy = "$err";
98 0 0         if ($copy =~ m|^Execution of ([/\w\.\-]+) aborted due to compilation errors|si) {
    0          
99 0           eval {
100 0     0     local $SIG{__WARN__} = sub {};
101 0           require $1;
102             };
103 0   0       my $error = $@ || '';
104 0           $error =~ s|Compilation failed in require at [/\w/\.\-]+/Die.pm line \d+\.\s*$||is;
105 0           chomp $error;
106 0           $err .= "\n($error)\n";
107             } elsif ($copy =~ m|^syntax error at ([/\w.\-]+) line \d+, near|mi) {
108             }
109             }
110              
111             ### prepare common args
112 0           my $msg = &CGI::Ex::Dump::_html_quote("$err");
113 0           $msg = "
Error: $msg
\n";
114 0 0         my $ctrace = ! $SHOW_TRACE ? ""
115             : "
" 
116             . dex_html(ctrace)."";
117 0           my $args = {err => "$err", msg => $msg, ctrace => $ctrace};
118              
119 0 0         &$LOG_HANDLER($args) if $LOG_HANDLER;
120              
121             ### web based - give more options
122 0 0         if ($ENV{REQUEST_METHOD}) {
123 0           my $cgix = CGI::Ex->new;
124 0           $| = 1;
125             ### get the template and swap it in
126             # allow for a sub that returns the template
127             # or a string
128             # or a filename (string starting with /)
129 0           my $out;
130 0 0         if ($ERROR_TEMPLATE) {
131             $out = UNIVERSAL::isa($ERROR_TEMPLATE, 'CODE') ? &$ERROR_TEMPLATE($args) # coderef
132             : (substr($ERROR_TEMPLATE,0,1) ne '/') ? $ERROR_TEMPLATE # html string
133 0 0         : do { # filename
    0          
134 0 0         if (open my $fh, $ERROR_TEMPLATE) {
135 0           read($fh, my $str, -s $ERROR_TEMPLATE);
136 0           $str; # return of the do
137             } };
138             }
139 0 0         if ($out) {
140 0           $cgix->swap_template(\$out, $args);
141             } else {
142 0           $out = $msg.'

'.$ctrace;
143             }
144              
145             ### similar to CGI::Carp
146 0 0         if (my $r = $cgix->apache_request) {
147 0 0         if ($r->bytes_sent) {
148 0           $r->print($out);
149             } else {
150 0           $r->status(500);
151 0           $r->custom_response(500, $out);
152             }
153             } else {
154 0           $cgix->print_content_type;
155 0           print $out;
156             }
157             } else {
158             ### command line execution
159             }
160              
161 0 0         &$FINAL_HANDLER($args) if $FINAL_HANDLER;
162              
163 0           die $err;
164             }
165              
166             1;
167              
168             __END__