pp_sys.c: Make warnings utf8-clean

diff --git a/pp_sys.c b/pp_sys.c
index 5240f8c..79d6787 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -592,8 +592,8 @@ PP(pp_open)
 
        if (IoDIRP(io))
            Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
 
        if (IoDIRP(io))
            Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),

-                            "Opening dirhandle %s also as a file",
-                            GvENAME(gv));
+                            "Opening dirhandle %"SVf" also as a file",
+                            SVfARG(sv_2mortal(newSVhek(GvENAME_HEK(gv)))));

 
        mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
        if (mg) {
 
        mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
        if (mg) {


@@ -1347,12 +1347,10 @@ PP(pp_enterwrite)
 
     cv = GvFORM(fgv);
     if (!cv) {
 
     cv = GvFORM(fgv);
     if (!cv) {

-       const char *name;

        tmpsv = sv_newmortal();
        gv_efullname4(tmpsv, fgv, NULL, FALSE);
        tmpsv = sv_newmortal();
        gv_efullname4(tmpsv, fgv, NULL, FALSE);

-       name = SvPV_nolen_const(tmpsv);
-       if (name && *name)
-           DIE(aTHX_ "Undefined format \"%s\" called", name);
+       if (SvPOK(tmpsv) && *SvPV_nolen_const(tmpsv))
+           DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));

 
        not_a_format_reference:
        DIE(aTHX_ "Not a format reference");
 
        not_a_format_reference:
        DIE(aTHX_ "Not a format reference");


@@ -1391,7 +1389,8 @@ PP(pp_leavewrite)
                SV *topname;
                if (!IoFMT_NAME(io))
                    IoFMT_NAME(io) = savepv(GvNAME(gv));
                SV *topname;
                if (!IoFMT_NAME(io))
                    IoFMT_NAME(io) = savepv(GvNAME(gv));

-               topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
+               topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"_TOP",
+                                        SVfARG(sv_2mortal(newSVhek(GvNAME_HEK(gv))))));

                topgv = gv_fetchsv(topname, 0, SVt_PVFM);
                if ((topgv && GvFORM(topgv)) ||
                  !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
                topgv = gv_fetchsv(topname, 0, SVt_PVFM);
                if ((topgv && GvFORM(topgv)) ||
                  !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))


@@ -1438,11 +1437,9 @@ PP(pp_leavewrite)
        cv = GvFORM(fgv);
        if (!cv) {
            SV * const sv = sv_newmortal();
        cv = GvFORM(fgv);
        if (!cv) {
            SV * const sv = sv_newmortal();

-           const char *name;

            gv_efullname4(sv, fgv, NULL, FALSE);
            gv_efullname4(sv, fgv, NULL, FALSE);

-           name = SvPV_nolen_const(sv);
-           if (name && *name)
-               DIE(aTHX_ "Undefined top format \"%s\" called", name);
+           if (SvPOK(sv) && *SvPV_nolen_const(sv))
+               DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));

            else
                DIE(aTHX_ "Undefined top format called");
        }
            else
                DIE(aTHX_ "Undefined top format called");
        }


@@ -2746,7 +2743,9 @@ PP(pp_stat)
            if (gv != PL_defgv) {
            do_fstat_warning_check:
                Perl_ck_warner(aTHX_ packWARN(WARN_IO),
            if (gv != PL_defgv) {
            do_fstat_warning_check:
                Perl_ck_warner(aTHX_ packWARN(WARN_IO),

-                              "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
+                              "lstat() on filehandle %"SVf, SVfARG(gv
+                                        ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
+                                        : &PL_sv_no));

            } else if (PL_laststype != OP_LSTAT)
                /* diag_listed_as: The stat preceding %s wasn't an lstat */
                Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
            } else if (PL_laststype != OP_LSTAT)
                /* diag_listed_as: The stat preceding %s wasn't an lstat */
                Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");


@@ -3787,8 +3786,8 @@ PP(pp_open_dir)
 
     if ((IoIFP(io) || IoOFP(io)))
        Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
 
     if ((IoIFP(io) || IoOFP(io)))
        Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),

-                        "Opening filehandle %s also as a directory",
-                        GvENAME(gv));
+                        "Opening filehandle %"SVf" also as a directory",
+                            SVfARG(sv_2mortal(newSVhek(GvENAME_HEK(gv)))) );

     if (IoDIRP(io))
        PerlDir_close(IoDIRP(io));
     if (!(IoDIRP(io) = PerlDir_open(dirname)))
     if (IoDIRP(io))
        PerlDir_close(IoDIRP(io));
     if (!(IoDIRP(io) = PerlDir_open(dirname)))


@@ -3823,7 +3822,8 @@ PP(pp_readdir)
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),

