Make sselect call fetch once

Not only does this commit make four-argument select call fetch once
on each argument (instead of sometimes 0 times), but it also checks
whether the argument is a string after calling fetch now, instead of
before, in determining whether to warn about a non-string.

diff --git a/pp_sys.c b/pp_sys.c
index 958a133..cc8b099 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1066,6 +1066,7 @@ PP(pp_sselect)
     SP -= 4;
     for (i = 1; i <= 3; i++) {
        SV * const sv = SP[i];
+       SvGETMAGIC(sv);
        if (!SvOK(sv))
            continue;
        if (SvREADONLY(sv)) {
@@ -1075,8 +1076,10 @@ PP(pp_sselect)
                Perl_croak_no_modify(aTHX);
        }
        if (!SvPOK(sv)) {
-           Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
-           SvPV_force_nolen(sv);       /* force string conversion */
+           if (!SvPOKp(sv))
+               Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+                                   "Non-string passed as bitmask");
+           SvPV_force_nomg_nolen(sv);  /* force string conversion */
        }
        j = SvCUR(sv);
        if (maxlen < j)

diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
index 6975627..3df894c 100644 (file)
--- a/t/lib/warnings/pp_sys
+++ b/t/lib/warnings/pp_sys
@@ -703,6 +703,9 @@ getc() on closed filehandle FH2 at - line 12.
 use warnings 'misc';
 $x = 1;
 select $x, undef, undef, 1;
+sub TIESCALAR{bless[]} sub FETCH {"hello"} sub STORE{}
+tie $y, "";
+select $y, undef, undef, 1;
 no warnings 'misc';
 select $x, undef, undef, 1;
 EXPECT

diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t
index 81cbe19..3198105 100644 (file)
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -7,7 +7,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 292);
+    plan (tests => 295);
 }
 
 use strict;
@@ -225,6 +225,19 @@ for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'],
     check_count "$op $args\\\$tied_glob$postargs";
 }
 
+{
+    no warnings;
+    $var = *foo;
+    $dummy  =  select $var, undef, undef, 0
+                            ; check_count 'select $tied_glob, ...';
+    $var = \1;
+    $dummy  =  select $var, undef, undef, 0
+                            ; check_count 'select $tied_ref, ...';
+    $var = undef;
+    $dummy  =  select $var, undef, undef, 0
+                            ; check_count 'select $tied_undef, ...';
+}
+
 ###############################################
 #        Tests for  $foo binop $foo           #
 ###############################################