File Coverage

blib/lib/Sledge/Plugin/DebugScreen.pm
Criterion Covered Total %
statement 29 77 37.6
branch 0 18 0.0
condition 0 6 0.0
subroutine 8 13 61.5
pod n/a
total 37 114 32.4


line stmt bran cond sub pod time code
1             package Sledge::Plugin::DebugScreen;
2 1     1   19538 use strict;
  1         2  
  1         29  
3 1     1   5 use warnings;
  1         1  
  1         33  
4             our $VERSION = '0.08';
5 1     1   17 use 5.008001;
  1         6  
  1         39  
6              
7 1     1   7002 use Template;
  1         23595  
  1         28  
8 1     1   1626 use Devel::StackTrace;
  1         3001  
  1         23  
9 1     1   864 use IO::File;
  1         10117  
  1         473  
10              
11             {
12             package Sledge::Exception::StackTrace;
13             sub print_context {
14 0     0   0 my $self = shift;
15 0         0 my($file, $linenum) = ($self->file, $self->line);
16 0         0 my $code;
17 0 0       0 if (-f $file) {
18 0         0 my $start = $linenum - 3;
19 0         0 my $end = $linenum + 3;
20 0 0       0 $start = $start < 1 ? 1 : $start;
21 0 0       0 if (my $fh = IO::File->new($file, 'r')) {
22 0         0 my $cur_line = 0;
23 0         0 while (my $line = <$fh>) {
24 0         0 ++$cur_line;
25 0 0       0 last if $cur_line > $end;
26 0 0       0 next if $cur_line < $start;
27 0 0       0 my @tag = $cur_line == $linenum ? qw( ) : ('', '');
28 0         0 $code .= sprintf(
29             '%s%5d: %s%s',
30             $tag[0], $cur_line, $self->_html_escape($line), $tag[1],
31             );
32             }
33             }
34             }
35 0         0 return $code;
36             }
37              
38             sub _html_escape {
39 0     0   0 my ($self, $str) = @_;
40 0         0 $str =~ s/&/&/g;
41 0         0 $str =~ s/
42 0         0 $str =~ s/>/>/g;
43 0         0 $str =~ s/"/"/g;
44 0         0 return $str;
45             }
46             }
47              
48             our $TEMPLATE = q{
49            
50            
51            
52             Error in [% title | html %]
53            
111            
112            
113            
114            

[% title | html %]
115              
116            
[% pages.current_url | html %]
117              
118            
119             [% desc | html %]
120            
121              
122            
123            

StackTrace
124            
125            
126             Package
127             Line
128             File
129            
130             [% FOR s IN stacktrace -%]
131            
132             [% s.pkg | html %]
133             [% s.line | html %]
134             [% s.file | html %]
135            
136            
137             
[% s.print_context %]
138            
139             [%- END %]
140            
141            
142            
143            
144            
145             };
146              
147             sub import {
148 1     1   10 my $self = shift;
149 1         1 my $pkg = caller;
150              
151 1     1   8 no strict 'refs';
  1         2  
  1         433  
152              
153             {
154 1         2 my $super = $pkg->can('dispatch');
  1         11  
155 1         3 *{"$pkg\::dispatch"} = sub {
156 0     0   0 my $self = shift;
157             local $SIG{__DIE__} = sub {
158 0     0   0 $self->{__stacktrace} = [map {Sledge::Exception::StackTrace->new(
  0         0  
159             file => $_->filename, line => $_->line, pkg => $_->package,
160             )} Devel::StackTrace->new->frames ];
161 0         0 die @_; # rethrow
162 0         0 };
163 0         0 $self->$super(@_);
164 1         4 };
165             }
166              
167 1         2 *{"$pkg\::handle_exception"} = \&_handle_exception;
  1         12  
168             }
169              
170             sub _handle_exception {
171 0     0     my ($self, $E) = @_;
172              
173 0 0         return if $self->finished;
174              
175 0 0         if ($self->debug_level) {
176 0           warn $E;
177              
178 0   0       my $vars = {
179             title => ref $self || $self,
180             desc => "$E",
181             pages => $self,
182             };
183              
184 0 0 0       if (ref $E and $E->can('stacktrace')) {
185 0           $vars->{stacktrace} = $E->stacktrace;
186             } else {
187 0           $vars->{stacktrace} = $self->{__stacktrace};
188 0           shift @{$vars->{stacktrace}};
  0            
189             }
190              
191 0           my $tmpl = Template->new;
192 0           my $output;
193 0           $tmpl->process(\$TEMPLATE, $vars, \$output);
194              
195 0           $self->r->content_type('text/html');
196 0           $self->set_content_length(length $output);
197 0           $self->r->status($self->SERVER_ERROR);
198 0           $self->send_http_header;
199 0           $self->r->print($output);
200 0           $self->finished(1);
201             } else {
202 0           die $E;
203             }
204             }
205              
206             1;
207             __END__