PageRenderTime 62ms CodeModel.GetById 26ms RepoModel.GetById 0ms app.codeStats 0ms

/lib/Dancer/Error.pm

https://github.com/jessevanherk/Dancer
Perl | 451 lines | 249 code | 52 blank | 150 comment | 20 complexity | 6f7561ad161bb932286f3733ff2b78c4 MD5 | raw file
Possible License(s): AGPL-1.0
  1. package Dancer::Error;
  2. use strict;
  3. use warnings;
  4. use Carp;
  5. use Scalar::Util qw(blessed);
  6. use base 'Dancer::Object';
  7. use Dancer::Response;
  8. use Dancer::Renderer;
  9. use Dancer::Config 'setting';
  10. use Dancer::Logger;
  11. use Dancer::Factory::Hook;
  12. use Dancer::Session;
  13. use Dancer::FileUtils qw(open_file);
  14. use Dancer::Engine;
  15. use Dancer::Exception qw(:all);
  16. Dancer::Factory::Hook->instance->install_hooks(
  17. qw/before_error_render after_error_render before_error_init/);
  18. sub init {
  19. my ($self) = @_;
  20. Dancer::Factory::Hook->instance->execute_hooks('before_error_init', $self);
  21. $self->attributes_defaults(
  22. title => 'Error ' . $self->code,
  23. type => 'runtime error',
  24. );
  25. $self->has_serializer
  26. and return;
  27. my $html_output = "<h2>" . $self->{type} . "</h2>";
  28. $html_output .= $self->backtrace;
  29. $html_output .= $self->environment;
  30. $self->{message} = $html_output;
  31. }
  32. sub has_serializer { setting('serializer') }
  33. sub code { $_[0]->{code} }
  34. sub title { $_[0]->{title} }
  35. sub message { $_[0]->{message} }
  36. sub exception { $_[0]->{exception} }
  37. sub backtrace {
  38. my ($self) = @_;
  39. $self->{message} ||= "";
  40. my $message =
  41. qq|<pre class="error">| . _html_encode($self->{message}) . "</pre>";
  42. # the default perl warning/error pattern
  43. my ($file, $line) = ($message =~ /at (\S+) line (\d+)/);
  44. # the Devel::SimpleTrace pattern
  45. ($file, $line) = ($message =~ /at.*\((\S+):(\d+)\)/)
  46. unless $file and $line;
  47. # no file/line found, cannot open a file for context
  48. return $message unless ($file and $line);
  49. # file and line are located, let's read the source Luke!
  50. my $fh = open_file('<', $file) or return $message;
  51. my @lines = <$fh>;
  52. close $fh;
  53. my $backtrace = $message;
  54. $backtrace
  55. .= qq|<div class="title">| . "$file around line $line" . "</div>";
  56. $backtrace .= qq|<pre class="content">|;
  57. $line--;
  58. my $start = (($line - 3) >= 0) ? ($line - 3) : 0;
  59. my $stop = (($line + 3) < scalar(@lines)) ? ($line + 3) : scalar(@lines);
  60. for (my $l = $start; $l <= $stop; $l++) {
  61. chomp $lines[$l];
  62. if ($l == $line) {
  63. $backtrace
  64. .= qq|<span class="nu">|
  65. . tabulate($l + 1, $stop + 1)
  66. . qq|</span> <span style="color: red;">|
  67. . _html_encode($lines[$l])
  68. . "</span>\n";
  69. }
  70. else {
  71. $backtrace
  72. .= qq|<span class="nu">|
  73. . tabulate($l + 1, $stop + 1)
  74. . "</span> "
  75. . _html_encode($lines[$l]) . "\n";
  76. }
  77. }
  78. $backtrace .= "</pre>";
  79. return $backtrace;
  80. }
  81. sub tabulate {
  82. my ($number, $max) = @_;
  83. my $len = length($max);
  84. return $number if length($number) == $len;
  85. return " $number";
  86. }
  87. sub dumper {
  88. my $obj = shift;
  89. return "Unavailable without Data::Dumper"
  90. unless Dancer::ModuleLoader->load('Data::Dumper');
  91. # Take a copy of the data, so we can mask sensitive-looking stuff:
  92. my %data = Dancer::ModuleLoader->load('Clone') ?
  93. %{ Clone::clone($obj) } :
  94. %$obj;
  95. my $censored = _censor(\%data);
  96. #use Data::Dumper;
  97. my $dd = Data::Dumper->new([\%data]);
  98. $dd->Terse(1)->Quotekeys(0)->Indent(1)->Sortkeys(1);
  99. my $content = $dd->Dump();
  100. $content =~ s{(\s*)(\S+)(\s*)=>}{$1<span class="key">$2</span>$3 =&gt;}g;
  101. if ($censored) {
  102. $content
  103. .= "\n\nNote: Values of $censored sensitive-looking key"
  104. . ($censored == 1 ? '' : 's')
  105. . " hidden\n";
  106. }
  107. return $content;
  108. }
  109. # Given a hashref, censor anything that looks sensitive. Returns number of
  110. # items which were "censored".
  111. sub _censor {
  112. my ( $hash, $recursecount ) = @_;
  113. $recursecount ||= 0;
  114. # we're checking recursion ourselves, no need to warn
  115. no warnings 'recursion';
  116. if ( $recursecount++ > 100 ) {
  117. warn "Data exceeding 100 levels, truncating\n";
  118. return $hash;
  119. }
  120. if (!$hash || ref $hash ne 'HASH') {
  121. carp "_censor given incorrect input: $hash";
  122. return;
  123. }
  124. my $censored = 0;
  125. for my $key (keys %$hash) {
  126. if (ref $hash->{$key} eq 'HASH') {
  127. $censored += _censor( $hash->{$key}, $recursecount );
  128. }
  129. elsif ($key =~ /(pass|card?num|pan|secret|private_key)/i) {
  130. $hash->{$key} = "Hidden (looks potentially sensitive)";
  131. $censored++;
  132. }
  133. }
  134. return $censored;
  135. }
  136. # Replaces the entities that are illegal in (X)HTML.
  137. sub _html_encode {
  138. my $value = shift;
  139. $value =~ s/&/&amp;/g;
  140. $value =~ s/</&lt;/g;
  141. $value =~ s/>/&gt;/g;
  142. $value =~ s/'/&#39;/g;
  143. $value =~ s/"/&quot;/g;
  144. return $value;
  145. }
  146. sub render {
  147. my $self = shift;
  148. my $serializer = setting('serializer');
  149. Dancer::Factory::Hook->instance->execute_hooks('before_error_render', $self);
  150. my $response;
  151. try {
  152. $response = $serializer ? $self->_render_serialized() : $self->_render_html();
  153. } continuation {
  154. my ($continuation) = @_;
  155. # If we have a Route continuation, run the after hook, then
  156. # propagate the continuation
  157. Dancer::Factory::Hook->instance->execute_hooks('after_error_render', $response);
  158. $continuation->rethrow();
  159. };
  160. Dancer::Factory::Hook->instance->execute_hooks('after_error_render', $response);
  161. $response;
  162. }
  163. sub _render_serialized {
  164. my $self = shift;
  165. my $message =
  166. !ref $self->message ? {error => $self->message} : $self->message;
  167. if (ref $message eq 'HASH' && defined $self->exception) {
  168. if (blessed($self->exception)) {
  169. $message->{exception} = ref($self->exception);
  170. $message->{exception} =~ s/^Dancer::Exception:://;
  171. } else {
  172. $message->{exception} = $self->exception;
  173. }
  174. }
  175. if (setting('show_errors')) {
  176. Dancer::Response->new(
  177. status => $self->code,
  178. content => Dancer::Serializer->engine->serialize($message),
  179. headers => ['Content-Type' => Dancer::Serializer->engine->content_type]
  180. );
  181. }
  182. # if show_errors is disabled, we don't expose the real error message to the
  183. # outside world
  184. else {
  185. Dancer::Response->new(
  186. status => $self->code,
  187. content => "An internal error occured",
  188. );
  189. }
  190. }
  191. sub _render_html {
  192. my $self = shift;
  193. # I think it is irrelevant to look into show_errors. In the
  194. # template the user can hide them if she desires so.
  195. if (setting("error_template")) {
  196. my $template_name = setting("error_template");
  197. my $ops = {
  198. title => $self->title,
  199. message => $self->message,
  200. code => $self->code,
  201. defined $self->exception ? ( exception => $self->exception ) : (),
  202. };
  203. my $content = Dancer::Engine->engine("template")->apply_renderer($template_name, $ops);
  204. return Dancer::Response->new(
  205. status => $self->code,
  206. headers => ['Content-Type' => 'text/html'],
  207. content => $content);
  208. } else {
  209. return Dancer::Response->new(
  210. status => $self->code,
  211. headers => ['Content-Type' => 'text/html'],
  212. content =>
  213. Dancer::Renderer->html_page($self->title, $self->message, 'error')
  214. ) if setting('show_errors');
  215. return Dancer::Renderer->render_error($self->code);
  216. }
  217. }
  218. sub environment {
  219. my ($self) = @_;
  220. my $request = Dancer::SharedData->request;
  221. my $r_env = {};
  222. $r_env = $request->env if defined $request;
  223. my $env =
  224. qq|<div class="title">Environment</div><pre class="content">|
  225. . dumper($r_env)
  226. . "</pre>";
  227. my $settings =
  228. qq|<div class="title">Settings</div><pre class="content">|
  229. . dumper(Dancer::Config->settings)
  230. . "</pre>";
  231. my $source =
  232. qq|<div class="title">Stack</div><pre class="content">|
  233. . $self->get_caller
  234. . "</pre>";
  235. my $session = "";
  236. if (setting('session')) {
  237. $session =
  238. qq[<div class="title">Session</div><pre class="content">]
  239. . dumper(Dancer::Session->get)
  240. . "</pre>";
  241. }
  242. return "$source $settings $session $env";
  243. }
  244. sub get_caller {
  245. my ($self) = @_;
  246. my @stack;
  247. my $deepness = 0;
  248. while (my ($package, $file, $line) = caller($deepness++)) {
  249. push @stack, "$package in $file l. $line";
  250. }
  251. return join("\n", reverse(@stack));
  252. }
  253. 1;
  254. __END__
  255. =pod
  256. =head1 NAME
  257. Dancer::Error - class for representing fatal errors
  258. =head1 SYNOPSIS
  259. # taken from send_file:
  260. use Dancer::Error;
  261. my $error = Dancer::Error->new(
  262. code => 404,
  263. message => "No such file: `$path'"
  264. );
  265. $error->render;
  266. =head1 DESCRIPTION
  267. With Dancer::Error you can throw reasonable-looking errors to the user instead
  268. of crashing the application and filling up the logs.
  269. This is usually used in debugging environments, and it's what Dancer uses as
  270. well under debugging to catch errors and show them on screen.
  271. =head1 ATTRIBUTES
  272. =head2 code
  273. The code that caused the error.
  274. This is only an attribute getter, you'll have to set it at C<new>.
  275. =head2 title
  276. The title of the error page.
  277. This is only an attribute getter, you'll have to set it at C<new>.
  278. =head2 message
  279. The message of the error page.
  280. This is only an attribute getter, you'll have to set it at C<new>.
  281. =head2 exception
  282. The exception that caused the error. If the error was not caused by an
  283. exception, returns undef. Exceptions are usually objects that inherits of
  284. Dancer::Exception.
  285. This is only an attribute getter, you'll have to set it at C<new>.
  286. =head1 METHODS/SUBROUTINES
  287. =head2 new
  288. Create a new Dancer::Error object.
  289. =head3 title
  290. The title of the error page.
  291. =head3 type
  292. What type of error this is.
  293. =head3 code
  294. The code that caused the error.
  295. =head3 message
  296. The message that will appear to the user.
  297. =head3 exception
  298. The exception that will be useable by the rendering.
  299. =head2 backtrace
  300. Create a backtrace of the code where the error is caused.
  301. This method tries to find out where the error appeared according to the actual
  302. error message (using the C<message> attribute) and tries to parse it (supporting
  303. the regular/default Perl warning or error pattern and the L<Devel::SimpleTrace>
  304. output) and then returns an error-higlighted C<message>.
  305. =head2 tabulate
  306. Small subroutine to help output nicer.
  307. =head2 dumper
  308. This uses L<Data::Dumper> to create nice content output with a few predefined
  309. options.
  310. =head2 render
  311. Renders a response using L<Dancer::Response>.
  312. =head2 environment
  313. A main function to render environment information: the caller (using
  314. C<get_caller>), the settings and environment (using C<dumper>) and more.
  315. =head2 get_caller
  316. Creates a strack trace of callers.
  317. =head2 _censor
  318. An internal method that tries to censor out content which should be protected.
  319. C<dumper> calls this method to censor things like passwords and such.
  320. =head2 _html_encode
  321. Internal method to encode entities that are illegal in (X)HTML. We output as
  322. UTF-8, so no need to encode all non-ASCII characters or use a module.
  323. FIXME : this is not true anymore, output can be any charset. Need fixing.
  324. =head1 AUTHOR
  325. Alexis Sukrieh
  326. =head1 LICENSE AND COPYRIGHT
  327. Copyright 2009-2010 Alexis Sukrieh.
  328. This program is free software; you can redistribute it and/or modify it
  329. under the terms of either: the GNU General Public License as published
  330. by the Free Software Foundation; or the Artistic License.
  331. See http://dev.perl.org/licenses/ for more information.