Merge f41ffac into 6128f43

embed.fnc

@@ -3716,4 +3716,8 @@ XEop	|STRLEN*|dup_warnings	|NULLOK STRLEN* warnings
 Amd	|void	|CopFILEGV_set	|NN COP * c|NN GV * gv
 #endif
 
+#ifdef PERL_CORE
+dip	|GV*	|last_in_gv
+#endif
+
 : ex: set ts=8 sts=4 sw=4 noet:

embed.h

@@ -1625,6 +1625,7 @@
 #define malloced_size		Perl_malloced_size
 #  endif
 #  if defined(PERL_CORE)
+#define last_in_gv()		Perl_last_in_gv(aTHX)
 #define opslab_force_free(a)	Perl_opslab_force_free(aTHX_ a)
 #define opslab_free(a)		Perl_opslab_free(aTHX_ a)
 #define opslab_free_nopad(a)	Perl_opslab_free_nopad(aTHX_ a)

embedvar.h

@@ -162,6 +162,7 @@
 #define PL_langinfo_buf		(vTHX->Ilanginfo_buf)
 #define PL_langinfo_bufsize	(vTHX->Ilanginfo_bufsize)
 #define PL_last_in_gv		(vTHX->Ilast_in_gv)
+#define PL_last_in_io		(vTHX->Ilast_in_io)
 #define PL_lastfd		(vTHX->Ilastfd)
 #define PL_lastgotoprobe	(vTHX->Ilastgotoprobe)
 #define PL_laststatval		(vTHX->Ilaststatval)

inline.h

@@ -3414,6 +3414,40 @@ Perl_sv_isbool(pTHX_ const SV *sv)
         (SvPVX_const(sv) == PL_Yes || SvPVX_const(sv) == PL_No);
 }
 
+#ifdef PERL_CORE
+
+/*
+=for apidoc last_in_gv
+
+Accessor for L<perlintern/PL_last_in_gv>/L<perlintern/PL_last_in_io>.
+
+Thie returns C<PL_last_in_gv> if valid, otherwise if C<PL_last_in_io>
+is non-NULL, returns a mortal GV referring to that.
+
+Returns NULL if neither is usable.
+
+=cut
+*/
+
+PERL_STATIC_INLINE GV *
+Perl_last_in_gv(pTHX)
+{
+   if (PL_last_in_gv) {
+        return PL_last_in_gv;
+   }
+   else if (PL_last_in_io && SvTYPE(PL_last_in_io) == SVt_PVIO) {
+        GV *gv = (GV*)sv_newmortal();
+        gv_init(gv, 0, "__ANONIO__", 10, 0);
+        SvREFCNT_inc_simple_void(PL_last_in_io);
+        GvIOp(gv) = MUTABLE_IO(PL_last_in_io);
+        return gv;
+    }
+
+    return NULL;
+}
+
+#endif
+
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */

intrpvar.h

@@ -274,6 +274,14 @@ On threaded perls, each thread has an independent copy of this variable;
 each initialized at creation time with the current value of the creating
 thread's copy.
 
+=for apidoc mn|IO*|PL_last_in_io
+
+The IO which was last used for a filehandle input operation.  (C<< <FH> >>)
+
+On threaded perls, each thread has an independent copy of this variable;
+each initialized at creation time with the current value of the creating
+thread's copy.
+
 =for apidoc mn|GV*|PL_ofsgv
 
 The glob containing the output field separator - C<*,> in Perl space.
@@ -287,6 +295,7 @@ thread's copy.
 
 PERLVAR(I, rs,		SV *)		/* input record separator $/ */
 PERLVAR(I, last_in_gv,	GV *)		/* GV used in last <FH> */
+PERLVAR(I, last_in_io,  IO *)           /* IO used in last <FH> */
 PERLVAR(I, ofsgv,	GV *)		/* GV of output field separator *, */
 PERLVAR(I, defoutgv,	GV *)		/* default FH for output */
 PERLVARI(I, chopset,	const char *, " \n-")	/* $: */

