diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | pp_ctl.c | 17 | ||||
| -rw-r--r-- | t/uni/caller.t | 71 |
3 files changed, 82 insertions, 7 deletions
@@ -5234,6 +5234,7 @@ t/test.pl Simple testing library t/thread_it.pl Run regression tests in a new thread t/uni/bless.t See if Unicode bless works t/uni/cache.t See if Unicode swash caching works +t/uni/caller.t See if Unicode doesn't get mangled in caller() t/uni/case.pl See if Unicode casing works t/uni/chomp.t See if Unicode chomp works t/uni/chr.t See if Unicode chr works @@ -1869,7 +1869,7 @@ PP(pp_caller) register const PERL_CONTEXT *cx; const PERL_CONTEXT *dbcx; I32 gimme; - const char *stashname; + const HEK *stash_hek; I32 count = 0; bool has_arg = MAXARG && TOPs; @@ -1888,14 +1888,14 @@ PP(pp_caller) RETURN; } - stashname = CopSTASHPV(cx->blk_oldcop); + stash_hek = HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop)); if (GIMME != G_ARRAY) { EXTEND(SP, 1); - if (!stashname) + if (!stash_hek) PUSHs(&PL_sv_undef); else { dTARGET; - sv_setpv(TARG, stashname); + sv_sethek(TARG, stash_hek); PUSHs(TARG); } RETURN; @@ -1903,10 +1903,13 @@ PP(pp_caller) EXTEND(SP, 11); - if (!stashname) + if (!stash_hek) PUSHs(&PL_sv_undef); - else - mPUSHs(newSVpv(stashname, 0)); + else { + dTARGET; + sv_sethek(TARG, stash_hek); + PUSHTARG; + } mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); mPUSHi((I32)CopLINE(cx->blk_oldcop)); if (!has_arg) diff --git a/t/uni/caller.t b/t/uni/caller.t new file mode 100644 index 0000000000..b98ae07c4f --- /dev/null +++ b/t/uni/caller.t @@ -0,0 +1,71 @@ +#!./perl +# Tests for caller() + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; + plan( tests => 18 ); +} + +use utf8; +use open qw( :utf8 :std ); + +package ｍａｉｎ; + +{ + local $@; + eval 'ok(1);'; + ::like $@, qr/Undefined subroutine &ｍａｉｎ::ok called at/u; +} +my @c; + +sub { @c = caller(0) } -> (); +::is( $c[3], "ｍａｉｎ::__ANON__", "anonymous subroutine name" ); +::ok( $c[4], "hasargs true with anon sub" ); + +# Bug 20020517.003, used to dump core +sub ｆｏｏ { @c = caller(0) } +my $fooref = delete $ｍａｉｎ::{ｆｏｏ}; +$fooref -> (); +::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" ); +::ok( $c[4], "hasargs true with deleted sub" ); + +print "# Tests with caller(1)\n"; + +sub ｆ { @c = caller(1) } + +sub ｃａｌｌｆ { ｆ(); } +ｃａｌｌｆ(); +::is( $c[3], "ｍａｉｎ::ｃａｌｌｆ", "subroutine name" ); +::ok( $c[4], "hasargs true with ｃａｌｌｆ()" ); +&ｃａｌｌｆ; +::ok( !$c[4], "hasargs false with &ｃａｌｌｆ" ); + +eval { ｆ() }; +::is( $c[3], "(eval)", "subroutine name in an eval {}" ); +::ok( !$c[4], "hasargs false in an eval {}" ); + +eval q{ ｆ() }; +::is( $c[3], "(eval)", "subroutine name in an eval ''" ); +::ok( !$c[4], "hasargs false in an eval ''" ); + +sub { ｆ() } -> (); +::is( $c[3], "ｍａｉｎ::__ANON__", "anonymous subroutine name" ); +::ok( $c[4], "hasargs true with anon sub" ); + +sub ｆｏｏ2 { ｆ() } +my $fooref2 = delete $ｍａｉｎ::{ｆｏｏ2}; +$fooref2 -> (); +::is( $c[3], "ｍａｉｎ::__ANON__", "deleted subroutine name" ); +::ok( $c[4], "hasargs true with deleted sub" ); + +sub ｐｂ { return (caller(0))[3] } + +::is( eval 'ｐｂ()', 'ｍａｉｎ::ｐｂ', "actually return the right function name" ); + +my $saved_perldb = $^P; +$^P = 16; +$^P = $saved_perldb; + +::is( eval 'ｐｂ()', 'ｍａｉｎ::ｐｂ', 'actually return the right function name even if $^P had been on at some point' ); |