pp_ctl.c: pp_caller UTF8 cleanup.

diff --git a/MANIFEST b/MANIFEST
index 81cfeee..b7258eb 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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

diff --git a/pp_ctl.c b/pp_ctl.c
index 0364723..2d8c4f2 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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 (file)
index 0000000..b98ae07
--- /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' );