From 8dc99089b7dd2506e907c4344ed28a3206866f37 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sat, 17 Dec 2011 23:01:07 -0800 Subject: [PATCH] Stop tell($glob_copy) from clearing PL_last_in_gv MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit This bug is a side effect of rv2gv’s starting to return an incoercible mortal copy of a coercible glob in 5.14: $ perl5.12.4 -le 'open FH, "t/test.pl"; $fh=*FH; tell $fh; print tell' 0 $ perl5.14.0 -le 'open FH, "t/test.pl"; $fh=*FH; tell $fh; print tell' -1 In the first case, tell without arguments is returning the position of the filehandle. In the second case, tell with an explicit argument that happens to be a coercible glob (tell has an implicit rv2gv, so tell $fh is actu- ally tell *$fh) sets PL_last_in_gv to a mortal copy thereof, which is freed at the end of the statement, setting PL_last_in_gv to null. So there is no ‘last used’ handle by the time we get to the tell without arguments. This commit adds a new rv2gv flag that tells it not to copy the glob. By doing it unconditionally on the kidop, this allows tell(*$fh) to work the same way. Let’s hope nobody does tell(*{*$fh}), which will unset PL_last_in_gv because the inner * returns a mortal copy. This whole area is really icky. PL_last_in_gv should be refcounted, but that would cause handles to leak out of scope, breaking programs that rely on the auto-closing ‘feature’. --- embed.h | 1 + ext/B/B/Concise.pm | 2 +- op.c | 11 +++++++++++ op.h | 6 ++++-- opcode.h | 2 +- pp.c | 2 +- proto.h | 6 ++++++ regen/opcodes | 2 +- t/io/tell.t | 11 ++++++++++- 9 files changed, 36 insertions(+), 7 deletions(-) diff --git a/embed.h b/embed.h index 8c9257d..86ffcd4 100644 --- a/embed.h +++ b/embed.h @@ -1028,6 +1028,7 @@ #define ck_subr(a) Perl_ck_subr(aTHX_ a) #define ck_substr(a) Perl_ck_substr(aTHX_ a) #define ck_svconst(a) Perl_ck_svconst(aTHX_ a) +#define ck_tell(a) Perl_ck_tell(aTHX_ a) #define ck_trunc(a) Perl_ck_trunc(aTHX_ a) #define convert(a,b,c) Perl_convert(aTHX_ a,b,c) #define core_prototype(a,b,c,d) Perl_core_prototype(aTHX_ a,b,c,d) diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index cc2c87d..f3b517a 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -612,7 +612,7 @@ $priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv)); @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") for (qw(rv2gv rv2sv padsv aelem helem)); $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv"); -$priv{rv2gv}{4} = "NOINIT"; +@{$priv{rv2gv}}{4,16} = qw "NOINIT FAKE"; @{$priv{"entersub"}}{1,4,16,32,64} = qw( INARGS TARG DBG DEREF ); @{$priv{rv2cv}}{1,8,128} = ("CONST","AMPER","NO()"); $priv{"gv"}{32} = "EARLYCV"; diff --git a/op.c b/op.c index ea6c89a..cfdf618 100644 --- a/op.c +++ b/op.c @@ -9687,6 +9687,17 @@ Perl_ck_substr(pTHX_ OP *o) } OP * +Perl_ck_tell(pTHX_ OP *o) +{ + OP *kid; + PERL_ARGS_ASSERT_CK_TELL; + o = ck_fun(o); + kid = cLISTOPo->op_first; + if (kid && kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE; + return o; +} + +OP * Perl_ck_each(pTHX_ OP *o) { dVAR; diff --git a/op.h b/op.h index 0758f9c..ffa9a3f 100644 --- a/op.h +++ b/op.h @@ -225,7 +225,7 @@ Deprecated. Use C instead. #define OPpEARLY_CV 32 /* foo() called before sub foo was parsed */ /* OP_?ELEM only */ #define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */ - /* OP_RV2?V, OP_GVSV, OP_ENTERITER only */ + /* OP_RV2[SAH]V, OP_GVSV, OP_ENTERITER only */ #define OPpOUR_INTRO 16 /* Variable was in an our() */ /* OP_RV2[AGH]V, OP_PAD[AH]V, OP_[AH]ELEM, OP_[AH]SLICE OP_AV2ARYLEN, OP_R?KEYS, OP_SUBSTR, OP_POS, OP_VEC */ @@ -242,6 +242,7 @@ Deprecated. Use C instead. #define OPpDONT_INIT_GV 4 /* Call gv_fetchpv with GV_NOINIT */ /* (Therefore will return whatever is currently in the symbol table, not guaranteed to be a PVGV) */ +#define OPpALLOW_FAKE 16 /* OK to return fake glob */ /* Private for OP_ENTERITER and OP_ITER */ #define OPpITER_REVERSED 4 /* for (reverse ...) */ @@ -308,7 +309,8 @@ Deprecated. Use C instead. #define OPpOFFBYONE 128 /* Treat caller(1) as caller(2) */ /* Private for OP_COREARGS */ -/* These must not conflict with OPpDONT_INIT_GV. See pp.c:S_rv2gv. */ +/* These must not conflict with OPpDONT_INIT_GV or OPpALLOW_FAKE. + See pp.c:S_rv2gv. */ #define OPpCOREARGS_DEREF1 1 /* Arg 1 is a handle constructor */ #define OPpCOREARGS_DEREF2 2 /* Arg 2 is a handle constructor */ #define OPpCOREARGS_SCALARMOD 64 /* \$ rather than \[$@%*] */ diff --git a/opcode.h b/opcode.h index d747d9a..00d27f8 100644 --- a/opcode.h +++ b/opcode.h @@ -1545,7 +1545,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_fun, /* sysread */ Perl_ck_fun, /* syswrite */ Perl_ck_eof, /* eof */ - Perl_ck_fun, /* tell */ + Perl_ck_tell, /* tell */ Perl_ck_fun, /* seek */ Perl_ck_trunc, /* truncate */ Perl_ck_fun, /* fcntl */ diff --git a/pp.c b/pp.c index 3c290dd..c9d72b8 100644 --- a/pp.c +++ b/pp.c @@ -232,7 +232,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, SvFAKE_off(sv); } } - if (SvFAKE(sv)) { + if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) { SV *newsv = sv_newmortal(); sv_setsv_flags(newsv, sv, 0); SvFAKE_off(newsv); diff --git a/proto.h b/proto.h index eec052f..60f191a 100644 --- a/proto.h +++ b/proto.h @@ -574,6 +574,12 @@ PERL_CALLCONV OP * Perl_ck_svconst(pTHX_ OP *o) #define PERL_ARGS_ASSERT_CK_SVCONST \ assert(o) +PERL_CALLCONV OP * Perl_ck_tell(pTHX_ OP *o) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CK_TELL \ + assert(o) + PERL_CALLCONV OP * Perl_ck_trunc(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); diff --git a/regen/opcodes b/regen/opcodes index c7b42c4..e3c8767 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -349,7 +349,7 @@ sysread sysread ck_fun imst@ F R S S? syswrite syswrite ck_fun imst@ F S S? S? eof eof ck_eof is% F? -tell tell ck_fun st% F? +tell tell ck_tell st% F? seek seek ck_fun s@ F S S # truncate really behaves as if it had both "S S" and "F S" truncate truncate ck_trunc is@ S S diff --git a/t/io/tell.t b/t/io/tell.t index 8e4f14e..5fe65b3 100644 --- a/t/io/tell.t +++ b/t/io/tell.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -print "1..28\n"; +print "1..31\n"; $TST = 'TST'; @@ -160,3 +160,12 @@ if (tell($tst) == 6) { print "ok 28$todo\n"; } else { print "not ok 28$todo\n"; } close $tst; +open FH, "test.pl"; +$fh = *FH; # coercible glob +$not = "not " x! (tell $fh == 0); +print "${not}ok 29 - tell on coercible glob\n"; +$not = "not " x! (tell == 0); +print "${not}ok 30 - argless tell after tell \$coercible\n"; +tell *$fh; +$not = "not " x! (tell == 0); +print "${not}ok 31 - argless tell after tell *\$coercible\n"; -- 2.7.4