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&module='; 14our $A_POD = '<a class="package" href="?rm=view_pod&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/&/&/g; 269 $str =~ s/</</g; 270 $str =~ s/>/>/g; 271 $str =~ s/"/"/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