Commit | Line | Data |
---|---|---|
d527ce7c BF |
1 | #!./perl |
2 | # Tests for caller() | |
3 | ||
4 | BEGIN { | |
5 | chdir 't' if -d 't'; | |
d527ce7c | 6 | require './test.pl'; |
624c42e2 | 7 | set_up_inc('../lib'); |
d527ce7c BF |
8 | plan( tests => 18 ); |
9 | } | |
10 | ||
11 | use utf8; | |
12 | use open qw( :utf8 :std ); | |
13 | ||
14 | package main; | |
15 | ||
16 | { | |
17 | local $@; | |
18 | eval 'ok(1);'; | |
19 | ::like $@, qr/Undefined subroutine &main::ok called at/u; | |
20 | } | |
21 | my @c; | |
22 | ||
23 | sub { @c = caller(0) } -> (); | |
24 | ::is( $c[3], "main::__ANON__", "anonymous subroutine name" ); | |
25 | ::ok( $c[4], "hasargs true with anon sub" ); | |
26 | ||
ee95e30c | 27 | # Bug 20020517.003 (#9367), used to dump core |
d527ce7c BF |
28 | sub foo { @c = caller(0) } |
29 | my $fooref = delete $main::{foo}; | |
30 | $fooref -> (); | |
31 | ::is( $c[3], "main::__ANON__", "deleted subroutine name" ); | |
32 | ::ok( $c[4], "hasargs true with deleted sub" ); | |
33 | ||
34 | print "# Tests with caller(1)\n"; | |
35 | ||
36 | sub f { @c = caller(1) } | |
37 | ||
38 | sub callf { f(); } | |
39 | callf(); | |
40 | ::is( $c[3], "main::callf", "subroutine name" ); | |
41 | ::ok( $c[4], "hasargs true with callf()" ); | |
42 | &callf; | |
43 | ::ok( !$c[4], "hasargs false with &callf" ); | |
44 | ||
45 | eval { f() }; | |
46 | ::is( $c[3], "(eval)", "subroutine name in an eval {}" ); | |
47 | ::ok( !$c[4], "hasargs false in an eval {}" ); | |
48 | ||
49 | eval q{ f() }; | |
50 | ::is( $c[3], "(eval)", "subroutine name in an eval ''" ); | |
51 | ::ok( !$c[4], "hasargs false in an eval ''" ); | |
52 | ||
53 | sub { f() } -> (); | |
54 | ::is( $c[3], "main::__ANON__", "anonymous subroutine name" ); | |
55 | ::ok( $c[4], "hasargs true with anon sub" ); | |
56 | ||
57 | sub foo2 { f() } | |
58 | my $fooref2 = delete $main::{foo2}; | |
59 | $fooref2 -> (); | |
60 | ::is( $c[3], "main::__ANON__", "deleted subroutine name" ); | |
61 | ::ok( $c[4], "hasargs true with deleted sub" ); | |
62 | ||
63 | sub pb { return (caller(0))[3] } | |
64 | ||
65 | ::is( eval 'pb()', 'main::pb', "actually return the right function name" ); | |
66 | ||
67 | my $saved_perldb = $^P; | |
68 | $^P = 16; | |
69 | $^P = $saved_perldb; | |
70 | ||
71 | ::is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' ); |