diff --git a/MANIFEST b/MANIFEST index cb5c0bb1b48e..85d328323158 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 3783750c8961..5457a632c2ab 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 - diff --git a/dist/IO/t/io_getline.t b/dist/IO/t/io_getline.t new file mode 100644 index 000000000000..22361e6b7e87 --- /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 89f726a7a700..adc95d999c4b 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';