diff options
Diffstat (limited to 't')
| -rw-r--r-- | t/01throw.t | 25 | ||||
| -rw-r--r-- | t/02order.t | 47 | ||||
| -rw-r--r-- | t/03throw-non-Error.t | 32 | ||||
| -rw-r--r-- | t/04use-base-Error-Simple.t | 18 | ||||
| -rw-r--r-- | t/05text-errors-with-file-handles.t | 52 | ||||
| -rw-r--r-- | t/06customize-text-throw.t | 66 | ||||
| -rw-r--r-- | t/07try-in-obj-destructor.t | 42 | ||||
| -rw-r--r-- | t/08warndie.t | 219 | ||||
| -rw-r--r-- | t/09dollar-at.t | 36 | ||||
| -rw-r--r-- | t/10throw-in-catch.t | 41 | ||||
| -rw-r--r-- | t/11rethrow.t | 50 | ||||
| -rw-r--r-- | t/12wrong-error-var.t | 37 | ||||
| -rw-r--r-- | t/13except-arg0.t | 22 | ||||
| -rw-r--r-- | t/lib/MyDie.pm | 19 | ||||
| -rw-r--r-- | t/pod-coverage.t | 6 | ||||
| -rw-r--r-- | t/pod.t | 6 |
16 files changed, 718 insertions, 0 deletions
diff --git a/t/01throw.t b/t/01throw.t new file mode 100644 index 0000000..a1bdba2 --- /dev/null +++ b/t/01throw.t @@ -0,0 +1,25 @@ + +use Error qw(:try); + +print "1..4\n"; + +try { + print "ok 1\n"; +}; + + +try { + throw Error::Simple("ok 2\n",2); + print "not ok 2\n"; +} +catch Error::Simple with { + my $err = shift; + print "$err"; +} +finally { + print "ok 3\n"; +}; + +$err = prior Error; + +print "ok ",2+$err,"\n";; diff --git a/t/02order.t b/t/02order.t new file mode 100644 index 0000000..7d1e59d --- /dev/null +++ b/t/02order.t @@ -0,0 +1,47 @@ + +use Error qw(:try); + +@Error::Fatal::ISA = qw(Error); + +print "1..6\n"; + +$num = try { + try { + try { + throw Error::Simple("ok 1\n"); + } + catch Error::Simple with { + my $err = shift; + print $err; + + throw Error::Fatal(-value => 4); + + print "not ok 3\n"; + } + catch Error::Fatal with { + exit(1); + } + finally { + print "ok 2\n"; + }; + } finally { + print "ok 3\n"; + }; +} +catch Error::Fatal with { + my $err = shift; + my $more = shift; + $$more = 1; + print "ok ",0+$err,"\n"; +} +catch Error::Fatal with { + my $err = shift; + print "ok ",1+$err,"\n"; + return 6; +} +catch Error::Fatal with { + my $err = shift; + print "not ok ",2+$err,"\n"; +}; + +print "ok ",$num,"\n"; diff --git a/t/03throw-non-Error.t b/t/03throw-non-Error.t new file mode 100644 index 0000000..03ef624 --- /dev/null +++ b/t/03throw-non-Error.t @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error (qw(:try)); +use Test::More tests => 2; + +my $count_of_Error = 0; +eval +{ +try +{ + die +{ 'private' => "Shlomi", 'family' => "Fish" }; +} +catch Error with +{ + my $err = shift; + $count_of_Error++; +} +}; +my $exception = $@; + +# TEST +is_deeply ( + $exception, + +{'private' => "Shlomi", 'family' => "Fish"}, + "Testing for thrown exception", +); + +# TEST +is ($count_of_Error, 0, "No Errors caught."); diff --git a/t/04use-base-Error-Simple.t b/t/04use-base-Error-Simple.t new file mode 100644 index 0000000..a9656bb --- /dev/null +++ b/t/04use-base-Error-Simple.t @@ -0,0 +1,18 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +package Error::MyError; + +use base 'Error::Simple'; + +package main; + +# TEST +ok(1, "Testing that the use base worked."); + +1; + diff --git a/t/05text-errors-with-file-handles.t b/t/05text-errors-with-file-handles.t new file mode 100644 index 0000000..dd36b33 --- /dev/null +++ b/t/05text-errors-with-file-handles.t @@ -0,0 +1,52 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; + +use Error qw(:try); + +BEGIN +{ + use File::Spec; + use lib File::Spec->catdir(File::Spec->curdir(), "t", "lib"); + use MyDie; +} + +package MyError::Foo; + +use vars qw(@ISA); + +@ISA=(qw(Error)); + +package main; + +my $ok = 1; +eval +{ + try + { + MyDie::mydie(); + } + catch MyError::Foo with + { + my $err = shift; + $ok = 0; + }; +}; + +my $err = $@; + +# TEST +ok($ok, "Not MyError::Foo"); + +# TEST +ok($err->isa("Error::Simple"), "Testing"); + +# TEST +is($err->{-line}, 16, "Testing for correct line number"); + +# TEST +ok(($err->{-file} =~ m{MyDie\.pm$}), "Testing for correct module"); + diff --git a/t/06customize-text-throw.t b/t/06customize-text-throw.t new file mode 100644 index 0000000..26eb523 --- /dev/null +++ b/t/06customize-text-throw.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More tests => 3; + +use Error qw(:try); + +package MyError::Foo; + +use vars qw(@ISA); + +@ISA=qw(Error); + +package MyError::Bar; + +use vars qw(@ISA); + +@ISA=qw(Error); + +package main; + +{ + eval + { + try + { + die "Hello"; + } + catch MyError::Foo with { + }; + }; + + my $err = $@; + + # TEST + ok($err->isa("Error::Simple"), "Error was auto-converted to Error::Simple"); +} + +sub throw_MyError_Bar +{ + my $args = shift; + my $err = MyError::Bar->new(); + $err->{'MyBarText'} = $args->{'text'}; + return $err; +} + +{ + local $Error::ObjectifyCallback = \&throw_MyError_Bar; + eval + { + try + { + die "Hello\n"; + } + catch MyError::Foo with { + }; + }; + + my $err = $@; + + # TEST + ok ($err->isa("MyError::Bar"), "Error was auto-converted to MyError::Bar"); + # TEST + is ($err->{'MyBarText'}, "Hello\n", "Text of the error is correct"); +} diff --git a/t/07try-in-obj-destructor.t b/t/07try-in-obj-destructor.t new file mode 100644 index 0000000..b15bff2 --- /dev/null +++ b/t/07try-in-obj-destructor.t @@ -0,0 +1,42 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More tests => 1; + +use Error qw/ :try /; + +package ErrorTest; +use Error qw/ :try /; + +sub new { + return bless {}, 'ErrorTest'; +} + +sub DESTROY { + my $self = shift; + try { 1; } otherwise { }; + return; +} + +package main; + +my $E; +try { + + my $y = ErrorTest->new(); +# throw Error::Simple("Object die"); + die "throw normal die"; + +} catch Error with { + $E = shift; +} otherwise { + $E = shift; +}; + +# TEST +is ($E->{'-text'}, "throw normal die", + "Testing that the excpetion is not trampeled" +); + + diff --git a/t/08warndie.t b/t/08warndie.t new file mode 100644 index 0000000..205c6e1 --- /dev/null +++ b/t/08warndie.t @@ -0,0 +1,219 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; + +use Test::More tests => 21; + +use Error qw/ :warndie /; + +# Turn on full stack trace capture +$Error::Debug = 1; + +# This file's name - for string matching. We need to quotemeta it, because on +# Win32, the filename is t\08warndie.t, and we don't want that accidentally +# matching an (invalid) \08 octal digit +my $file = qr/\Q$0\E/; + +# Most of these tests are fatal, and print data on STDERR. We therefore use +# this testing function to run a CODEref in a child process and captures its +# STDERR and note whether the CODE block exited +my ( $s, $felloffcode ); +my $linekid = __LINE__ + 15; # the $code->() is 15 lines below this one +sub run_kid(&) +{ + my ( $code ) = @_; + + # Win32's fork() emulation can't correctly handle the open("-|") case yet + # So we'll implement this manually - inspired by 'perldoc perlfork' + pipe my $childh, my $child or die "Cannot pipe() - $!"; + defined( my $kid = fork() ) or die "Cannot fork() - $!"; + + if ( !$kid ) { + close $childh; + close STDERR; + open(STDERR, ">&=" . fileno($child)) or die; + + $code->(); + + print STDERR "FELL OUT OF CODEREF\n"; + exit(1); + } + + close $child; + + $s = ""; + while( defined ( $_ = <$childh> ) ) { + $s .= $_; + } + + close( $childh ); + waitpid( $kid, 0 ); + + $felloffcode = 0; + $s =~ tr/\r//d; # Remove Win32 \r linefeeds to make RE tests easier + if( $s =~ s/FELL OUT OF CODEREF\n$// ) { + $felloffcode = 1; + } +} + +ok(1, "Loaded"); + +run_kid { + print STDERR "Print to STDERR\n"; +}; + +is( $s, "Print to STDERR\n", "Test framework STDERR" ); +is( $felloffcode, 1, "Test framework felloffcode" ); + +my $line; + +$line = __LINE__; +run_kid { + warn "A warning\n"; +}; + +my ( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^A warning at $file line $linea\.?: +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb +$/, "warn \\n-terminated STDERR" ); +is( $felloffcode, 1, "warn \\n-terminated felloffcode" ); + +$line = __LINE__; +run_kid { + warn "A warning"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^A warning at $file line $linea\.?: +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb +$/, "warn unterminated STDERR" ); +is( $felloffcode, 1, "warn unterminated felloffcode" ); + +$line = __LINE__; +run_kid { + die "An error\n"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^ +Unhandled perl error caught at toplevel: + + An error + +Thrown from: $file:$linea + +Full stack trace: + +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb + +$/, "die \\n-terminated STDERR" ); +is( $felloffcode, 0, "die \\n-terminated felloffcode" ); + +$line = __LINE__; +run_kid { + die "An error"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^ +Unhandled perl error caught at toplevel: + + An error + +Thrown from: $file:$linea + +Full stack trace: + +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb + +$/, "die unterminated STDERR" ); +is( $felloffcode, 0, "die unterminated felloffcode" ); + +$line = __LINE__; +run_kid { + throw Error( -text => "An exception" ); +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^ +Unhandled exception of type Error caught at toplevel: + + An exception + +Thrown from: $file:$linea + +Full stack trace: + +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb + +$/, "Error STDOUT" ); +is( $felloffcode, 0, "Error felloffcode" ); + +# Now custom warn and die functions to ensure the :warndie handler respects them +$SIG{__WARN__} = sub { warn "My custom warning here: $_[0]" }; +$SIG{__DIE__} = sub { die "My custom death here: $_[0]" }; + +# First test them +$line = __LINE__; +run_kid { + warn "A warning"; +}; + +$linea = $line + 2; +like( $s, qr/^My custom warning here: A warning at $file line $linea\.? +$/, "Custom warn test STDERR" ); +is( $felloffcode, 1, "Custom warn test felloffcode" ); + +$line = __LINE__; +run_kid { + die "An error"; +}; + +$linea = $line + 2; +like( $s, qr/^My custom death here: An error at $file line $linea\.? +/, "Custom die test STDERR" ); +is( $felloffcode, 0, "Custom die test felloffcode" ); + +# Re-install the :warndie handlers +import Error qw( :warndie ); + +$line = __LINE__; +run_kid { + warn "A warning\n"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^My custom warning here: A warning at $file line $linea\.?: +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb +$/, "Custom warn STDERR" ); +is( $felloffcode, 1, "Custom warn felloffcode" ); + +$line = __LINE__; +run_kid { + die "An error"; +}; + +( $linea, $lineb ) = ( $line + 2, $line + 3 ); +like( $s, qr/^My custom death here: +Unhandled perl error caught at toplevel: + + An error + +Thrown from: $file:$linea + +Full stack trace: + +\tmain::__ANON__\(\) called at $file line $linekid +\tmain::run_kid\('CODE\(0x[0-9a-f]+\)'\) called at $file line $lineb + +$/, "Custom die STDERR" ); +is( $felloffcode, 0, "Custom die felloffcode" ); + +# Done diff --git a/t/09dollar-at.t b/t/09dollar-at.t new file mode 100644 index 0000000..7a46b16 --- /dev/null +++ b/t/09dollar-at.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); +use Test::More tests => 8; + +my $dollar_at; +my $arg_0; + +try { + throw Error::Simple( "message" ); +} +catch Error::Simple with { + $arg_0 = shift; + $dollar_at = $@; +}; + +ok( defined $arg_0, 'defined( $_[0] ) after throw/catch' ); +ok( defined $dollar_at, 'defined( $@ ) after throw/catch' ); +ok( ref $arg_0 && $arg_0->isa( "Error::Simple" ), '$_[0]->isa( "Error::Simple" ) after throw/catch' ); +ok( ref $dollar_at && $dollar_at->isa( "Error::Simple" ), '$@->isa( "Error::Simple" ) after throw/catch' ); + +try { + throw Error::Simple( "message" ); +} +otherwise { + $arg_0 = shift; + $dollar_at = $@; +}; + +ok( defined $arg_0, 'defined( $_[0] ) after throw/otherwise' ); +ok( defined $dollar_at, 'defined( $@ ) after throw/otherwise' ); +ok( ref $arg_0 && $arg_0->isa( "Error::Simple" ), '$_[0]->isa( "Error::Simple" ) after throw/otherwise' ); +ok( ref $dollar_at && $dollar_at->isa( "Error::Simple" ), '$@->isa( "Error::Simple" ) after throw/otherwise' ); diff --git a/t/10throw-in-catch.t b/t/10throw-in-catch.t new file mode 100644 index 0000000..7d2af3e --- /dev/null +++ b/t/10throw-in-catch.t @@ -0,0 +1,41 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); +use Test::More tests => 2; + +my ($error); + +eval +{ +try { + throw Error::Simple( "message" ); +} +catch Error::Simple with { + die "A-Lovely-Day"; +}; +}; +$error = $@; + +# TEST +ok (scalar($error =~ /^A-Lovely-Day/), + "Error thrown in the catch clause is registered" +); + +eval { +try { + throw Error::Simple( "message" ); +} +otherwise { + die "Had-the-ancient-greeks"; +}; +}; +$error = $@; + +# TEST +ok (scalar($error =~ /^Had-the-ancient/), + "Error thrown in the otherwise clause is registered" +); + diff --git a/t/11rethrow.t b/t/11rethrow.t new file mode 100644 index 0000000..227bca5 --- /dev/null +++ b/t/11rethrow.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use Error qw(:try); +use Test::More tests => 4; + +try { + try { die "inner" } + catch Error::Simple with { die "foobar" }; +} +otherwise +{ + my $err = shift; + # TEST + ok (scalar($err =~ /foobar/), "Error rethrown"); +}; + +try { + try { die "inner" } + catch Error::Simple with { throw Error::Simple "foobar" }; +} +otherwise +{ + my $err = shift; + # TEST + ok (scalar("$err" =~ /foobar/), "Thrown Error::Simple"); +}; + +try { + try { die "inner" } + otherwise { die "foobar" }; +} +otherwise +{ + my $err = shift; + # TEST + ok (scalar("$err" =~ /foobar/), "die foobar"); +}; + +try { + try { die "inner" } + catch Error::Simple with { throw Error::Simple "foobar" }; +} +otherwise +{ + my $err = shift; + # TEST + ok (scalar($err =~ /foobar/), "throw Error::Simple"); +}; + +1; diff --git a/t/12wrong-error-var.t b/t/12wrong-error-var.t new file mode 100644 index 0000000..888c723 --- /dev/null +++ b/t/12wrong-error-var.t @@ -0,0 +1,37 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +use Error qw(:try); + +try { + eval { + throw Error::Simple "This is caught by eval, not by try."; + }; + + # TEST + ok (($@ && $@ =~ /This is caught by eval, not by try/), + "Checking that eval { ... } is sane" + ); + + print "# Error::THROWN = $Error::THROWN\n"; + + die "This is a simple 'die' exception."; + + # not reached +} +otherwise { + my $E = shift; + my $t = $Error::THROWN ? "$Error::THROWN" : ''; + print "# Error::THROWN = $t\n"; + $E ||= ''; + print "# E = $E\n"; + + # TEST + ok ("$E" =~ /This is a simple 'die' exception/, + "Checking that the argument to otherwise is the thrown exception" + ); +}; diff --git a/t/13except-arg0.t b/t/13except-arg0.t new file mode 100644 index 0000000..5bc9497 --- /dev/null +++ b/t/13except-arg0.t @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Error qw(:try); +use Test::More tests => 2; + +my $arg_0; + +try { + throw Error::Simple( "message" ); +} +except { + $arg_0 = shift; + return { + 'Error::Simple' => sub {}, + }; +}; + +ok( defined $arg_0, 'defined( $_[0] ) after throw/except' ); +ok( ref $arg_0 && $arg_0->isa( "Error::Simple" ), '$_[0]->isa( "Error::Simple" ) after throw/except' ); diff --git a/t/lib/MyDie.pm b/t/lib/MyDie.pm new file mode 100644 index 0000000..21205c8 --- /dev/null +++ b/t/lib/MyDie.pm @@ -0,0 +1,19 @@ +package MyDie; + +sub mydie +{ + local *I; + open I, "<", "ChangeLog"; + my $s = <I>; + + + + + + + + + die "Hello"; +} + +1; diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..703f91d --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +all_pod_coverage_ok(); @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; +all_pod_files_ok(); |