Dancer::Error - class for representing fatal errors

    # taken from send_file:
    use Dancer::Error;

    my $error = Dancer::Error->new(
        code    => 404,
        message => "No such file: `$path'"
    );

    Dancer::Response->set($error->render);

package Dancer::Error;

use strict;
use warnings;
use Carp;

use base 'Dancer::Object';

use Dancer::Response;
use Dancer::Renderer;
use Dancer::Config 'setting';
use Dancer::Logger;
use Dancer::Factory::Hook;
use Dancer::Session;
use Dancer::FileUtils qw(open_file);
use Dancer::Engine;

Dancer::Factory::Hook->instance->install_hooks(
    qw/before_error_render after_error_render/);

sub init {
    my ($self) = @_;

    $self->attributes_defaults(
        title => 'Error ' . $self->code,
        type  => 'runtime error',
    );

    $self->has_serializer
      and return;

    my $html_output = "<h2>" . $self->{type} . "</h2>";
    $html_output .= $self->backtrace;
    $html_output .= $self->environment;

    $self->{message} = $html_output;
}

sub has_serializer { setting('serializer') }
sub code           { $_[0]->{code} }
sub title          { $_[0]->{title} }
sub message        { $_[0]->{message} }

sub backtrace {
    my ($self) = @_;

    $self->{message} ||= "";
    my $message =
      qq|<pre class="error">| . _html_encode($self->{message}) . "</pre>";

    # the default perl warning/error pattern
    my ($file, $line) = ($message =~ /at (\S+) line (\d+)/);

    # the Devel::SimpleTrace pattern
    ($file, $line) = ($message =~ /at.*\((\S+):(\d+)\)/)
      unless $file and $line;

    # no file/line found, cannot open a file for context
    return $message unless ($file and $line);

    # file and line are located, let's read the source Luke!
    my $fh = open_file('<', $file) or return $message;
    my @lines = <$fh>;
    close $fh;

    my $backtrace = $message;

    $backtrace
      .= qq|<div class="title">| . "$file around line $line" . "</div>";

    $backtrace .= qq|<pre class="content">|;

    $line--;
    my $start = (($line - 3) >= 0)             ? ($line - 3) : 0;
    my $stop  = (($line + 3) < scalar(@lines)) ? ($line + 3) : scalar(@lines);

    for (my $l = $start; $l <= $stop; $l++) {
        chomp $lines[$l];

        if ($l == $line) {
            $backtrace
              .= qq|<span class="nu">|
              . tabulate($l + 1, $stop + 1)
              . qq|</span> <span style="color: red;">|
              . _html_encode($lines[$l])
              . "</span>\n";
        }
        else {
            $backtrace
              .= qq|<span class="nu">|
              . tabulate($l + 1, $stop + 1)
              . "</span> "
              . _html_encode($lines[$l]) . "\n";
        }
    }
    $backtrace .= "</pre>";


    return $backtrace;
}

sub tabulate {
    my ($number, $max) = @_;
    my $len = length($max);
    return $number if length($number) == $len;
    return " $number";
}

sub dumper {
    my $obj = shift;
    return "Unavailable without Data::Dumper"
      unless Dancer::ModuleLoader->load('Data::Dumper');


    # Take a copy of the data, so we can mask sensitive-looking stuff:
    my %data     = Dancer::ModuleLoader->load('Clone') ?
                   %{ Clone::clone($obj) }             :
                   %$obj;
    my $censored = _censor(\%data);

    #use Data::Dumper;
    my $dd = Data::Dumper->new([\%data]);
    $dd->Terse(1)->Quotekeys(0)->Indent(1);
    my $content = $dd->Dump();
    $content =~ s{(\s*)(\S+)(\s*)=>}{$1<span class="key">$2</span>$3 =&gt;}g;
    if ($censored) {
        $content
          .= "\n\nNote: Values of $censored sensitive-looking keys hidden\n";
    }
    return $content;
}

# Given a hashref, censor anything that looks sensitive.  Returns number of
# items which were "censored".
sub _censor {
    my $hash = shift;
    if (!$hash || ref $hash ne 'HASH') {
        carp "_censor given incorrect input: $hash";
        return;
    }

    my $censored = 0;
    for my $key (keys %$hash) {
        if (ref $hash->{$key} eq 'HASH') {
            $censored += _censor($hash->{$key});
        }
        elsif ($key =~ /(pass|card?num|pan|secret)/i) {
            $hash->{$key} = "Hidden (looks potentially sensitive)";
            $censored++;
        }
    }

    return $censored;
}

# Replaces the entities that are illegal in (X)HTML.
sub _html_encode {
    my $value = shift;

    $value =~ s/&/&amp;/g;
    $value =~ s/</&lt;/g;
    $value =~ s/>/&gt;/g;
    $value =~ s/'/&#39;/g;
    $value =~ s/"/&quot;/g;

    return $value;
}

sub render {
    my $self = shift;

    my $serializer = setting('serializer');
    Dancer::Factory::Hook->instance->execute_hooks('before_error_render', $self);
    my $response = $serializer ? $self->_render_serialized() : $self->_render_html();
    Dancer::Factory::Hook->instance->execute_hooks('after_error_render', $response);
    $response;
}

sub _render_serialized {
    my $self = shift;

    my $message =
      !ref $self->message ? {error => $self->message} : $self->message;

    if (setting('show_errors')) {
        Dancer::Response->new(
            status  => $self->code,
            content => Dancer::Serializer->engine->serialize($message),
            headers => ['Content-Type' => Dancer::Serializer->engine->content_type]
            );
    }

    # if show_errors is disabled, we don't expose the real error message to the
    # outside world
    else {
        Dancer::Response->new(
            status => $self->code,
            content => "An internal error occured",
        );
    }

}

sub _render_html {
    my $self = shift;

    # I think it is irrelevant to look into show_errors. In the
    # template the user can hide them if she desires so.
    if (setting("error_template")) {
        my $template_name = setting("error_template");
        my $ops = {
                   title => $self->title,
                   message => $self->message,
                   code => $self->code,
                  };
        my $content = Dancer::Engine->engine("template")->apply_renderer($template_name, $ops);
        return Dancer::Response->new(
            status => $self->code,
            headers => ['Content-Type' => 'text/html'],
            content => $content);
    } else {
        return Dancer::Response->new(
            status  => $self->code,
            headers => ['Content-Type' => 'text/html'],
            content =>
                Dancer::Renderer->html_page($self->title, $self->message, 'error')
        ) if setting('show_errors');

        return Dancer::Renderer->render_error($self->code);
    }
}

sub environment {
    my ($self) = @_;

    my $request = Dancer::SharedData->request;
    my $r_env   = {};
    $r_env = $request->env if defined $request;

    my $env =
        qq|<div class="title">Environment</div><pre class="content">|
      . dumper($r_env)
      . "</pre>";
    my $settings =
        qq|<div class="title">Settings</div><pre class="content">|
      . dumper(Dancer::Config->settings)
      . "</pre>";
    my $source =
        qq|<div class="title">Stack</div><pre class="content">|
      . $self->get_caller
      . "</pre>";
    my $session = "";

    if (setting('session')) {
        $session =
            qq[<div class="title">Session</div><pre class="content">]
          . dumper(Dancer::Session->get)
          . "</pre>";
    }
    return "$source $settings $session $env";
}

sub get_caller {
    my ($self) = @_;
    my @stack;

    my $deepness = 0;
    while (my ($package, $file, $line) = caller($deepness++)) {
        push @stack, "$package in $file l. $line";
    }

    return join("\n", reverse(@stack));
}

1;

__END__