1package Dancer::Error; 2our $AUTHORITY = 'cpan:SUKRIA'; 3#ABSTRACT: class for representing fatal errors 4$Dancer::Error::VERSION = '1.3513'; 5use strict; 6use warnings; 7use Carp; 8use Scalar::Util qw(blessed); 9 10use base 'Dancer::Object'; 11 12use Dancer::Response; 13use Dancer::Renderer; 14use Dancer::Config 'setting'; 15use Dancer::Logger; 16use Dancer::Factory::Hook; 17use Dancer::Session; 18use Dancer::FileUtils qw(open_file); 19use Dancer::Engine; 20use Dancer::Exception qw(:all); 21 22Dancer::Factory::Hook->instance->install_hooks( 23 qw/before_error_render after_error_render before_error_init/); 24 25sub init { 26 my ($self) = @_; 27 28 Dancer::Factory::Hook->instance->execute_hooks('before_error_init', $self); 29 30 $self->attributes_defaults( 31 title => 'Error ' . $self->code, 32 type => 'runtime error', 33 ); 34 35 $self->has_serializer 36 and return; 37 38 my $html_output = "<h2>" . $self->{type} . "</h2>"; 39 $html_output .= $self->backtrace; 40 $html_output .= $self->environment; 41 42 $self->{message} = $html_output; 43} 44 45sub has_serializer { setting('serializer') } 46sub code { $_[0]->{code} } 47sub title { $_[0]->{title} } 48sub message { $_[0]->{message} } 49sub exception { $_[0]->{exception} } 50 51sub backtrace { 52 my ($self) = @_; 53 54 $self->{message} ||= ""; 55 my $message = 56 qq|<pre class="error">| . _html_encode($self->{message}) . "</pre>"; 57 58 # the default perl warning/error pattern 59 my ($file, $line) = ($message =~ /at (\S+) line (\d+)/); 60 61 # the Devel::SimpleTrace pattern 62 ($file, $line) = ($message =~ /at.*\((\S+):(\d+)\)/) 63 unless $file and $line; 64 65 # no file/line found, cannot open a file for context 66 return $message unless ($file and $line); 67 68 # file and line are located, let's read the source Luke! 69 my $fh = open_file('<', $file) or return $message; 70 my @lines = <$fh>; 71 close $fh; 72 73 my $backtrace = $message; 74 75 $backtrace 76 .= qq|<div class="title">| . "$file around line $line" . "</div>"; 77 78 $backtrace .= qq|<pre class="content">|; 79 80 $line--; 81 my $start = (($line - 3) >= 0) ? ($line - 3) : 0; 82 my $stop = (($line + 3) < scalar(@lines)) ? ($line + 3) : scalar(@lines); 83 84 for (my $l = $start; $l <= $stop; $l++) { 85 chomp $lines[$l]; 86 87 if ($l == $line) { 88 $backtrace 89 .= qq|<span class="nu">| 90 . tabulate($l + 1, $stop + 1) 91 . qq|</span> <span style="color: red;">| 92 . _html_encode($lines[$l]) 93 . "</span>\n"; 94 } 95 else { 96 $backtrace 97 .= qq|<span class="nu">| 98 . tabulate($l + 1, $stop + 1) 99 . "</span> " 100 . _html_encode($lines[$l]) . "\n"; 101 } 102 } 103 $backtrace .= "</pre>"; 104 105 106 return $backtrace; 107} 108 109sub tabulate { 110 my ($number, $max) = @_; 111 my $len = length($max); 112 return $number if length($number) == $len; 113 return " $number"; 114} 115 116sub dumper { 117 my $obj = shift; 118 return "Unavailable without Data::Dumper" 119 unless Dancer::ModuleLoader->load('Data::Dumper'); 120 121 122 # Take a copy of the data, so we can mask sensitive-looking stuff: 123 my $data = Dancer::ModuleLoader->load('Clone') ? 124 Clone::clone($obj) 125 : eval Data::Dumper->new([$obj])->Purity(1)->Terse(1)->Deepcopy(1)->Dump; 126 127 $data = {%$data} if blessed($data); 128 129 my $censored = _censor($data); 130 131 #use Data::Dumper; 132 my $dd = Data::Dumper->new([$data]); 133 $dd->Terse(1)->Quotekeys(0)->Indent(1)->Sortkeys(1); 134 my $content = $dd->Dump(); 135 $content =~ s{(\s*)(\S+)(\s*)=>}{$1<span class="key">$2</span>$3 =>}g; 136 if ($censored) { 137 $content 138 .= "\n\nNote: Values of $censored sensitive-looking key" 139 . ($censored == 1 ? '' : 's') 140 . " hidden\n"; 141 } 142 return $content; 143} 144 145# Given a hashref, censor anything that looks sensitive. Returns number of 146# items which were "censored". 147sub _censor { 148 my ( $hash, $recursecount ) = @_; 149 $recursecount ||= 0; 150 151 # we're checking recursion ourselves, no need to warn 152 no warnings 'recursion'; 153 154 if ( $recursecount++ > 100 ) { 155 warn "Data exceeding 100 levels, truncating\n"; 156 return $hash; 157 } 158 159 if (!$hash || ref $hash ne 'HASH') { 160 carp "_censor given incorrect input: $hash"; 161 return; 162 } 163 164 my $censored = 0; 165 for my $key (keys %$hash) { 166 if (ref $hash->{$key} eq 'HASH') { 167 $censored += _censor( $hash->{$key}, $recursecount ); 168 } 169 elsif ($key =~ /(pass|card?num|pan|cvv2?|ccv|secret|private_key|cookie_key)/i) { 170 $hash->{$key} = "Hidden (looks potentially sensitive)"; 171 $censored++; 172 } 173 } 174 175 return $censored; 176} 177 178# Replaces the entities that are illegal in (X)HTML. 179sub _html_encode { 180 my $value = shift; 181 182 $value =~ s/&/&/g; 183 $value =~ s/</</g; 184 $value =~ s/>/>/g; 185 $value =~ s/'/'/g; 186 $value =~ s/"/"/g; 187 188 return $value; 189} 190 191sub render { 192 my $self = shift; 193 194 my $serializer = setting('serializer'); 195 Dancer::Factory::Hook->instance->execute_hooks('before_error_render', $self); 196 my $response; 197 try { 198 $response = $serializer ? $self->_render_serialized() : $self->_render_html(); 199 } continuation { 200 my ($continuation) = @_; 201 # If we have a Route continuation, run the after hook, then 202 # propagate the continuation 203 Dancer::Factory::Hook->instance->execute_hooks('after_error_render', $response); 204 $continuation->rethrow(); 205 }; 206 Dancer::Factory::Hook->instance->execute_hooks('after_error_render', $response); 207 $response; 208} 209 210sub _render_serialized { 211 my $self = shift; 212 213 my $message = 214 !ref $self->message ? {error => $self->message} : $self->message; 215 216 if (ref $message eq 'HASH' && defined $self->exception) { 217 if (blessed($self->exception)) { 218 $message->{exception} = ref($self->exception); 219 $message->{exception} =~ s/^Dancer::Exception:://; 220 } else { 221 $message->{exception} = $self->exception; 222 } 223 } 224 225 if (setting('show_errors')) { 226 Dancer::Response->new( 227 status => $self->code, 228 content => Dancer::Serializer->engine->serialize($message), 229 headers => ['Content-Type' => Dancer::Serializer->engine->content_type] 230 ); 231 } 232 233 # if show_errors is disabled, we don't expose the real error message to the 234 # outside world 235 else { 236 Dancer::Response->new( 237 status => $self->code, 238 content => "An internal error occured", 239 ); 240 } 241 242} 243 244sub _render_html { 245 my $self = shift; 246 247 # I think it is irrelevant to look into show_errors. In the 248 # template the user can hide them if she desires so. 249 if (setting("error_template")) { 250 my $template_name = setting("error_template"); 251 my $ops = { 252 title => $self->title, 253 message => $self->message, 254 code => $self->code, 255 defined $self->exception ? ( exception => $self->exception ) : (), 256 }; 257 my $content = Dancer::Engine->engine("template")->apply_renderer($template_name, $ops); 258 return Dancer::Response->new( 259 status => $self->code, 260 headers => ['Content-Type' => 'text/html'], 261 content => $content); 262 } else { 263 return Dancer::Response->new( 264 status => $self->code, 265 headers => ['Content-Type' => 'text/html'], 266 content => 267 Dancer::Renderer->html_page($self->title, $self->message, 'error') 268 ) if setting('show_errors'); 269 270 return Dancer::Renderer->render_error($self->code); 271 } 272} 273 274sub environment { 275 my ($self) = @_; 276 277 my $request = Dancer::SharedData->request; 278 my $r_env = {}; 279 $r_env = $request->env if defined $request; 280 281 my $env = 282 qq|<div class="title">Environment</div><pre class="content">| 283 . dumper($r_env) 284 . "</pre>"; 285 my $settings = 286 qq|<div class="title">Settings</div><pre class="content">| 287 . dumper(Dancer::Config->settings) 288 . "</pre>"; 289 my $source = 290 qq|<div class="title">Stack</div><pre class="content">| 291 . $self->get_caller 292 . "</pre>"; 293 my $session = ""; 294 295 if (setting('session')) { 296 $session = 297 qq[<div class="title">Session</div><pre class="content">] 298 . dumper(Dancer::Session->get) 299 . "</pre>"; 300 } 301 return "$source $settings $session $env"; 302} 303 304sub get_caller { 305 my ($self) = @_; 306 my @stack; 307 308 my $deepness = 0; 309 while (my ($package, $file, $line) = caller($deepness++)) { 310 push @stack, "$package in $file l. $line"; 311 } 312 313 return join("\n", reverse(@stack)); 314} 315 3161; 317 318__END__ 319 320=pod 321 322=encoding UTF-8 323 324=head1 NAME 325 326Dancer::Error - class for representing fatal errors 327 328=head1 VERSION 329 330version 1.3513 331 332=head1 SYNOPSIS 333 334 # taken from send_file: 335 use Dancer::Error; 336 337 my $error = Dancer::Error->new( 338 code => 404, 339 message => "No such file: `$path'" 340 ); 341 342 $error->render; 343 344=head1 DESCRIPTION 345 346With Dancer::Error you can throw reasonable-looking errors to the user instead 347of crashing the application and filling up the logs. 348 349This is usually used in debugging environments, and it's what Dancer uses as 350well under debugging to catch errors and show them on screen. 351 352=head1 ATTRIBUTES 353 354=head2 code 355 356The code that caused the error. 357 358This is only an attribute getter, you'll have to set it at C<new>. 359 360=head2 title 361 362The title of the error page. 363 364This is only an attribute getter, you'll have to set it at C<new>. 365 366=head2 message 367 368The message of the error page. 369 370This is only an attribute getter, you'll have to set it at C<new>. 371 372=head2 exception 373 374The exception that caused the error. If the error was not caused by an 375exception, returns undef. Exceptions are usually objects that inherit from 376Dancer::Exception. 377 378This is only an attribute getter, you'll have to set it at C<new>. 379 380=head1 METHODS/SUBROUTINES 381 382=head2 new 383 384Create a new Dancer::Error object. 385 386=head3 title 387 388The title of the error page. 389 390=head3 type 391 392What type of error this is. 393 394=head3 code 395 396The code that caused the error. 397 398=head3 message 399 400The message that will appear to the user. 401 402=head3 exception 403 404The exception that will be useable by the rendering. 405 406=head2 backtrace 407 408Create a backtrace of the code where the error is caused. 409 410This method tries to find out where the error appeared according to the actual 411error message (using the C<message> attribute) and tries to parse it (supporting 412the regular/default Perl warning or error pattern and the L<Devel::SimpleTrace> 413output) and then returns an error-highlighted C<message>. 414 415=head2 tabulate 416 417Small subroutine to help output nicer. 418 419=head2 dumper 420 421This uses L<Data::Dumper> to create nice content output with a few predefined 422options. 423 424=head2 render 425 426Renders a response using L<Dancer::Response>. 427 428=head2 environment 429 430A main function to render environment information: the caller (using 431C<get_caller>), the settings and environment (using C<dumper>) and more. 432 433=head2 get_caller 434 435Creates a stack trace of callers. 436 437=head2 _censor 438 439An internal method that tries to censor out content which should be protected. 440 441C<dumper> calls this method to censor things like passwords and such. 442 443=head2 _html_encode 444 445Internal method to encode entities that are illegal in (X)HTML. We output as 446UTF-8, so no need to encode all non-ASCII characters or use a module. 447FIXME : this is not true any more, output can be any charset. Need fixing. 448 449=head1 AUTHOR 450 451Dancer Core Developers 452 453=head1 COPYRIGHT AND LICENSE 454 455This software is copyright (c) 2010 by Alexis Sukrieh. 456 457This is free software; you can redistribute it and/or modify it under 458the same terms as the Perl 5 programming language system itself. 459 460=cut 461