From 423e8af5fd21022f9107100c8561c5f880121231 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sun, 18 Dec 2011 00:00:31 -0800
Subject: [PATCH] Stop seek($glob_copy...) from clearing PL_last_in_gv
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

seek had the same bug as tell.  Here is the commit message from
8dc99089, which fixed tell:

----------------------------------------------------------------------

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’.
---
 op.c          | 1 +
 opcode.h      | 2 +-
 regen/opcodes | 2 +-
 t/io/tell.t   | 8 +++++++-
 4 files changed, 10 insertions(+), 3 deletions(-)

diff --git a/op.c b/op.c
index ad06161..08e9790 100644
--- a/op.c
+++ b/op.c
@@ -9697,6 +9697,7 @@ Perl_ck_tell(pTHX_ OP *o)
     o = ck_fun(o);
     if (o->op_flags & OPf_KIDS) {
      OP *kid = cLISTOPo->op_first;
+     if (kid->op_type == OP_NULL && kid->op_sibling) kid = kid->op_sibling;
      if (kid->op_type == OP_RV2GV) kid->op_private |= OPpALLOW_FAKE;
     }
     return o;
diff --git a/opcode.h b/opcode.h
index 00d27f8..709e92c 100644
--- a/opcode.h
+++ b/opcode.h
@@ -1546,7 +1546,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 	Perl_ck_fun,		/* syswrite */
 	Perl_ck_eof,		/* eof */
 	Perl_ck_tell,		/* tell */
-	Perl_ck_fun,		/* seek */
+	Perl_ck_tell,		/* seek */
 	Perl_ck_trunc,		/* truncate */
 	Perl_ck_fun,		/* fcntl */
 	Perl_ck_fun,		/* ioctl */
diff --git a/regen/opcodes b/regen/opcodes
index e3c8767..353bcc6 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -350,7 +350,7 @@ syswrite	syswrite		ck_fun		imst@	F S S? S?
 
 eof		eof			ck_eof		is%	F?
 tell		tell			ck_tell		st%	F?
-seek		seek			ck_fun		s@	F S S
+seek		seek			ck_tell		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 91fe317..1e577cb 100644
--- a/t/io/tell.t
+++ b/t/io/tell.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-print "1..33\n";
+print "1..35\n";
 
 $TST = 'TST';
 
@@ -175,3 +175,9 @@ print "${not}ok 32 - argless tell after eof \$coercible\n";
 eof *$fh;
 $not = "not " x! (tell == 0);
 print "${not}ok 33 - argless tell after eof *\$coercible\n";
+seek $fh,0,0;
+$not = "not " x! (tell == 0);
+print "${not}ok 34 - argless tell after seek \$coercible...\n";
+seek *$fh,0,0;
+$not = "not " x! (tell == 0);
+print "${not}ok 35 - argless tell after seek *\$coercible...\n";
-- 
2.7.4