File Coverage

blib/lib/Dancer/Error.pm

Criterion	Covered	Total	%
statement	158	165	95.7
branch	46	54	85.1
condition	11	16	68.7
subroutine	32	33	96.9
pod	11	12	91.6
total	258	280	92.1

package Dancer::Error;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: class for representing fatal errors
$Dancer::Error::VERSION = '1.3521';
use strict;
use warnings;
use Carp;
use Scalar::Util qw(blessed);

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;
use Dancer::Exception qw(:all);

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

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

    Dancer::Factory::Hook->instance->execute_hooks('before_error_init', $self);

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

    $self->has_serializer
      and return;

    my $html_output = "" . $self->{type} . "";
    $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 exception      { $_[0]->{exception} }

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

    $self->{message} ||= "";
    my $message =
      qq|| . _html_encode($self->{message}) . "";

    # 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|| . "$file around line $line" . "";

    $backtrace .= qq||;

    $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||
              . tabulate($l + 1, $stop + 1)
              . qq| |
              . _html_encode($lines[$l])
              . "\n";
        }
        else {
            $backtrace
              .= qq||
              . tabulate($l + 1, $stop + 1)
              . " "
              . _html_encode($lines[$l]) . "\n";
        }
    }
    $backtrace .= "";


    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)
                   : eval Data::Dumper->new([$obj])->Purity(1)->Terse(1)->Deepcopy(1)->Dump;

    $data = {%$data} if blessed($data);

	my $censored = _censor($data);

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

# Given a hashref, censor anything that looks sensitive.  Returns number of
# items which were "censored".
sub _censor {
    my ( $hash, $recursecount ) = @_;
    $recursecount ||= 0;

    # we're checking recursion ourselves, no need to warn
    no warnings 'recursion';

    if ( $recursecount++ > 100 ) {
        warn "Data exceeding 100 levels, truncating\n";
        return $hash;
    }

    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}, $recursecount );
        }
        elsif ($key =~ /(pass|card?num|pan|cvv2?|ccv|secret|private_key|cookie_key)/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/&/&/g;
    $value =~ s/
    $value =~ s/>/>/g;
    $value =~ s/'/'/g;
    $value =~ s/"/"/g;

    return $value;
}

sub render {
    my $self = shift;

    my $serializer = setting('serializer');
    my $ops = { title => $self->title,
		message => $self->message,
		code => $self->code,
		defined $self->exception ? ( exception => $self->exception ) : (),
	      };
    Dancer::Factory::Hook->instance->execute_hooks('before_error_render', $self, $ops);
    my $response;
    try {
        $response = $serializer ? $self->_render_serialized($ops) : $self->_render_html($ops);
    } continuation {
        my ($continuation) = @_;
        # If we have a Route continuation, run the after hook, then
        # propagate the continuation
        Dancer::Factory::Hook->instance->execute_hooks('after_error_render', $response);
        $continuation->rethrow();
    };
    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 (ref $message eq 'HASH' && defined $self->exception) {
        if (blessed($self->exception)) {
            $message->{exception} = ref($self->exception);
            $message->{exception} =~ s/^Dancer::Exception:://;
        } else {
            $message->{exception} = $self->exception;
        }
    }

    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;
    my $ops = 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 $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|Environment|
      . dumper($r_env)
      . "";
    my $settings =
        qq|Settings|
      . dumper(Dancer::Config->settings)
      . "";
    my $source =
        qq|Stack|
      . $self->get_caller
      . "";
    my $session = "";

    if (setting('session')) {
        $session =
            qq[Session]
          . dumper(Dancer::Session->get)
          . "";
    }
    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__