view release on metacpan or  search on metacpan

lib/Ambrosia/error/Exception/Error.pm  view on Meta::CPAN

package Ambrosia::error::Exception::Error;
use strict;
use warnings;

use overload '""' => \&as_string, fallback => 1;

our $VERSION = 0.010;

sub PREF() { '    ' };

sub throw
{
    my $class = shift;
    my $error_code = shift;
    my @msg = @_;

    unless ( $error_code =~ /^E\d+/ )
    {
        unshift @msg, $error_code;
        $error_code = 'E0000';
    }

    my $frames = undef;
    foreach ( @msg )
    {
        if ( ref $_ && eval{$_->can('frames')} )
        {
            $frames = $_;
            last;
        }
    }

    my $self = bless
        {
            _error_code => $error_code,
            _message    => (join ' - ', grep { !ref $_ } @msg),
            _frames     => $frames || [],
        }, $class;

    $self->_addFrames() unless defined $frames;

    die $self;
}

# Формирует стек вызова
sub _addFrames
{
    my $self = shift;
    my $p = __PACKAGE__;
    my $x = 0;
    my ($package, $line, $subroutine);
    
    while ( do { package DB; ($package, $line, $subroutine) = (caller($x++))[0, 2, 3] } )
    {# Do the quickest ones first.
        next if $package eq __PACKAGE__ or substr($subroutine, 0, 33) eq __PACKAGE__;
        my @arg = $subroutine !~ /^$p\:\:/ ? @DB::args : ('...');
        push @{ $self->{_frames} }, { 'callers' => [$line, $subroutine, $package], 'argums' => \@arg };
    }
}

sub frames
{
    my $self = shift;

    local $@;
    return $self->{_frames}->frames if ref $self->{_frames} && ref $self->{_frames} ne 'ARRAY' && eval {$self->{_frames}->can('frames')};

    my @frms;
    foreach my $f ( @{$self->{_frames}} )
    {
        if ( ref $f )
        {
            my $subrutine = $f->{callers}->[1];
            unshift @frms, &PREF . $subrutine
                        . ( $subrutine ne '(eval)'
                                ? ( '( ' . (join ', ', map { defined $_ ? $_ : 'undef' } @{$f->{argums}}) . ' )')
                                : ''
                          )
                        . ' at ' . $f->{callers}->[2]
                        . ' line ' . $f->{callers}->[0];
        }
        else
        {
            unshift @frms, $f;
        }
    }
    return \@frms;
}

sub message
{
    my $self = shift;
    my $indent = shift || 0;