From: James Laver Date: Thu, 29 Jul 2010 15:08:58 +0000 (+0100) Subject: Added exception class and corresponding test 316_exceptions.t X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6eaa52c1ff48c08cfcc724d9dc363bc4778725e3;p=gitmo%2FClass-MOP.git Added exception class and corresponding test 316_exceptions.t --- diff --git a/Makefile.PL b/Makefile.PL index 5b9fee3..a7ffbf2 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -20,6 +20,7 @@ if ( -d '.git' || $ENV{MAINTAINER_MODE} ) { requires 'Carp'; requires 'Data::OptList'; requires 'Devel::GlobalDestruction'; +requires 'Devel::StackTrace'; requires 'List::MoreUtils' => '0.12'; requires 'MRO::Compat' => '0.05'; requires 'Package::DeprecationManager'; diff --git a/lib/exception.pm b/lib/exception.pm new file mode 100644 index 0000000..8109d0c --- /dev/null +++ b/lib/exception.pm @@ -0,0 +1,54 @@ +package exception; + +use strict; +use warnings; + +use overload '""' => \&to_string; + +use Devel::StackTrace; + +# use Moose; ## Haha, if only. + +##### ACCESSORS ##### +sub message { shift->{message}; } +sub stacktrace { shift->{stacktrace}; } + +# Builder for stacktrace +sub _build_stacktrace { + shift->{stacktrace} = Devel::StackTrace->new(ignore_class => __PACKAGE__); +} + +# Stringification +sub to_string { + my ($self) = @_; + my $first = 1; + my @lines; + while (my $frame = $self->{stacktrace}->next_frame) { + if ($first) { + $first = 0; + # message at foo.pl line 1 + push @lines, sprintf("%s at %s line %s", $self->message, $frame->filename, $frame->line); + } else { + my @args = map { ref $_ ? "$_" : "'$_'" } $frame->args; + # main::foo called at foo.pl line 1 + push @lines, sprintf("\t%s(%s) called at %s line %s", $frame->subroutine, join(", ", @args), $frame->filename, $frame->line); + } + } + join("\n", @lines); +} + +# Constructor +sub new { + my ($class, %kwargs) = @_; + $class = ref $class if ref $class; # Also take another exception object, if we must. + my $message = $kwargs{message} || ''; # Default to no error message + + # Construction + my $self = bless {message => $message}, $class; + $self->_build_stacktrace; + + $self; +} + +1; +__END__ \ No newline at end of file diff --git a/t/316_exceptions.t b/t/316_exceptions.t new file mode 100644 index 0000000..c14872b --- /dev/null +++ b/t/316_exceptions.t @@ -0,0 +1,94 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use exception; + + sub new { + bless {}, 'Foo'; + } + + sub except { + shift; + exception->new(@_); + } + +} + +{ + package Bar; + use exception; + + sub one { + two(@_); + } + + sub two { + three(@_); + } + + sub three { + exception->new(@_); + } +} + +{ + + my $foo = Foo->new; + + my $f1 = $foo->except(message => 'bar'); + my $f2 = $foo->except(); + my $f3 = $foo->except(foo => {1,2}); + + my $b1 = Bar::one(message => 'bar'); + my $b2 = Bar::one(); + my $b3 = Bar::one(foo => {1,2}); + +################################################## BASIC TESTS ################### + + isa_ok($_,'exception',"type check") for ($f1,$f2,$f3,$b1,$b2,$b3); + isa_ok($_->stacktrace, 'Devel::StackTrace',"stacktraces are stacktraces") for ($f1,$f2,$f3,$b1,$b2,$b3); + ok(!ref $_->message,"messages are strings") for ($f1,$f2,$f3,$b1,$b2,$b3); + is($_->message,'bar', "correct messages") for ($f1,$b1); + ok(!$_->message,'lack of messages') for ($f2,$f3,$b2,$b3); + +################################################## STRINGIFICATION TESTS ################### + + # Verify number of frames dumped + is(scalar @{[split(/\n/,$_)]}, 2, "length of foos") for $f1,$f2,$f3; + is(scalar @{[split(/\n/,$_)]}, 4, "length of bars") for $b1,$b2,$b3; + + # Verify initial lines + like([split(/\n/,$_)]->[0], qr{ at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"error messages contain correct info") for ($f1,$f2,$f3,$b1,$b2,$b3); + + # And the messages of the initial lines + like([split(/\n/,$_)]->[0], qr{^bar at t/}, "messages of f1,b1") for ($f1,$b1); + + # And the lack of messages of the other lines + like([split(/\n/,$_)]->[0], qr{^ at t/}, "messages of others") for ($f2,$f3,$b2,$b3); + + # And the second lines of foo + like([split(/\n/,$f1)]->[1], qr{^\tFoo::except\(Foo=HASH\(0x[0-9a-f]+\), 'message', 'bar'\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"f1[1]"); + like([split(/\n/,$f2)]->[1], qr{^\tFoo::except\(Foo=HASH\(0x[0-9a-f]+\)\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"f2[1]"); + like([split(/\n/,$f3)]->[1], qr{^\tFoo::except\(Foo=HASH\(0x[0-9a-f]+\), 'foo', HASH\(0x[0-9a-f]+\)\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"f3[1]"); + + # And the second lines of bar + like([split(/\n/,$b1)]->[1], qr{^\tBar::three\('message', 'bar'\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b1[1]"); + like([split(/\n/,$b2)]->[1], qr{^\tBar::three\(\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b2[1]"); + like([split(/\n/,$b3)]->[1], qr{^\tBar::three\('foo', HASH\(0x[0-9a-f]+\)\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b3[1]"); + + # And the third lines of bar + like([split(/\n/,$b1)]->[2], qr{^\tBar::two\('message', 'bar'\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b1[2]"); + like([split(/\n/,$b2)]->[2], qr{^\tBar::two\(\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b2[2]"); + like([split(/\n/,$b3)]->[2], qr{^\tBar::two\('foo', HASH\(0x[0-9a-f]+\)\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b3[2]"); + + # And the fourth lines of bar + like([split(/\n/,$b1)]->[3], qr{^\tBar::one\('message', 'bar'\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b1[3]"); + like([split(/\n/,$b2)]->[3], qr{^\tBar::one\(\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b2[3]"); + like([split(/\n/,$b3)]->[3], qr{^\tBar::one\('foo', HASH\(0x[0-9a-f]+\)\) called at t/[0-9]+_[a-zA-Z0-9_-]+\.t line [0-9]+$},"b3[3]"); +} + +done_testing;