File Coverage

blib/lib/Cake/Exception.pm

Criterion	Covered	Total	%
statement	54	91	59.3
branch	12	30	40.0
condition	4	6	66.6
subroutine	10	14	71.4
pod	0	8	0.0
total	80	149	53.6

package Cake::Exception;
use strict;
use Carp;
use Data::Dumper;

our @CARP_NOT;
use base 'Exporter';
our @EXPORT = qw(
    error
    log
    warn
);

##For quick testing
BEGIN {
   $SIG{__DIE__} = \&trapper;
}

sub trapper {
    my $message = shift;
    $message = __PACKAGE__->backtrace($message);
print STDOUT <
Content-Type: text/html
$message
END
}

## die nicely just to detach the flow sequence of Cake action
## and not a real die
my $kill_nicely = 0;
sub Mercy_Killing {
    my $c = shift;
    $kill_nicely = 1;
    die();
}

sub error {
    my ($self,$error) = @_;
    local @CARP_NOT = qw(Cake);
    if ($kill_nicely){
        $kill_nicely = 0;
        return;
    }

    my ($message,$caller);
    if (ref $error eq 'HASH'){
        $message = $error->{message};
        $caller = $error->{caller};
        $error = $message.' at '.$caller->[1].' line '.$caller->[2];
    }

    if ($self->debug){
        $error = __PACKAGE__->backtrace($error) if $error;
        local $SIG{__DIE__} = \&handleErrors($self,$error);
    } else {
        if ($self->app->can('errors')){
            $self->app->errors($self,$error);
        } else {
            $self->status_code('404');
            $self->body('something wrong is going on');
        }
    }
    return 1;
}

sub log {
    my $self = shift;
    if (@_ > 1){
        push @{$self->app->{log}},\@_;
    } else {
        push @{$self->app->{log}},shift;
    }
    return 1;
}

sub warn {
    my $self = shift;
    my $message = shift;
    my ($caller,$file,$line) = caller;
    $self->app->{warnings}->{$caller} = [] if !$self->app->{warnings}->{$caller};
    push @{ $self->app->{warnings}->{$caller} }, {
        line => $line,
        message => $message
    };
    return 1;
}

sub handleErrors {
    my $self = shift;
    my $message = shift;
    $self->status_code(500);
    $self->body($message);
    return $self;
}

########proudly stolen from Dancer :P
sub backtrace {
    my ($self,$message) = @_;
    $message =
      qq|| . _html_encode($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!

    open FILE, "<$file" or return $message;
    my @lines = ;
    close FILE;

    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 {
            my $thisline = $lines[$l];

            if ($thisline =~ m/^\s*#/){
                $thisline = ''.$thisline.'';
            }

            $backtrace
              .= qq||
              . tabulate($l + 1, $stop + 1)
              . " "
              . _html_encode($thisline) . "\n";
        }
    }
    $backtrace .= "";
    return $backtrace;
}

sub _html_encode {
    my $value = shift;
    $value =~ s/&/&/g;
    $value =~ s/
    $value =~ s/>/>/g;
    $value =~ s/'/'/g;
    $value =~ s/"/"/g;
    return $value;
}

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

1;