Merge of autodie 1.999 into blead.

9 files changed, 213 insertions, 8 deletions

diff --git a/lib/Fatal.pm b/lib/Fatal.pm
index bc926305fb..9acf4e23e9 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 41ad856ddf..cb999a8334 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<Fatal/DIAGNOSTICS>.
 is used with package filehandles (eg, C<FILE>).  It's strongly recommended
 you use scalar filehandles instead.
 
+Under Perl 5.8 only, C<autodie> I<does not> propagate into string C<eval>
+statements, although it can be explicitly enabled inside a string
+C<eval>.  This bug does not affect block C<eval> statements in
+any version of Perl.
+
 When using C<autodie> or C<Fatal> with user subroutines, the
 declaration of those subroutines must appear before the first use of
 C<Fatal> or C<autodie>, or have been exported from a module.
diff --git a/lib/autodie/exception.pm b/lib/autodie/exception.pm
index 45a32b076d..f297bf8461 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 e49bf4b39e..6b1144054a 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 0981e8d6ef..56876be481 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 0000000000..1874353627
--- /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 0000000000..6ee9c69c07
--- /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 3d7b55510c..529daa3ecd 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 0000000000..96a0390fa0
--- /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");