File Coverage

lib/Badger/Exception.pm

Criterion	Covered	Total	%
statement	57	62	91.9
branch	26	40	65.0
condition	16	23	69.5
subroutine	10	11	90.9
pod	9	9	100.0
total	118	145	81.3

#========================================================================
#
# Badger::Exception
#
# DESCRIPTION
#   Module implementing an exception class for reporting structured
#   errors.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Exception;

use Badger::Class
    base        => 'Badger::Base',
    version     => 0.01,
    debug       => 0,
    mutators    => 'type',
    accessors   => 'stack',
    constants   => 'TRUE ARRAY HASH DELIMITER',
    import      => 'class',
    as_text     => 'text',      # overloaded text stringification
    is_true     => 1,           # always evaluates to a true value
    exports     => {
        hooks => {
            trace  => [
                # args are ($self, $target, $symbol, $value)
                sub { $TRACE = $_[3] },
                # expects one value argument
                1
            ],
            colour  => [
                # args are ($self, $target, $symbol, $value)
                sub { $COLOUR = $_[3] },
                # expects one value argument
                1
            ],
        },
    },
    messages => {
        caller => "<4> called from <1>\n  in <2> at line <3>",
    };

use Badger::Rainbow ANSI => 'cyan yellow green';
our $FORMAT  = ' error - ' unless defined $FORMAT;
our $TYPE    = 'undef'                 unless defined $TYPE;
our $INFO    = 'no information'        unless defined $INFO;
our $ANON    = 'unknown'               unless defined $ANON;
our $TRACE   = 0                       unless defined $TRACE;
our $COLOUR  = 0                       unless defined $COLOUR;


sub init {
    my ($self, $config) = @_;
    $self->{ type  } = $config->{ type  } || $self->class->any_var('TYPE');
    $self->{ info  } = $config->{ info  } || '';
    $self->{ file  } = $config->{ file  };
    $self->{ line  } = $config->{ line  };
    # watch out for the case where 'trace' is set explicitly to 0
    $self->{ trace } =
        exists $config->{ trace }
             ? $config->{ trace }
             : $TRACE;

    return $self;
}


sub info {
    my $self = shift;
    return @_
        ? ($self->{ info }  = shift)
        : ($self->{ info } || $INFO);
}


sub file {
    my $self = shift;
    return @_
        ? ($self->{ file }  = shift)
        : ($self->{ file } || $ANON);
}


sub line {
    my $self = shift;
    return @_
        ? ($self->{ line }  = shift)
        : ($self->{ line } || $ANON);
}


sub text {
    my $self = shift;
    my $text = shift || $self->class->any_var('FORMAT');

    # TODO: extend Badger::Utils::xprintf to handle this
    $text  =~ s/<(\w+)>/defined $self->{ $1 } ? $self->{ $1 } : "(no $1)"/eg;

    # TODO: not sure we should add file and line automatically - better to
    # leave it up to the $FORMAT
    $text .= " in $self->{ file }"      if $self->{ file };
    $text .= " at line $self->{ line }" if $self->{ line };

    if ($self->{ trace } && (my $trace = $self->stack_trace)) {
        $text .= "\n" . $trace;
    }

    return $text;
}


sub stack_trace {
    my $self = shift;
    my @lines;

    if (my $stack = $self->{ stack }) {
        foreach my $caller (@$stack) {
            my @args = $COLOUR
                ? (
                    cyan($caller->[0]),
                    cyan($caller->[1]),
                    yellow($caller->[2]),
                    yellow($caller->[3]),
                  )
                : @$caller;
            push(@lines, $self->message( caller => @args ));
        }
    }

    return join("\n", @lines);
}


sub trace {
    my $self = shift;
    if (ref $self) {
        return @_
            ? ($self->{ trace } = shift )
            :  $self->{ trace };
    }
    else {
        return @_
            ? $self->class->var( TRACE => shift )
            : $self->class->var('TRACE');
    }
}

sub throw {
    my $self = shift;

    # save relevant information from caller stack for enhanced debugging,
    # but only the first time the exception is thrown
    if ($self->{ trace } && ! $self->{ stack }) {
        my @stack;
        my $i = 1;
        while (1) {
            my @info = caller($i++);
            last unless @info;
            push(@stack, \@info);
        }
        $self->{ stack } = \@stack;
    }

    die $self;
}




#------------------------------------------------------------------------
# match_type(@types)
#
# Selects the most appropriate handler for the current exception type,
# from the list of types passed in as arguments.  The method returns the
# item which is an exact match for type or the closest, more
# generic handler (e.g. foo being more generic than foo.bar, etc.)
#------------------------------------------------------------------------

sub match_type {
    my $self  = shift;
    my $types = @_ == 1 ? shift :  [@_];
    my $type  = $self->{ type };

    $types = [ split(DELIMITER, $types) ]
        unless ref $types;

    $types = { map { $_ => $_ } @$types }
        if ref $types eq ARRAY;

    return $self->error( invalid => 'type match' => $types )
        unless ref $types eq HASH;

    while ($type) {
        return $types->{ $type }
            if $types->{ $type };

        # strip .element from the end of the exception type to find a
        # more generic handler
        $type =~ s/\.?[^\.]*$//;
    }

    return undef;
}



1;
__END__