dslinux/user/perl/ext/PerlIO/t PerlIO.t encoding.t fail.t fallback.t open.t scalar.t via.t
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:26:54 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/PerlIO/t
In directory antilope:/tmp/cvs-serv7729/ext/PerlIO/t
Added Files:
PerlIO.t encoding.t fail.t fallback.t open.t scalar.t via.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: open.t ---
#!./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");
}
--- NEW FILE: scalar.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
require Config;
if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
exit 0;
}
}
$| = 1;
print "1..27\n";
my $fh;
my $var = "ok 2\n";
open($fh,"+<",\$var) or print "not ";
print "ok 1\n";
print <$fh>;
print "not " unless eof($fh);
print "ok 3\n";
seek($fh,0,0) or print "not ";
print "not " if eof($fh);
print "ok 4\n";
print "ok 5\n";
print $fh "ok 7\n" or print "not ";
print "ok 6\n";
print $var;
$var = "foo\nbar\n";
seek($fh,0,0) or print "not ";
print "not " if eof($fh);
print "ok 8\n";
print "not " unless <$fh> eq "foo\n";
print "ok 9\n";
my $rv = close $fh;
if (!$rv) {
print "# Close on scalar failed: $!\n";
print "not ";
}
print "ok 10\n";
# Test that semantics are similar to normal file-based I/O
# Check that ">" clobbers the scalar
$var = "Something";
open $fh, ">", \$var;
print "# Got [$var], expect []\n";
print "not " unless $var eq "";
print "ok 11\n";
# Check that file offset set to beginning of scalar
my $off = tell($fh);
print "# Got $off, expect 0\n";
print "not " unless $off == 0;
print "ok 12\n";
# Check that writes go where they should and update the offset
$var = "Something";
print $fh "Brea";
$off = tell($fh);
print "# Got $off, expect 4\n";
print "not " unless $off == 4;
print "ok 13\n";
print "# Got [$var], expect [Breathing]\n";
print "not " unless $var eq "Breathing";
print "ok 14\n";
close $fh;
# Check that ">>" appends to the scalar
$var = "Something ";
open $fh, ">>", \$var;
$off = tell($fh);
print "# Got $off, expect 10\n";
print "not " unless $off == 10;
print "ok 15\n";
print "# Got [$var], expect [Something ]\n";
print "not " unless $var eq "Something ";
print "ok 16\n";
# Check that further writes go to the very end of the scalar
$var .= "else ";
print "# Got [$var], expect [Something else ]\n";
print "not " unless $var eq "Something else ";
print "ok 17\n";
$off = tell($fh);
print "# Got $off, expect 10\n";
print "not " unless $off == 10;
print "ok 18\n";
print $fh "is here";
print "# Got [$var], expect [Something else is here]\n";
print "not " unless $var eq "Something else is here";
print "ok 19\n";
close $fh;
# Check that updates to the scalar from elsewhere do not
# cause problems
$var = "line one\nline two\line three\n";
open $fh, "<", \$var;
while (<$fh>) {
$var = "foo";
}
close $fh;
print "# Got [$var], expect [foo]\n";
print "not " unless $var eq "foo";
print "ok 20\n";
# Check that dup'ing the handle works
$var = '';
open $fh, "+>", \$var;
print $fh "ok 21\n";
open $dup,'+<&',$fh;
print $dup "ok 22\n";
seek($dup,0,0);
while (<$dup>) {
print;
}
close($fh);
close($dup);
# Check reading from non-string scalars
open $fh, '<', \42;
print <$fh> eq "42" ? "ok 23\n" : "not ok 23\n";
close $fh;
# reading from magic scalars
{ package P; sub TIESCALAR {bless{}} sub FETCH {"ok 24\n"} }
tie $p, P; open $fh, '<', \$p;
print <$fh>;
# don't warn when writing to an undefined scalar
{
use warnings;
my $ok = 1;
local $SIG{__WARN__} = sub { $ok = 0; };
open my $fh, '>', \my $scalar;
print $fh "foo";
close $fh;
print $ok ? "ok 25\n" : "not ok 25\n";
}
my $data = "a non-empty PV";
$data = undef;
open(MEM, '<', \$data) or die "Fail: $!\n";
my $x = join '', <MEM>;
print $x eq '' ? "ok 26\n" : "not ok 26\n";
{
# [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
my $s = <<'EOF';
line A
line B
a third line
EOF
open(F, '<', \$s) or die "Could not open string as a file";
local $/ = "";
my $ln = <F>;
close F;
print $ln eq $s ? "ok 27\n" : "not ok 27\n";
}
--- NEW FILE: fallback.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
require "../t/test.pl";
skip_all("No perlio") unless (find PerlIO::Layer 'perlio');
if (ord("A") == 193) {
print "1..0 # Skip: EBCDIC\n";
exit 0;
}
unless( eval { require Encode } ) {
print "1..0 # Skip: No Encode\n";
exit 0;
}
plan (9);
import Encode qw(:fallback_all);
}
# $PerlIO::encoding = 0; # WARN_ON_ERR|PERLQQ;
my $file = "fallback$$.txt";
{
my $message = '';
local $SIG{__WARN__} = sub { $message = $_[0] };
$PerlIO::encoding::fallback = Encode::PERLQQ;
ok(open(my $fh,">encoding(iso-8859-1)",$file),"opened iso-8859-1 file");
my $str = "\x{20AC}";
print $fh $str,"0.02\n";
close($fh);
like($message, qr/does not map to iso-8859-1/o, "FB_WARN message");
}
open($fh,$file) || die "File cannot be re-opened";
my $line = <$fh>;
is($line,"\\x{20ac}0.02\n","perlqq escapes");
close($fh);
$PerlIO::encoding::fallback = Encode::HTMLCREF;
ok(open(my $fh,">encoding(iso-8859-1)",$file),"opened iso-8859-1 file");
my $str = "\x{20AC}";
print $fh $str,"0.02\n";
close($fh);
open($fh,$file) || die "File cannot be re-opened";
my $line = <$fh>;
is($line,"€0.02\n","HTML escapes");
close($fh);
{
no utf8;
open($fh,">$file") || die "File cannot be re-opened";
binmode($fh);
print $fh "\xA30.02\n";
close($fh);
}
ok(open($fh,"<encoding(US-ASCII)",$file),"Opened as ASCII");
my $line = <$fh>;
printf "# %x\n",ord($line);
is($line,"\\xA30.02\n","Escaped non-mapped char");
close($fh);
$PerlIO::encoding::fallback = Encode::WARN_ON_ERROR;
ok(open($fh,"<encoding(US-ASCII)",$file),"Opened as ASCII");
my $line = <$fh>;
printf "# %x\n",ord($line);
is($line,"\x{FFFD}0.02\n","Unicode replacement char");
close($fh);
END {
1 while unlink($file);
}
--- NEW FILE: encoding.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
no warnings; # Need global -w flag for later tests, but don't want this
# to warn here:
push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
unless (eval { require Encode } ) {
print "1..0 # Skip: not Encode\n";
exit 0;
}
}
print "1..15\n";
my $grk = "grk$$";
my $utf = "utf$$";
my $fail1 = "fa$$";
my $fail2 = "fb$$";
my $russki = "koi8r$$";
my $threebyte = "3byte$$";
if (open(GRK, ">$grk")) {
binmode(GRK, ":bytes");
# alpha beta gamma in ISO 8859-7
print GRK "\xe1\xe2\xe3";
close GRK or die "Could not close: $!";
}
{
open(my $i,'<:encoding(iso-8859-7)',$grk);
print "ok 1\n";
open(my $o,'>:utf8',$utf);
print "ok 2\n";
print $o readline($i);
print "ok 3\n";
close($o) or die "Could not close: $!";
close($i);
}
if (open(UTF, "<$utf")) {
binmode(UTF, ":bytes");
if (ord('A') == 193) { # EBCDIC
# alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3)
print "not " unless <UTF> eq "\xb4\x58\xb4\x59\xb4\x62";
} else {
# alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
}
print "ok 4\n";
close UTF;
}
{
use Encode;
open(my $i,'<:utf8',$utf);
print "ok 5\n";
open(my $o,'>:encoding(iso-8859-7)',$grk);
print "ok 6\n";
print $o readline($i);
print "ok 7\n";
close($o) or die "Could not close: $!";
close($i);
}
if (open(GRK, "<$grk")) {
binmode(GRK, ":bytes");
print "not " unless <GRK> eq "\xe1\xe2\xe3";
print "ok 8\n";
close GRK;
}
$SIG{__WARN__} = sub {$warn .= $_[0]};
if (open(FAIL, ">:encoding(NoneSuch)", $fail1)) {
print "not ok 9 # Open should fail\n";
} else {
print "ok 9\n";
}
if (!defined $warn) {
print "not ok 10 # warning is undef\n";
} elsif ($warn =~ /^Cannot find encoding "NoneSuch" at/) {
print "ok 10\n";
} else {
print "not ok 10 # warning is '$warn'";
}
if (open(RUSSKI, ">$russki")) {
print RUSSKI "\x3c\x3f\x78";
close RUSSKI or die "Could not close: $!";
open(RUSSKI, "$russki");
binmode(RUSSKI, ":raw");
my $buf1;
read(RUSSKI, $buf1, 1);
# eof(RUSSKI);
binmode(RUSSKI, ":encoding(koi8-r)");
my $buf2;
read(RUSSKI, $buf2, 1);
my $offset = tell(RUSSKI);
if (ord($buf1) == 0x3c &&
ord($buf2) == (ord('A') == 193) ? 0x6f : 0x3f &&
$offset == 2) {
print "ok 11\n";
} else {
printf "not ok 11 # [%s] [%s] %d\n",
join(" ", unpack("H*", $buf1)),
join(" ", unpack("H*", $buf2)), $offset;
}
close(RUSSKI);
} else {
print "not ok 11 # open failed: $!\n";
}
undef $warn;
# Check there is no Use of uninitialized value in concatenation (.) warning
# due to the way @latin2iso_num was used to make aliases.
if (open(FAIL, ">:encoding(latin42)", $fail2)) {
print "not ok 12 # Open should fail\n";
} else {
print "ok 12\n";
}
if (!defined $warn) {
print "not ok 13 # warning is undef\n";
} elsif ($warn =~ /^Cannot find encoding "latin42" at.*line \d+\.$/) {
print "ok 13\n";
} else {
print "not ok 13 # warning is: \n";
$warn =~ s/^/# /mg;
print "$warn";
}
# Create a string of chars that are 3 bytes in UTF-8
my $str = "\x{1f80}" x 2048;
# Write them to a file
open(F,'>:utf8',$threebyte) || die "Cannot open $threebyte:$!";
print F $str;
close(F);
# Read file back as UTF-8
open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
my $dstr = <F>;
close(F);
print "not " unless ($dstr eq $str);
print "ok 14\n";
# Try decoding some bad stuff
open(F,'>:raw',$threebyte) || die "Cannot open $threebyte:$!";
print F "foo\xF0\x80\x80\x80bar\n\x80foo\n";
close(F);
open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
$dstr = join(":", <F>);
close(F);
print "not " unless $dstr eq "foo\\xF0\\x80\\x80\\x80bar\n:\\x80foo\n";
print "ok 15\n";
END {
1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
}
--- NEW FILE: via.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
require Config;
if (($Config::Config{'extensions'} !~ m!\bPerlIO/via\b!) ){
print "1..0 # Skip -- Perl configured without PerlIO::via module\n";
exit 0;
}
}
use strict;
use warnings;
my $tmp = "via$$";
use Test::More tests => 18;
my $fh;
my $a = join("", map { chr } 0..255) x 10;
my $b;
BEGIN { use_ok('PerlIO::via::QuotedPrint'); }
ok( !open($fh,"<via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for input fails');
ok( open($fh,">via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for output');
ok( (print $fh $a), "print to output file");
ok( close($fh), 'close output file');
ok( open($fh,"<via(PerlIO::via::QuotedPrint)", $tmp), 'open QuotedPrint for input');
{ local $/; $b = <$fh> }
ok( close($fh), "close input file");
is($a, $b, 'compare original data with filtered version');
{
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings = join '', @_ };
use warnings 'layer';
# Find fd number we should be using
my $fd = open($fh,">$tmp") && fileno($fh);
print $fh "Hello\n";
close($fh);
ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail');
like( $warnings, qr/^Cannot find package 'Unknown::Module'/, 'warn about unknown package' );
# Now open normally again to see if we get right fileno
my $fd2 = open($fh,"<$tmp") && fileno($fh);
is($fd2,$fd,"Wrong fd number after failed open");
my $data = <$fh>;
is($data,"Hello\n","File clobbered by failed open");
close($fh);
{
package Incomplete::Module;
}
$warnings = '';
no warnings 'layer';
ok( ! open($fh,">via(Incomplete::Module)", $tmp), 'open via Incomplete::Module will fail');
is( $warnings, "", "don't warn about unknown package" );
$warnings = '';
no warnings 'layer';
ok( ! open($fh,">via(Unknown::Module)", $tmp), 'open via Unknown::Module will fail');
is( $warnings, "", "don't warn about unknown package" );
}
my $obj = '';
sub Foo::PUSHED { $obj = shift; -1; }
sub PerlIO::via::Bar::PUSHED { $obj = shift; -1; }
open $fh, '<:via(Foo)', "foo";
is( $obj, 'Foo', 'search for package Foo' );
open $fh, '<:via(Bar)', "bar";
is( $obj, 'PerlIO::via::Bar', 'search for package PerlIO::via::Bar' );
END {
1 while unlink $tmp;
}
--- NEW FILE: fail.t ---
#!./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);
--- NEW FILE: PerlIO.t ---
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;
}
More information about the dslinux-commit
mailing list