File Coverage

blib/lib/Throwable/Factory.pm

Criterion	Covered	Total	%
statement	101	101	100.0
branch	26	26	100.0
condition	3	3	100.0
subroutine	27	27	100.0
pod	2	9	22.2
total	159	166	95.7

use 5.008;
use strict;
use warnings;

use Moo 1.000006 ();
use MooX::Struct 0.009 ();
use Throwable::Error 0.200000 ();

{
	package Throwable::Factory;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.006';

	our @SHORTCUTS;

	use MooX::Struct -retain,
		Base => [
			-class   => \'Throwable::Factory::Struct',
			-extends => ['Throwable::Factory::Base'],
			-with    => ['Throwable', 'StackTrace::Auto'],
			'$message',
		],
	;

	sub import
	{
		my $class  = shift() . '::Struct';
		unshift @_, $class;
		goto \&MooX::Struct::import;
	}

	{
		package Throwable::Taxonomy::Caller;
		use Moo::Role;
		push @SHORTCUTS, __PACKAGE__;
	}

	{
		package Throwable::Taxonomy::Environment;
		use Moo::Role;
		push @SHORTCUTS, __PACKAGE__;
	}

	{
		package Throwable::Taxonomy::NotImplemented;
		use Moo::Role;
		push @SHORTCUTS, __PACKAGE__;
	}

	Base;
}

{
	package Throwable::Factory::Base;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.006';

	use Data::Dumper ();
	use Moo;
	use namespace::clean;
	extends 'MooX::Struct';

	sub description { 'Generic exception' }
	sub error       { shift->message }
	sub package     { shift->stack_trace->frame(0)->package }
	sub file        { shift->stack_trace->frame(0)->filename }
	sub line        { shift->stack_trace->frame(0)->line }

	sub BUILDARGS
	{
		my $class = shift;
		return +{} unless @_;
		unshift @_, 'message' if @_ % 2 and not ref $_[0];
		$class->SUPER::BUILDARGS(@_);
	}

	sub TO_STRING
	{
		local $Data::Dumper::Terse = 1;
		local $Data::Dumper::Indent = 0;
		local $Data::Dumper::Useqq = 1;
		local $Data::Dumper::Deparse = 0;
		local $Data::Dumper::Quotekeys = 0;
		local $Data::Dumper::Sortkeys = 1;

		my $self = shift;
		my $str  = $self->message . "\n\n";

		for my $f ($self->FIELDS) {
			next if $f eq 'message';
			my $v = $self->$f;
			$str .= sprintf(
				"%-8s = %s\n",
				$f,
				ref($v) ? Data::Dumper::Dumper($v) : $v,
			);
		}
		$str .= "\n";
		$str .= $self->stack_trace->as_string;
		return $str;
	}
}

{
	package Throwable::Factory::Struct::Processor;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.006';

	use Moo;
	use Carp;
	use namespace::clean;
	extends 'MooX::Struct::Processor';

	has '+base' => (
		default => sub { Throwable::Factory::Base },
	);

	sub process_meta
	{
		my ($self, $klass, $name, $value) = @_;

		if ($name !~ /^-(isa|extends|with|class)$/) {
			my $k = substr $name, 1;
			my @matches = grep /::$k$/i, @Throwable::Factory::SHORTCUTS;
			croak "Shortcut '$name' has too many matches: @matches" if @matches > 1;
			croak "Shortcut '$name' has no matches" if @matches < 1;
			$name  = '-with';
			$value = \@matches;
		}

		$self->SUPER::process_meta($klass, $name, $value);
	}

	# Allow make_sub to accept Exception::Class-like hashrefs.
	sub make_sub
	{
		my ($self, $name, $proto) = @_;
		if (ref $proto eq 'HASH')
		{
			my %proto = %$proto;
			$proto = [];

			if (defined $proto{isa}) {
				my $isa = delete $proto{isa};
				push @$proto, -extends => [$isa];
			}
			if (defined $proto{description}) {
				my $desc = delete $proto{description};
				push @$proto, description => sub { $desc };
			}
			if (defined $proto{fields}) {
				my $fields = delete $proto{fields};
				push @$proto, ref $fields ? @$fields : $fields;
			}

			if (keys %proto) {
				croak sprintf(
					"Exception::Class-style %s option not supported",
					join('/', sort keys %proto),
				);
			}
		}
		return $self->SUPER::make_sub($name, $proto);
	}
}

1;

__END__