File Coverage

blib/lib/CGI/Carp/DebugScreen.pm
Criterion Covered Total %
statement 96 137 70.0
branch 25 46 54.3
condition 7 18 38.8
subroutine 15 24 62.5
pod 9 9 100.0
total 152 234 64.9


line stmt bran cond sub pod time code
1             package CGI::Carp::DebugScreen;
2            
3 2     2   48608 use strict;
  2         5  
  2         78  
4 2     2   12 use warnings;
  2         5  
  2         60  
5 2     2   12 use Exporter;
  2         9  
  2         118  
6 2     2   2016 use CGI::Carp qw/fatalsToBrowser/;
  2         11052  
  2         14  
7            
8             our $VERSION = '0.16';
9            
10             BEGIN {
11 2     2   342 my $MyDebug = 0;
12             CGI::Carp::set_message(
13 0         0 sub { __PACKAGE__->_output(@_) }
14 2 50       22 ) unless $MyDebug;
15             }
16            
17             $Carp::Verbose = 1; # for stacktraces
18            
19             sub _default_stylesheet {
20 20     20   279 return <<'EOS';
21            
133             EOS
134             }
135            
136             my %Options;
137             my %Mapping = (
138             debug => qr/^d(?:ebug)?$/,
139             engine => qr/^e(?:ngine)?$/,
140             show_lines => qr/^l(?:ines)?$/,
141             show_mod => qr/^m(?:od(?:ules)?)?$/,
142             show_env => qr/^env(?:ironment)?$/,
143             show_raw_error => qr/^raw(?:_error)?$/,
144             ignore_overload => qr/^(?:ignore_)?overload$/,
145             debug_template => qr/^d(?:ebug_)?t(?:emplate)?$/,
146             error_template => qr/^e(?:rror_)?t(?:emplate)?$/,
147             style => qr/^s(?:tyle)?$/,
148             );
149            
150             sub import {
151 20     20   96360 my ($class, %options) = @_;
152            
153 20         101 %Options = (
154             debug => 1,
155             engine => 'DefaultView',
156             show_lines => 3,
157             show_mod => 0,
158             show_env => 0,
159             show_raw_error => 0,
160             ignore_overload => 0,
161             debug_template => '',
162             error_template => '',
163             style => _default_stylesheet(),
164             watchlist => {},
165             );
166            
167 20         2700 while(my ($key, $value) = each %options) {
168 39 50       124 next unless defined $value;
169 39         161 foreach my $canonkey ( keys %Mapping ) {
170 210 100       965 if ( $key =~ $Mapping{$canonkey} ) {
171 39         104 $Options{$canonkey} = $value;
172 39         210 last;
173             }
174             }
175             }
176             }
177            
178 0     0 1 0 sub debug { shift; $Options{debug} = shift; }
  0         0  
179 0     0 1 0 sub set_debug_template { shift; $Options{debug_template} = shift; }
  0         0  
180 0     0 1 0 sub set_error_template { shift; $Options{error_template} = shift; }
  0         0  
181 0     0 1 0 sub set_style { shift; $Options{style} = shift; }
  0         0  
182 0     0 1 0 sub show_modules { shift; $Options{show_mod} = shift; }
  0         0  
183 0     0 1 0 sub show_environment { shift; $Options{show_env} = shift; }
  0         0  
184 0     0 1 0 sub show_raw_error { shift; $Options{show_raw_error} = shift; }
  0         0  
185 0     0 1 0 sub ignore_overload { shift; $Options{ignore_overload} = shift; }
  0         0  
