Move the 4 tests of core PerlIO functionality to t/io. PerlIO::Layer::find is

implemented in perlio.c

4 files changed, 252 insertions, 0 deletions

diff --git a/t/io/perlio.t b/t/io/perlio.t
new file mode 100644
index 0000000000..3be0f6af36
--- /dev/null
+++ b/t/io/perlio.t
@@ -0,0 +1,136 @@
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+	require Config; import Config;
+	unless (find PerlIO::Layer 'perlio') {
+	    print "1..0 # Skip: PerlIO not used\n";
+	    exit 0;
+	}
+}
+
+use Test::More tests => 37;
+
+use_ok('PerlIO');
+
+my $txt = "txt$$";
+my $bin = "bin$$";
+my $utf = "utf$$";
+
+my $txtfh;
+my $binfh;
+my $utffh;
+
+ok(open($txtfh, ">:crlf", $txt));
+
+ok(open($binfh, ">:raw",  $bin));
+
+ok(open($utffh, ">:utf8", $utf));
+
+print $txtfh "foo\n";
+print $txtfh "bar\n";
+
+ok(close($txtfh));
+
+print $binfh "foo\n";
+print $binfh "bar\n";
+
+ok(close($binfh));
+
+print $utffh "foo\x{ff}\n";
+print $utffh "bar\x{abcd}\n";
+
+ok(close($utffh));
+
+ok(open($txtfh, "<:crlf", $txt));
+
+ok(open($binfh, "<:raw",  $bin));
+
+
+ok(open($utffh, "<:utf8", $utf));
+
+is(scalar <$txtfh>, "foo\n");
+is(scalar <$txtfh>, "bar\n");
+
+is(scalar <$binfh>, "foo\n");
+is(scalar <$binfh>, "bar\n");
+
+is(scalar <$utffh>,  "foo\x{ff}\n");
+is(scalar <$utffh>, "bar\x{abcd}\n");
+
+ok(eof($txtfh));;
+
+ok(eof($binfh));
+
+ok(eof($utffh));
+
+ok(close($txtfh));
+
+ok(close($binfh));
+
+ok(close($utffh));
+
+# magic temporary file via 3 arg open with undef
+{
+    ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef');
+    ok( defined fileno($x),     '       fileno' );
+
+    select $x;
+    ok( (print "ok\n"),         '       print' );
+
+    select STDOUT;
+    ok( seek($x,0,0),           '       seek' );
+    is( scalar <$x>, "ok\n",    '       readline' );
+    ok( tell($x) >= 3,          '       tell' );
+
+    # test magic temp file over STDOUT
+    open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
+    my $status = open(STDOUT,"+<",undef);
+    open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
+    # report after STDOUT is restored
+    ok($status, '       re-open STDOUT');
+    close OLDOUT;
+}
+
+# in-memory open
+{
+    my $var;
+    ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var');
+    ok( defined fileno($x),     '       fileno' );
+
+    select $x;
+    ok( (print "ok\n"),         '       print' );
+
+    select STDOUT;
+    ok( seek($x,0,0),           '       seek' );
+    is( scalar <$x>, "ok\n",    '       readline' );
+    ok( tell($x) >= 3,          '       tell' );
+
+  TODO: {
+        local $TODO = "broken";
+
+        # test in-memory open over STDOUT
+        open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
+        #close STDOUT;
+        my $status = open(STDOUT,">",\$var);
+        my $error = "$!" unless $status; # remember the error
+	close STDOUT unless $status;
+        open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
+        print "# $error\n" unless $status;
+        # report after STDOUT is restored
+        ok($status, '       open STDOUT into in-memory var');
+
+        # test in-memory open over STDERR
+        open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!";
+        #close STDERR;
+        ok( open(STDERR,">",\$var), '       open STDERR into in-memory var');
+        open STDERR,  ">&OLDERR" or die "cannot dup OLDERR: $!";
+    }
+}
+
+
+END {
+    1 while unlink $txt;
+    1 while unlink $bin;
+    1 while unlink $utf;
+}
+
diff --git a/t/io/perlio_fail.t b/t/io/perlio_fail.t
new file mode 100644
index 0000000000..56e3d1d5a5
--- /dev/null
+++ b/t/io/perlio_fail.t
@@ -0,0 +1,48 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require "../t/test.pl";
+    skip_all("No perlio") unless (find PerlIO::Layer 'perlio');
+    plan (15);
+}
+
+use warnings 'layer';
+my $warn;
+my $file = "fail$$";
+$SIG{__WARN__} = sub { $warn = shift };
+
+END { 1 while unlink($file) }
+
+ok(open(FH,">",$file),"Create works");
+close(FH);
+ok(open(FH,"<",$file),"Normal open works");
+
+$warn = ''; $! = 0;
+ok(!binmode(FH,":-)"),"All punctuation fails binmode");
+print "# $!\n";
+isnt($!,0,"Got errno");
+like($warn,qr/in PerlIO layer/,"Got warning");
+
+$warn = ''; $! = 0;
+ok(!binmode(FH,":nonesuch"),"Bad package fails binmode");
+print "# $!\n";
+isnt($!,0,"Got errno");
+like($warn,qr/nonesuch/,"Got warning");
+close(FH);
+
+$warn = ''; $! = 0;
+ok(!open(FH,"<:-)",$file),"All punctuation fails open");
+print "# $!\n";
+isnt($!,"","Got errno");
+like($warn,qr/in PerlIO layer/,"Got warning");
+
+$warn = ''; $! = 0;
+ok(!open(FH,"<:nonesuch",$file),"Bad package fails open");
+print "# $!\n";
+isnt($!,0,"Got errno");
+like($warn,qr/nonesuch/,"Got warning");
+
+ok(open(FH,"<",$file),"Normal open (still) works");
+close(FH);
diff --git a/t/io/perlio_leaks.t b/t/io/perlio_leaks.t
new file mode 100644
index 0000000000..ad76c39e9e
--- /dev/null
+++ b/t/io/perlio_leaks.t
@@ -0,0 +1,26 @@
+#!perl
+# ioleaks.t
+
+use strict;
+use warnings;
+use Test::More 'no_plan';
+
+# :unix   -> not ok
+# :stdio  -> not ok
+# :perlio -> ok
+# :crlf   -> ok
+
+TODO: {
+    local $TODO = "[perl #56644] PerlIO resource leaks on open() and then :pop in :unix and :stdio";
+    foreach my $layer(qw(:unix :stdio  :perlio :crlf)){
+        my $base_fd = do{ open my $in, '<', $0 or die $!; fileno $in };
+
+        for(1 .. 3){
+                open my $fh, "<$layer", $0 or die $!;
+
+                is fileno($fh), $base_fd, $layer;
+                binmode $fh, ':pop';
+        }
+    }
+}
+
diff --git a/t/io/perlio_open.t b/t/io/perlio_open.t
new file mode 100644
index 0000000000..7d870b9e67
--- /dev/null
+++ b/t/io/perlio_open.t
@@ -0,0 +1,42 @@
+#!./perl
+
+use strict;
+use warnings;
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    unless (find PerlIO::Layer 'perlio') {
+	print "1..0 # Skip: not perlio\n";
+	exit 0;
+    }
+    use Config;
+    unless (" $Config{extensions} " =~ / Fcntl /) {
+	print "1..0 # Skip: no Fcntl (how did you get this far?)\n";
+	exit 0;
+    }
+}
+
+use Test::More tests => 6;
+
+use Fcntl qw(:seek);
+
+{
+    ok((open my $fh, "+>", undef), "open my \$fh, '+>', undef");
+    print $fh "the right write stuff";
+    ok(seek($fh, 0, SEEK_SET), "seek to zero");
+    my $data = <$fh>;
+    is($data, "the right write stuff", "found the right stuff");
+}
+
+{
+    ok((open my $fh, "+<", undef), "open my \$fh, '+<', undef");
+    print $fh "the right read stuff";
+    ok(seek($fh, 0, SEEK_SET), "seek to zero");
+    my $data = <$fh>;
+    is($data, "the right read stuff", "found the right stuff");
+}
+
+
+
+