Test-Exception-LessClever-0.006000755001750001750 011547212727 16770 5ustar00exodistexodist000000000000Test-Exception-LessClever-0.006/README000444001750001750 653711547212727 20020 0ustar00exodistexodist000000000000NAME Test::Exception::LessClever - Test::Exception simplified DESCRIPTION An alternative to Test::Exception that is much simpler. This alternative does not use fancy stack tricks to hide itself. The idea here is to keep it simple. This also solves the Test::Exception bug where some dies will be hidden when a DESTROY method calls eval. If a DESTROY method masks $@ a warning will be generated as well. WHY REWRITE TEST-EXCEPTION Here is an IRC log. wtf? Bizarre copy of HASH in sassign at /usr/lib64/perl5/5.10.1/Carp/Heavy.pm line 104 hmm, it doesn't happen when I step through the debugger, that sure is helpful yessir hmm, throws_ok or dies_ok { stuff that croaks in a package used by the one being tested }, at least in this case causes that error. If I change it to eval {}; ok( $@ ); like( $@, qr// ); it works fine Ah-Ha, earlier when I mentioned I stopped using throws_ok because of something I could not remember, this was it, I stumbled on it again! probably because throws_ok tries to do clever things to fiddle with the call stack to make it appear as though its guts are not being called less clever would be more useful SYNOPSYS Pretty much a clone of Test::Exception Refer to those docs for more details. use Test::More; use Test::Exception; dies_ok { die( 'xxx' )} "Should die"; lives_ok { 1 } "Should live"; throws_ok { die( 'xxx' )} qr/xxx/, "Throws 'xxx'"; lives_and { ok( 1, "We did not die" )} "Ooops we died"; done_testing; EXPORTABLE FUNCTIONS $status = live_or_die( sub { ... }, $name ) ($status, $msg) = live_or_die( sub { ... }, $name ) Check if the code lives or dies. In scalar context returns true or false. In array context returns the same true or false with the error message. If the return is true the error message will be something along the lines of 'did not die' but this may change in the future. Will generate a warning if the test dies, $@ is empty AND called in array context. This usually occurs when an objects DESTROY method calls eval and masks $@. *NOT EXPORTED BY DEFAULT* lives_ok( sub { ... }, $name ) Test passes if the sub does not die, false if it does. dies_ok( sub { ... }, $name ) Test passes if the sub dies, false if it does not. throws_ok( sub { ... }, qr/message/, $name ) Check that the sub dies, and that it throws an error that matches the regex. Test fails is the sub does not die, or if the message does not match the regex. lives_and( sub {...}, $name ) Fails with $name if the sub dies, otherwise is passive. This is useful for running a test that could die. If it dies there is a failure, fi ti lives it is responsible for itself. SEE ALSO Test::Exception AUTHORS Chad Granum exodist7@gmail.com COPYRIGHT Copyright (C) 2010 Chad Granum Test-Exception-LessClever is free software; Standard perl licence. Test-Exception-LessClever is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the license for more details. Test-Exception-LessClever-0.006/Build.PL000444001750001750 73511547212727 20406 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Test::Exception::LessClever', license => 'perl', dist_author => 'Chad Granum ', create_readme => 1, requires => { Carp => 0, Exporter => 0, 'Test::Builder' => 0, }, build_requires => { 'Test::Simple' => 0.88, 'Mock::Quick' => '1.100', }, ); $build->create_build_script; Test-Exception-LessClever-0.006/META.yml000444001750001750 121111547212727 20371 0ustar00exodistexodist000000000000--- abstract: 'Test::Exception simplified' author: - 'Chad Granum ' build_requires: Mock::Quick: 1.100 Test::Simple: 0.88 configure_requires: Module::Build: 0.38 dynamic_config: 1 generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.110440' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-Exception-LessClever provides: Test::Exception::LessClever: file: lib/Test/Exception/LessClever.pm version: 0.006 requires: Carp: 0 Exporter: 0 Test::Builder: 0 resources: license: http://dev.perl.org/licenses/ version: 0.006 Test-Exception-LessClever-0.006/META.json000444001750001750 215311547212727 20547 0ustar00exodistexodist000000000000{ "abstract" : "Test::Exception simplified", "author" : [ "Chad Granum " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.110440", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Exception-LessClever", "prereqs" : { "build" : { "requires" : { "Mock::Quick" : "1.100", "Test::Simple" : "0.88" } }, "configure" : { "requires" : { "Module::Build" : "0.38" } }, "runtime" : { "requires" : { "Carp" : 0, "Exporter" : 0, "Test::Builder" : 0 } } }, "provides" : { "Test::Exception::LessClever" : { "file" : "lib/Test/Exception/LessClever.pm", "version" : "0.006" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.006" } Test-Exception-LessClever-0.006/MANIFEST000444001750001750 15411547212727 20236 0ustar00exodistexodist000000000000Build.PL lib/Test/Exception/LessClever.pm MANIFEST This list of files README t/tests.t META.yml META.json Test-Exception-LessClever-0.006/t000755001750001750 011547212727 17233 5ustar00exodistexodist000000000000Test-Exception-LessClever-0.006/t/tests.t000444001750001750 660211547212727 20723 0ustar00exodistexodist000000000000#!/usr/bin/perl use strict; use warnings; use Test::Builder::Tester; use Test::More; use Mock::Quick qw/qobj qmeth/; our $CLASS; BEGIN { test_out( 'ok 1 - use Test::Exception::LessClever;' ); $CLASS = 'Test::Exception::LessClever'; use_ok( $CLASS, qw/lives_ok dies_ok throws_ok lives_and live_or_die/ ); } my $program = quotemeta($0); test_out( "not ok 2 - dies_ok fail" ); test_fail(+1); dies_ok { 1 } "dies_ok fail"; test_out( "not ok 3 - lives_ok fail" ); test_fail(+1); lives_ok { die( 'xxx' )} 'lives_ok fail'; test_err( "# Test did not die as expected at $0 line 29." ); test_out( "not ok 4 - throws_ok doesn't die" ); test_fail(+1); throws_ok { 1 } qr/xxx/, "throws_ok doesn't die"; test_out( "not ok 5 - throws_ok error doesn't match" ); test_fail(+7); if ( $^V and $^V ge '5.13.6' ) { test_err( "# $0 line 39:\n# Wanted: (?^:YYY)\n# Got: XXX at $0 line 39." ); } else { test_err( "# $0 line 39:\n# Wanted: (?-xism:YYY)\n# Got: XXX at $0 line 39." ); } throws_ok { die "XXX" } qr/YYY/, "throws_ok error doesn't match"; test_err( "# Test unexpectedly died: 'xxx at $0 line 44.' at $0 line 44." ); test_out( "not ok 6 - did not live to test" ); test_fail(+1); lives_and { die 'xxx' } "did not live to test"; test_test "Test output was as desired"; ###### # # End of failure tests # ###### my $ret = live_or_die( sub { die( 'apple' ) }); ok( !$ret, "Registered a die" ); ($ret, my $error) = live_or_die( sub { die( 'apple' ) }); ok( !$ret, "Registered a die" ); like( $error, qr/apple/, "Got error" ); $ret = live_or_die( sub { 1 }); ok( $ret, "Registered a live" ); ($ret, my $msg) = live_or_die( sub { 1; }); ok( $ret, "Registered a live" ); like( $msg, qr/did not die/, "Got msg" ); if ( $^V and $^V ge '5.13.0' ) { note( "Perl version $^V does not suffer from die in eval edge case, skipping..." ); } else { my @warn; local $SIG{ __WARN__ } = sub { push @warn => @_ }; ($ret, $error) = live_or_die( sub { my $obj = qobj( DESTROY => qmeth { eval { 1 }} ); die( 'apple' ); $obj->x; }); ok( !$ret, "Registered a die despite eval in DESTROY" ); ok( !$error, "Error was masked by eval in DESTROY" ); like( $warn[0], qr/ code \s died \s as \s expected, \s however \s the \s error \s is \s masked\. \s This \s can \s occur \s when \s an \s object's \s DESTROY\(\) \s method \s calls \s eval \s at \s $program /x, "Warn of edge case" ); @warn = (); $ret = live_or_die( sub { my $obj = qobj( DESTROY => qmeth { eval { 1 }} ); die( 'apple' ); $obj->x; }); ok( !$ret, "Registered a die despite eval in DESTROY" ); ok( !@warn, "No warning when error is not requested" ); @warn = (); throws_ok { my $obj = qobj( DESTROY => qmeth { eval { 1 }} ); die( 'xxx' ); $obj->x; } qr/^$/, "Throw edge case"; like( $warn[0], qr/ code \s died \s as \s expected, \s however \s the \s error \s is \s masked\. \s This \s can \s occur \s when \s an \s object's \s DESTROY\(\) \s method \s calls \s eval \s at \s $program /x, "Warn of edge case" ); } lives_ok { 1 } "Simple living sub"; dies_ok { die( 'xxx' )} "Simple dying sub"; throws_ok { die( 'xxx' )} qr/xxx/, "Simple throw"; lives_and { ok( 1, "Blah" )} "Test did not die"; done_testing; Test-Exception-LessClever-0.006/lib000755001750001750 011547212727 17536 5ustar00exodistexodist000000000000Test-Exception-LessClever-0.006/lib/Test000755001750001750 011547212727 20455 5ustar00exodistexodist000000000000Test-Exception-LessClever-0.006/lib/Test/Exception000755001750001750 011547212727 22413 5ustar00exodistexodist000000000000Test-Exception-LessClever-0.006/lib/Test/Exception/LessClever.pm000444001750001750 1212311547212727 25174 0ustar00exodistexodist000000000000package Test::Exception::LessClever; use strict; use warnings; use base 'Exporter'; use Test::Builder; use Carp qw/carp/; #{{{ POD =head1 NAME Test::Exception::LessClever - Test::Exception simplified =head1 DESCRIPTION An alternative to L that is much simpler. This alternative does not use fancy stack tricks to hide itself. The idea here is to keep it simple. This also solves the Test::Exception bug where some dies will be hidden when a DESTROY method calls eval. If a DESTROY method masks $@ a warning will be generated as well. =head1 WHY REWRITE TEST-EXCEPTION Here is an IRC log. wtf? Bizarre copy of HASH in sassign at /usr/lib64/perl5/5.10.1/Carp/Heavy.pm line 104 hmm, it doesn't happen when I step through the debugger, that sure is helpful yessir hmm, throws_ok or dies_ok { stuff that croaks in a package used by the one being tested }, at least in this case causes that error. If I change it to eval {}; ok( $@ ); like( $@, qr// ); it works fine Ah-Ha, earlier when I mentioned I stopped using throws_ok because of something I could not remember, this was it, I stumbled on it again! probably because throws_ok tries to do clever things to fiddle with the call stack to make it appear as though its guts are not being called less clever would be more useful =head1 SYNOPSYS Pretty much a clone of L Refer to those docs for more details. use Test::More; use Test::Exception; dies_ok { die( 'xxx' )} "Should die"; lives_ok { 1 } "Should live"; throws_ok { die( 'xxx' )} qr/xxx/, "Throws 'xxx'"; lives_and { ok( 1, "We did not die" )} "Ooops we died"; done_testing; =head1 EXPORTABLE FUNCTIONS =over 4 =cut #}}} our @EXPORT_OK = qw/live_or_die/; our @EXPORT = qw/lives_ok dies_ok throws_ok lives_and/; our @CARP_NOT = ( __PACKAGE__ ); our $TB = Test::Builder->new; our $VERSION = "0.006"; =item $status = live_or_die( sub { ... }, $name ) =item ($status, $msg) = live_or_die( sub { ... }, $name ) Check if the code lives or dies. In scalar context returns true or false. In array context returns the same true or false with the error message. If the return is true the error message will be something along the lines of 'did not die' but this may change in the future. Will generate a warning if the test dies, $@ is empty AND called in array context. This usually occurs when an objects DESTROY method calls eval and masks $@. *NOT EXPORTED BY DEFAULT* =cut sub live_or_die { my ( $code ) = @_; my $return = eval { $code->(); 'did not die' } || "died"; my $msg = $@; if ( $return eq 'did not die' ) { return ( 1, $return ) if wantarray; return 1; } else { return 0 unless wantarray; if ( !$msg ) { carp "code died as expected, however the error is masked. This" . " can occur when an object's DESTROY() method calls eval"; } return ( 0, $msg ); } } =item lives_ok( sub { ... }, $name ) Test passes if the sub does not die, false if it does. =cut sub lives_ok(&;$) { my ( $code, $name ) = @_; my $ok = live_or_die( $code ); $TB->ok( $ok, $name ); return $ok; } =item dies_ok( sub { ... }, $name ) Test passes if the sub dies, false if it does not. =cut sub dies_ok(&;$) { my ( $code, $name ) = @_; my $ok = live_or_die( $code ); $TB->ok( !$ok, $name ); return !$ok; } =item throws_ok( sub { ... }, qr/message/, $name ) Check that the sub dies, and that it throws an error that matches the regex. Test fails is the sub does not die, or if the message does not match the regex. =cut sub throws_ok(&$;$) { my ( $code, $reg, $name ) = @_; my ( $ok, $msg ) = live_or_die( $code ); my ( $pkg, $file, $number ) = caller; # If we lived if ( $ok ) { $TB->diag( "Test did not die as expected at $file line $number." ); return $TB->ok( !$ok, $name ); } my $match = $msg =~ $reg ? 1 : 0; $TB->ok( $match, $name ); $TB->diag( "$file line $number:\n Wanted: $reg\n Got: $msg" ) unless( $match ); return $match; } =item lives_and( sub {...}, $name ) Fails with $name if the sub dies, otherwise is passive. This is useful for running a test that could die. If it dies there is a failure, fi ti lives it is responsible for itself. =cut sub lives_and(&;$) { my ( $code, $name ) = @_; my ( $ok, $msg )= live_or_die( $code ); my ( $pkg, $file, $number ) = caller; chomp( $msg ); $msg =~ s/\n/ /g; $TB->diag( "Test unexpectedly died: '$msg' at $file line $number." ) unless $ok; $TB->ok( $ok, $name ) if !$ok; return $ok; } 1; __END__ =back =head1 SEE ALSO L =head1 AUTHORS Chad Granum L =head1 COPYRIGHT Copyright (C) 2010 Chad Granum Test-Exception-LessClever is free software; Standard perl licence. Test-Exception-LessClever is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.