186            
187             sub add_watchlist {
188 6     6 1 75 my ($class, %hash) = @_;
189 6         22 foreach my $key (keys %hash) {
190 6         35 $Options{watchlist}->{$key} = $hash{$key};
191             }
192             }
193            
194             sub _get_stacktraces {
195 18     18   42 my ($class, $raw_error) = @_;
196            
197 18         38 my $first_message = '';
198 18         27 my $no_more_first;
199            
200 54   50     155 my @stacktraces = grep {
201 54         93 my $caller = $_->{caller} || '';
202             (
203 54 50 33     441 $caller eq '' or # ignore undefined caller;
204             $caller eq $INC{'Carp.pm'} or # ignore Carp;
205             $caller eq $INC{'CGI/Carp.pm'} # ignore CGI::Carp;
206             ) ? 0 : 1;
207             }
208             map {
209 18         87 my $line = $_;
210 54         595 my ($message, $caller, $line_no) = $line =~ /^(?:\s*)(.*?)(?: called)? at (\S+) line (.+)$/;
211 54 0 33     157 $first_message .= "$line
" if !defined $message && !$no_more_first;
212 54 50       124 $no_more_first = 1 if defined $message;
213 54 100       113 $first_message = $message unless $first_message;
214 54   50     118 $caller ||= '';
215 54   50     101 $line_no ||= 0;
216 54         283 my $context = $class->_get_context($caller, $line_no);
217             +{
218 54         350 message => $message,
219             caller => $caller,
220             line => $line_no,
221             context => $context,
222            
223             # XXX: will be deprecated next time
224             contents => $context,
225             };
226             } split(/\n/, $raw_error);
227            
228 18         65 my $error_at = $stacktraces[$#stacktraces]->{caller};
229 18         79 my $error_message = $first_message.' at '.$stacktraces[0]->{caller}.' line '.$stacktraces[0]->{line};
230            
231 18         107 return ( $error_at, $error_message, @stacktraces );
232             }
233            
234             sub _get_context {
235 54     54   161 my ($class, $file, $line_no) = @_;
236            
237 54 50 33     1160 return unless $file && -f $file;
238            
239 54         87 my @context;
240 54 50       2070 if (open my $fh, '<', $file) {
241 54         76 my $ct = 0;
242 54         883 while(my $line = <$fh>) {
243 4680         4302 $ct++;
244 4680 100       14587 next if $ct < $line_no - $Options{show_lines};
245 432 100       831 last if $ct > $line_no + $Options{show_lines};
246 378         2058 push @context, {
247             no => $ct,
248             line => $line,
249             hit => ($ct == $line_no),
250             };
251             }
252             }
253 54         4103 \@context;
254             }
255            
256             sub _get_modules {
257 18     18   41 my ($class, $flag) = @_;
258            
259 18 100       78 return unless $flag;
260            
261 527         723 return map {
262 2789         3073 my $key = $_;
263 527         1164 (my $package = $key) =~ s|/|::|g;
264             +{
265 527         8330 package => $package,
266             file => $INC{$key},
267             }
268 6         343 } sort {$a cmp $b} keys %INC;
269             }
270            
271             sub _get_env {
272 18     18   29 my ($class, $flag) = @_;
273            
274 18 100       54 return unless $flag;
275            
276 132         457 return map {
277 438         465 +{
278             key => $_,
279             value => $ENV{$_},
280             }
281 6         74 } sort {$a cmp $b} keys %ENV;
282             }
283            
284             sub _get_watchlist {
285 18     18   30 my ($class, $href, $overload) = @_;
286            
287 18         30 my @list;
288 18 100       29 if (%{ $href }) {
  18         56  
289 6         12126 require CGI::Carp::DebugScreen::Dumper;
290 6         93 CGI::Carp::DebugScreen::Dumper->ignore_overload($overload);
291 6         11 foreach my $key (sort {$a cmp $b} keys %{ $href }) {
  0         0  
  6         30  
292 6         33 my $dump = CGI::Carp::DebugScreen::Dumper->dump($href->{$key});
293 6         40 push @list, {
294             key => $key,
295             value => $dump,
296            
297             # XXX: will be deprecated next time
298             table => $dump,
299             };
300             }
301             }
302 18         54 return @list;
303             }
304            
305             sub _load_view {
306 18     18   32 my ($class, $engine) = @_;
307            
308 18         21 my ($view_class, $view);
309 18 50 33     67 if ( ref $engine && $engine->can('as_html') ) {
310 0         0 $view_class = ref $engine;
311 0         0 $view = $engine;
312             }
313             else {
314             # engine alias
315 18 50       58 $engine = 'TT' if lc $engine eq 'template';
316            
317 18 50       64 $view_class = ( $engine =~ s/^\+// ) ? $engine : __PACKAGE__.'::'.$engine;
318            
319 18         1509 eval "require $view_class";
320 18 100       497 if ($@) {
321 6         941 require CGI::Carp::DebugScreen::DefaultView;
322 6         15 $view_class = 'CGI::Carp::DebugScreen::DefaultView';
323             }
324 18         34 $view = $view_class;
325             }
326 18         58 return ( $view_class, $view );
327             }
328            
329             sub _render {
330 18     18   6804 my ($class, $raw_error) = @_;
331            
332 18         87 my ($error_at, $error_message, @stacktraces) = $class->_get_stacktraces($raw_error);
333            
334 18         121 my @modules = $class->_get_modules($Options{show_mod});
335 18         124 my @environment = $class->_get_env($Options{show_env});
336 18         102 my @watchlist = $class->_get_watchlist(
337             $Options{watchlist},
338             $Options{ignore_overload},
339             );
340            
341 18         75 my ($view_class, $view) = $class->_load_view($Options{engine});
342            
343 18         233 return $view->as_html(
344             version => $VERSION,
345             debug => $Options{debug},
346             debug_template => $Options{debug_template},
347             error_template => $Options{error_template},
348             view => $view_class,
349             style => $Options{style},
350             error_at => $error_at,
351             error_message => $error_message,
352             raw_error => $raw_error,
353             show_raw_error => $Options{show_raw_error},
354             stacktraces => \@stacktraces,
355             modules => \@modules,
356             environment => \@environment,
357             watchlist => \@watchlist,
358            
359             # XXX: will be deprecated next time
360             debug_tmpl => $Options{debug_template},
361             error_tmpl => $Options{error_template},
362             traces => \@stacktraces,
363             );
364             }
365            
366             sub _output {
367 0     0     my ($class, $raw_error) = @_;
368            
369 0           my $html = $class->_render($raw_error);
370            
371             # shamelessly stolen from CGI::Carp
372            
373 0 0         if (exists $ENV{MOD_PERL}) {
374 0           my $r;
375             my $mod_perl;
376 0 0         if ($ENV{MOD_PERL_API_VERSION}) {
377 0           $mod_perl = 2;
378 0           require Apache2::RequestRec;
379 0           require Apache2::RequestIO;
380 0           require Apache2::RequestUtil;
381 0           require APR::Pool;
382 0           require ModPerl::Util;
383 0           require Apache2::Response;
384 0           $r = Apache2::RequestUtil->request;
385             }
386             else {
387 0           $r = Apache->request;
388             }
389 0 0         if ($r->bytes_sent) {
390 0           $r->print($html);
391 0 0         $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
392             }
393             else {
394 0 0         if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
395 0           $html = "\n$html";
396             }
397 0           $r->custom_response(500, $html);
398             }
399             }
400             else {
401 0           print $html;
402             }
403             }
404            
405             1;
406            
407             __END__