[perl #77810] Scalars vs globs

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.

4 files changed, 52 insertions, 21 deletions

diff --git a/op.c b/op.c
index 469d48d0bd..f616761818 100644
--- 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 b777f39509..d05425c091 100644
--- 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;
 }
 
diff --git a/t/io/defout.t b/t/io/defout.t
index d99b39bd6c..dda3b4c997 100644
--- a/t/io/defout.t
+++ b/t/io/defout.t
@@ -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';
 
diff --git a/t/op/gv.t b/t/op/gv.t
index 32afdff69b..f2642f99cf 100644
--- 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 *.