From: Brian Fraser Date: Thu, 29 Sep 2011 21:39:35 +0000 (-0700) Subject: pp_sys.c: Make warnings utf8-clean X-Git-Tag: v5.15.4~132^2~41 X-Git-Url: https://perl5.git.perl.org/perl5.git/commitdiff_plain/bf29d05f84d1479fc85ca7522e262bebcb354e97?hp=b375e37b5f034d8442f5744864dedf6bca9b8bea pp_sys.c: Make warnings utf8-clean --- diff --git a/pp_sys.c b/pp_sys.c index 5240f8c..79d6787 100644 --- 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), - "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) { @@ -1347,12 +1347,10 @@ PP(pp_enterwrite) cv = GvFORM(fgv); if (!cv) { - const char *name; 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"); @@ -1391,7 +1389,8 @@ PP(pp_leavewrite) 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)) @@ -1438,11 +1437,9 @@ PP(pp_leavewrite) cv = GvFORM(fgv); if (!cv) { SV * const sv = sv_newmortal(); - const char *name; 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"); } @@ -2746,7 +2743,9 @@ PP(pp_stat) 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"); @@ -3787,8 +3786,8 @@ PP(pp_open_dir) 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))) @@ -3823,7 +3822,8 @@ PP(pp_readdir) 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; } @@ -3874,7 +3874,8 @@ PP(pp_telldir) 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; } @@ -3899,7 +3900,8 @@ PP(pp_seekdir) 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); @@ -3923,7 +3925,8 @@ PP(pp_rewinddir) 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)); @@ -3946,7 +3949,8 @@ PP(pp_closedir) 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 diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys index 51248ad..225d9ec 100644 --- 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. ######## +# 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; @@ -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. ######## +# 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"; @@ -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. +######## +# 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 --- a/t/uni/write.t +++ b/t/uni/write.t @@ -7,7 +7,7 @@ BEGIN { skip_all_without_perlio(); } -plan tests => 6; +plan tests => 8; # Some tests for UTF8 and format/write @@ -93,4 +93,31 @@ $ulite1 $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 );