File Coverage

blib/lib/CGI/Application/Plugin/DebugScreen.pm
Criterion Covered Total %
statement 31 104 29.8
branch 3 32 9.3
condition 0 18 0.0
subroutine 9 14 64.2
pod 0 3 0.0
total 43 171 25.1


line stmt bran cond sub pod time code
1             package CGI::Application::Plugin::DebugScreen;
2              
3 1     1   15460 use 5.006;
  1         6  
  1         67  
4 1     1   9 use strict;
  1         4  
  1         46  
5 1     1   21 use warnings;
  1         2  
  1         56  
6 1     1   14399 use HTML::Template;
  1         48335  
  1         56  
7 1     1   2056 use Devel::StackTrace;
  1         5288  
  1         34  
8 1     1   1323 use IO::File;
  1         18412  
  1         197  
9 1     1   4095 use UNIVERSAL::require;
  1         3981  
  1         15  
10              
11             our $VERSION = '1.00';
12              
13             our $A_CODE = ' 14             our $A_POD = ' 15             our $A_TAIL = '">';
16             our $A_END = '';
17              
18             our $TEMPLATE = qq{
19            
20            
21             Error in <!-- TMPL_VAR NAME="title" -->
22            
90            
91            
92            
93            

94              
95            
96            
97            
98            
99            
100            

StackTrace
101            
102              
103            
104             Package
105             Line
106             File
107            
108             View
109            
110            
111            
112            
113            
114              
115            
116            
117            
118            
119            
120            
121            
122            
123            
124            
125            
126            
127            
128            
129            
130             };
131              
132             sub import {
133 1     1   18 my $self = shift;
134 1         4 my $caller = scalar caller;
135              
136             $caller->add_callback( 'init', sub{
137 0     0   0 my $self = shift;
138              
139             $SIG{__DIE__} = sub{
140 0         0 push @{$self->{__stacktrace}},[Devel::StackTrace->new(ignore_package=>[qw/CGI::Application::Plugin::DebugScreen Carp CGI::Carp/])->frames];
  0         0  
141 0         0 die @_; # rethrow
142 0         0 };
143             {
144 1     1   450 no strict 'refs';
  1         3  
  1         3801  
  0         0  
145 0         0 *{"$caller\::report"} = \&debug_report;
  0         0  
146              
147 0         0 *{"$caller\::__debugscreen_error"} = sub{
148 0         0 my $self = shift;
149 0 0 0     0 if (
150             exists $INC{'CGI/Application/Plugin/ViewCode.pm'}
151             &&
152             ! exists $INC{'CGI/Application/Dispatch.pm'}
153             )
154             {
155 0         0 $self->{__viewcode}++;
156             }
157 0         0 $self->report(@_);
158 0         0 };
159             }
160 1         26 });
161              
162             $caller->add_callback( 'error', sub{
163 0     0   0 my $self = shift;
164 0 0 0     0 if ( $ENV{CGI_APP_DEBUG} && exists $INC{'CGI/Application/Plugin/ViewCode.pm'} ) {
165 0         0 $self->error_mode('__debugscreen_error');
166             }
167 1         21 });
168              
169 1 50       17 if ( ! exists $INC{'CGI/Application/Plugin/ViewCode.pm'} ) {
170 1 50       14 "CGI::Application::Plugin::ViewCode"->require
171             or delete $INC{'CGI/Application/Plugin/ViewCode.pm'};
172 1 50       29 unless ($@) {goto &CGI::Application::Plugin::ViewCode::import}
  0            
173             }
174             }
175              
176             sub debug_report{
177 0     0 0   my $self = shift;
178 0           my $desc = '' . shift; #stringify
179             #useful in case of exception from CGI::Application::Plugin::TT
180 0           my $url = $self->query->url(-path_info=>1,-query=>1);
181              
182 0   0       my $title = ref $self || $self;
183              
184 0           $title = html_escape($title);
185 0           my $title_a = $title;
186              
187 0 0         if ( $self->{__viewcode} ) {
188 0           $title_a = $A_CODE . $title . $A_TAIL . $title . $A_END;
189             }
190              
191 0           my $stacks = $self->{__stacktrace}[0];
192              
193 0           my @stacktraces;
194 0           for my $stack ( @{$stacks} ) {
  0            
195 0           my %s;
196 0 0         $s{package} = exists $stack->{pkg} ? $stack->{pkg} : $stack->{package};
197 0 0         $s{filename} = exists $stack->{file} ? $stack->{file} : $stack->{filename};
198              
199 0           $s{package} = html_escape($s{package});
200 0           $s{filename} = html_escape($s{filename});
201 0           $s{line} = html_escape($stack->{line});
202 0           $s{code_preview} = print_context($s{filename},$s{line},$s{package},$self->{__viewcode});
203              
204 0 0 0       if ( $self->{__viewcode} && $s{package} ne 'main' ) {
205 0           $s{line} = $A_CODE . $s{package} . '#'.$s{line} . $A_TAIL . $s{line} . $A_END;
206 0           $s{pod} = $A_POD . $s{package} . $A_TAIL . 'pod' . $A_END;
207 0           $s{code} = $A_CODE . $s{package} . $A_TAIL . 'code' . $A_END;
208 0           $s{filename} = $A_CODE . $s{package} . $A_TAIL . $s{filename} . $A_END;
209 0           $s{package} = $A_CODE . $s{package} . $A_TAIL . $s{package} . $A_END;
210              
211 0           $s{view} = $self->{__viewcode};
212             }
213 0           push @stacktraces, \%s;
214             }
215              
216 0           my $t = HTML::Template->new(
217             scalarref => \$TEMPLATE,
218             die_on_bad_params => 0,
219             );
220 0           $t->param(
221             title => $title,
222             title_a => $title_a,
223             view => $self->{__viewcode},
224             url => html_escape($url),
225             desc => html_escape($desc),
226             stacktrace => \@stacktraces,
227             );
228              
229 0           $self->header_props( -type => 'text/html' );
230 0           return $t->output;
231             }
232              
233             sub print_context {
234 0     0 0   my($file, $linenum, $package, $view) = @_;
235 0           my $code;
236 0 0         if (-f $file) {
237 0           my $start = $linenum - 3;
238 0           my $end = $linenum + 3;
239 0 0         $start = $start < 1 ? 1 : $start;
240 0 0         if (my $fh = IO::File->new($file, 'r')) {
241 0           my $cur_line = 0;
242 0           while (my $line = <$fh>) {
243 0           ++$cur_line;
244 0 0         last if $cur_line > $end;
245 0 0         next if $cur_line < $start;
246 0 0         my @tag = $cur_line == $linenum ? qw( ) : ("","");
247 0 0 0       if ( $view && $package ne 'main' && $cur_line == $linenum ) {
      0        
248 0           my $t_line = $A_CODE.$package.'#'.$linenum.$A_TAIL;
249 0           $code .= sprintf(
250             '%s%s%5d: %s%s%s',
251             $tag[0], $t_line, $cur_line, html_escape($line), $A_END, $tag[1],
252             );
253             }
254             else {
255 0           $code .= sprintf(
256             '%s%5d: %s%s',
257             $tag[0], $cur_line, html_escape($line), $tag[1],
258             );
259             }
260             }
261             }
262             }
263 0           return $code;
264             }
265              
266             sub html_escape {
267 0     0 0   my $str = shift;
268 0           $str =~ s/&/&/g;
269 0           $str =~ s/
270 0           $str =~ s/>/>/g;
271 0           $str =~ s/"/"/g;
272 0           return $str;
273             }
274              
275             1;
276              
277             =head1 NAME
278              
279             CGI::Application::Plugin::DebugScreen - add Debug support to CGI::Application.
280              
281             =head1 VERSION
282              
283             This documentation refers to CGI::Application::Plugin::DebugScreen version 0.06
284              
285             =head1 SYNOPSIS
286              
287             use CGI::Application::Plugin::DebugScreen;
288              
289             Only it.
290             If "Internal Server Error" was generated by "run_mode"....
291              
292             =head1 DESCRIPTION
293              
294             This plug-in add Debug support to CGI::Application.
295             This plug-in like Catalyst debug mode.
296              
297             DebugScreen is done when B<$ENV{CGI_APP_DEBUG}> is set,
298             and DebugScreen is not done when not setting it.
299             When your code is released, this plug-in need not be removed.
300              
301             When 'die' is generated by 'run_mode',
302             this plug-in outputs the stack trace by error_mode().
303             As for this plug-in, error_mode() is overwrited in error callback.
304             The error cannot be caught excluding run_mode.
305              
306             This uses CGI::Application::Plugin::ViewCode
307             if a state that CGI::Application::Plugin::ViewCode can be used or used.
308             But CGI::Application::Dispatch is used,
309             this not uses CGI::Application::Plugin::ViewCode.
310              
311             When CGI::Application::Plugin::ViewCode can be used,
312             Title, Package, File, code and line are links to CGI::Application::Plugin::ViewCode's view_code mode.
313             line jumps to the specified line.
314             And pod are links to CGI::Application::Plugin::ViewCode's view_pod mode.
315             The code of the displayed is links to CGI::Application::Plugin::ViewCode's view_code mode.
316              
317             =head1 DEPENDENCIES
318              
319             L
320              
321             L
322              
323             L
324              
325             L
326              
327             L
328              
329             L
330              
331             L
332              
333             L
334              
335             =head1 BUGS AND LIMITATIONS
336              
337             There are no known bugs in this module.
338             Please report problems to Atsushi Kobayashi (Enekokak@cpan.orgE)
339             Patches are welcome.
340              
341             =head1 SEE ALSO
342              
343             L
344              
345             L
346              
347             L
348              
349             L
350              
351             =head1 Thanks To
352              
353             MATSUNO Tokuhiro (MATSUNO)
354              
355             Koichi Taniguchi (TANIGUCHI)
356              
357             Masahiro Nagano (KAZEBURO)
358              
359             Tomoyuki Misonou
360              
361             =head1 AUTHOR
362              
363             Atsushi Kobayashi, Enekokak@cpan.orgE
364              
365             =head1 COPYRIGHT AND LICENSE
366              
367             Copyright (C) 2006 by Atsushi Kobayashi (Enekokak@cpan.orgE). All rights reserved.
368              
369             This library is free software; you can redistribute it and/or modify it
370             under the same terms as Perl itself. See L.
371              
372             =cut