sv.c: Make most warnings utf8-clean

diff --git a/sv.c b/sv.c
index 3cfbe7c..069ef06 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6351,8 +6351,8 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
        if (check_refcnt && SvREFCNT(sv)) {
            if (PL_in_clean_objs)
                Perl_croak(aTHX_
-                   "DESTROY created new reference to dead object '%s'",
-                   HvNAME_get(stash));
+                   "DESTROY created new reference to dead object '%"SVf"'",
+                   SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))));
            /* DESTROY gave object new lease on life */
            return FALSE;
        }
@@ -8858,7 +8858,8 @@ Perl_sv_2io(pTHX_ SV *const sv)
            gv = MUTABLE_GV(sv);
            io = GvIO(gv);
            if (!io)
-               Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
+               Perl_croak(aTHX_ "Bad filehandle: %"SVf,
+                                    SVfARG(sv_2mortal(newSVhek(GvNAME_HEK(gv)))));
            break;
        }
        /* FALL THROUGH */
@@ -13824,7 +13825,7 @@ S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
            return NULL;
        av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE)));
        sv = *av_fetch(av, targ, FALSE);
-       sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv));
+       sv_setsv(name, sv);
     }
 
     if (subscript_type == FUV_SUBSCRIPT_HASH) {

diff --git a/t/io/open.t b/t/io/open.t
index dce0e23..8066391 100644 (file)
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -10,7 +10,7 @@ $|  = 1;
 use warnings;
 use Config;
 
-plan tests => 115;
+plan tests => 119;
 
 my $Perl = which_perl();
 
@@ -105,6 +105,15 @@ EOC
 ok( !eval { open my $f, '<&', $afile; 1; },    '<& on a non-filehandle' );
 like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
 
+ok( !eval { *some_glob = 1; open my $f, '<&', *some_glob; 1; },    '<& on a non-filehandle glob' );
+like( $@, qr/Bad filehandle:\s+some_glob/,          '       right error' );
+
+{
+    use utf8;
+    use open qw( :utf8 :std );
+    ok( !eval { use utf8; *ǡfilḛ = 1; open my $f, '<&', *ǡfilḛ; 1; },    '<& on a non-filehandle glob' );
+    like( $@, qr/Bad filehandle:\s+ǡfilḛ/u,          '       right error' );
+}
 
 # local $file tests
 {

diff --git a/t/op/method.t b/t/op/method.t
index 8ed3dcf..5a1c754 100644 (file)
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -13,7 +13,7 @@ BEGIN {
 use strict;
 no warnings 'once';
 
-plan(tests => 82);
+plan(tests => 83);
 
 @A::ISA = 'B';
 @B::ISA = 'C';
@@ -343,3 +343,13 @@ is $kalled, 1, 'calling a class method via a magic variable';
 
     like(NulTest->${ \"nul\0test" }, "nul\0test", "AUTOLOAD is nul-clean");
 }
+
+
+{
+    fresh_perl_is(
+    q! sub T::DESTROY { $x = $_[0]; } bless [], "T";!,
+    "DESTROY created new reference to dead object 'T' during global destruction.",
+    {},
+       "DESTROY creating a new reference to the object generates a warning."
+    );
+}

diff --git a/t/uni/method.t b/t/uni/method.t
index 5009a1c..7c458b8 100644 (file)
--- a/t/uni/method.t
+++ b/t/uni/method.t
@@ -15,7 +15,7 @@ use utf8;
 use open qw( :utf8 :std );
 no warnings 'once';
 
-plan(tests => 16);
+plan(tests => 25);
 
 #Can't use bless yet, as it might not be clean
 
@@ -40,3 +40,59 @@ ok $@, "Even if both stash and method are in UTF-8, lookup is nul-clean";
 
 eval { my $ref = \my $var; $ref->ｍｅｔｈｏｄ };
 like $@, qr/Can't call method "ｍｅｔｈｏｄ" on unblessed reference /u;
+
+{
+    use utf8;
+    use open qw( :utf8 :std );
+
+    my $e;
+    
+    eval '$e = bless {}, "Ｅ::Ａ"; Ｅ::Ａ->ｆｏｏ()';
+    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ａ" at/u);
+    eval '$e = bless {}, "Ｅ::Ｂ"; $e->ｆｏｏ()';  
+    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｂ" at/u);
+    eval 'Ｅ::Ｃ->ｆｏｏ()';
+    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｃ" (perhaps /u);
+    
+    eval 'UNIVERSAL->Ｅ::Ｄ::ｆｏｏ()';
+    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｄ" (perhaps /u);
+    eval 'my $e = bless {}, "UNIVERSAL"; $e->Ｅ::Ｅ::ｆｏｏ()';
+    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｅ" (perhaps /u);
+    
+    $e = bless {}, "Ｅ::Ｆ";  # force package to exist
+    eval 'UNIVERSAL->Ｅ::Ｆ::ｆｏｏ()';
+    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｆ" at/u);
+    eval '$e = bless {}, "UNIVERSAL"; $e->Ｅ::Ｆ::ｆｏｏ()';
+    like ($@, qr/^\QCan't locate object method "ｆｏｏ" via package "Ｅ::Ｆ" at/u);
+}
+
+is(do { use utf8; use open qw( :utf8 :std ); eval 'Ｆｏｏ->ｂｏｏｇｉｅ()';
+         $@ =~ /^\QCan't locate object method "ｂｏｏｇｉｅ" via package "Ｆｏｏ" (perhaps /u ? 1 : $@}, 1);
+
+#This reimplements a bit of _fresh_perl() from test.pl, as we want to decode
+#the output of that program before using it.
+SKIP: {
+    skip_if_miniperl('no dynamic loading on miniperl, no Encode');
+
+    my $prog = q!use utf8; use open qw( :utf8 :std ); sub Ｔ::DESTROY { $x = $_[0]; } bless [], "Ｔ";!;
+    utf8::decode($prog);
+
+    my $tmpfile = tempfile();
+    my $runperl_args = {};
+    $runperl_args->{progfile} = $tmpfile;
+    $runperl_args->{stderr} = 1;
+
+    open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!";
+
+    print TEST $prog;
+    close TEST or die "Cannot close $tmpfile: $!";
+
+    my $results = runperl(%$runperl_args);
+
+    require Encode;
+    $results = Encode::decode("UTF-8", $results);
+
+    like($results,
+            qr/DESTROY created new reference to dead object 'Ｔ' during global destruction./u,
+            "DESTROY creating a new reference to the object generates a warning in UTF-8.");
+}