mg.c

@@ -901,6 +901,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     REGEXP *rx;
     const char * const remaining = mg->mg_ptr + 1;
     char nextchar;
+    GV *gv;
 
     PERL_ARGS_ASSERT_MAGIC_GET;
 
@@ -1047,6 +1048,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                 sv_setrv_inc(sv, MUTABLE_SV(PL_last_in_gv));
                 sv_rvweaken(sv);
             }
+            else if (PL_last_in_io && SvTYPE(PL_last_in_io) == SVt_PVIO) {
+                /* sv_rvweaken() will remove one reference, and we
+                   want the GV referenced to live long enough for the
+                   accessing code to see it, so make the other
+                   reference mortalized.
+                */
+                GV *gv = (GV*)sv_newmortal();
+                SvREFCNT_inc_simple_NN(gv); /* one reference for sv_rvweaken() to eat */
+                gv_init(gv, 0, "__ANONIO__", 10, 0);
+                SvREFCNT_inc_simple_NN(PL_last_in_io);
+                GvIOp(gv) = MUTABLE_IO(PL_last_in_io);
+                SV_CHECK_THINKFIRST_COW_DROP(sv);
+                prepare_SV_for_RV(sv);
+                SvOK_off(sv);
+                SvRV_set(sv, (SV*)gv);
+                SvROK_on(sv);
+                sv_rvweaken(sv);
+            }
             else
                 sv_set_undef(sv);
         }
@@ -1140,8 +1159,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
         }
         goto set_undef;
     case '.':
-        if (GvIO(PL_last_in_gv)) {
-            sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
+        if ((gv = last_in_gv()) && GvIO(gv)) {
+            sv_setiv(sv, (IV)IoLINES(GvIOp(gv)));
         }
         break;
     case '?':
@@ -2882,6 +2901,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
     I32 i;
     STRLEN len;
     MAGIC *tmg;
+    GV *gv;
 
     PERL_ARGS_ASSERT_MAGIC_SET;
 
@@ -3075,11 +3095,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
         break;
     case '.':
         if (PL_localizing) {
-            if (PL_localizing == 1)
+            if (PL_localizing == 1) {
                 SAVESPTR(PL_last_in_gv);
+                SAVESPTR(PL_last_in_io);
+            }
         }
-        else if (SvOK(sv) && GvIO(PL_last_in_gv))
-            IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
+        else if (SvOK(sv) && (gv = last_in_gv()) && GvIO(gv))
+            IoLINES(GvIOp(gv)) = SvIV(sv);
         break;
     case '^':
         Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));

perl.c

@@ -1060,6 +1060,7 @@ perl_destruct(pTHXx)
     PL_stdingv = NULL;
     PL_stderrgv = NULL;
     PL_last_in_gv = NULL;
+    PL_last_in_io = NULL;
     PL_DBsingle = NULL;
     PL_DBtrace = NULL;
     PL_DBsignal = NULL;

pp_ctl.c

