This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Stop seek($glob_copy...) from clearing PL_last_in_gv
authorFather Chrysostomos <sprout@cpan.org>
Sun, 18 Dec 2011 08:00:31 +0000 (00:00 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 18 Dec 2011 08:00:31 +0000 (00:00 -0800)
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
opcode.h
regen/opcodes
t/io/tell.t

diff --git a/op.c b/op.c
index ad06161..08e9790 100644 (file)
--- 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;
index 00d27f8..709e92c 100644 (file)
--- 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 */
index e3c8767..353bcc6 100644 (file)
@@ -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
 
index 91fe317..1e577cb 100644 (file)
@@ -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";