Make IO::Handle::getline(s) respect the open pragma

See <https://rt.cpan.org/Ticket/Display.html?id=66474>.  Also, this
came up in <https://rt.perl.org/rt3/Ticket/Display.html?id=92728>.

The <> operator, when reading from the magic ARGV handle, automatic-
ally opens the next file.  Layers set by the lexical open pragma are
applied, if they are in scope at the point where <> is used.

This works almost all the time, because the common convention is:

    use open ":utf8";

    while(<>) {
        ...
    }

IO::Handle’s getline and getlines methods are Perl subroutines
that call <> themselves.  But that happens within the scope of
IO/Handle.pm, so the caller’s I/O layer settings are ignored.  That
means that these two expressions are not equivalent within in a
‘use open’ scope:

    <>
    *ARGV->getline

The latter will open the next file with no layers applied.

This commit solves that by putting PL_check hooks in place in
IO::Handle before compiling the getline and getlines subroutines.
Those hooks cause every state op (nextstate, or dbstate under the
debugger) to have a custom pp function that saves the previous value
of PL_curcop, calls the default pp function, and then restores
PL_curcop.

That means that getline and getlines run with the caller’s compile-
time hints.  Another way to see it is that getline and getlines’s own
lexical hints are never activated.

(A state op carries all the lexical pragmata.  Every statement
has one.  When any op executes, it’s ‘pp’ function is called.
pp_nextstate and pp_dbstate both set PL_curcop to the op itself.  Any
code that checks hints looks at PL_curcop, which contains the current
run-time hints.)

7 files changed, 99 insertions, 4 deletions

diff --git a/MANIFEST b/MANIFEST
index 1cd70f6100..4ed4aa11f0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3172,6 +3172,7 @@ dist/IO/t/io_taint.t		See if the untaint method from IO works
 dist/IO/t/io_tell.t		See if seek()/tell()-related methods from IO work
 dist/IO/t/io_udp.t		See if UDP socket-related methods from IO work
 dist/IO/t/io_unix.t		See if UNIX socket-related methods from IO work
+dist/IO/t/io_utf8argv.t		See if <> respects open pragma
 dist/IO/t/io_utf8.t		See if perlio opens work
 dist/IO/t/io_xs.t		See if XSUB methods from IO work
 dist/lib/lib_pm.PL		For "use lib", produces lib/lib.pm
diff --git a/dist/IO/IO.pm b/dist/IO/IO.pm
index 09143f2e39..e6f5567b9f 100644
--- a/dist/IO/IO.pm
+++ b/dist/IO/IO.pm
@@ -7,7 +7,7 @@ use Carp;
 use strict;
 use warnings;
 
-our $VERSION = "1.25_05";
+our $VERSION = "1.25_06";
 XSLoader::load 'IO', $VERSION;
 
 sub import {
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index d696603eac..0501567157 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -57,6 +57,10 @@ typedef FILE * OutputStream;
 # define NORETURN_FUNCTION_END /* NOT REACHED */ return 0
 #endif
 
+#ifndef dVAR
+#  define dVAR dNOOP
+#endif
+
 static int not_here(const char *s) __attribute__noreturn__;
 static int
 not_here(const char *s)
@@ -142,6 +146,27 @@ io_blocking(pTHX_ InputStream f, int block)
 #endif
 }
 
+static OP *
+io_pp_nextstate(pTHX)
+{
+    dVAR;
+    COP *old_curcop = PL_curcop;
+    OP *next = PL_ppaddr[PL_op->op_type](aTHX);
+    PL_curcop = old_curcop;
+    return next;
+}
+
+static OP *
+io_ck_lineseq(pTHX_ OP *o)
+{
+    OP *kid = cBINOPo->op_first;
+    for (; kid; kid = kid->op_sibling)
+	if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+	    kid->op_ppaddr = io_pp_nextstate;
+    return o;
+}
+
+
 MODULE = IO	PACKAGE = IO::Seekable	PREFIX = f
 
 void
@@ -457,6 +482,18 @@ fsync(handle)
     OUTPUT:
 	RETVAL
 
+SV *
+_create_getline_subs(const char *code)
+    PREINIT:
+	SV *ret;
+    CODE:
+	OP *(*io_old_ck_lineseq)(pTHX_ OP *) = PL_check[OP_LINESEQ];
+	PL_check[OP_LINESEQ] = io_ck_lineseq;
+	RETVAL = SvREFCNT_inc(eval_pv(code,FALSE));
+	PL_check[OP_LINESEQ] = io_old_ck_lineseq;
+    OUTPUT:
+	RETVAL
+
 
 MODULE = IO	PACKAGE = IO::Socket
 
