File Coverage

blib/lib/Exception/Chain.pm

Criterion	Covered	Total	%
statement	108	109	99.0
branch	28	30	93.3
condition	3	3	100.0
subroutine	22	22	100.0
pod	5	9	55.5
total	166	173	95.9

package Exception::Chain;
use 5.008005;
use strict;
use warnings;
use overload
    '""' => sub { $_[0]->to_string || $_[0] };

use Class::Accessor::Lite (
    ro => [qw/ delivery is_delivery_duplicated duplicated_trace /],
);
use Time::Piece qw(localtime);
use Time::HiRes qw(gettimeofday tv_interval);
use Data::Dumper;
use Data::Util qw(is_instance);

our $VERSION   = "0.10";
our $SkipDepth = 0;

# class method
sub new {
    my ($class, %args) = @_;

    my $self = bless {
        tags                   => {},
        stack                  => [],
        message                => undef,
        delivery               => undef,
        is_delivery_duplicated => 0,
        duplicated_trace       => [],
    }, $class;
}

sub _get_external_caller {
    my $class = shift;
    my $i = 0;
    while (my @caller = caller(++$i)) {
        unless ($caller[0] =~ /^Exception::Chain/) {
            my $level = $i + $SkipDepth;
            @caller = caller($level);
            return @caller;
        }
    }
}

sub _build_arg {
    my ($class, @info) = @_;

    if (scalar @info == 0) {
        return { };
    }
    elsif (scalar @info == 1) {
        if ($class->_is_my_instance($info[0])) {
            return { error => $info[0] };
        }
        else {
            return { message => $class->dumper($info[0]) };
        }
    }
    else {
        my %data = @info;
        my $ret = {};

        $ret->{message} = $class->dumper($data{message});
        for my $name (qw/tag error delivery/) {
            $ret->{$name} = $data{$name};
        }

        return $ret;
    }
}

sub _is_my_instance {
    my ($class, $instance) = @_;
    is_instance($instance, 'Exception::Chain');
}

sub dumper {
    my ($self, $value) = @_;
    if ( defined $value && ref($value) ) {
        local $Data::Dumper::Terse = 1;
        local $Data::Dumper::Indent = 0;
        local $Data::Dumper::Sortkeys = 1;
        return Data::Dumper::Dumper($value);
    }
    return $value;
}

# instance method

sub throw {
    my ($class, @args) = @_;
    my $builded_args = $class->_build_arg(@args);
    my $self;
    if (not defined $builded_args->{error}) {
        $self = $class->new;
        $self->{message}  = $builded_args->{message};
    }
    elsif ($class->_is_my_instance($builded_args->{error})) {
        $self = delete $builded_args->{error};
    }
    else {
        $self = $class->new;
        push @{$self->{stack}}, $builded_args->{error};
        $self->rethrow(%{$builded_args});
    }
    $self->logging($builded_args);
    die $self;
}

sub rethrow {
    my ($self, @args) = @_;
    $self->logging($self->_build_arg(@args));
    die $self;
}

sub to_string {
    my $self = shift;
    my $string = join( ' ', @{$self->{stack}} );
    $string =~ s/\n//g;
    return $string;
}

sub match {
    my ($self, @tags) = @_;
    return scalar grep { defined $self->{tags}{$_} } @tags;
}

sub first_message {
    my $self = shift;
    return $self->{message};
}

sub add_message {
    my ($self, $message) = @_;
    $self->logging($self->_build_arg($message));
}

sub logging {
    my ($self, $args) = @_;

    my ($pkg, $file, $line) = $self->_get_external_caller;

    if (%{$args}) {
        if (my $tags = $args->{tag}) {
            $tags = [$tags] unless ref $tags;
            for my $tag (@$tags) {
                $self->{tags}{$tag} = 1;
            }
        }
        if (my $message = $args->{message}) {
            push @{$self->{stack}}, "$message at $file line $line.";
        }
        if (my $delivery = $args->{delivery}) {
            if ($self->delivery) {
                unless ($self->is_delivery_duplicated) {
                    $self->{is_delivery_duplicated} = 1;
                    push @{$self->{duplicated_trace}}, $self->{stack}->[0];
                }
                push @{$self->{duplicated_trace}}, "$file line $line." ;
            }
            else {
                $self->{delivery} = $delivery;
            }
        }
    }
    else {
        push @{$self->{stack}}, "at $file line $line.";
    }
}

1;
__END__