Try::Tiny results from the CPAN

Try::Tiny

Ark

view release on metacpan or search on metacpan

lib/Ark/Context/Debug.pm view on Meta::CPAN

package Ark::Context::Debug;
use Mouse::Role;

use Try::Tiny;
use HTML::Escape ();

has debug_report => (
    is      => 'rw',
    isa     => 'Text::SimpleTable',
    lazy    => 1,
    default => sub {
        my $self = shift;
        $self->ensure_class_loaded('Text::SimpleTable');
        Text::SimpleTable->new([62, 'Action'], [9, 'Time']);
    },
);

has debug_report_stack => (
    is      => 'rw',
    isa     => 'ArrayRef',
    lazy    => 1,
    default => sub { [] },
);

has debug_stack_traces => (
    is      => 'rw',
    isa     => 'ArrayRef',
    lazy    => 1,
    default => sub { [] },
);

has debug_screen_tamplate => (
    is      => 'rw',
    isa     => 'CodeRef',
    lazy    => 1,
    default => sub {
        my $self = shift;
        $self->ensure_class_loaded('Text::MicroTemplate');
        Text::MicroTemplate::build_mt(<<'__EOF__');
? sub encoded_string { goto &Text::MicroTemplate::encoded_string }
<?= encoded_string(qq[<\?xml version="1.0" encoding="utf-8"?\>\n]) ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<meta http-equiv="Content-Script-Type" content="text/javascript" />
<title>500 Internal Server Error</title>
<style type="text/css">
* {
  margin: 0;
  padding: 0;
  font-family: Verdana, Arial, sans-serif;
  font-size: 100%;
}

pre {
  padding: 5px;
  overflow: auto;
}
code {
  font-family: Monaco, 'Courier New', monospace;
}

pre code {

lib/Ark/Context/Debug.pm view on Meta::CPAN

</html>
__EOF__
    },
);

around process => sub {
    my $next = shift;
    my ($self,) = @_;

    $self->ensure_class_loaded('Time::HiRes');
    my $start = [Time::HiRes::gettimeofday()];

    my $res = $next->(@_);

    my $elapsed = sprintf '%f', Time::HiRes::tv_interval($start);
    my $av      = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
    $self->log( debug =>
                  "Request took ${elapsed}s (${av}/s)\n%s", $self->debug_report->draw);

    $res;
};

after dispatch => sub {
    my ($self) = @_;

    if (my @error = @{ $self->error }) {
        $self->ensure_class_loaded('Text::MicroTemplate');

        $self->res->status(500);
        $self->res->body( my $body = $self->debug_screen_tamplate->($self)->as_string );
    }
};

after prepare_action => sub {
    my $self = shift;
    my $req  = $self->request;

    $self->log( debug => q/"%s" request for "%s" from "%s"/,
                $req->method, $req->path, $req->address );
    $self->log( debug => q/Arguments are "%s"/, join('/', @{ $req->arguments }) );
};

around execute_action => sub {
    my $next = shift;
    my ($self, $obj, $method, @args) = @_;

    $self->ensure_class_loaded('Time::HiRes');
    $self->stack->[-1]->{start} = [Time::HiRes::gettimeofday()];

    my ($res, $err);
    my @__args = @_;
    try {
        local $SIG{__DIE__} = sub {
            $self->ensure_class_loaded('Devel::StackTrace');
            my $trace = Devel::StackTrace->new(
                ignore_package => [
                    qw/Ark::Core
                       Ark::Action
                       Ark::Context::Debug
                       Ark::Context
                       Try::Tiny/,
                ],
                no_refs => 1,
            );
            $self->debug_stack_traces([ $trace->frames ])
                unless scalar @{ $self->debug_stack_traces };
        };

        $res = $next->(@__args);
    } catch {
        $err = $_;
    };

    my $last    = $self->stack->[-1];
    my $elapsed = Time::HiRes::tv_interval($last->{start});

    my $name;
    if ($last->{obj}->isa('Ark::Controller')) {
        $name = $last->{obj}->namespace
            ? '/' . $last->{obj}->namespace . '/' . $last->{method}
            : '/' . $last->{method};
    }
    else {
        $name = $last->{as_string};
    }

    if ($self->depth > 1) {
        $name = ' ' x $self->depth . '-> ' . $name;
        push @{ $self->debug_report_stack }, [ $name, sprintf("%fs", $elapsed) ];
    }
    else {
        $self->debug_report->row( $name, sprintf("%fs", $elapsed) );
        while (my $report = shift @{ $self->debug_report_stack }) {
            $self->debug_report->row( @$report );
        }

        if (my @error = @{ $self->error }) {
            $self->res->status(500);
            my $body = $self->debug_screen_tamplate->($self)->as_string;
            $self->res->body( $body . ' 'x300 ) # for IE
        }
    }

    die $err if defined $err;
    $res;
};

sub debug_print_context {
    my ($self, $file, $linenum, $context) = @_;

    my $code = q[];
    if (-f $file) {
        $self->ensure_class_loaded('HTML::Entities');

        my $start = $linenum - $context;
        my $end   = $linenum + $context;
        $start = $start < 1 ? 1 : $start;
        if ( my $fh = IO::File->new( $file, 'r' ) ) {
            my $cur_line = 0;
            while ( my $line = <$fh> ) {
                ++$cur_line;

( run in 0.559 second using v1.01-cache-2.11-cpan-39bf76dae61 )