diff --git a/dist/IO/lib/IO/Handle.pm b/dist/IO/lib/IO/Handle.pm
index c15e5a36f0..68e6d902e4 100644
--- a/dist/IO/lib/IO/Handle.pm
+++ b/dist/IO/lib/IO/Handle.pm
@@ -268,7 +268,7 @@ use IO ();	# Load the XS module
 require Exporter;
 @ISA = qw(Exporter);
 
-$VERSION = "1.32";
+$VERSION = "1.33";
 $VERSION = eval $VERSION;
 
 @EXPORT_OK = qw(
@@ -430,14 +430,14 @@ sub say {
     print $this @_;
 }
 
+# Special XS wrapper to make them inherit lexical hints from the caller.
+_create_getline_subs( <<'END' ) or die $@;
 sub getline {
     @_ == 1 or croak 'usage: $io->getline()';
     my $this = shift;
     return scalar <$this>;
 } 
 
-*gets = \&getline;  # deprecated
-
 sub getlines {
     @_ == 1 or croak 'usage: $io->getlines()';
     wantarray or
@@ -445,6 +445,10 @@ sub getlines {
     my $this = shift;
     return <$this>;
 }
+1; # return true for error checking
+END
+
+*gets = \&getline;  # deprecated
 
 sub truncate {
     @_ == 2 or croak 'usage: $io->truncate(LEN)';
diff --git a/dist/IO/t/IO.t b/dist/IO/t/IO.t
index effd414a4c..382e282a07 100644
--- a/dist/IO/t/IO.t
+++ b/dist/IO/t/IO.t
@@ -21,8 +21,10 @@ plan(tests => 18);
 
 	my @load;
 	local $^W;
+	my $xsl = \&XSLoader::load;
 	local *XSLoader::load = sub {
 		push @load, \@_;
+		&$xsl(@_);
 	};
 
 	# use_ok() calls import, which we do not want to do
diff --git a/dist/IO/t/io_utf8argv.t b/dist/IO/t/io_utf8argv.t
new file mode 100644
index 0000000000..c97c260181
--- /dev/null
+++ b/dist/IO/t/io_utf8argv.t
@@ -0,0 +1,38 @@
+#!./perl
+
+BEGIN {
+    unless ($] >= 5.008 and find PerlIO::Layer 'perlio') {
+	print "1..0 # Skip: not perlio\n";
+	exit 0;
+    }
+    require($ENV{PERL_CORE} ? "../../t/test.pl" : "./t/test.pl");
+}
+
+use utf8;
+
+
+plan(tests => 2);
+
+open my $fh, ">", 'io_utf8argv';
+print $fh
+   "\xce\x9c\xe1\xbd\xb7\xce\xb1\x20\xcf\x80\xe1\xbd\xb1\xcf\x80\xce".
+   "\xb9\xce\xb1\x2c\x20\xce\xbc\xe1\xbd\xb0\x20\xcf\x80\xce\xbf\xce".
+   "\xb9\xe1\xbd\xb0\x20\xcf\x80\xe1\xbd\xb1\xcf\x80\xce\xb9\xce\xb1".
+   "\xcd\xbe\x0a";
+close $fh or die "close: $!";
+
+
+use open ":std", ":utf8";
+
+use IO::Handle;
+
+@ARGV = ('io_utf8argv') x 2;
+is *ARGV->getline, "Μία πάπια, μὰ ποιὰ πάπια;\n",
+  'getline respects open pragma when magically opening ARGV';
+
+is join('',*ARGV->getlines), "Μία πάπια, μὰ ποιὰ πάπια;\n",
+  'getlines respects open pragma when magically opening ARGV';
+
+END {
+  1 while unlink "io_utf8argv";
+}
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 57c8f86931..9304c49740 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -275,6 +275,19 @@ method are now hidden from filters that do not want to deal with strings
 
 =item *
 
+L<IO> has been upgraded from version 1.25_05 to 1.25_06, and L<IO::Handle>
+from version 1.32 to 1.33.
+
+Together, these upgrades fix a problem with IO::Handle's C<getline> and
+C<getlines> methods.  When these methods are called on the special ARGV
+handle, the next file is automatically opened, as happens with the built-in
+C<< <> >> and C<readline> functions.  But, unlike the built-ins, these
+methods were not respecting the caller's use of the L<open> pragma and
+applying the approprate I/O layers to the newly-opened file
+[rt.cpan.org #66474].
+
+=item *
+
 L<Math::BigRat> has been upgraded from version 0.2602 to version 0.2603.
 
 C<int()> on a Math::BigRat object containing -1/2 now creates a