From: Paul Fenwick Date: Mon, 2 Mar 2009 05:06:59 +0000 (+1100) Subject: Merge of autodie 1.999 into blead. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=db4e6d0949c40ede9013b33870ab2645f54ed664;p=p5sagit%2Fp5-mst-13.2.git Merge of autodie 1.999 into blead. --- diff --git a/lib/Fatal.pm b/lib/Fatal.pm index bc92630..9acf4e2 100644 --- a/lib/Fatal.pm +++ b/lib/Fatal.pm @@ -31,7 +31,7 @@ use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; # All the Fatal/autodie modules share the same version number. -our $VERSION = '1.998'; +our $VERSION = '1.999'; our $Debug ||= 0; @@ -84,6 +84,7 @@ my %TAGS = ( ':1.996' => [qw(:default)], ':1.997' => [qw(:default)], ':1.998' => [qw(:default)], + ':1.999' => [qw(:default)], ); @@ -759,6 +760,7 @@ sub _make_fatal { $call = 'CORE::system'; $name = 'system'; + $core = 1; } elsif ($name eq 'exec') { # Exec doesn't have a prototype. We don't care. This @@ -861,9 +863,19 @@ sub _make_fatal { sub$real_proto { + # If we're inside a string eval, we can end up with a + # whacky filename. The following code allows autodie + # to propagate correctly into string evals. + + my \$caller_level = 0; + + while ( (caller \$caller_level)[1] =~ m{^\\(eval \\d+\\)\$} ) { + \$caller_level++; + } + # If we're called from the correct file, then use the # autodying code. - goto &\$code if ((caller)[1] eq \$filename); + goto &\$code if ((caller \$caller_level)[1] eq \$filename); # Oh bother, we've leaked into another file. Call the # original code. Note that \$sref may actually be a diff --git a/lib/autodie.pm b/lib/autodie.pm index 41ad856..cb999a8 100644 --- a/lib/autodie.pm +++ b/lib/autodie.pm @@ -8,7 +8,7 @@ our @ISA = qw(Fatal); our $VERSION; BEGIN { - $VERSION = "1.998"; + $VERSION = "1.999"; } use constant ERROR_WRONG_FATAL => q{ @@ -307,6 +307,11 @@ See also L. is used with package filehandles (eg, C). It's strongly recommended you use scalar filehandles instead. +Under Perl 5.8 only, C I propagate into string C +statements, although it can be explicitly enabled inside a string +C. This bug does not affect block C statements in +any version of Perl. + When using C or C with user subroutines, the declaration of those subroutines must appear before the first use of C or C, or have been exported from a module. diff --git a/lib/autodie/exception.pm b/lib/autodie/exception.pm index 45a32b0..f297bf8 100644 --- a/lib/autodie/exception.pm +++ b/lib/autodie/exception.pm @@ -14,7 +14,7 @@ use overload use if ($] >= 5.010), overload => '~~' => "matches"; -our $VERSION = '1.998'; +our $VERSION = '1.999'; my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. @@ -628,6 +628,28 @@ sub _init { } + # We now have everything correct, *except* for our subroutine + # name. If it's __ANON__ or (eval), then we need to keep on + # digging deeper into our stack to find the real name. However we + # don't update our other information, since that will be correct + # for our current exception. + + my $first_guess_subroutine = $sub; + + while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) { + $depth++; + + $sub = (CORE::caller($depth))[3]; + } + + # If we end up falling out the bottom of our stack, then our + # __ANON__ guess is the best we can get. This includes situations + # where we were called from thetop level of a program. + + if (not defined $sub) { + $sub = $first_guess_subroutine; + } + $this->{$PACKAGE}{package} = $package; $this->{$PACKAGE}{file} = $file; $this->{$PACKAGE}{line} = $line; diff --git a/lib/autodie/exception/system.pm b/lib/autodie/exception/system.pm index e49bf4b..6b11440 100644 --- a/lib/autodie/exception/system.pm +++ b/lib/autodie/exception/system.pm @@ -5,7 +5,7 @@ use warnings; use base 'autodie::exception'; use Carp qw(croak); -our $VERSION = '1.998'; +our $VERSION = '1.999'; my $PACKAGE = __PACKAGE__; @@ -16,7 +16,7 @@ autodie::exception::system - Exceptions from autodying system(). =head1 SYNOPSIS eval { - use autodie; + use autodie qw(system); system($cmd, @args); diff --git a/t/lib/autodie/basic_exceptions.t b/t/lib/autodie/basic_exceptions.t index 0981e8d..56876be 100644 --- a/t/lib/autodie/basic_exceptions.t +++ b/t/lib/autodie/basic_exceptions.t @@ -1,13 +1,15 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 13; +use Test::More tests => 17; use constant NO_SUCH_FILE => "this_file_had_better_not_exist"; +my $line; + eval { use autodie ':io'; - open(my $fh, '<', NO_SUCH_FILE); + $line = __LINE__; open(my $fh, '<', NO_SUCH_FILE); }; like($@, qr/Can't open '\w+' for reading: /, "Prety printed open msg"); @@ -21,7 +23,24 @@ is($@->file, $0, "Correct file"); is($@->function, 'CORE::open', "Correct dying sub"); is($@->package, __PACKAGE__, "Correct package"); is($@->caller,__PACKAGE__."::__ANON__", "Correct caller"); +is($@->line, $line, "Correct line"); is($@->args->[1], '<', 'Correct mode arg'); is($@->args->[2], NO_SUCH_FILE, 'Correct filename arg'); ok($@->matches('open'), 'Looks like an error from open'); ok($@->matches(':io'), 'Looks like an error from :io'); + +# Testing of caller info with a real subroutine. + +my $line2; + +sub xyzzy { + use autodie ':io'; + $line2 = __LINE__; open(my $fh, '<', NO_SUCH_FILE); + return; +}; + +eval { xyzzy(); }; + +isa_ok($@, 'autodie::exception'); +is($@->caller, __PACKAGE__."::xyzzy", "Subroutine caller test"); +is($@->line, $line2, "Subroutine line test"); diff --git a/t/lib/autodie/caller.t b/t/lib/autodie/caller.t new file mode 100644 index 0000000..1874353 --- /dev/null +++ b/t/lib/autodie/caller.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use autodie; +use Test::More 'no_plan'; +use FindBin qw($Bin); +use lib "$Bin/lib"; +use Caller_helper; + +use constant NO_SUCH_FILE => "kiwifoo_is_so_much_fun"; + +eval { + foo(); +}; + +isa_ok($@, 'autodie::exception'); + +is($@->caller, 'main::foo', "Caller should be main::foo"); + +sub foo { + use autodie; + open(my $fh, '<', NO_SUCH_FILE); +} + +eval { + Caller_helper::foo(); +}; + +isa_ok($@, 'autodie::exception'); + +is($@->line, $Caller_helper::line, "External line number check"); +is($@->file, $INC{"Caller_helper.pm"}, "External filename check"); +is($@->package, "Caller_helper", "External package check"); +is($@->caller, "Caller_helper::foo", "External subname check"); diff --git a/t/lib/autodie/lib/Caller_helper.pm b/t/lib/autodie/lib/Caller_helper.pm new file mode 100644 index 0000000..6ee9c69 --- /dev/null +++ b/t/lib/autodie/lib/Caller_helper.pm @@ -0,0 +1,13 @@ +package Caller_helper; + +our $line; + +sub foo { + use autodie; + + $line = __LINE__; open(my $fh, '<', "no_such_file_here"); + + return; +} + +1; diff --git a/t/lib/autodie/scope_leak.t b/t/lib/autodie/scope_leak.t index 3d7b555..529daa3 100644 --- a/t/lib/autodie/scope_leak.t +++ b/t/lib/autodie/scope_leak.t @@ -35,3 +35,44 @@ eval { }; is($@,"","Other package open should be unaffected"); + +# Due to odd filenames reported when doing string evals, +# older versions of autodie would not propogate into string evals. + +eval q{ + open(my $fh, '<', NO_SUCH_FILE); +}; + +TODO: { + local $TODO = "No known way of propagating into string eval in 5.8" + if $] < 5.010; + + ok($@, "Failing-open string eval should throw an exception"); + isa_ok($@, 'autodie::exception'); +} + +eval q{ + no autodie; + + open(my $fh, '<', NO_SUCH_FILE); +}; + +is("$@","","disabling autodie in string context should work"); + +eval { + open(my $fh, '<', NO_SUCH_FILE); +}; + +ok($@,"...but shouldn't disable it for the calling code."); +isa_ok($@, 'autodie::exception'); + +eval q{ + no autodie; + + use autodie qw(open); + + open(my $fh, '<', NO_SUCH_FILE); +}; + +ok($@,"Wacky flipping of autodie in string eval should work too!"); +isa_ok($@, 'autodie::exception'); diff --git a/t/lib/autodie/user-context.t b/t/lib/autodie/user-context.t new file mode 100644 index 0000000..96a0390 --- /dev/null +++ b/t/lib/autodie/user-context.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl -w +use strict; +use warnings; +use Test::More 'no_plan'; +use File::Copy; +use constant NO_SUCH_FILE => 'this_file_had_better_not_exist'; +use constant EXCEPTION => 'autodie::exception'; + +# http://perlmonks.org/?node_id=744246 describes a situation where +# using autodie on user-defined functions can fail, depending upon +# their context. These tests attempt to detect this bug. + +eval { + use autodie qw(copy); + copy(NO_SUCH_FILE, 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"Copying a non-existent file should throw an error"); + +eval { + use autodie qw(copy); + my $x = copy(NO_SUCH_FILE, 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"This shouldn't change with scalar context"); + +eval { + use autodie qw(copy); + my @x = copy(NO_SUCH_FILE, 'xyzzy'); +}; + +TODO: { + local $TODO = "Fixed in 'hints' branch"; + + isa_ok($@,EXCEPTION,"This shouldn't change with array context"); +} + +# For good measure, test with built-ins. + +eval { + use autodie qw(open); + open(my $fh, '<', 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"Opening a non-existent file should throw an error"); + +eval { + use autodie qw(open); + my $x = open(my $fh, '<', 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"This shouldn't change with scalar context"); + +eval { + use autodie qw(open); + my @x = open(my $fh, '<', 'xyzzy'); +}; + +isa_ok($@,EXCEPTION,"This shouldn't change with array context");