-                      "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
+                      "readdir() attempted on invalid dirhandle %"SVf,
+                            SVfARG(sv_2mortal(newSVhek(GvENAME_HEK(gv)))));

         goto nope;
     }
 
         goto nope;
     }
 


@@ -3874,7 +3874,8 @@ PP(pp_telldir)
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),

-                      "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
+                      "telldir() attempted on invalid dirhandle %"SVf,
+                            SVfARG(sv_2mortal(newSVhek(GvENAME_HEK(gv)))));

         goto nope;
     }
 
         goto nope;
     }
 


@@ -3899,7 +3900,8 @@ PP(pp_seekdir)
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),

-                      "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
+                      "seekdir() attempted on invalid dirhandle %"SVf,
+                                SVfARG(sv_2mortal(newSVhek(GvENAME_HEK(gv)))));

         goto nope;
     }
     (void)PerlDir_seek(IoDIRP(io), along);
         goto nope;
     }
     (void)PerlDir_seek(IoDIRP(io), along);


@@ -3923,7 +3925,8 @@ PP(pp_rewinddir)
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),

-                      "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
+                      "rewinddir() attempted on invalid dirhandle %"SVf,
+                                SVfARG(sv_2mortal(newSVhek(GvENAME_HEK(gv)))));

        goto nope;
     }
     (void)PerlDir_rewind(IoDIRP(io));
        goto nope;
     }
     (void)PerlDir_rewind(IoDIRP(io));


@@ -3946,7 +3949,8 @@ PP(pp_closedir)
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),
 
     if (!io || !IoDIRP(io)) {
        Perl_ck_warner(aTHX_ packWARN(WARN_IO),

-                      "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
+                      "closedir() attempted on invalid dirhandle %"SVf,
+                                SVfARG(sv_2mortal(newSVhek(GvENAME_HEK(gv)))));

         goto nope;
     }
 #ifdef VOID_CLOSEDIR
         goto nope;
     }
 #ifdef VOID_CLOSEDIR

diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
index 51248ad..225d9ec 100644 (file)
--- a/t/lib/warnings/pp_sys
+++ b/t/lib/warnings/pp_sys
@@ -659,6 +659,24 @@ lstat() on filehandle FH at - line 5.
 lstat() on filehandle FH at - line 6.
 lstat() on filehandle $fh at - line 8.
 ########
 lstat() on filehandle FH at - line 6.
 lstat() on filehandle $fh at - line 8.
 ########

+# TODO ? 1 ? "Scalar filehandles not yet UTF-8 clean" : ''
+# pp_sys.c [pp_lstat]
+use warnings 'io';
+use utf8;
+use open qw( :utf8 :std );
+open ᶠḨ, "../harness" or die "# $!";
+lstat ᶠḨ;
+open my $ｆᚺ, $0 or die "# $!";
+lstat $ｆᚺ;
+no warnings 'io';
+lstat ᶠḨ;
+lstat $ｆᚺ;
+close ᶠḨ;
+close $ｆᚺ;
+EXPECT
+lstat() on filehandle ᶠḨ at - line 6.
+lstat() on filehandle $ｆᚺ at - line 8.
+########

 # pp_sys.c [pp_getc]
 use warnings qw(unopened closed) ;
 getc FOO;
 # pp_sys.c [pp_getc]
 use warnings qw(unopened closed) ;
 getc FOO;


@@ -732,6 +750,22 @@ EXPECT
 Opening dirhandle FOO also as a file at - line 5.
 Opening dirhandle $foo also as a file at - line 6.
 ########
 Opening dirhandle FOO also as a file at - line 5.
 Opening dirhandle $foo also as a file at - line 6.
 ########

+# TODO ? 1 ? "Scalar filehandles not yet UTF-8 clean" : ''
+# pp_sys.c [pp_open]
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+open ＦＯＯ, "../harness";
+open $ｆｏｏ, "../harness";
+no warnings qw(io deprecated);
+open ＦＯＯ, "../harness";
+open $ｆｏｏ, "../harness";
+EXPECT
+Opening dirhandle ＦＯＯ also as a file at - line 7.
+Opening dirhandle $ｆｏｏ also as a file at - line 8.
+########

 # pp_sys.c [pp_open_dir]
 use warnings;
 open FOO, "../harness";
 # pp_sys.c [pp_open_dir]
 use warnings;
 open FOO, "../harness";


@@ -744,3 +778,87 @@ opendir $foo, ".";
 EXPECT
 Opening filehandle FOO also as a directory at - line 5.
 Opening filehandle $foo also as a directory at - line 6.
 EXPECT
 Opening filehandle FOO also as a directory at - line 5.
 Opening filehandle $foo also as a directory at - line 6.

