File Coverage

blib/lib/Error/TypeTiny.pm

Criterion	Covered	Total	%
statement	52	53	98.1
branch	13	18	72.2
condition	8	14	57.1
subroutine	16	16	100.0
pod	8	8	100.0
total	97	109	88.9

package Error::TypeTiny;

use 5.008001;
use strict;
use warnings;

BEGIN {
	$Error::TypeTiny::AUTHORITY = 'cpan:TOBYINK';
	$Error::TypeTiny::VERSION   = '2.010001';
}

$Error::TypeTiny::VERSION =~ tr/_//d;

require Type::Tiny;
__PACKAGE__->Type::Tiny::_install_overloads(
	q[""]   => sub { local $@; $_[0]->to_string },
	q[bool] => sub { 1 },
);

require Carp;
*CarpInternal = \%Carp::CarpInternal;

our %CarpInternal;
$CarpInternal{$_}++ for @Type::Tiny::InternalPackages;

sub new {
	my $class  = shift;
	my %params = ( @_ == 1 ) ? %{ $_[0] } : @_;
	return bless \%params, $class;
}

sub throw {
	my $next = $_[0]->can( 'throw_cb' );
	splice( @_, 1, 0, undef );
	goto $next;
}

sub throw_cb {
	my $class = shift;
	my $callback = shift;

	my ( $level, @caller, %ctxt ) = 0;
	while (
		do {
			my $caller = caller $level;
			defined $caller and $CarpInternal{$caller};
		}
		)
	{
		$level++;
	}
	if ( ( ( caller( $level - 1 ) )[1] || "" ) =~
		/^(?:parameter validation for|exportable function) '(.+?)'$/ )
	{
		my ( $pkg, $func ) = ( $1 =~ m{^(.+)::(\w+)$} );
		$level++ if caller( $level ) eq ( $pkg || "" );
	}

	{
		no warnings 'uninitialized';
		# Moo's Method::Generate::Constructor puts an eval in the stack trace,
		# that is useless for debugging, so show the stack frame one above.
		$level++
			if (
			( caller( $level ) )[1] =~ /^\(eval \d+\)$/
			and ( caller( $level ) )[3] eq '(eval)'    # (caller())[3] is $subroutine
			);
		@ctxt{qw/ package file line /} = caller( $level );
	}

	my $stack = undef;
	if ( our $StackTrace ) {
		require Devel::StackTrace;
		$stack = "Devel::StackTrace"->new(
			ignore_package => [ keys %CarpInternal ],
		);
	}

	our $LastError = $class->new(
		context     => \%ctxt,
		stack_trace => $stack,
		@_,
	);

	$callback ? $callback->( $LastError ) : die( $LastError );
} #/ sub throw

sub message     { $_[0]{message} ||= $_[0]->_build_message }
sub context     { $_[0]{context} }
sub stack_trace { $_[0]{stack_trace} }

sub to_string {
	my $e = shift;
	my $c = $e->context;
	my $m = $e->message;

	$m =~ /\n\z/s
		? $m
		: $c ? sprintf(
		"%s at %s line %s.\n", $m, $c->{file} || 'file?',
		$c->{line} || 'NaN'
		)
		: sprintf( "%s\n", $m );
} #/ sub to_string

sub _build_message {
	return 'An exception has occurred';
}

sub croak {
	my ( $fmt, @args ) = @_;
	@_ = (
		__PACKAGE__,
		message => sprintf( $fmt, @args ),
	);
	goto \&throw;
}

1;

__END__