File Coverage

blib/lib/CGI/HTMLError.pm
Criterion Covered Total %
statement 10 71 14.0
branch 1 38 2.6
condition 1 21 4.7
subroutine 4 6 66.6
pod 0 2 0.0
total 16 138 11.5


line stmt bran cond sub pod time code
1             package CGI::HTMLError;
2              
3 1     1   838 use strict;
  1         2  
  1         75  
4              
5 1     1   6 use vars qw($VERSION %CONF $CSS $OLD_HANDLER);
  1         2  
  1         92  
6              
7             BEGIN {
8 1     1   11 $VERSION = '1.00';
9 1         989 $CONF{trace} = 0;
10             }
11              
12             $CSS = '
27             ';
28              
29             sub import {
30 1     1   9 shift @_;
31 1 50 33     13 return unless $ENV{GATEWAY_INTERFACE} and $ENV{GATEWAY_INTERFACE} =~ /CGI/;
32 0           %CONF = ( %CONF, @_ );
33 0 0 0       $OLD_HANDLER = $SIG{__DIE__} if defined $SIG{__DIE__} and $SIG{__DIE__} ne 'IGNORE' and $SIG{__DIE__} ne 'DEFAULT';
      0        
34 0           $SIG{__DIE__} = \ &show_source;
35             }
36              
37             sub show_source {
38              
39              
40             #
41             # First we try to establish if this exception might yet be cought.
42             # we try to do this by examining the stack trace for (eval) frames
43             #
44             # In a case of a fatal error inside an eval, this code gets
45             # called twice: the first time with the (eval) frame, the
46             # second time without.
47             #
48              
49 0     0 0   my $i;
50 0           my ($filename_from_stack,$number_from_stack);
51 0           while (1) {
52 0           my @caller = caller($i++);
53 0 0         if (defined $caller[3]) {
54 0   0       $filename_from_stack ||= $caller[1];
55 0   0       $number_from_stack ||= $caller[2];
56 0 0         return if $caller[3] eq '(eval)';
57             }
58             else {
59 0           last;
60             }
61             }
62              
63              
64             #
65             # now get the error string (we ignore exception objects, and just
66             # pray they will be stringified to a useful string)
67             #
68              
69 0           my ($error) = @_;
70              
71 0           my ($filename,$number,$rest_of_error);
72 0 0         if ($error =~ s/^(.*?\s+at\s+(.*?)\s+line\s+(\d+)[^\n]*)//s) {
73 0           $rest_of_error = $error;
74 0           $error = $1;
75 0           $filename = $2;
76 0           $number = $3;
77             }
78              
79              
80             #
81             # If we haven't found the file and line in the string, just use
82             # the one found in the stack-trace.
83             #
84              
85 0 0         unless ($filename) {
86 0           $filename = $filename_from_stack;
87 0           $number = $number_from_stack;
88 0           $rest_of_error .= "Exception caused at $filename line $number";
89             }
90              
91              
92              
93             #
94             # use the default css section or a link to another stylesheet
95             #
96              
97 0 0         my $css = $CONF{css} ? "" : $CSS;
98              
99              
100             #
101             # Setting status header and title..
102             #
103              
104 0           encode($error, $rest_of_error);
105            
106              
107 0           print "Status: 500 Server Error
108             Content-type: text/html
109              
110             500 Internal Server Error
111             $css
112            
113            
114            

500 Internal Server Error
115            
116             $error$rest_of_error
117            
118             ";
119              
120 0 0 0       if ($filename and $number) {
121              
122             #
123             # try to open the sourcefile where the error occured,
124             # fastforward to the apropiate line and print the section
125             #
126              
127 0 0         if ( open SOURCE,"< $filename" ) {
128 0 0         my $startline = $number - 10 >= 0 ? $number - 10 : 0;
129 0           my $endline = $startline + 20;
130 0           print 'Source:
';
131 0 0         print "....\n" if ($startline > 1);
132 0           while () {
133 0 0         last if $. > $endline;
134 0           chomp;
135 0 0         if ($. > $startline) {
136 0           encode($_);
137 0 0 0       if ($. == $number) {
    0          
138 0           $_ = "$_";
139             }
140             elsif ($. > $number - 5 and $. < $number + 5) {
141 0           $_ = "$_";
142             }
143 0           printf "%04d| %s\n",$.,$_;
144             }
145             }
146 0 0         print '....' if not eof SOURCE;
147 0           close SOURCE;
148 0           print "";
149             }
150             else {
151 0           print "Could not open $filename: $!";
152             }
153             }
154             else {
155 0           print "No filename or line number found in the error message";
156             }
157              
158             #
159             # show stacktrace if a tracelevel is specified.
160             #
161              
162 0 0         if ($CONF{trace}) {
163 0           print '
Stacktrace:
';
164 0           my $i;
165 0           while (1) {
166 0 0         my ($pack,$file,$number,$sub) = caller($i) or last;
167 0           printf "%02d| \&$sub called at $file line $number\n",$i++;
168             }
169 0           print '';
170             }
171              
172             #
173             # end with a version identifier.
174             #
175              
176 0           print "
CGI::HTMLError $VERSION
";
177              
178 0 0         if ($OLD_HANDLER) {
179 0           $SIG{__DIE__} = $OLD_HANDLER;
180 0           goto &$OLD_HANDLER;
181             }
182             }
183              
184             sub encode {
185 0     0 0   for (@_) {
186 0           s/
187 0           s/>/>/g;
188 0           s/\n/
\n/g;
189             }
190             }
191            
192             1;
193             __END__