Fix bug 20020517.003 : segfault with caller().

Add regression tests for caller.

p4raw-id: //depot/perl@16658

1 files changed, 46 insertions, 0 deletions

diff --git a/t/op/caller.t b/t/op/caller.t
new file mode 100644
index 0000000000..1b08d93002
--- /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" );