In perl.git, the branch blead has been updated
<https://perl5.git.perl.org/perl.git/commitdiff/db9848c8d3fb321d27f38c1bd7992005a77ccfbc?hp=ed55dc190542e7407287d08246600d9232656f01>
- Log -----------------------------------------------------------------
commit db9848c8d3fb321d27f38c1bd7992005a77ccfbc
Author: Zefram <zef...@fysh.org>
Date: Sun Dec 10 01:34:04 2017 +0000
stop gensyming when vivifying IO handles
When open() is given as a handle a scalar with undef value, the rv2gv
op creates a new glob for the I/O handle, and mutates the scalar to
contain an RV referencing the glob. This is documented behaviour.
The question arises of what GvNAME the glob should have. There's some
compile-time logic that spots that this might happen, and if the handle
expression is simple enough it stores in the pad a name representing
that expression, and rv2gv uses that for the GvNAME. But if no name
was supplied by that route then rv2gv was using newGVgen() to generate
the glob. That succeeds in giving it some kind of name, but has the
unwanted side effect of interning the glob in the stash under that name.
From the user's point of view, that creates a phantom reference to the
glob, which means that killing the RV doesn't remove the last reference
to the glob and so doesn't close the handle.
Instead of gensyming, just create an uninterned glob and give it a
fixed GvNAME. Fixes [perl #115814].
-----------------------------------------------------------------------
Summary of changes:
pp.c | 12 +++++-------
t/io/open.t | 29 ++++++++++++++++++++++++++---
t/op/coreamp.t | 2 +-
3 files changed, 32 insertions(+), 11 deletions(-)
diff --git a/pp.c b/pp.c
index 130019f056..3ef23cae59 100644
--- a/pp.c
+++ b/pp.c
@@ -129,20 +129,18 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool
strict,
*/
if (vivify_sv && sv != &PL_sv_undef) {
GV *gv;
+ HV *stash;
if (SvREADONLY(sv))
Perl_croak_no_modify();
+ gv = MUTABLE_GV(newSV(0));
+ stash = CopSTASH(PL_curcop);
+ if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
if (cUNOP->op_targ) {
SV * const namesv = PAD_SV(cUNOP->op_targ);
- HV *stash = CopSTASH(PL_curcop);
- if (SvTYPE(stash) != SVt_PVHV) stash = NULL;
- gv = MUTABLE_GV(newSV(0));
gv_init_sv(gv, stash, namesv, 0);
}
else {
- const char * const name = CopSTASHPV(PL_curcop);
- gv = newGVgen_flags(name,
- HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0
);
- SvREFCNT_inc_simple_void_NN(gv);
+ gv_init_pv(gv, stash, "__ANONIO__", 0);
}
prepare_SV_for_RV(sv);
SvRV_set(sv, MUTABLE_SV(gv));
diff --git a/t/io/open.t b/t/io/open.t
index 6be9f0e842..2671c1a040 100644
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -10,7 +10,7 @@ $| = 1;
use warnings;
use Config;
-plan tests => 156;
+plan tests => 161;
my $Perl = which_perl();
@@ -485,5 +485,28 @@ pass("no crash when open autovivifies glob in freed
package");
unlink "$fh";
}
-package OverloadTest;
-use overload '""' => sub { ${$_[0]} };
+{
+ package OverloadTest;
+ use overload '""' => sub { ${$_[0]} };
+}
+
+# [perl #115814] open(${\$x}, ...) creates spurious reference to handle in
stash
+SKIP: {
+ # The bug doesn't depend on perlio, but perlio provides this nice
+ # way of discerning when a handle actually closes.
+ skip("These tests use perlio", 5) unless $Config{useperlio};
+ my($a, $b, $s, $t);
+ $s = "";
+ open($a, ">:scalar:perlio", \$s) or die;
+ print {$a} "abc";
+ is $s, "", "buffering delays writing to scalar (simple open)";
+ $a = undef;
+ is $s, "abc", "buffered write happens on dropping handle ref (simple
open)";
+ $t = "";
+ open(${\$b}, ">:scalar:perlio", \$t) or die;
+ print {$b} "xyz";
+ is $t, "", "buffering delays writing to scalar (complex open)";
+ $b = undef;
+ is $t, "xyz", "buffered write happens on dropping handle ref (complex
open)";
+ is scalar(grep { /\A_GEN_/ } keys %::), 0, "no gensym appeared in stash";
+}
diff --git a/t/op/coreamp.t b/t/op/coreamp.t
index 277ac1094a..7231d66e81 100644
--- a/t/op/coreamp.t
+++ b/t/op/coreamp.t
@@ -881,7 +881,7 @@ is &myselect, select, '&select with no args';
my $prev = select;
is &myselect(my $fh), $prev, '&select($arg) retval';
is lc ref $fh, 'glob', '&select autovivifies';
- is select=~s/\*//rug, (*$fh."")=~s/\*//rug, '&select selects';
+ is select, $fh, '&select selects';
select $prev;
}
eval { &myselect(1,2) };
--
Perl5 Master Repository
