Added exception class and corresponding test 316_exceptions.t

diff --git a/Makefile.PL b/Makefile.PL
index 5b9fee3..a7ffbf2 100644 (file)
--- 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 (file)
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 (file)
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;