File Coverage

blib/lib/Zoidberg/Utils/Error.pm

Criterion	Covered	Total	%
statement	58	75	77.3
branch	20	42	47.6
condition	12	24	50.0
subroutine	11	12	91.6
pod	5	5	100.0
total	106	158	67.0

package Zoidberg::Utils::Error;

our $VERSION = '0.981';

use strict;
use Exporter::Tidy default => [qw/error bug todo/];
use overload
	'""' => \&stringify,
	'eq' => sub { $_[0] },
	fallback => 'TRUE';

use Scalar::Util qw/reftype/;

our $Scope = $0;
$Scope =~ s#.*/##;

# ################ #
# Exported methods #
# ################ #

sub error {
	my @caller = caller;

	if ($@ && !@_) { # make it work more like die
		my $error = $@;
		my $can_propagate = do {
			local $@;
			eval{ $error->can( 'PROPAGATE') };
		};
		die $@->PROPAGATE(@caller[1,2]) if $can_propagate;
		unshift @_, PROPAGATE({}, @caller[1,2]), $@;
	}

	my $error = bless {};

	for (@_) { # compiling the error here
		if ( (reftype $_ || '') eq 'HASH') { %$error = (%$error, %$_) }
		else { $$error{string} .= $_ }
	}

	unless ($$error{string}) {
		$$error{string} =
			  $$error{is_bug}  ? 'This is a bug'
			: $$error{is_todo} ? 'Something TODO here' : 'Error' ;
	}
	elsif ($$error{string} =~ s/\(\@INC contains\: (.*?)\)\s*//g) { # make it less verbose
		$$error{INC} = $1;
	}

	# trace stack
	$$error{stack} ||= [];
	{
		no strict 'refs';
		@caller = caller(${$caller[0].'::ERROR_CALLER'})
			if ${$caller[0].'::ERROR_CALLER'};
		push @{$$error{stack}}, \@caller;

		if ( # debug code
			$$error{debug} = ${$caller[0].'::DEBUG'}
				|| $Zoidberg::CURRENT->{settings}{debug}
		) {
			push @{$$error{stack}}, [ (caller $_)[0..2] ]
				for (1..$$error{debug});
		}
	}

	if (defined $Scope) { # set fake caller
		$$error{scope} ||= ref($Scope)
			? [ $$Scope[0], $$Scope[1] || $caller[2] ]
			: [ $Scope ];
	}

	die $error;
}

sub bug {
	unshift @_, { is_bug => 1 };
	goto \&error;
}

sub todo {
	unshift @_, { is_todo => 1 };
	goto \&error;
}

# ############## #
# Object methods #
# ############## #

sub stringify {
	# TODO verbosity optie
	no warnings; # lots of stupid warnings here (due to 'overload' ?)
	my $self = shift;
	my %opt = @_;
	my $string;
	if ($opt{format} eq 'gnu') {
		$string = join( ': ', grep {defined $_}
			( $$self{scope}  ? (@{$$self{scope}}) : (@{$$self{stack}[0]}) ),
			( $$self{is_bug} ? 'BUG' : $$self{is_todo} ? 'TODO' : undef   ),
			$$self{string} ) . "\n" ;
	}
	else {
		$string = ($$self{is_bug} ? 'BUG: ' : $$self{is_todo} ? 'TODO: ' : '')
			. $self->{string};
		$string .= qq# at $$self{stack}[0][1] line $$self{stack}[0][2]\n#
				unless $string =~ /\n$/;
		if (exists $$self{propagated} and ref $$self{propagated}) {
			$string = PROPAGATE($string, @$_) for @{$self->{propagated}};
		}
	}
	return $string;
}

sub PROPAGATE { # see perldoc -f die
	my ($self, $file, $line) = @_;
	($file, $line) = ( caller() )[1,2] unless $file or $line;
	if (ref $self) {
		$self->{propagated} ||= [];
		push @{$self->{propagated}}, [$file, $line];
	}
	else { $self .= "\t...propagated at $file line $line\n" }
	return $self;
}


1;

__END__