Fix bug 20020517.003 : segfault with caller().

Add regression tests for caller.

p4raw-id: //depot/perl@16658

diff --git a/MANIFEST b/MANIFEST
index 39cd432..834b980 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2441,6 +2441,7 @@ t/op/auto.t                       See if autoincrement et all work
 t/op/avhv.t                    See if pseudo-hashes work
 t/op/bless.t                   See if bless works
 t/op/bop.t                     See if bitops work
+t/op/caller.t                  See if caller() works
 t/op/chars.t                   See if character escapes work
 t/op/chdir.t                   See if chdir works
 t/op/chop.t                    See if chop works

diff --git a/pp_ctl.c b/pp_ctl.c
index d461873..8432a15 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1450,11 +1450,18 @@ PP(pp_caller)
     if (!MAXARG)
        RETURN;
     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
+       GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
        /* So is ccstack[dbcxix]. */
-       sv = NEWSV(49, 0);
-       gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
-       PUSHs(sv_2mortal(sv));
-       PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+       if (isGV(cvgv)) {
+           sv = NEWSV(49, 0);
+           gv_efullname3(sv, cvgv, Nullch);
+           PUSHs(sv_2mortal(sv));
+           PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
+       }
+       else {
+           PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
+           PUSHs(sv_2mortal(newSViv(0)));
+       }
     }
     else {
        PUSHs(sv_2mortal(newSVpvn("(eval)",6)));

diff --git a/t/op/caller.t b/t/op/caller.t
new file mode 100644 (file)
index 0000000..1b08d93
--- /dev/null
+++ b/t/op/caller.t
@@ -0,0 +1,46 @@
+#!./perl
+# Tests for caller()
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+plan( tests => 9 );
+
+my @c;
+
+@c = caller(0);
+ok( (!@c), "caller(0) in main program" );
+
+eval { @c = caller(0) };
+is( $c[3], "(eval)", "caller(0) - subroutine name in an eval {}" );
+
+eval q{ @c = (Caller(0))[3] };
+is( $c[3], "(eval)", "caller(0) - subroutine name in an eval ''" );
+
+sub { @c = caller(0) } -> ();
+is( $c[3], "main::__ANON__", "caller(0) - anonymous subroutine name" );
+
+# Bug 20020517.003, used to dump core
+sub foo { @c = caller(0) }
+my $fooref = delete $::{foo};
+$fooref -> ();
+is( $c[3], "(unknown)", "caller(0) - unknown subroutine name" );
+
+sub f { @c = caller(1) }
+
+eval { f() };
+is( $c[3], "(eval)", "caller(1) - subroutine name in an eval {}" );
+
+eval q{ f() };
+is( $c[3], "(eval)", "caller(1) - subroutine name in an eval ''" );
+
+sub { f() } -> ();
+is( $c[3], "main::__ANON__", "caller(1) - anonymous subroutine name" );
+
+sub foo2 { f() }
+my $fooref2 = delete $::{foo2};
+$fooref2 -> ();
+is( $c[3], "(unknown)", "caller(1) - unknown subroutine name" );