@@ -1170,8 +1170,9 @@ PP(pp_flip)
         int flip = 0;
 
         if (PL_op->op_private & OPpFLIP_LINENUM) {
-            if (GvIO(PL_last_in_gv)) {
-                flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
+            GV *gv = last_in_gv();
+            if (GvIO(gv)) {
+                flip = SvIV(sv) == (IV)IoLINES(GvIOp(gv));
             }
             else {
                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
@@ -1287,8 +1288,9 @@ PP(pp_flop)
         sv_inc(targ);
 
         if (PL_op->op_private & OPpFLIP_LINENUM) {
-            if (GvIO(PL_last_in_gv)) {
-                flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
+            GV *gv = last_in_gv();
+            if (GvIO(gv)) {
+                flop = SvIV(sv) == (IV)IoLINES(GvIOp(gv));
             }
             else {
                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);

pp_hot.c

@@ -3172,7 +3172,7 @@ Perl_do_readline(pTHX)
     STRLEN tmplen = 0;
     STRLEN offset;
     PerlIO *fp;
-    IO * const io = GvIO(PL_last_in_gv);
+    IO * const io = PL_last_in_io = GvIO(PL_last_in_gv);
     const I32 type = PL_op->op_type;
     const U8 gimme = GIMME_V;
 

pp_sys.c

@@ -383,7 +383,9 @@ PP(pp_glob)
 #endif /* !VMS */
 
     SAVESPTR(PL_last_in_gv);	/* We don't want this to be permanent. */
+    SAVESPTR(PL_last_in_io);
     PL_last_in_gv = gv;
+    PL_last_in_io = NULL;
 
     SAVESPTR(PL_rs);		/* This is not permanent, either. */
     PL_rs = newSVpvs_flags("\000", SVs_TEMP);
@@ -400,7 +402,7 @@ PP(pp_glob)
 
 PP(pp_rcatline)
 {
-    PL_last_in_gv = cGVOP_gv;
+    PL_last_in_gv = cGVOP_gv; /* do_readline() will set PL_last_in_io */
     return do_readline();
 }
 
@@ -2116,15 +2118,16 @@ PP(pp_eof)
             which = 2;
         }
         else {
-            gv = PL_last_in_gv;			/* eof */
+            gv = last_in_gv();			/* eof */
             which = 0;
         }
     }
+    PL_last_in_io = io = GvIO(gv);
 
     if (!gv)
         RETPUSHYES;
 
-    if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
+    if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
         return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
     }
 
@@ -2159,13 +2162,15 @@ PP(pp_tell)
     GV *gv;
     IO *io;
 
-    if (MAXARG != 0 && (TOPs || POPs))
-        PL_last_in_gv = MUTABLE_GV(POPs);
-    else
+    if (MAXARG != 0 && (TOPs || POPs)) {
+        gv = PL_last_in_gv = MUTABLE_GV(POPs);
+    }
+    else {
         EXTEND(SP, 1);
-    gv = PL_last_in_gv;
+        gv = last_in_gv();
+    }
+    PL_last_in_io = io = GvIO(gv);
 
-    io = GvIO(gv);
     if (io) {
         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
         if (mg) {
@@ -2201,7 +2206,7 @@ PP(pp_sysseek)
 #endif
 
     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
-    IO *const io = GvIO(gv);
+    IO *const io = PL_last_in_io = GvIO(gv);
 
     if (io) {
         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);

proto.h

@@ -4896,6 +4896,10 @@ PERL_CALLCONV SV*	Perl_sv_setsv_cow(pTHX_ SV* dsv, SV* ssv);
 	assert(ssv)
 #endif
 #if defined(PERL_CORE)
+#ifndef PERL_NO_INLINE_FUNCTIONS
+PERL_STATIC_INLINE GV*	Perl_last_in_gv(pTHX);
+#define PERL_ARGS_ASSERT_LAST_IN_GV
+#endif
 PERL_CALLCONV void	Perl_opslab_force_free(pTHX_ OPSLAB *slab);
 #define PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE	\
 	assert(slab)

sv.c

@@ -6705,6 +6705,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
             Safefree(IoBOTTOM_NAME(sv));
             if ((const GV *)sv == PL_statgv)
                 PL_statgv = NULL;
+            else if ((const IO *)sv == PL_last_in_io)
+                PL_last_in_io = NULL;
             goto freescalar;
         case SVt_REGEXP:
             /* FIXME for plugins */
@@ -15870,6 +15872,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     PL_rs		= sv_dup_inc(proto_perl->Irs, param);
     PL_last_in_gv	= gv_dup(proto_perl->Ilast_in_gv, param);
+    PL_last_in_io	= io_dup(proto_perl->Ilast_in_io, param);
     PL_defoutgv		= gv_dup_inc(proto_perl->Idefoutgv, param);
     PL_toptarget	= sv_dup_inc(proto_perl->Itoptarget, param);
     PL_bodytarget	= sv_dup_inc(proto_perl->Ibodytarget, param);

t/op/magic.t

@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     require './test.pl';
     set_up_inc( '../lib' );
-    plan (tests => 197); # some tests are run in BEGIN block
+    plan (tests => 201); # some tests are run in BEGIN block
 }
 
 # Test that defined() returns true for magic variables created on the fly,
@@ -638,6 +638,11 @@ is ${^LAST_FH}, \*STDIN, '${^LAST_FH} after another tell';
     () = tell $fh;
     is ${^LAST_FH}, \$fh, '${^LAST_FH} referencing lexical coercible glob';
 }
+{
+    # set PL_last_in_gv, and clear it, and clears PL_last_in_io
+    open my $fh, "<", "test.pl" or die;
+    () = tell $fh;
+}
 # This also tests that ${^LAST_FH} is a weak reference:
 is ${^LAST_FH}, undef, '${^LAST_FH} is undef when PL_last_in_gv is NULL';
 
@@ -650,6 +655,22 @@ for my $code ('tell $0', 'sysseek $0, 0, 0', 'seek $0, 0, 0', 'eof $0') {
                   undef, "check $code doesn't define \${^LAST_FH}");
 }
 
+# check each case where only the IO is still available that we still
+# have a working handle
+for my $code ('tell $fh', 'sysseek $fh, 0, 0', 'seek $fh, 0, 0', 'eof $fh') {
+    fresh_perl_is(<<EOS, "ok\n", undef, "check $code populates PL_last_in_io");
+my \$fh;
+{
+    open my \$fhg, "<", "test.pl" or die;
+    # only preserve the IO
+    my \$fh = *{\$fhg}{IO};
+    $code;
+    \$. = 42;
+}
+print \$. == 42 ? "ok\n" : "not ok \$.\n";
+EOS
+}
+
 # $|
 fresh_perl_is 'print $| = ~$|', "1\n", {switches => ['-l']},
  '[perl #4760] print $| = ~$|';

t/op/readline.t

@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan tests => 32;
+plan tests => 34;
 
 # [perl #19566]: sv_gets writes directly to its argument via
 # TARG. Test that we respect SvREADONLY.
@@ -268,10 +268,11 @@ open *foom,'test.pl';
 my %f;
 $f{g} = *foom;
 readline $f{g};
-$f{g} = 3; # PL_last_in_gv should be cleared now
-is tell, -1, 'tell returns -1 after last gv is unglobbed';
+$f{g} = 3; # PL_last_in_gv should be cleared now, but PL_last_in_io is still set
+# but we now remember the underlying IO object
+isnt tell, -1, 'tell no longer returns -1 after last gv is unglobbed';
 $f{g} = *foom; # since PL_last_in_gv is null, this should have no effect
-is tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv';
+isnt tell, -1, 'unglobbery of last gv nullifies PL_last_in_gv, but PL_last_in_io still set';
 readline *{$f{g}};
 is tell, tell *foom, 'readline *$glob_copy sets PL_last_in_gv';
 
@@ -289,6 +290,22 @@ is ${^LAST_FH}, undef, '${^LAST_FH} after readline undef';
         '[perl #123790] *x=<y> used to fail an assertion';
 }
 
+# github #1420
+{
+    {
+        # test case from the ticket
+        my $io = do { open FH, "<", "test.pl" or die; *FH{IO}; };
+        <$io>;
+        ok(defined $., "IO refs now saved as a last handle");
+    }
+
+    {
+        my $io = do { open FH, "<", "test.pl" or die; *FH{IO}; };
+        <$io>;
+        is(*{${^LAST_FH}}{IO}, $io, 'test ${^LAST_FH} properly populated');
+    }
+}
+
 __DATA__
 moo
 moo