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,"&#8364;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