File Coverage

blib/lib/Throw/Back.pm

Criterion	Covered	Total	%
statement	10	21	47.6
branch	0	4	0.0
condition			n/a
subroutine	4	5	80.0
pod			n/a
total	14	30	46.6

package Throw::Back;

use strict;
use warnings;

$Throw::Back::VERSION = '0.01';

use overload fallback => 1, '""' => sub {
    my ($exc) = @_;
    my $call_stack = '';
    if ( exists $exc->{call_stack} ) {
        for my $frame ( @{ $exc->{call_stack} } ) {
            my $func = $frame->[3];
            $func =~ s/^$frame->[0]\:://;
            $call_stack .= "    : $func() (file: $frame->[1], line: $frame->[2])\n";
        }
    }

    return $exc->{string} =~ m/\n$/ ? "$exc->{string}$call_stack" : "$exc->{string} (file: $exc->{file}, line: $exc->{line})\n$call_stack";
};

use Module::Want 0.6 ();

sub throw::back {
    my ( $class, @args ) = @_;

    # hack for no args:
    if ( ref($class) eq 'Throw::Back::_arg' ) {
        push @args, $class;
        $class = undef;
    }

    my $_arg = ref( $args[-1] ) eq 'Throw::Back::_arg' ? pop(@args) : bless( {}, 'Throw::Back::_arg' );
    my %obj = %{$_arg};
    if ( ref $class eq 'Throw::Back::_arg' ) {
        %obj = %{$class};
    }

    my $cn = 0;
    my $caller;
    my @stack_trace;
    while ( my @caller = caller($cn) ) {
        $caller = \@caller;
        unshift( @{ $obj{call_stack} }, $caller ) if exists $obj{call_stack};
        $cn++;
    }

    $obj{file} = $caller->[1];
    $obj{line} = $caller->[2];

    $obj{'previous_exception'} = $@ if defined $@ && ( ref($@) || length($@) );
    local $@;

    if ( defined $class ) {
        if ( !ref($class) && Module::Want::is_ns($class) ) {    # a one word message is pointless so don’t do that!
            $obj{type} = $class;

            # TODO ? $class->can('throw') ?

            if ( Module::Want::have_mod($class) && $class->can('new') ) {
                $obj{exception} = $class->new(@args);
                $obj{string} ||= eval { $obj{exception}->to_string } || "$class Exception Thrown";
            }
            else {
                $obj{string} ||= defined $args[0] && length $args[0] ? $args[0] : "$class Exception Thrown";
            }
        }
        else {
            if ( my $type = ref($class) ) {
                $obj{type}      = $type;
                $obj{exception} = $class;
                $obj{string} ||= defined $args[0] && length $args[0] ? $args[0] : "$type Exception Thrown";
            }
            else {
                $obj{string} ||= $class;
            }
        }
    }
    else {
        $obj{string} ||= defined $args[0] && length $args[0] ? $args[0] : "Exception Thrown";
    }

    $obj{type} ||= __PACKAGE__;

    if ( defined wantarray ) {
        return bless \%obj, __PACKAGE__;
    }
    else {
        die bless \%obj, __PACKAGE__;
    }
    return;
}

sub throw::stack {
    push @_, bless( { 'call_stack' => [] }, 'Throw::Back::_arg' );
    goto &throw::back;
}

sub throw::text {
    my ( $class, $phrase, @args ) = ref( $_[0] ) || Module::Want::is_ns( $_[0] ) ? @_ : ( undef, @_ );    # a one word message is pointless so don’t do that!
    my $phrase_args = ref( $args[0] ) eq 'ARRAY' ? shift @args : [];

    my $_arg = ref( $args[-1] ) eq 'Throw::Back::_arg' ? pop(@args) : bless( {}, 'Throw::Back::_arg' );

    if ( defined $class ) {
        my $lh = $class->can('locale') ? $class->locale : $class;                                         # lazy façade baby, lazy façade!
        if ( $lh->can('makevar') && $lh->can('makethis_base') ) {
            $_arg->{string} = $lh->makevar( $phrase, @{$phrase_args} );                                   # parser knows throw::text() so makevar is good
            $_arg->{string_not_localized} = $lh->makethis_base( $phrase, @{$phrase_args} );
        }
        elsif ( $class->can('maketext') ) {                                                               ## no extract maketext
            $_arg->{string} = $class->maketext( $phrase, @{$phrase_args} );                               ## no extract maketext (i.e. no makevar)
        }
    }

    if ( !exists $_arg->{string} ) {
        $_arg->{phrase}      = $phrase;
        $_arg->{phrase_args} = $phrase_args;
    }

    @_ = ( $class, @args, $_arg );
    goto &throw::back;
}

sub throw::stack::text {
    push @_, bless( { 'call_stack' => [] }, 'Throw::Back::_arg' );
    goto &throw::text;
}

# TODO ? v0.02 ?:
# sub rethrow {
#     my ($self) = @_;
#     my $caller = [caller(0)];
#
#     $self->{file} = $caller->[1];
#     $self->{line} = $caller->[2];
#     $self->{call_stack} =  __get_stack() if $self->{call_stack};
#
#     goto &__std_lazy_throw;
# }
#
# sub PROPAGATE { # see perldoc -f die
#     my ($self, $file, $line) = @_;
#     $self->{file} = $file;
#     $self->{line} = $line;
#     return $self;
# }

1;

__END__