+########
+# TODO ? 1 ? "Scalar filehandles not yet UTF-8 clean" : ''
+# pp_sys.c [pp_open_dir]
+use utf8;
+use open qw( :utf8 :std );
+use warnings;
+use warnings;
+open ＦＯＯ, "../harness";
+open $ｆｏｏ, "../harness";
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+no warnings qw(io deprecated);
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+EXPECT
+Opening filehandle ＦＯＯ also as a directory at - line 7.
+Opening filehandle $ｆｏｏ also as a directory at - line 8.
+########
+# pp_sys.c [pp_*dir]
+use warnings 'io';
+opendir FOO, ".";
+opendir $foo, ".";
+closedir FOO;
+closedir $foo;
+
+readdir(FOO);
+telldir(FOO);
+seekdir(FOO, 0);
+rewinddir(FOO);
+closedir(FOO);
+
+readdir($foo);
+telldir($foo);
+seekdir($foo, 0);
+rewinddir($foo);
+closedir($foo);
+
+EXPECT
+readdir() attempted on invalid dirhandle FOO at - line 8.
+telldir() attempted on invalid dirhandle FOO at - line 9.
+seekdir() attempted on invalid dirhandle FOO at - line 10.
+rewinddir() attempted on invalid dirhandle FOO at - line 11.
+closedir() attempted on invalid dirhandle FOO at - line 12.
+readdir() attempted on invalid dirhandle $foo at - line 14.
+telldir() attempted on invalid dirhandle $foo at - line 15.
+seekdir() attempted on invalid dirhandle $foo at - line 16.
+rewinddir() attempted on invalid dirhandle $foo at - line 17.
+closedir() attempted on invalid dirhandle $foo at - line 18.
+########
+# TODO ? 1 ? "Scalar filehandles not yet UTF-8 clean" : ''
+# pp_sys.c [pp_*dir]
+use utf8;
+use open qw( :utf8 :std );
+use warnings 'io';
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+opendir ＦＯＯ, ".";
+opendir $ｆｏｏ, ".";
+closedir ＦＯＯ;
+closedir $ｆｏｏ;
+
+readdir(ＦＯＯ);
+telldir(ＦＯＯ);
+seekdir(ＦＯＯ, 0);
+rewinddir(ＦＯＯ);
+closedir(ＦＯＯ);
+
+readdir($ｆｏｏ);
+telldir($ｆｏｏ);
+seekdir($ｆｏｏ, 0);
+rewinddir($ｆｏｏ);
+closedir($ｆｏｏ);
+
+EXPECT
+readdir() attempted on invalid dirhandle ＦＯＯ at - line 12.
+telldir() attempted on invalid dirhandle ＦＯＯ at - line 13.
+seekdir() attempted on invalid dirhandle ＦＯＯ at - line 14.
+rewinddir() attempted on invalid dirhandle ＦＯＯ at - line 15.
+closedir() attempted on invalid dirhandle ＦＯＯ at - line 16.
+readdir() attempted on invalid dirhandle $ｆｏｏ at - line 18.
+telldir() attempted on invalid dirhandle $ｆｏｏ at - line 19.
+seekdir() attempted on invalid dirhandle $ｆｏｏ at - line 20.
+rewinddir() attempted on invalid dirhandle $ｆｏｏ at - line 21.
+closedir() attempted on invalid dirhandle $ｆｏｏ at - line 22.

diff --git a/t/uni/write.t b/t/uni/write.t
index c60065d..bfc1ddb 100644 (file)
--- a/t/uni/write.t
+++ b/t/uni/write.t
@@ -7,7 +7,7 @@ BEGIN {
     skip_all_without_perlio();
 }
 
     skip_all_without_perlio();
 }
 

-plan tests => 6;
+plan tests => 8;

 
 # Some tests for UTF8 and format/write
 
 
 # Some tests for UTF8 and format/write
 


@@ -93,4 +93,31 @@ $ulite1
 $bmulti$blite2
 EOEXPECT
 
 $bmulti$blite2
 EOEXPECT
 

-unlink_all 'Uni_write.tmp';
+{
+    use utf8;
+    use open qw( :utf8 :std );
+
+    local $~ = "놋웇ʱＦᚖṀŦ";
+    eval { write };
+    like $@, qr/Undefined format "놋웇ʱＦᚖṀŦ/u, 'no such format, with format name in UTF-8.';
+}
+
+{
+
+format OUT =
+
+
+.
+    use utf8;
+    use open qw( :utf8 :std );
+    open OUT, '>', 'Uni_write2.tmp';
+
+    my $oldfh = select OUT;
+    local $^ = "უデfiᕣネḓ_ＦᚖṀŦɐȾ";#"UNDEFINED_FORMAT";
+    eval { write };
+    like $@, qr/Undefined top format "უデfiᕣネḓ_ＦᚖṀŦɐȾ/u, 'no such top format';
+    select $oldfh;
+    close OUT;
+}
+
+unlink_all qw( Uni_write.tmp Uni_write2.tmp );