1package CGI::Application::Plugin::DebugScreen;
2
3use 5.006;
4use strict;
5use warnings;
6use HTML::Template;
7use Devel::StackTrace;
8use IO::File;
9use UNIVERSAL::require;
10
11our $VERSION = '1.00';
12
13our $A_CODE = '<a class="package" href="?rm=view_code&amp;module=';
14our $A_POD  = '<a class="package" href="?rm=view_pod&amp;module=';
15our $A_TAIL = '">';
16our $A_END  = '</a>';
17
18our $TEMPLATE = qq{
19<html><!-- HTML::Template -->
20   <head>
21       <title>Error in <!-- TMPL_VAR NAME="title" --></title>
22       <style type="text/css">
23           body {
24               font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
25                           Tahoma, Arial, helvetica, sans-serif;
26               color: #000;
27               background-color: #E68200;
28               margin: 0px;
29               padding: 0px;
30           }
31           :link, :link:hover, :visited, :visited:hover {
32               color: #000;
33           }
34           div.box {
35               position: relative;
36               background-color: #fff;
37               border: 1px solid #aaa;
38               padding: 4px;
39               margin: 10px;
40               -moz-border-radius: 10px;
41           }
42           div.infos {
43               background-color: #fff;
44               border: 3px solid #FFCC99;
45               padding: 8px;
46               margin: 4px;
47               margin-bottom: 10px;
48               -moz-border-radius: 10px;
49               overflow: auto;
50           }
51           div.infos td.head{
52               text-align: center;
53           }
54
55           h1 {
56               margin: 0;
57               color: #999999;
58           }
59           h2 {
60               margin-top: 0;
61               margin-bottom: 10px;
62               font-size: medium;
63               font-weight: bold;
64               text-decoration: underline;
65           }
66           div.url {
67               font-size: x-small;
68               overflow: auto;
69           }
70           pre {
71               font-size: .8em;
72               line-height: 120%;
73               font-family: 'Courier New', Courier, monospace;
74               background-color: #FFCC99;
75               color: #333;
76               border: 1px dotted #000;
77               padding: 5px;
78               margin: 8px;
79               overflow: auto;
80           }
81           pre b {
82               font-weight: bold;
83               color: #000;
84               background-color: #E68200;
85           }
86           h1 a.package {
87               color: #999999;
88           }
89       </style>
90   </head>
91   <body>
92       <div class="box">
93           <h1><!-- TMPL_VAR NAME="title_a" --></h1>
94
95           <div class="url"><!-- TMPL_VAR NAME="url" --></div>
96           <div class="infos">
97               <!-- TMPL_VAR NAME="desc" --><br />
98           </div>
99           <div class="infos">
100               <h2>StackTrace</h2>
101               <table>
102
103                   <tr>
104                       <th>Package</th>
105                       <th>Line   </th>
106                       <th>File   </th>
107                       <!-- TMPL_IF NAME="view" -->
108                       <th>View   </th>
109                       <!-- /TMPL_IF -->
110                   </tr>
111                   <!-- TMPL_LOOP NAME="stacktrace" -->
112                       <tr>
113                           <td class="head"><!-- TMPL_VAR NAME="package" --></td>
114
115                           <td class="head"><!-- TMPL_VAR NAME="line" --></td>
116                           <td class="head"><!-- TMPL_VAR NAME="filename" --></td>
117                           <!-- TMPL_IF NAME="view" -->
118                           <td class="head"><!-- TMPL_VAR NAME="code" --> <!-- TMPL_VAR NAME="pod" --></td>
119                           <!-- /TMPL_IF -->
120                       </tr>
121                       <tr>
122                           <td colspan="4"><pre><!-- TMPL_VAR NAME="code_preview" --></pre></td>
123                       </tr>
124                   <!-- /TMPL_LOOP -->
125               </table>
126           </div>
127       </div>
128   </body>
129</html>
130};
131
132sub import {
133    my $self   = shift;
134    my $caller = scalar caller;
135
136    $caller->add_callback( 'init', sub{
137        my $self = shift;
138
139        $SIG{__DIE__} = sub{
140            push @{$self->{__stacktrace}},[Devel::StackTrace->new(ignore_package=>[qw/CGI::Application::Plugin::DebugScreen Carp CGI::Carp/])->frames];
141            die @_; # rethrow
142        };
143        {
144            no strict 'refs';
145            *{"$caller\::report"} = \&debug_report;
146
147            *{"$caller\::__debugscreen_error"} = sub{
148                my $self = shift;
149                if (
150                      exists $INC{'CGI/Application/Plugin/ViewCode.pm'}
151                      &&
152                    ! exists $INC{'CGI/Application/Dispatch.pm'}
153                   )
154                {
155                    $self->{__viewcode}++;
156                }
157                $self->report(@_);
158            };
159        }
160    });
161
162    $caller->add_callback( 'error', sub{
163        my $self = shift;
164        if ( $ENV{CGI_APP_DEBUG} && exists $INC{'CGI/Application/Plugin/ViewCode.pm'} ) {
165            $self->error_mode('__debugscreen_error');
166        }
167    });
168
169    if ( ! exists $INC{'CGI/Application/Plugin/ViewCode.pm'} ) {
170        "CGI::Application::Plugin::ViewCode"->require
171         or delete $INC{'CGI/Application/Plugin/ViewCode.pm'};
172        unless ($@) {goto &CGI::Application::Plugin::ViewCode::import}
173    }
174}
175
176sub debug_report{
177    my $self = shift;
178    my $desc = '' . shift; #stringify
179                           #useful in case of exception from CGI::Application::Plugin::TT
180    my $url = $self->query->url(-path_info=>1,-query=>1);
181
182    my $title = ref $self || $self;
183
184    $title = html_escape($title);
185    my $title_a = $title;
186
187    if ( $self->{__viewcode} ) {
188        $title_a = $A_CODE . $title . $A_TAIL . $title . $A_END;
189    }
190
191    my $stacks = $self->{__stacktrace}[0];
192
193    my @stacktraces;
194    for my $stack ( @{$stacks} ) {
195        my %s;
196        $s{package}  = exists $stack->{pkg}  ? $stack->{pkg}  : $stack->{package};
197        $s{filename} = exists $stack->{file} ? $stack->{file} : $stack->{filename};
198
199        $s{package}  = html_escape($s{package});
200        $s{filename} = html_escape($s{filename});
201        $s{line}     = html_escape($stack->{line});
202        $s{code_preview} = print_context($s{filename},$s{line},$s{package},$self->{__viewcode});
203
204        if ( $self->{__viewcode} && $s{package} ne 'main' ) {
205            $s{line}     = $A_CODE . $s{package} . '#'.$s{line} . $A_TAIL . $s{line} . $A_END;
206            $s{pod}      = $A_POD  . $s{package} . $A_TAIL . 'pod'        . $A_END;
207            $s{code}     = $A_CODE . $s{package} . $A_TAIL . 'code'       . $A_END;
208            $s{filename} = $A_CODE . $s{package} . $A_TAIL . $s{filename} . $A_END;
209            $s{package}  = $A_CODE . $s{package} . $A_TAIL . $s{package}  . $A_END;
210
211            $s{view} = $self->{__viewcode};
212        }
213        push @stacktraces, \%s;
214    }
215
216    my $t = HTML::Template->new(
217        scalarref => \$TEMPLATE,
218        die_on_bad_params => 0,
219    );
220    $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    $self->header_props( -type => 'text/html' );
230    return $t->output;
231}
232
233sub print_context {
234    my($file, $linenum, $package, $view) = @_;
235    my $code;
236    if (-f $file) {
237        my $start = $linenum - 3;
238        my $end   = $linenum + 3;
239        $start = $start < 1 ? 1 : $start;
240        if (my $fh = IO::File->new($file, 'r')) {
241            my $cur_line = 0;
242            while (my $line = <$fh>) {
243                ++$cur_line;
244                last if $cur_line > $end;
245                next if $cur_line < $start;
246                my @tag = $cur_line == $linenum ? qw(<b> </b>) : ("","");
247                if ( $view && $package ne 'main' && $cur_line == $linenum ) {
248                    my $t_line = $A_CODE.$package.'#'.$linenum.$A_TAIL;
249                    $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                    $code .= sprintf(
256                        '%s%5d: %s%s',
257                            $tag[0], $cur_line, html_escape($line), $tag[1],
258                    );
259                }
260            }
261        }
262    }
263    return $code;
264}
265
266sub html_escape {
267    my $str = shift;
268    $str =~ s/&/&amp;/g;
269    $str =~ s/</&lt;/g;
270    $str =~ s/>/&gt;/g;
271    $str =~ s/"/&quot;/g;
272    return $str;
273}
274
2751;
276
277=head1 NAME
278
279CGI::Application::Plugin::DebugScreen - add Debug support to CGI::Application.
280
281=head1 VERSION
282
283This documentation refers to CGI::Application::Plugin::DebugScreen version 0.06
284
285=head1 SYNOPSIS
286
287  use CGI::Application::Plugin::DebugScreen;
288
289Only it.
290If "Internal Server Error" was generated by "run_mode"....
291
292=head1 DESCRIPTION
293
294This plug-in add Debug support to CGI::Application.
295This plug-in like Catalyst debug mode.
296
297DebugScreen is done when B<$ENV{CGI_APP_DEBUG}> is set,
298 and DebugScreen is not done when not setting it.
299When your code is released, this plug-in need not be removed.
300
301When 'die' is generated by 'run_mode',
302 this plug-in outputs the stack trace by error_mode().
303As for this plug-in, error_mode() is overwrited in error callback.
304The error cannot be caught excluding run_mode.
305
306This uses CGI::Application::Plugin::ViewCode
307 if a state that CGI::Application::Plugin::ViewCode can be used or used.
308But CGI::Application::Dispatch is used,
309 this not uses CGI::Application::Plugin::ViewCode.
310
311When 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.
313line jumps to the specified line.
314And pod are links to CGI::Application::Plugin::ViewCode's view_pod mode.
315The code of the displayed is links to CGI::Application::Plugin::ViewCode's view_code mode.
316
317=head1 DEPENDENCIES
318
319L<strict>
320
321L<warnings>
322
323L<CGI::Application>
324
325L<HTML::Template>
326
327L<Devel::StackTrace>
328
329L<IO::File>
330
331L<CGI::Application::Plugin::ViewCode>
332
333L<UNIVERSAL::require>
334
335=head1 BUGS AND LIMITATIONS
336
337There are no known bugs in this module.
338Please report problems to Atsushi Kobayashi (E<lt>nekokak@cpan.orgE<gt>)
339Patches are welcome.
340
341=head1 SEE ALSO
342
343L<CGI::Application::Plugin::ViewCode>
344
345L<Sledge::Plugin::DebugScreen>
346
347L<CGI::Carp::DebugScreen>
348
349L<Catalyst::Plugin::StackTrace>
350
351=head1 Thanks To
352
353MATSUNO Tokuhiro (MATSUNO)
354
355Koichi Taniguchi (TANIGUCHI)
356
357Masahiro Nagano (KAZEBURO)
358
359Tomoyuki Misonou
360
361=head1 AUTHOR
362
363Atsushi Kobayashi, E<lt>nekokak@cpan.orgE<gt>
364
365=head1 COPYRIGHT AND LICENSE
366
367Copyright (C) 2006 by Atsushi Kobayashi (E<lt>nekokak@cpan.orgE<gt>). All rights reserved.
368
369This library is free software; you can redistribute it and/or modify it
370 under the same terms as Perl itself. See L<perlartistic>.
371
372=cut
373