In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/2acc3314e31a9342e325f35c5b592967c9850c9b?hp=e1be28b42dd83015ebd81dbeda258cc72f8dddf0>
- Log -----------------------------------------------------------------
commit 2acc3314e31a9342e325f35c5b592967c9850c9b
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Oct 24 15:50:23 2010 -0700
[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.
-----------------------------------------------------------------------
Summary of changes:
op.c | 2 ++
pp.c | 10 +++++++++-
t/io/defout.t | 17 +++++++++--------
t/op/gv.t | 44 ++++++++++++++++++++++++++++++++------------
4 files changed, 52 insertions(+), 21 deletions(-)
diff --git a/op.c b/op.c
index 469d48d..f616761 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 b777f39..d05425c 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 d99b39b..dda3b4c 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 32afdff..f2642f9 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 *.
--
Perl5 Master Repository
