Stop tell($glob_copy) from clearing PL_last_in_gv

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’.

diff --git a/embed.h b/embed.h
index 8c9257d..86ffcd4 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- a/op.h
+++ b/op.h
@@ -225,7 +225,7 @@ Deprecated.  Use C<GIMME_V> 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<GIMME_V> 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<GIMME_V> 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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";