From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Fri, 17 May 2002 19:03:06 +0000 (+0000)
Subject: Fix bug 20020517.003 : segfault with caller().
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=07b8c804e887e8334910292dd4862f56c37dcb00;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
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" );