This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #77810] Scalars vs globs
authorFather Chrysostomos <sprout@cpan.org>
Sun, 24 Oct 2010 22:50:23 +0000 (15:50 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 24 Oct 2010 23:18:40 +0000 (16:18 -0700)
Stop *{} from returning globs with the SVf_FAKE flag on.

It removes three tests from t/op/gv.t (that I added) that test buggy
edge cases that can no longer occur.

It also modifies tests in t/io/defout.t to keep them passing. I am not
sure that test script serves any purpose any more.

op.c
pp.c
t/io/defout.t
t/op/gv.t

diff --git a/op.c b/op.c
index 469d48d..f616761 100644 (file)
--- a/op.c
+++ b/op.c
@@ -7290,6 +7290,8 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 #endif
            kid->op_private = 0;
            kid->op_ppaddr = PL_ppaddr[OP_GV];
+           /* FAKE globs in the symbol table cause weird bugs (#77810) */
+           SvFAKE_off(gv);
        }
     }
     return o;
diff --git a/pp.c b/pp.c
index b777f39..d05425c 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -213,11 +213,19 @@ PP(pp_rv2gv)
                }
                sv = MUTABLE_SV(gv_fetchsv(sv, GV_ADD, SVt_PVGV));
            }
+           /* FAKE globs in the symbol table cause weird bugs (#77810) */
+           if (sv) SvFAKE_off(sv);
        }
     }
     if (PL_op->op_private & OPpLVAL_INTRO)
        save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
-    SETs(sv);
+    if (sv && SvFAKE(sv)) {
+       SV *newsv = sv_newmortal();
+       sv_setsv(newsv, sv);
+       SvFAKE_off(newsv);
+       SETs(newsv);
+    }
+    else SETs(sv);
     RETURN;
 }
 
index d99b39b..dda3b4c 100644 (file)
@@ -18,12 +18,13 @@ plan tests => 16;
 my $stderr = *STDERR;
 select($stderr);
 $stderr = 1; # whoops, PL_defoutgv no longer a GV!
+# XXX It is a GV as of 5.13.7. Is this test file needed any more?
 
 # note that in the tests below, the return values aren't as important
 # as the fact that they don't crash
 
-ok !print(""), 'print';
-ok !select(), 'select';
+ok print(""), 'print';
+ok select(), 'select';
 $a = 'fooo';
 format STDERR =
 #@<<
@@ -31,11 +32,11 @@ $a;
 .
 ok ! write(), 'write';
 
-is($^, "",     '$^');
-is($~, "",     '$~');
-is($=, undef,  '$=');
-is($-, undef,  '$-');
-is($%, undef,  '$%');
+ok($^, '$^');
+ok($~, '$~');
+ok($=, '$=');
+ok($-, '$-');
+is($%, 0,      '$%');
 is($|, 0,      '$|');
 $^ = 1; pass '$^ = 1';
 $~ = 1; pass '$~ = 1';
@@ -43,5 +44,5 @@ $= = 1; pass '$= = 1';
 $- = 1; pass '$- = 1';
 $% = 1; pass '$% = 1';
 $| = 1; pass '$| = 1';
-ok !close(), 'close';
+ok close(), 'close';
 
index 32afdff..f2642f9 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 
 use warnings;
 
-plan( tests => 219 );
+plan( tests => 221 );
 
 # type coersion on assignment
 $foo = 'foo';
@@ -32,6 +32,34 @@ is(ref(\$foo), 'GLOB');
 is($foo, '*main::bar');
 is(ref(\$foo), 'GLOB');
 
+{
+ no warnings;
+ ${\*$foo} = undef;
+ is(ref(\$foo), 'GLOB', 'no type coersion when assigning to *{} retval');
+ $::{phake} = *bar;
+ is(
+   \$::{phake}, \*{"phake"},
+   'symbolic *{} returns symtab entry when FAKE'
+ );
+ ${\*{"phake"}} = undef;
+ is(
+   ref(\$::{phake}), 'GLOB',
+  'no type coersion when assigning to retval of symbolic *{}'
+ );
+ $::{phaque} = *bar;
+ eval '
+   is(
+     \$::{phaque}, \*phaque,
+     "compile-time *{} returns symtab entry when FAKE"
+   );
+   ${\*phaque} = undef;
+ ';
+ is(
+   ref(\$::{phaque}), 'GLOB',
+  'no type coersion when assigning to retval of compile-time *{}'
+ );
+}
+
 # type coersion on substitutions that match
 $a = *main::foo;
 $b = $a;
@@ -683,21 +711,13 @@ EOF
     'PVLV: assigning undef to the glob warns';
   }
 
-  # Neither should number assignment...
-  *$_ = 1;
-  is $_, "*main::1", "PVLV: integer-to-glob assignment assigns a glob";
-  *$_ = 2.0;
-  is $_, "*main::2", "PVLV: float-to-glob assignment assigns a glob";
-
-  # Nor reference assignment.
-  *$_ = \*thit;
-  is $_, "*main::thit", "PVLV: globref-to-glob assignment assigns a glob";
+  # Neither should reference assignment.
   *$_ = [];
-  is $_, "*main::thit", "PVLV: arrayref assignment assigns to the AV slot";
+  is $_, "*main::hon", "PVLV: arrayref assignment assigns to the AV slot";
 
   # Concatenation should still work.
   ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@;
-  is $_, '*main::thitthlew', 'PVLV concatenation works';
+  is $_, '*main::honthlew', 'PVLV concatenation works';
 
   # And we should be able to overwrite it with a string, number, or refer-
   # ence, too, if we omit the *.