This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
-l $handle warning: globs, iorefs, utf8
authorFather Chrysostomos <sprout@cpan.org>
Wed, 5 Jun 2013 01:32:46 +0000 (18:32 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Wed, 5 Jun 2013 03:16:04 +0000 (20:16 -0700)
The warning restored in commit cd22fad3cbcea only applied to globrefs,
not to globs or iorefs.  The warning message was also not utf8-clean.
This commit fixes both.

This resolves ticket #117595.

doio.c
pod/perldiag.pod
t/op/filetest.t

diff --git a/doio.c b/doio.c
index aa87c81..b24a5b4 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1337,6 +1337,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
     dSP;
     const char *file;
     SV* const sv = TOPs;
+    bool isio = FALSE;
     if (PL_op->op_flags & OPf_REF) {
        if (cGVOP_gv == PL_defgv) {
            if (PL_laststype != OP_LSTAT)
@@ -1345,6 +1346,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
        }
        PL_laststatval = -1;
        if (ckWARN(WARN_IO)) {
+           /* diag_listed_as: Use of -l on filehandle%s */
            Perl_warner(aTHX_ packWARN(WARN_IO),
                             "Use of -l on filehandle %"HEKf,
                              HEKfARG(GvENAME_HEK(cGVOP_gv)));
@@ -1360,9 +1362,22 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
 
     PL_laststype = OP_LSTAT;
     PL_statgv = NULL;
-    if (SvROK(sv) && isGV_with_GP(SvRV(sv)) && ckWARN(WARN_IO)) {
-        Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %s",
-           GvENAME((const GV *)SvRV(sv)));
+    if ( (  (SvROK(sv) && (  isGV_with_GP(SvRV(sv))
+                          || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO)  )
+            )
+         || isGV_with_GP(sv)
+         )
+      && ckWARN(WARN_IO)) {
+        if (isio)
+           /* diag_listed_as: Use of -l on filehandle%s */
+            Perl_warner(aTHX_ packWARN(WARN_IO),
+                             "Use of -l on filehandle");
+        else
+           /* diag_listed_as: Use of -l on filehandle%s */
+            Perl_warner(aTHX_ packWARN(WARN_IO),
+                             "Use of -l on filehandle %"HEKf,
+                              GvENAME_HEK((const GV *)
+                                          (SvROK(sv) ? SvRV(sv) : sv)));
     }
     file = SvPV_flags_const_nolen(sv, flags);
     sv_setpv(PL_statname,file);
index da1933a..ecb4191 100644 (file)
@@ -5953,7 +5953,7 @@ only C.  This usually means there's a better way to do it in Perl.
 generally because there's a better way to do it, and also because the
 old way has bad side effects.
 
-=item Use of -l on filehandle %s
+=item Use of -l on filehandle%s
 
 (W io) A filehandle represents an opened file, and when you opened the file
 it already went past any symlink you are presumably trying to look for.
index 8878400..3ee50f1 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan(tests => 50 + 27*14);
+plan(tests => 53 + 27*14);
 
 # Tests presume we are in t/op directory and that file 'TEST' is found
 # therein.
@@ -117,6 +117,23 @@ SKIP: {
  ok($warnings[0] =~ /-l on filehandle foo/, 'warning for -l $handle');
  unlink \*foo;
 }
+# More -l $handle warning tests
+{
+ local $^W = 1;
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, @_ };
+ () = -l \*{"\x{3c6}oo"};
+ like($warnings[0], qr/-l on filehandle \x{3c6}oo/,
+  '-l $handle warning is utf8-clean');
+ () = -l *foo;
+ like($warnings[1], qr/-l on filehandle foo/,
+  '-l $handle warning occurs for globs, not just globrefs');
+ tell foo; # vivify the IO slot
+ () = -l *foo{IO};
+    # (element [3] because tell also warns)
+ like($warnings[3], qr/-l on filehandle at/,
+  '-l $handle warning occurs for iorefs as well');
+} 
 
 # test that _ is a bareword after filetest operators