Skip to content

Commit

Permalink
Add tests for IO::Handle getline() and getlines().
Browse files Browse the repository at this point in the history
Extend the tests for <> and the open pragma to verify that the behaviour
changes with/without the open pragma.
  • Loading branch information
nwc10 committed Jan 19, 2020
1 parent 17d6187 commit 7a992cc
Show file tree
Hide file tree
Showing 4 changed files with 128 additions and 4 deletions.
1 change: 1 addition & 0 deletions MANIFEST
Expand Up @@ -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
Expand Down
1 change: 0 additions & 1 deletion dist/IO/README
Expand Up @@ -24,4 +24,3 @@ To build, test and install this distribution type:

Share and Enjoy!
Graham Barr <gbarr@pobox.com>

117 changes: 117 additions & 0 deletions 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');
13 changes: 10 additions & 3 deletions dist/IO/t/io_utf8argv.t
Expand Up @@ -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".
Expand All @@ -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';
Expand Down

0 comments on commit 7a992cc

Please sign in to comment.