From 7a992ccc8be4ce4c27268e1980edb4701f9948d9 Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 3 Nov 2019 11:06:59 +0100
Subject: [PATCH] Add tests for IO::Handle getline() and getlines().
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Extend the tests for <> and the open pragma to verify that the behaviour
changes with/without the open pragma.
Signed-off-by: Petr Písař <ppisar@redhat.com>
---
MANIFEST | 1 +
dist/IO/README | 1 -
dist/IO/t/io_getline.t | 117 ++++++++++++++++++++++++++++++++++++++++
dist/IO/t/io_utf8argv.t | 13 +++--
4 files changed, 128 insertions(+), 4 deletions(-)
create mode 100644 dist/IO/t/io_getline.t
diff --git a/MANIFEST b/MANIFEST
index cb5c0bb1b4..85d3283231 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3676,6 +3676,7 @@ dist/IO/t/io_dir.t See if directory-related methods from IO work
dist/IO/t/io_dup.t See if dup()-related methods from IO work
dist/IO/t/io_file.t See if binmode()-related methods on IO::File work
dist/IO/t/io_file_export.t Test IO::File exports
+dist/IO/t/io_getline.t Test getline and getlines
dist/IO/t/io_leak.t See if IO leaks SVs (only run in core)
dist/IO/t/io_linenum.t See if I/O line numbers are tracked correctly
dist/IO/t/io_multihomed.t See if INET sockets work with multi-homed hosts
diff --git a/dist/IO/README b/dist/IO/README
index 3783750c89..5457a632c2 100644
--- a/dist/IO/README
+++ b/dist/IO/README
@@ -24,4 +24,3 @@ To build, test and install this distribution type:
Share and Enjoy!
Graham Barr <gbarr@pobox.com>
-
diff --git a/dist/IO/t/io_getline.t b/dist/IO/t/io_getline.t
new file mode 100644
index 0000000000..22361e6b7e
--- /dev/null
+++ b/dist/IO/t/io_getline.t
@@ -0,0 +1,117 @@
+#!./perl -w
+use strict;
+
+use Test::More tests => 37;
+
+my $File = 'README';
+
+use IO::File;
+
+my $io = IO::File->new($File);
+isa_ok($io, 'IO::File', "Opening $File");
+
+my $line = $io->getline();
+like($line, qr/^This is the/, "Read first line");
+
+my ($list, $context) = $io->getline();
+is($list, "\n", "Read second line");
+is($context, undef, "Did not read third line with getline() in list context");
+
+$line = $io->getline();
+like($line, qr/^This distribution/, "Read third line");
+
+my @lines = $io->getlines();
+cmp_ok(@lines, '>', 3, "getlines reads lots of lines");
+like($lines[-2], qr/^Share and Enjoy!/, "Share and Enjoy!");
+
+$line = $io->getline();
+is($line, undef, "geline reads no more at EOF");
+
+@lines = $io->getlines();
+is(@lines, 0, "gelines reads no more at EOF");
+
+# And again
+$io = IO::File->new($File);
+isa_ok($io, 'IO::File', "Opening $File");
+
+$line = $io->getline();
+like($line, qr/^This is the/, "Read first line again");
+
+is(eval {
+ $line = $io->getline("Boom");
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^usage.*getline\(\) at .*\bio_getline\.t line /, 'getline usage');
+like($line, qr/^This is the/, '$line unchanged');
+
+is(eval {
+ ($list, $context) = $io->getlines("Boom");
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^usage.*getlines\(\) at .*\bio_getline\.t line /, 'getlines usage');
+is($list, "\n", '$list unchanged');
+
+is(eval {
+ $line = $io->getlines();
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^Can't call .*getlines in a scalar context.* at .*\bio_getline\.t line /,
+ 'getlines in scalar context croaks');
+like($line, qr/^This is the/, '$line unchanged');
+
+is(eval {
+ $io->getlines();
+ 1;
+ }, undef, "eval caught an exception");
+like($@, qr/^Can't call .*getlines in a scalar context.* at .*\bio_getline\.t line /,
+ 'getlines in void context croaks');
+like($line, qr/^This is the/, '$line unchanged');
+
+($list, $context) = $io->getlines();
+is($list, "\n", "Read second line");
+like($context, qr/^This distribution/, "Read third line");
+
+{
+ package TiedHandle;
+
+ sub TIEHANDLE {
+ return bless ["Tick", "tick", "tick"];
+ }
+
+ sub READLINE {
+ my $fh = shift;
+ die "Boom!"
+ unless @$fh;
+ return shift @$fh
+ unless wantarray;
+ return splice @$fh;
+ }
+}
+
+tie *FH, 'TiedHandle';
+
+is(*FH->getline(), "Tick", "tied handle read works");
+($list, $context) = *FH->getline();
+is($list, "tick", "tied handle read works in list context 0");
+is($context, undef, "tied handle read works in list context 1");
+is(*FH->getline(), "tick", "tied handle read works again");
+is(eval {
+ $line = *FH->getline();
+ 1;
+ }, undef, "eval on tied handle caught an exception");
+like($@, qr/^Boom!/,
+ 'getline on tied handle propagates exception');
+like($line, qr/^This is the/, '$line unchanged');
+
+tie *FH, 'TiedHandle';
+
+($list, $context) = *FH->getlines();
+is($list, "Tick", "tied handle read works in list context 2");
+is($context, "tick", "tied handle read works in list context 3");
+is(eval {
+ ($list, $context) = *FH->getlines();
+ 1;
+ }, undef, "eval on tied handle caught an exception again");
+like($@, qr/^Boom!/,
+ 'getlines on tied handle propagates exception');
+is($list, "Tick", '$line unchanged');
diff --git a/dist/IO/t/io_utf8argv.t b/dist/IO/t/io_utf8argv.t
index 89f726a7a7..adc95d999c 100644
--- a/dist/IO/t/io_utf8argv.t
+++ b/dist/IO/t/io_utf8argv.t
@@ -13,7 +13,7 @@ use utf8;
skip_all("EBCDIC platform; testing not core")
if $::IS_EBCDIC && ! $ENV{PERL_CORE};
-plan(tests => 2);
+plan(tests => 4);
my $bytes =
"\xce\x9c\xe1\xbd\xb7\xce\xb1\x20\xcf\x80\xe1\xbd\xb1\xcf\x80\xce".
@@ -31,10 +31,17 @@ print $fh $bytes;
close $fh or die "close: $!";
-use open ":std", ":utf8";
-
use IO::Handle;
+@ARGV = ('io_utf8argv') x 2;
+is *ARGV->getline, $bytes,
+ 'getline (no open pragma) when magically opening ARGV';
+
+is join('',*ARGV->getlines), $bytes,
+ 'getlines (no open pragma) when magically opening ARGV';
+
+use open ":std", ":utf8";
+
@ARGV = ('io_utf8argv') x 2;
is *ARGV->getline, "Μία πάπια, μὰ ποιὰ πάπια;\n",
'getline respects open pragma when magically opening ARGV';
--
2.21.1