dslinux/user/perl/t/io argv.t binmode.t crlf.t crlf_through.t dup.t fflush.t fs.t inplace.t iprefix.t layers.t nargv.t open.t openpid.t pipe.t print.t read.t tell.t through.t utf8.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:51 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/t/io
In directory antilope:/tmp/cvs-serv17422/t/io
Added Files:
argv.t binmode.t crlf.t crlf_through.t dup.t fflush.t fs.t
inplace.t iprefix.t layers.t nargv.t open.t openpid.t pipe.t
print.t read.t tell.t through.t utf8.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: open.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
# Cheat. Until we figure out a solution for BEGIN blocks not setting a new
# stack (and thus perl API calls possibly moving the stack by extending it)
# which doesn't in turn break calling exit from inside a signal handler inside
# a BEGIN block.
eval {require Errno};
$| = 1;
use warnings;
use Config;
$Is_VMS = $^O eq 'VMS';
$Is_MacOS = $^O eq 'MacOS';
plan tests => 108;
my $Perl = which_perl();
{
unlink("afile") if -f "afile";
$! = 0; # the -f above will set $! if 'afile' doesn't exist.
ok( open(my $f,"+>afile"), 'open(my $f, "+>...")' );
binmode $f;
ok( -f "afile", ' its a file');
ok( (print $f "SomeData\n"), ' we can print to it');
is( tell($f), 9, ' tell()' );
ok( seek($f,0,0), ' seek set' );
$b = <$f>;
is( $b, "SomeData\n", ' readline' );
ok( -f $f, ' still a file' );
eval { die "Message" };
like( $@, qr/<\$f> line 1/, ' die message correct' );
ok( close($f), ' close()' );
ok( unlink("afile"), ' unlink()' );
}
{
ok( open(my $f,'>', 'afile'), "open(my \$f, '>', 'afile')" );
ok( (print $f "a row\n"), ' print');
ok( close($f), ' close' );
ok( -s 'afile' < 10, ' -s' );
}
{
ok( open(my $f,'>>', 'afile'), "open(my \$f, '>>', 'afile')" );
ok( (print $f "a row\n"), ' print' );
ok( close($f), ' close' );
ok( -s 'afile' > 10, ' -s' );
}
{
ok( open(my $f, '<', 'afile'), "open(my \$f, '<', 'afile')" );
my @rows = <$f>;
is( scalar @rows, 2, ' readline, list context' );
is( $rows[0], "a row\n", ' first line read' );
is( $rows[1], "a row\n", ' second line' );
ok( close($f), ' close' );
}
{
ok( -s 'afile' < 20, '-s' );
ok( open(my $f, '+<', 'afile'), 'open +<' );
my @rows = <$f>;
is( scalar @rows, 2, ' readline, list context' );
ok( seek($f, 0, 1), ' seek cur' );
ok( (print $f "yet another row\n"), ' print' );
ok( close($f), ' close' );
ok( -s 'afile' > 20, ' -s' );
unlink("afile");
}
SKIP: {
skip "open -| busted and noisy on VMS", 3 if $Is_VMS;
ok( open(my $f, '-|', <<EOC), 'open -|' );
$Perl -e "print qq(a row\\n); print qq(another row\\n)"
EOC
my @rows = <$f>;
is( scalar @rows, 2, ' readline, list context' );
ok( close($f), ' close' );
}
SKIP: {
skip "Output for |- doesn't go to shell on MacOS", 5 if $Is_MacOS;
ok( open(my $f, '|-', <<EOC), 'open |-' );
$Perl -pe "s/^not //"
EOC
my @rows = <$f>;
my $test = curr_test;
print $f "not ok $test - piped in\n";
next_test;
$test = curr_test;
print $f "not ok $test - piped in\n";
next_test;
ok( close($f), ' close' );
sleep 1;
pass('flushing');
}
ok( !eval { open my $f, '<&', 'afile'; 1; }, '<& on a non-filehandle' );
like( $@, qr/Bad filehandle:\s+afile/, ' right error' );
# local $file tests
{
unlink("afile") if -f "afile";
ok( open(local $f,"+>afile"), 'open local $f, "+>", ...' );
binmode $f;
ok( -f "afile", ' -f' );
ok( (print $f "SomeData\n"), ' print' );
is( tell($f), 9, ' tell' );
ok( seek($f,0,0), ' seek set' );
$b = <$f>;
is( $b, "SomeData\n", ' readline' );
ok( -f $f, ' still a file' );
eval { die "Message" };
like( $@, qr/<\$f> line 1/, ' proper die message' );
ok( close($f), ' close' );
unlink("afile");
}
{
ok( open(local $f,'>', 'afile'), 'open local $f, ">", ...' );
ok( (print $f "a row\n"), ' print');
ok( close($f), ' close');
ok( -s 'afile' < 10, ' -s' );
}
{
ok( open(local $f,'>>', 'afile'), 'open local $f, ">>", ...' );
ok( (print $f "a row\n"), ' print');
ok( close($f), ' close');
ok( -s 'afile' > 10, ' -s' );
}
{
ok( open(local $f, '<', 'afile'), 'open local $f, "<", ...' );
my @rows = <$f>;
is( scalar @rows, 2, ' readline list context' );
ok( close($f), ' close' );
}
ok( -s 'afile' < 20, ' -s' );
{
ok( open(local $f, '+<', 'afile'), 'open local $f, "+<", ...' );
my @rows = <$f>;
is( scalar @rows, 2, ' readline list context' );
ok( seek($f, 0, 1), ' seek cur' );
ok( (print $f "yet another row\n"), ' print' );
ok( close($f), ' close' );
ok( -s 'afile' > 20, ' -s' );
unlink("afile");
}
SKIP: {
skip "open -| busted and noisy on VMS", 3 if $Is_VMS;
ok( open(local $f, '-|', <<EOC), 'open local $f, "-|", ...' );
$Perl -e "print qq(a row\\n); print qq(another row\\n)"
EOC
my @rows = <$f>;
is( scalar @rows, 2, ' readline list context' );
ok( close($f), ' close' );
}
SKIP: {
skip "Output for |- doesn't go to shell on MacOS", 5 if $Is_MacOS;
ok( open(local $f, '|-', <<EOC), 'open local $f, "|-", ...' );
$Perl -pe "s/^not //"
EOC
my @rows = <$f>;
my $test = curr_test;
print $f "not ok $test - piping\n";
next_test;
$test = curr_test;
print $f "not ok $test - piping\n";
next_test;
ok( close($f), ' close' );
sleep 1;
pass("Flush");
}
ok( !eval { open local $f, '<&', 'afile'; 1 }, 'local <& on non-filehandle');
like( $@, qr/Bad filehandle:\s+afile/, ' right error' );
{
local *F;
for (1..2) {
ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' );
is(scalar <F>, "ok\n", ' readline');
ok( close F, ' close' );
}
for (1..2) {
ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|');
is( scalar <F>, "ok\n", ' readline');
ok( close F, ' close' );
}
}
# other dupping techniques
{
ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh');
ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh');
{
use strict; # the below should not warn
ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh');
}
# used to try to open a file [perl #17830]
ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!;
}
SKIP: {
skip "This perl uses perlio", 1 if $Config{useperlio};
skip "miniperl cannot be relied on to load %Errno"
if $ENV{PERL_CORE_MINITEST};
# Force the reference to %! to be run time by writing ! as {"!"}
skip "This system doesn't understand EINVAL", 1
unless exists ${"!"}{EINVAL};
no warnings 'io';
ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL');
}
{
ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' );
like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' );
}
{
local $SIG{__WARN__} = sub { $@ = shift };
sub gimme {
my $tmphandle = shift;
my $line = scalar <$tmphandle>;
warn "gimme";
return $line;
}
open($fh0[0], "TEST");
gimme($fh0[0]);
like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
open($fh1{k}, "TEST");
gimme($fh1{k});
like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem");
my @fh2;
open($fh2[0], "TEST");
gimme($fh2[0]);
like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
my %fh3;
open($fh3{k}, "TEST");
gimme($fh3{k});
like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
}
SKIP: {
skip("These tests use perlio", 5) unless $Config{useperlio};
my $w;
use warnings 'layer';
local $SIG{__WARN__} = sub { $w = shift };
eval { open(F, ">>>", "afile") };
like($w, qr/Invalid separator character '>' in PerlIO layer spec/,
"bad open (>>>) warning");
like($@, qr/Unknown open\(\) mode '>>>'/,
"bad open (>>>) failure");
eval { open(F, ">:u", "afile" ) };
like($w, qr/Unknown PerlIO layer "u"/,
'bad layer ">:u" warning');
eval { open(F, "<:u", "afile" ) };
like($w, qr/Unknown PerlIO layer "u"/,
'bad layer "<:u" warning');
eval { open(F, ":c", "afile" ) };
like($@, qr/Unknown open\(\) mode ':c'/,
'bad layer ":c" failure');
}
# [perl #28986] "open m" crashes Perl
fresh_perl_like('open m', qr/^Search pattern not terminated at/,
{ stderr => 1 }, 'open m test');
fresh_perl_is(
'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"',
'ok', { stderr => 1 },
'#29102: Crash on assignment to lexical filehandle');
# [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise
# an exception
eval { open $99, "foo" };
like($@, qr/Modification of a read-only value attempted/, "readonly fh");
--- NEW FILE: argv.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
require "./test.pl";
plan(tests => 22);
use File::Spec;
my $devnull = File::Spec->devnull;
open(TRY, '>Io_argv1.tmp') || (die "Can't open temp file: $!");
print TRY "a line\n";
close TRY or die "Could not close: $!";
$x = runperl(
prog => 'while (<>) { print $., $_; }',
args => [ 'Io_argv1.tmp', 'Io_argv1.tmp' ],
);
is($x, "1a line\n2a line\n", '<> from two files');
{
$x = runperl(
prog => 'while (<>) { print $_; }',
stdin => "foo\n",
args => [ 'Io_argv1.tmp', '-' ],
);
is($x, "a line\nfoo\n", ' from a file and STDIN');
$x = runperl(
prog => 'while (<>) { print $_; }',
stdin => "foo\n",
);
is($x, "foo\n", ' from just STDIN');
}
@ARGV = ('Io_argv1.tmp', 'Io_argv1.tmp', $devnull, 'Io_argv1.tmp');
while (<>) {
$y .= $. . $_;
if (eof()) {
is($., 3, '$. counts <>');
}
}
is($y, "1a line\n2a line\n3a line\n", '<> from @ARGV');
open(TRY, '>Io_argv1.tmp') or die "Can't open temp file: $!";
close TRY or die "Could not close: $!";
open(TRY, '>Io_argv2.tmp') or die "Can't open temp file: $!";
close TRY or die "Could not close: $!";
@ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp');
$^I = '_bak'; # not .bak which confuses VMS
$/ = undef;
my $i = 6;
while (<>) {
s/^/ok $i\n/;
++$i;
print;
next_test();
}
open(TRY, '<Io_argv1.tmp') or die "Can't open temp file: $!";
print while <TRY>;
open(TRY, '<Io_argv2.tmp') or die "Can't open temp file: $!";
print while <TRY>;
close TRY or die "Could not close: $!";
undef $^I;
ok( eof TRY );
{
no warnings 'once';
ok( eof NEVEROPENED, 'eof() true on unopened filehandle' );
}
open STDIN, 'Io_argv1.tmp' or die $!;
@ARGV = ();
ok( !eof(), 'STDIN has something' );
is( <>, "ok 6\n" );
open STDIN, $devnull or die $!;
@ARGV = ();
ok( eof(), 'eof() true with empty @ARGV' );
@ARGV = ('Io_argv1.tmp');
ok( !eof() );
@ARGV = ($devnull, $devnull);
ok( !eof() );
close ARGV or die $!;
ok( eof(), 'eof() true after closing ARGV' );
{
local $/;
open F, 'Io_argv1.tmp' or die "Could not open Io_argv1.tmp: $!";
<F>; # set $. = 1
is( <F>, undef );
open F, $devnull or die;
ok( defined(<F>) );
is( <F>, undef );
is( <F>, undef );
open F, $devnull or die; # restart cycle again
ok( defined(<F>) );
is( <F>, undef );
close F or die "Could not close: $!";
}
# This used to dump core
fresh_perl_is( <<'**PROG**', "foobar", {}, "ARGV aliasing and eof()" );
open OUT, ">Io_argv3.tmp" or die "Can't open temp file: $!";
print OUT "foo";
close OUT;
open IN, "Io_argv3.tmp" or die "Can't open temp file: $!";
*ARGV = *IN;
while (<>) {
print;
print "bar" if eof();
}
close IN;
unlink "Io_argv3.tmp";
**PROG**
END {
1 while unlink 'Io_argv1.tmp', 'Io_argv1.tmp_bak',
'Io_argv2.tmp', 'Io_argv2.tmp_bak', 'Io_argv3.tmp';
}
--- NEW FILE: dup.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
require "./test.pl";
}
use Config;
no warnings 'once';
my $test = 1;
print "1..26\n";
print "ok 1\n";
open(DUPOUT,">&STDOUT");
open(DUPERR,">&STDERR");
open(STDOUT,">Io.dup") || die "Can't open stdout";
open(STDERR,">&STDOUT") || die "Can't open stderr";
select(STDERR); $| = 1;
select(STDOUT); $| = 1;
print STDOUT "ok 2\n";
print STDERR "ok 3\n";
# Since some systems don't have echo, we use Perl.
$echo = qq{$^X -le "print q(ok %d)"};
$cmd = sprintf $echo, 4;
print `$cmd`;
$cmd = sprintf "$echo 1>&2", 5;
$cmd = sprintf $echo, 5 if $^O eq 'MacOS'; # don't know if we can do this ...
print `$cmd`;
# KNOWN BUG system() does not honor STDOUT redirections on VMS.
if( $^O eq 'VMS' ) {
print "not ok $_ # TODO system() not honoring STDOUT redirect on VMS\n"
for 6..7;
}
else {
system sprintf $echo, 6;
if ($^O eq 'MacOS') {
system sprintf $echo, 7;
}
else {
system sprintf "$echo 1>&2", 7;
}
}
close(STDOUT) or die "Could not close: $!";
close(STDERR) or die "Could not close: $!";
open(STDOUT,">&DUPOUT") or die "Could not open: $!";
open(STDERR,">&DUPERR") or die "Could not open: $!";
if (($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'VMS')) { print `type Io.dup` }
elsif ($^O eq 'MacOS') { system 'catenate Io.dup' }
else { system 'cat Io.dup' }
unlink 'Io.dup';
print STDOUT "ok 8\n";
open(F,">&",1) or die "Cannot dup to numeric 1: $!";
print F "ok 9\n";
close(F);
open(F,">&",'1') or die "Cannot dup to string '1': $!";
print F "ok 10\n";
close(F);
open(F,">&=",1) or die "Cannot dup to numeric 1: $!";
print F "ok 11\n";
close(F);
if ($Config{useperlio}) {
open(F,">&=",'1') or die "Cannot dup to string '1': $!";
print F "ok 12\n";
close(F);
} else {
open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!";
print F "ok 12\n";
close(F);
}
# To get STDOUT back.
open(F, ">&DUPOUT") or die "Cannot dup stdout back: $!";
curr_test(13);
SKIP: {
skip("need perlio", 14) unless $Config{useperlio};
ok(open(F, ">&", STDOUT));
isnt(fileno(F), fileno(STDOUT));
close F;
ok(open(F, "<&=STDIN")) or _diag $!;
is(fileno(F), fileno(STDIN));
close F;
ok(open(F, ">&=STDOUT"));
is(fileno(F), fileno(STDOUT));
close F;
ok(open(F, ">&=STDERR"));
is(fileno(F), fileno(STDERR));
close F;
open(G, ">dup$$") or die;
my $g = fileno(G);
ok(open(F, ">&=$g"));
is(fileno(F), $g);
close F;
ok(open(F, ">&=G"));
is(fileno(F), $g);
print G "ggg\n";
print F "fff\n";
close G; # flush first
close F; # flush second
open(G, "<dup$$") or die;
{
my $line;
$line = <G>; chomp $line; is($line, "ggg");
$line = <G>; chomp $line; is($line, "fff");
}
close G;
END { 1 while unlink "dup$$" }
}
--- NEW FILE: pipe.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
require './test.pl';
if (!$Config{'d_fork'}) {
skip_all("fork required to pipe");
}
else {
plan(tests => 22);
}
}
my $Perl = which_perl();
$| = 1;
open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
printf PIPE "Xk %d - open |- || exec\n", curr_test();
next_test();
printf PIPE "oY %d - again\n", curr_test();
next_test();
close PIPE;
SKIP: {
# Technically this should be TODO. Someone try it if you happen to
# have a vmesa machine.
skip "Doesn't work here yet", 4 if $^O eq 'vmesa';
if (open(PIPE, "-|")) {
while(<PIPE>) {
s/^not //;
print;
}
close PIPE; # avoid zombies
}
else {
printf STDOUT "not ok %d - open -|\n", curr_test();
next_test();
my $tnum = curr_test;
next_test();
exec $Perl, '-le', "print q{not ok $tnum - again}";
}
# This has to be *outside* the fork
next_test() for 1..2;
SKIP: {
skip "fork required", 2 unless $Config{d_fork};
pipe(READER,WRITER) || die "Can't open pipe";
if ($pid = fork) {
close WRITER;
while(<READER>) {
s/^not //;
y/A-Z/a-z/;
print;
}
close READER; # avoid zombies
}
else {
die "Couldn't fork" unless defined $pid;
close READER;
printf WRITER "not ok %d - pipe & fork\n", curr_test;
next_test;
open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
close WRITER;
my $tnum = curr_test;
next_test;
exec $Perl, '-le', "print q{not ok $tnum - with fh dup }";
}
# This has to be done *outside* the fork.
next_test() for 1..2;
}
}
wait; # Collect from $pid
pipe(READER,WRITER) || die "Can't open pipe";
close READER;
$SIG{'PIPE'} = 'broken_pipe';
sub broken_pipe {
$SIG{'PIPE'} = 'IGNORE'; # loop preventer
printf "ok %d - SIGPIPE\n", curr_test;
}
printf WRITER "not ok %d - SIGPIPE\n", curr_test;
close WRITER;
sleep 1;
next_test;
pass();
# VMS doesn't like spawning subprocesses that are still connected to
# STDOUT. Someone should modify these tests to work with VMS.
SKIP: {
skip "doesn't like spawning subprocesses that are still connected", 10
if $^O eq 'VMS';
SKIP: {
# Sfio doesn't report failure when closing a broken pipe
# that has pending output. Go figure. MachTen doesn't either,
# but won't write to broken pipes, so nothing's pending at close.
# BeOS will not write to broken pipes, either.
# Nor does POSIX-BC.
skip "Won't report failure on broken pipe", 1
if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' ||
$^O eq 'posix-bc';
local $SIG{PIPE} = 'IGNORE';
open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
sleep 5;
if (print NIL 'foo') {
# If print was allowed we had better get an error on close
ok( !close NIL, 'close error on broken pipe' );
}
else {
ok(close NIL, 'print failed on broken pipe');
}
}
SKIP: {
skip "Don't work yet", 9 if $^O eq 'vmesa';
# check that errno gets forced to 0 if the piped program exited
# non-zero
open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
$! = 1;
ok(!close NIL, 'close failure on non-zero piped exit');
is($!, '', ' errno');
isnt($?, 0, ' status');
SKIP: {
skip "Don't work yet", 6 if $^O eq 'mpeix';
# check that status for the correct process is collected
my $zombie;
unless( $zombie = fork ) {
$NO_ENDING=1;
exit 37;
}
my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
$SIG{ALRM} = sub { return };
alarm(1);
is( close FH, '', 'close failure for... umm, something' );
is( $?, 13*256, ' status' );
is( $!, '', ' errno');
my $wait = wait;
is( $?, 37*256, 'status correct after wait' );
is( $wait, $zombie, ' wait pid' );
is( $!, '', ' errno');
}
}
}
# Test new semantics for missing command in piped open
# 19990114 M-J. Dominus mjd at plover.com
{ local *P;
ok( !open(P, "| "), 'missing command in piped open input' );
ok( !open(P, " |"), ' output');
}
# check that status is unaffected by implicit close
{
local(*NIL);
open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
$? = 42;
# NIL implicitly closed here
}
is($?, 42, 'status unaffected by implicit close');
$? = 0;
# check that child is reaped if the piped program can't be executed
SKIP: {
skip "/no_such_process exists", 1 if -e "/no_such_process";
open NIL, '/no_such_process |';
close NIL;
my $child = 0;
eval {
local $SIG{ALRM} = sub { die; };
alarm 2;
$child = wait;
alarm 0;
};
is($child, -1, 'child reaped if piped program cannot be executed');
}
--- NEW FILE: crlf.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
}
use Config;
require "test.pl";
my $file = "crlf$$.dat";
END {
1 while unlink($file);
}
if (find PerlIO::Layer 'perlio') {
plan(tests => 16);
ok(open(FOO,">:crlf",$file));
ok(print FOO 'a'.((('a' x 14).qq{\n}) x 2000) || close(FOO));
ok(open(FOO,"<:crlf",$file));
my $text;
{ local $/; $text = <FOO> }
is(count_chars($text, "\015\012"), 0);
is(count_chars($text, "\n"), 2000);
binmode(FOO);
seek(FOO,0,0);
{ local $/; $text = <FOO> }
is(count_chars($text, "\015\012"), 2000);
SKIP:
{
skip("miniperl can't rely on loading PerlIO::scalar")
if $ENV{PERL_CORE_MINITEST};
skip("no PerlIO::scalar") unless $Config{extensions} =~ m!\bPerlIO/scalar\b!;
require PerlIO::scalar;
my $fcontents = join "", map {"$_\015\012"} "a".."zzz";
open my $fh, "<:crlf", \$fcontents;
local $/ = "xxx";
local $_ = <$fh>;
my $pos = tell $fh; # pos must be behind "xxx", before "\nxxy\n"
seek $fh, $pos, 0;
$/ = "\n";
$s = <$fh>.<$fh>;
ok($s eq "\nxxy\n");
}
ok(close(FOO));
# binmode :crlf should not cumulate.
# Try it first once and then twice so that even UNIXy boxes
# get to exercise this, for DOSish boxes even once is enough.
# Try also pushing :utf8 first so that there are other layers
# in between (this should not matter: CRLF layers still should
# not accumulate).
for my $utf8 ('', ':utf8') {
for my $binmode (1..2) {
open(FOO, ">$file");
# require PerlIO; print PerlIO::get_layers(FOO), "\n";
binmode(FOO, "$utf8:crlf") for 1..$binmode;
# require PerlIO; print PerlIO::get_layers(FOO), "\n";
print FOO "Hello\n";
close FOO;
open(FOO, "<$file");
binmode(FOO);
my $foo = scalar <FOO>;
close FOO;
print join(" ", "#", map { sprintf("%02x", $_) } unpack("C*", $foo)),
"\n";
ok($foo =~ /\x0d\x0a$/);
ok($foo !~ /\x0d\x0d/);
}
}
}
else {
skip_all("No perlio, so no :crlf");
}
sub count_chars {
my($text, $chars) = @_;
my $seen = 0;
$seen++ while $text =~ /$chars/g;
return $seen;
}
--- NEW FILE: layers.t ---
#!./perl
my $PERLIO;
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
eval 'use Encode';
if ($@ =~ /dynamic loading not available/) {
print "1..0 # miniperl cannot load Encode\n";
exit 0;
}
# Makes testing easier.
$ENV{PERLIO} = 'stdio' if exists $ENV{PERLIO} && $ENV{PERLIO} eq '';
if (exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/) {
# We are not prepared for anything else.
print "1..0 # PERLIO='$ENV{PERLIO}' unknown\n";
exit 0;
}
$PERLIO = exists $ENV{PERLIO} ? $ENV{PERLIO} : "(undef)";
}
use Config;
my $DOSISH = $^O =~ /^(?:MSWin32|os2|dos|NetWare|mint)$/ ? 1 : 0;
$DOSISH = 1 if !$DOSISH and $^O =~ /^uwin/;
my $NONSTDIO = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio' ? 1 : 0;
my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio} ? 1 : 0;
my $UNICODE_STDIN;
if (${^UNICODE} & 1) {
if (${^UNICODE} & 64) {
# Conditional on the locale
$UNICODE_STDIN = ${^UTF8LOCALE};
} else {
# Unconditional
$UNICODE_STDIN = 1;
}
} else {
$UNICODE_STDIN = 0;
}
my $NTEST = 44 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 5 : 0)
+ $UNICODE_STDIN;
sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h
plan tests => $NTEST;
print <<__EOH__;
# PERLIO = $PERLIO
# DOSISH = $DOSISH
# NONSTDIO = $NONSTDIO
# FASTSTDIO = $FASTSTDIO
# UNICODE = ${^UNICODE}
# UTF8LOCALE = ${^UTF8LOCALE}
# UNICODE_STDIN = $UNICODE_STDIN
__EOH__
SKIP: {
# FIXME - more of these could be tested without Encode or full perl
skip("This perl does not have Encode", $NTEST)
unless " $Config{extensions} " =~ / Encode /;
skip("miniperl does not have Encode", $NTEST) if $ENV{PERL_CORE_MINITEST};
sub check {
my ($result, $expected, $id) = @_;
# An interesting dance follows where we try to make the following
# IO layer stack setups to compare equal:
#
# PERLIO UNIX-like DOS-like
#
# unset / "" unix perlio / stdio [1] unix crlf
# stdio unix perlio / stdio [1] stdio
# perlio unix perlio unix perlio
# mmap unix mmap unix mmap
#
# [1] "stdio" if Configure found out how to do "fast stdio" (depends
# on the stdio implementation) and in Perl 5.8, otherwise "unix perlio"
#
if ($NONSTDIO) {
# Get rid of "unix".
shift @$result if $result->[0] eq "unix";
# Change expectations.
if ($FASTSTDIO) {
$expected->[0] = $ENV{PERLIO};
} else {
$expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio";
}
} elsif (!$FASTSTDIO && !$DOSISH) {
splice(@$result, 0, 2, "stdio")
if @$result >= 2 &&
$result->[0] eq "unix" &&
$result->[1] eq "perlio";
} elsif ($DOSISH) {
splice(@$result, 0, 2, "stdio")
if @$result >= 2 &&
$result->[0] eq "unix" &&
$result->[1] eq "crlf";
}
if ($DOSISH && grep { $_ eq 'crlf' } @$expected) {
# 5 tests potentially skipped because
# DOSISH systems already have a CRLF layer
# which will make new ones not stick.
@$expected = grep { $_ ne 'crlf' } @$expected;
}
my $n = scalar @$expected;
is(scalar @$result, $n, "$id - layers == $n");
for (my $i = 0; $i < $n; $i++) {
my $j = $expected->[$i];
if (ref $j eq 'CODE') {
ok($j->($result->[$i]), "$id - $i is ok");
} else {
is($result->[$i], $j,
sprintf("$id - $i is %s",
defined $j ? $j : "undef"));
}
}
}
check([ PerlIO::get_layers(STDIN) ],
$UNICODE_STDIN ? [ "stdio", "utf8" ] : [ "stdio" ],
"STDIN");
open(F, ">:crlf", "afile");
check([ PerlIO::get_layers(F) ],
[ qw(stdio crlf) ],
"open :crlf");
binmode(F, ":encoding(sjis)"); # "sjis" will be canonized to "shiftjis"
check([ PerlIO::get_layers(F) ],
[ qw[stdio crlf encoding(shiftjis) utf8] ],
":encoding(sjis)");
binmode(F, ":pop");
check([ PerlIO::get_layers(F) ],
[ qw(stdio crlf) ],
":pop");
binmode(F, ":raw");
check([ PerlIO::get_layers(F) ],
[ "stdio" ],
":raw");
binmode(F, ":utf8");
check([ PerlIO::get_layers(F) ],
[ qw(stdio utf8) ],
":utf8");
binmode(F, ":bytes");
check([ PerlIO::get_layers(F) ],
[ "stdio" ],
":bytes");
binmode(F, ":encoding(utf8)");
check([ PerlIO::get_layers(F) ],
[ qw[stdio encoding(utf8) utf8] ],
":encoding(utf8)");
binmode(F, ":raw :crlf");
check([ PerlIO::get_layers(F) ],
[ qw(stdio crlf) ],
":raw:crlf");
binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized
# 7 tests potentially skipped.
unless ($DOSISH || !$FASTSTDIO) {
my @results = PerlIO::get_layers(F, details => 1);
# Get rid of the args and the flags.
splice(@results, 1, 2) if $NONSTDIO;
check([ @results ],
[ "stdio", undef, sub { $_[0] > 0 },
"encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ],
":raw:encoding(latin1)");
}
binmode(F);
check([ PerlIO::get_layers(F) ],
[ "stdio" ],
"binmode");
close F;
{
use open(IN => ":crlf", OUT => ":encoding(cp1252)");
open F, "<afile";
open G, ">afile";
check([ PerlIO::get_layers(F, input => 1) ],
[ qw(stdio crlf) ],
"use open IN");
check([ PerlIO::get_layers(G, output => 1) ],
[ qw[stdio encoding(cp1252) utf8] ],
"use open OUT");
close F;
close G;
}
# Check that PL_sigwarn's reference count is correct, and that
# &PerlIO::Layer::NoWarnings isn't prematurely freed.
fresh_perl_like (<<'EOT', qr/^CODE/);
open(UTF, "<:raw:encoding(utf8)", "afile") or die $!;
print ref *PerlIO::Layer::NoWarnings{CODE};
EOT
1 while unlink "afile";
}
--- NEW FILE: utf8.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
unless (find PerlIO::Layer 'perlio') {
print "1..0 # Skip: not perlio\n";
exit 0;
}
}
no utf8; # needed for use utf8 not griping about the raw octets
require "./test.pl";
plan(tests => 55);
$| = 1;
open(F,"+>:utf8",'a');
print F chr(0x100).'£';
cmp_ok( tell(F), '==', 4, tell(F) );
print F "\n";
cmp_ok( tell(F), '>=', 5, tell(F) );
seek(F,0,0);
is( getc(F), chr(0x100) );
is( getc(F), "£" );
is( getc(F), "\n" );
seek(F,0,0);
binmode(F,":bytes");
my $chr = chr(0xc4);
if (ord('A') == 193) { $chr = chr(0x8c); } # EBCDIC
is( getc(F), $chr );
$chr = chr(0x80);
if (ord('A') == 193) { $chr = chr(0x41); } # EBCDIC
is( getc(F), $chr );
$chr = chr(0xc2);
if (ord('A') == 193) { $chr = chr(0x80); } # EBCDIC
is( getc(F), $chr );
$chr = chr(0xa3);
if (ord('A') == 193) { $chr = chr(0x44); } # EBCDIC
is( getc(F), $chr );
is( getc(F), "\n" );
seek(F,0,0);
binmode(F,":utf8");
is( scalar(<F>), "\x{100}£\n" );
seek(F,0,0);
$buf = chr(0x200);
$count = read(F,$buf,2,1);
cmp_ok( $count, '==', 2 );
is( $buf, "\x{200}\x{100}£" );
close(F);
{
$a = chr(300); # This *is* UTF-encoded
$b = chr(130); # This is not.
open F, ">:utf8", 'a' or die $!;
print F $a,"\n";
close F;
open F, "<:utf8", 'a' or die $!;
$x = <F>;
chomp($x);
is( $x, chr(300) );
open F, "a" or die $!; # Not UTF
binmode(F, ":bytes");
$x = <F>;
chomp($x);
$chr = chr(196).chr(172);
if (ord('A') == 193) { $chr = chr(141).chr(83); } # EBCDIC
is( $x, $chr );
close F;
open F, ">:utf8", 'a' or die $!;
binmode(F); # we write a "\n" and then tell() - avoid CRLF issues.
binmode(F,":utf8"); # turn UTF-8-ness back on
print F $a;
my $y;
{ my $x = tell(F);
{ use bytes; $y = length($a);}
cmp_ok( $x, '==', $y );
}
{ # Check byte length of $b
use bytes; my $y = length($b);
cmp_ok( $y, '==', 1 );
}
print F $b,"\n"; # Don't upgrades $b
{ # Check byte length of $b
use bytes; my $y = length($b);
cmp_ok( $y, '==', 1 );
}
{
my $x = tell(F);
{ use bytes; if (ord('A')==193){$y += 2;}else{$y += 3;}} # EBCDIC ASCII
cmp_ok( $x, '==', $y );
}
close F;
open F, "a" or die $!; # Not UTF
binmode(F, ":bytes");
$x = <F>;
chomp($x);
$chr = v196.172.194.130;
if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
is( $x, $chr, sprintf('(%vd)', $x) );
open F, "<:utf8", "a" or die $!;
$x = <F>;
chomp($x);
close F;
is( $x, chr(300).chr(130), sprintf('(%vd)', $x) );
open F, ">", "a" or die $!;
if (${^OPEN} =~ /:utf8/) {
binmode(F, ":bytes:");
}
# Now let's make it suffer.
my $w;
{
use warnings 'utf8';
local $SIG{__WARN__} = sub { $w = $_[0] };
print F $a;
ok( (!$@));
like($w, qr/Wide character in print/i );
}
}
# Hm. Time to get more evil.
open F, ">:utf8", "a" or die $!;
print F $a;
binmode(F, ":bytes");
print F chr(130)."\n";
close F;
open F, "<", "a" or die $!;
binmode(F, ":bytes");
$x = <F>; chomp $x;
$chr = v196.172.130;
if (ord('A') == 193) { $chr = v141.83.130; } # EBCDIC
is( $x, $chr );
# Right.
open F, ">:utf8", "a" or die $!;
print F $a;
close F;
open F, ">>", "a" or die $!;
binmode(F, ":bytes");
print F chr(130)."\n";
close F;
open F, "<", "a" or die $!;
binmode(F, ":bytes");
$x = <F>; chomp $x;
SKIP: {
skip("Defaulting to UTF-8 output means that we can't generate a mangled file")
if $UTF8_OUTPUT;
is( $x, $chr );
}
# Now we have a deformed file.
SKIP: {
if (ord('A') == 193) {
skip("EBCDIC doesn't complain", 2);
} else {
my @warnings;
open F, "<:utf8", "a" or die $!;
$x = <F>; chomp $x;
local $SIG{__WARN__} = sub { push @warnings, $_[0]; };
eval { sprintf "%vd\n", $x };
is (scalar @warnings, 1);
like ($warnings[0], qr/Malformed UTF-8 character \(unexpected continuation byte 0x82, with no preceding start byte/);
}
}
close F;
unlink('a');
open F, ">:utf8", "a";
@a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
unshift @a, chr(0); # ... and a null byte in front just for fun
print F @a;
close F;
my $c;
# read() should work on characters, not bytes
open F, "<:utf8", "a";
$a = 0;
my $failed;
for (@a) {
unless (($c = read(F, $b, 1) == 1) &&
length($b) == 1 &&
ord($b) == ord($_) &&
tell(F) == ($a += bytes::length($b))) {
print '# ord($_) == ', ord($_), "\n";
print '# ord($b) == ', ord($b), "\n";
print '# length($b) == ', length($b), "\n";
print '# bytes::length($b) == ', bytes::length($b), "\n";
print '# tell(F) == ', tell(F), "\n";
print '# $a == ', $a, "\n";
print '# $c == ', $c, "\n";
$failed++;
last;
}
}
close F;
is($failed, undef);
{
# Check that warnings are on on I/O, and that they can be muffled.
local $SIG{__WARN__} = sub { $@ = shift };
undef $@;
open F, ">a";
binmode(F, ":bytes");
print F chr(0x100);
close(F);
like( $@, 'Wide character in print' );
undef $@;
open F, ">:utf8", "a";
print F chr(0x100);
close(F);
isnt( defined $@ );
undef $@;
open F, ">a";
binmode(F, ":utf8");
print F chr(0x100);
close(F);
isnt( defined $@ );
no warnings 'utf8';
undef $@;
open F, ">a";
print F chr(0x100);
close(F);
isnt( defined $@ );
use warnings 'utf8';
undef $@;
open F, ">a";
binmode(F, ":bytes");
print F chr(0x100);
close(F);
like( $@, 'Wide character in print' );
}
{
open F, ">:bytes","a"; print F "\xde"; close F;
open F, "<:bytes", "a";
my $b = chr 0x100;
$b .= <F>;
is( $b, chr(0x100).chr(0xde), "21395 '.= <>' utf8 vs. bytes" );
close F;
}
{
open F, ">:utf8","a"; print F chr 0x100; close F;
open F, "<:utf8", "a";
my $b = "\xde";
$b .= <F>;
is( $b, chr(0xde).chr(0x100), "21395 '.= <>' bytes vs. utf8" );
close F;
}
{
my @a = ( [ 0x007F, "bytes" ],
[ 0x0080, "bytes" ],
[ 0x0080, "utf8" ],
[ 0x0100, "utf8" ] );
my $t = 34;
for my $u (@a) {
for my $v (@a) {
# print "# @$u - @$v\n";
open F, ">a";
binmode(F, ":" . $u->[1]);
print F chr($u->[0]);
close F;
open F, "<a";
binmode(F, ":" . $u->[1]);
my $s = chr($v->[0]);
utf8::upgrade($s) if $v->[1] eq "utf8";
$s .= <F>;
is( $s, chr($v->[0]) . chr($u->[0]), 'rcatline utf8' );
close F;
$t++;
}
}
# last test here 49
}
{
# [perl #23428] Somethings rotten in unicode semantics
open F, ">a";
binmode F, ":utf8";
syswrite(F, $a = chr(0x100));
close F;
is( ord($a), 0x100, '23428 syswrite should not downgrade scalar' );
like( $a, qr/^\w+/, '23428 syswrite should not downgrade scalar' );
}
# sysread() and syswrite() tested in lib/open.t since Fcntl is used
{
# <FH> on a :utf8 stream should complain immediately with -w
# if it finds bad UTF-8 (:encoding(utf8) works this way)
use warnings 'utf8';
undef $@;
local $SIG{__WARN__} = sub { $@ = shift };
open F, ">a";
binmode F;
my ($chrE4, $chrF6) = (chr(0xE4), chr(0xF6));
if (ord('A') == 193) # EBCDIC
{ ($chrE4, $chrF6) = (chr(0x43), chr(0xEC)); }
print F "foo", $chrE4, "\n";
print F "foo", $chrF6, "\n";
close F;
open F, "<:utf8", "a";
undef $@;
my $line = <F>;
my ($chrE4, $chrF6) = ("E4", "F6");
if (ord('A') == 193) { ($chrE4, $chrF6) = ("43", "EC"); } # EBCDIC
like( $@, qr/utf8 "\\x$chrE4" does not map to Unicode .+ <F> line 1/,
"<:utf8 readline must warn about bad utf8");
undef $@;
$line .= <F>;
like( $@, qr/utf8 "\\x$chrF6" does not map to Unicode .+ <F> line 2/,
"<:utf8 rcatline must warn about bad utf8");
close F;
}
END {
1 while unlink "a";
1 while unlink "b";
}
--- NEW FILE: crlf_through.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
no warnings 'once';
$main::use_crlf = 1;
do './io/through.t' or die "no kid script";
--- NEW FILE: read.t ---
#!./perl
# $RCSfile: read.t,v $
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
use strict;
eval 'use Errno';
die $@ if $@ and !$ENV{PERL_CORE_MINITEST};
plan tests => 2;
open(A,"+>a");
print A "_";
seek(A,0,0);
my $b = "abcd";
$b = "";
read(A,$b,1,4);
close(A);
unlink("a");
is($b,"\000\000\000\000_"); # otherwise probably "\000bcd_"
unlink 'a';
SKIP: {
skip "no EBADF", 1 if (!exists &Errno::EBADF);
$! = 0;
read(B,$b,1);
ok($! == &Errno::EBADF);
}
--- NEW FILE: nargv.t ---
#!./perl
print "1..5\n";
my $j = 1;
for $i ( 1,2,5,4,3 ) {
$file = mkfiles($i);
open(FH, "> $file") || die "can't create $file: $!";
print FH "not ok " . $j++ . "\n";
close(FH) || die "Can't close $file: $!";
}
{
local *ARGV;
local $^I = '.bak';
local $_;
@ARGV = mkfiles(1..3);
$n = 0;
while (<>) {
print STDOUT "# initial \@ARGV: [@ARGV]\n";
if ($n++ == 2) {
other();
}
show();
}
}
$^I = undef;
@ARGV = mkfiles(1..3);
$n = 0;
while (<>) {
print STDOUT "#final \@ARGV: [@ARGV]\n";
if ($n++ == 2) {
other();
}
show();
}
sub show {
#warn "$ARGV: $_";
s/^not //;
print;
}
sub other {
print STDOUT "# Calling other\n";
local *ARGV;
local *ARGVOUT;
local $_;
@ARGV = mkfiles(5, 4);
while (<>) {
print STDOUT "# inner \@ARGV: [@ARGV]\n";
show();
}
}
sub mkfiles {
my @files = map { "scratch$_" } @_;
return wantarray ? @files : $files[-1];
}
END { unlink map { ($_, "$_.bak") } mkfiles(1..5) }
--- NEW FILE: inplace.t ---
#!./perl
$^I = $^O eq 'VMS' ? '_bak' : '.bak';
# $RCSfile: inplace.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:01:48 $
print "1..2\n";
@ARGV = ('.a','.b','.c');
if ($^O eq 'MSWin32') {
$CAT = '.\perl -e "print<>"';
`.\\perl -le "print 'foo'" > .a`;
`.\\perl -le "print 'foo'" > .b`;
`.\\perl -le "print 'foo'" > .c`;
}
elsif ($^O eq 'NetWare') {
$CAT = 'perl -e "print<>"';
`perl -le "print 'foo'" > .a`;
`perl -le "print 'foo'" > .b`;
`perl -le "print 'foo'" > .c`;
}
elsif ($^O eq 'MacOS') {
$CAT = "$^X -e \"print<>\"";
`$^X -le "print 'foo'" > .a`;
`$^X -le "print 'foo'" > .b`;
`$^X -le "print 'foo'" > .c`;
}
elsif ($^O eq 'VMS') {
$CAT = 'MCR []perl. -e "print<>"';
`MCR []perl. -le "print 'foo'" > ./.a`;
`MCR []perl. -le "print 'foo'" > ./.b`;
`MCR []perl. -le "print 'foo'" > ./.c`;
}
else {
$CAT = 'cat';
`echo foo | tee .a .b .c`;
}
while (<>) {
s/foo/bar/;
}
continue {
print;
}
if (`$CAT .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";}
if (`$CAT .a$^I .b$^I .c$^I` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
unlink '.a', '.b', '.c', ".a$^I", ".b$^I", ".c$^I";
--- NEW FILE: print.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use strict 'vars';
eval 'use Errno';
die $@ if $@ and !$ENV{PERL_CORE_MINITEST};
print "1..21\n";
my $foo = 'STDOUT';
print $foo "ok 1\n";
print "ok 2\n","ok 3\n","ok 4\n";
print STDOUT "ok 5\n";
open(foo,">-");
print foo "ok 6\n";
printf "ok %d\n",7;
printf("ok %d\n",8);
my @a = ("ok %d%c",9,ord("\n"));
printf @a;
$a[1] = 10;
printf STDOUT @a;
$, = ' ';
$\ = "\n";
print "ok","11";
my @x = ("ok","12\nok","13\nok");
my @y = ("15\nok","16");
print @x,"14\nok", at y;
{
local $\ = "ok 17\n# null =>[\000]\nok 18\n";
print "";
}
$\ = '';
if (!exists &Errno::EBADF) {
print "ok 19 # skipped: no EBADF\n";
} else {
$! = 0;
print NONEXISTENT "foo";
print "not " if ($! != &Errno::EBADF);
print "ok 19\n";
}
{
# Change 26009: pp_print didn't extend the stack
# before pushing its return value
# to make sure only that these obfuscated sentences will not crash.
map print(reverse), ('')x68;
print "ok 20\n";
map print(+()), ('')x68;
print "ok 21\n";
}
--- NEW FILE: fflush.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
# Script to test auto flush on fork/exec/system/qx. The idea is to
# print "Pe" to a file from a parent process and "rl" to the same file
# from a child process. If buffers are flushed appropriately, the
# file should contain "Perl". We'll see...
use Config;
use warnings;
use strict;
# This attempts to mirror the #ifdef forest found in perl.h so that we
# know when to run these tests. If that forest ever changes, change
# it here too or expect test gratuitous test failures.
my $useperlio = defined $Config{useperlio} ? $Config{useperlio} eq 'define' ? 1 : 0 : 0;
my $fflushNULL = defined $Config{fflushNULL} ? $Config{fflushNULL} eq 'define' ? 1 : 0 : 0;
my $d_sfio = defined $Config{d_sfio} ? $Config{d_sfio} eq 'define' ? 1 : 0 : 0;
my $fflushall = defined $Config{fflushall} ? $Config{fflushall} eq 'define' ? 1 : 0 : 0;
my $d_fork = defined $Config{d_fork} ? $Config{d_fork} eq 'define' ? 1 : 0 : 0;
if ($useperlio || $fflushNULL || $d_sfio) {
print "1..7\n";
} else {
if ($fflushall) {
print "1..7\n";
} else {
print "1..0 # Skip: fflush(NULL) or equivalent not available\n";
exit;
}
}
my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
$runperl .= qq{ "-I../lib"};
my @delete;
END {
for (@delete) {
unlink $_ or warn "unlink $_: $!";
}
}
sub file_eq {
my $f = shift;
my $val = shift;
open IN, $f or die "open $f: $!";
chomp(my $line = <IN>);
close IN;
print "# got $line\n";
print "# expected $val\n";
return $line eq $val;
}
# This script will be used as the command to execute from
# child processes
open PROG, "> ff-prog" or die "open ff-prog: $!";
print PROG <<'EOF';
my $f = shift;
my $str = shift;
open OUT, ">> $f" or die "open $f: $!";
print OUT $str;
close OUT;
EOF
;
close PROG or die "close ff-prog: $!";;
push @delete, "ff-prog";
$| = 0; # we want buffered output
# Test flush on fork/exec
if (!$d_fork) {
print "ok 1 # skipped: no fork\n";
} else {
my $f = "ff-fork-$$";
open OUT, "> $f" or die "open $f: $!";
print OUT "Pe";
my $pid = fork;
if ($pid) {
# Parent
wait;
close OUT or die "close $f: $!";
} elsif (defined $pid) {
# Kid
print OUT "r";
my $command = qq{$runperl "ff-prog" "$f" "l"};
print "# $command\n";
exec $command or die $!;
exit;
} else {
# Bang
die "fork: $!";
}
print file_eq($f, "Perl") ? "ok 1\n" : "not ok 1\n";
push @delete, $f;
}
# Test flush on system/qx/pipe open
my %subs = (
"system" => sub {
my $c = shift;
system $c;
},
"qx" => sub {
my $c = shift;
qx{$c};
},
"popen" => sub {
my $c = shift;
open PIPE, "$c|" or die "$c: $!";
close PIPE;
},
);
my $t = 2;
for (qw(system qx popen)) {
my $code = $subs{$_};
my $f = "ff-$_-$$";
my $command = qq{$runperl "ff-prog" "$f" "rl"};
open OUT, "> $f" or die "open $f: $!";
print OUT "Pe";
close OUT or die "close $f: $!";;
print "# $command\n";
$code->($command);
print file_eq($f, "Perl") ? "ok $t\n" : "not ok $t\n";
push @delete, $f;
++$t;
}
my $cmd = _create_runperl(
switches => ['-l'],
prog =>
sprintf('print qq[ok $_] for (%d..%d)', $t, $t+2));
print "# cmd = '$cmd'\n";
open my $CMD, "$cmd |" or die "Can't open pipe to '$cmd': $!";
while (<$CMD>) {
system("$runperl -e 0");
print;
}
close $CMD;
$t += 3;
--- NEW FILE: openpid.t ---
#!./perl
#####################################################################
#
# Test for process id return value from open
# Ronald Schmidt (The Software Path) RonaldWS at software-path.com
#
#####################################################################
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
}
if ($^O eq 'dos' || $^O eq 'MacOS') {
skip_all("no multitasking");
}
plan tests => 10;
use Config;
$| = 1;
$SIG{PIPE} = 'IGNORE';
$SIG{HUP} = 'IGNORE' if $^O eq 'interix';
my $perl = which_perl();
$perl .= qq[ "-I../lib"];
#
# commands run 4 perl programs. Two of these programs write a
# short message to STDOUT and exit. Two of these programs
# read from STDIN. One reader never exits and must be killed.
# the other reader reads one line, waits a few seconds and then
# exits to test the waitpid function.
#
$cmd1 = qq/$perl -e "\$|=1; print qq[first process\\n]; sleep 30;"/;
$cmd2 = qq/$perl -e "\$|=1; print qq[second process\\n]; sleep 30;"/;
$cmd3 = qq/$perl -e "print <>;"/; # hangs waiting for end of STDIN
$cmd4 = qq/$perl -e "print scalar <>;"/;
#warn "#$cmd1\n#$cmd2\n#$cmd3\n#$cmd4\n";
# start the processes
ok( $pid1 = open(FH1, "$cmd1 |"), 'first process started');
ok( $pid2 = open(FH2, "$cmd2 |"), ' second' );
ok( $pid3 = open(FH3, "| $cmd3"), ' third' );
ok( $pid4 = open(FH4, "| $cmd4"), ' fourth' );
print "# pids were $pid1, $pid2, $pid3, $pid4\n";
my $killsig = 'HUP';
$killsig = 1 unless $Config{sig_name} =~ /\bHUP\b/;
# get message from first process and kill it
chomp($from_pid1 = scalar(<FH1>));
is( $from_pid1, 'first process', 'message from first process' );
$kill_cnt = kill $killsig, $pid1;
is( $kill_cnt, 1, 'first process killed' ) ||
print "# errno == $!\n";
# get message from second process and kill second process and reader process
chomp($from_pid2 = scalar(<FH2>));
is( $from_pid2, 'second process', 'message from second process' );
$kill_cnt = kill $killsig, $pid2, $pid3;
is( $kill_cnt, 2, 'killing procs 2 & 3' ) ||
print "# errno == $!\n";
# send one expected line of text to child process and then wait for it
select(FH4); $| = 1; select(STDOUT);
printf FH4 "ok %d - text sent to fourth process\n", curr_test();
next_test();
print "# waiting for process $pid4 to exit\n";
$reap_pid = waitpid $pid4, 0;
is( $reap_pid, $pid4, 'fourth process reaped' );
--- NEW FILE: fs.t ---
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require "./test.pl";
}
use Config;
use File::Spec::Functions;
my $Is_MacOS = ($^O eq 'MacOS');
my $Is_VMSish = ($^O eq 'VMS');
if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
$wd = `cd`;
} elsif ($^O eq 'VMS') {
$wd = `show default`;
} else {
$wd = `pwd`;
}
chomp($wd);
my $has_link = $Config{d_link};
my $accurate_timestamps =
!($^O eq 'MSWin32' || $^O eq 'NetWare' ||
$^O eq 'dos' || $^O eq 'os2' ||
$^O eq 'mint' || $^O eq 'cygwin' ||
$^O eq 'amigaos' || $wd =~ m#$Config{afsroot}/# ||
$Is_MacOS
);
if (defined &Win32::IsWinNT && Win32::IsWinNT()) {
if (Win32::FsType() eq 'NTFS') {
$has_link = 1;
$accurate_timestamps = 1;
}
}
my $needs_fh_reopen =
$^O eq 'dos'
# Not needed on HPFS, but needed on HPFS386 ?!
|| $^O eq 'os2';
$needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95());
my $skip_mode_checks =
$^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
plan tests => 42;
if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
`rmdir /s /q tmp 2>nul`;
`mkdir tmp`;
}
elsif ($^O eq 'VMS') {
`if f\$search("[.tmp]*.*") .nes. "" then delete/nolog/noconfirm [.tmp]*.*.*`;
`if f\$search("tmp.dir") .nes. "" then delete/nolog/noconfirm tmp.dir;`;
`create/directory [.tmp]`;
}
elsif ($Is_MacOS) {
rmdir "tmp"; mkdir "tmp";
}
else {
`rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
}
chdir catdir(curdir(), 'tmp');
`/bin/rm -rf a b c x` if -x '/bin/rm';
umask(022);
SKIP: {
skip "bogus umask", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare') || ($^O eq 'epoc') || $Is_MacOS;
is((umask(0)&0777), 022, 'umask'),
}
open(FH,'>x') || die "Can't create x";
close(FH);
open(FH,'>a') || die "Can't create a";
close(FH);
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks);
SKIP: {
skip("no link", 4) unless $has_link;
ok(link('a','b'), "link a b");
ok(link('b','c'), "link b c");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('c');
SKIP: {
skip "no nlink", 1 if $Config{dont_use_nlink};
is($nlink, 3, "link count of triply-linked file");
}
SKIP: {
skip "hard links not that hard in $^O", 1 if $^O eq 'amigaos';
skip "no mode checks", 1 if $skip_mode_checks;
# if ($^O eq 'cygwin') { # new files on cygwin get rwx instead of rw-
# is($mode & 0777, 0777, "mode of triply-linked file");
# } else {
is($mode & 0777, 0666, "mode of triply-linked file");
# }
}
}
$newmode = (($^O eq 'MSWin32') || ($^O eq 'NetWare')) ? 0444 : 0777;
is(chmod($newmode,'a'), 1, "chmod succeeding");
SKIP: {
skip("no link", 7) unless $has_link;
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('c');
SKIP: {
skip "no mode checks", 1 if $skip_mode_checks;
is($mode & 0777, $newmode, "chmod going through");
}
$newmode = 0700;
chmod 0444, 'x';
$newmode = 0666;
is(chmod($newmode,'c','x'), 2, "chmod two files");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('c');
SKIP: {
skip "no mode checks", 1 if $skip_mode_checks;
is($mode & 0777, $newmode, "chmod going through to c");
}
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('x');
SKIP: {
skip "no mode checks", 1 if $skip_mode_checks;
is($mode & 0777, $newmode, "chmod going through to x");
}
is(unlink('b','x'), 2, "unlink two files");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('b');
is($ino, undef, "ino of removed file b should be undef");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('x');
is($ino, undef, "ino of removed file x should be undef");
}
SKIP: {
skip "no fchmod", 5 unless ($Config{d_fchmod} || "") eq "define";
ok(open(my $fh, "<", "a"), "open a");
is(chmod(0, $fh), 1, "fchmod");
$mode = (stat "a")[2];
SKIP: {
skip "no mode checks", 1 if $skip_mode_checks;
is($mode & 0777, 0, "perm reset");
}
is(chmod($newmode, "a"), 1, "fchmod");
$mode = (stat $fh)[2];
SKIP: {
skip "no mode checks", 1 if $skip_mode_checks;
is($mode & 0777, $newmode, "perm restored");
}
}
SKIP: {
skip "no fchown", 1 unless ($Config{d_fchown} || "") eq "define";
open(my $fh, "<", "a");
is(chown(-1, -1, $fh), 1, "fchown");
}
SKIP: {
skip "has fchmod", 1 if ($Config{d_fchmod} || "") eq "define";
open(my $fh, "<", "a");
eval { chmod(0777, $fh); };
like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented");
}
SKIP: {
skip "has fchown", 1 if ($Config{d_fchown} || "") eq "define";
open(my $fh, "<", "a");
eval { chown(0, 0, $fh); };
like($@, qr/^The fchown function is unimplemented at/, "fchown is unimplemented");
}
is(rename('a','b'), 1, "rename a b");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('a');
is($ino, undef, "ino of renamed file a should be undef");
$delta = $accurate_timestamps ? 1 : 2; # Granularity of time on the filesystem
chmod 0777, 'b';
$foo = (utime 500000000,500000000 + $delta,'b');
is($foo, 1, "utime");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('b');
SKIP: {
skip "bogus inode num", 1 if ($^O eq 'MSWin32') || ($^O eq 'NetWare');
ok($ino, 'non-zero inode num');
}
SKIP: {
skip "filesystem atime/mtime granularity too low", 2
unless $accurate_timestamps;
print "# atime - $atime mtime - $mtime delta - $delta\n";
if($atime == 500000000 && $mtime == 500000000 + $delta) {
pass('atime');
pass('mtime');
}
else {
if ($^O =~ /\blinux\b/i) {
print "# Maybe stat() cannot get the correct atime, ".
"as happens via NFS on linux?\n";
$foo = (utime 400000000,500000000 + 2*$delta,'b');
my ($new_atime, $new_mtime) = (stat('b'))[8,9];
print "# newatime - $new_atime nemtime - $new_mtime\n";
if ($new_atime == $atime && $new_mtime - $mtime == $delta) {
pass("atime - accounted for possible NFS/glibc2.2 bug on linux");
pass("mtime - accounted for possible NFS/glibc2.2 bug on linux");
}
else {
fail("atime - $atime/$new_atime $mtime/$new_mtime");
fail("mtime - $atime/$new_atime $mtime/$new_mtime");
}
}
elsif ($^O eq 'VMS') {
# why is this 1 second off?
is( $atime, 500000001, 'atime' );
is( $mtime, 500000000 + $delta, 'mtime' );
}
elsif ($^O eq 'beos') {
SKIP: { skip "atime not updated", 1; }
is($mtime, 500000001, 'mtime');
}
else {
fail("atime");
fail("mtime");
}
}
}
is(unlink('b'), 1, "unlink b");
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat('b');
is($ino, undef, "ino of unlinked file b should be undef");
unlink 'c';
chdir $wd || die "Can't cd back to $wd";
# Yet another way to look for links (perhaps those that cannot be
# created by perl?). Hopefully there is an ls utility in your
# %PATH%. N.B. that $^O is 'cygwin' on Cygwin.
SKIP: {
skip "Win32/Netware specific test", 2
unless ($^O eq 'MSWin32') || ($^O eq 'NetWare');
skip "No symbolic links found to test with", 2
unless `ls -l perl 2>nul` =~ /^l.*->/;
system("cp TEST TEST$$");
# we have to copy because e.g. GNU grep gets huffy if we have
# a symlink forest to another disk (it complains about too many
# levels of symbolic links, even if we have only two)
is(symlink("TEST$$","c"), 1, "symlink");
$foo = `grep perl c 2>&1`;
ok($foo, "found perl in c");
unlink 'c';
unlink("TEST$$");
}
unlink "Iofs.tmp";
open IOFSCOM, ">Iofs.tmp" or die "Could not write IOfs.tmp: $!";
print IOFSCOM 'helloworld';
close(IOFSCOM);
# TODO: pp_truncate needs to be taught about F_CHSIZE and F_FREESP,
# as per UNIX FAQ.
SKIP: {
# Check truncating a closed file.
eval { truncate "Iofs.tmp", 5; };
skip("no truncate - $@", 8) if $@;
is(-s "Iofs.tmp", 5, "truncation to five bytes");
truncate "Iofs.tmp", 0;
ok(-z "Iofs.tmp", "truncation to zero bytes");
#these steps are necessary to check if file is really truncated
#On Win95, FH is updated, but file properties aren't
open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
print FH "x\n" x 200;
close FH;
# Check truncating an open file.
open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
binmode FH;
select FH;
$| = 1;
select STDOUT;
{
use strict;
print FH "x\n" x 200;
ok(truncate(FH, 200), "fh resize to 200");
}
if ($needs_fh_reopen) {
close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
}
SKIP: {
if ($^O eq 'vos') {
skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5);
}
is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
ok(truncate(FH, 0), "fh resize to zero");
if ($needs_fh_reopen) {
close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
}
ok(-z "Iofs.tmp", "fh resize to zero working (filename check)");
close FH;
open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
binmode FH;
select FH;
$| = 1;
select STDOUT;
{
use strict;
print FH "x\n" x 200;
ok(truncate(*FH{IO}, 100), "fh resize by IO slot");
}
if ($needs_fh_reopen) {
close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
}
is(-s "Iofs.tmp", 100, "fh resize by IO slot working");
close FH;
}
}
# check if rename() can be used to just change case of filename
SKIP: {
skip "Works in Cygwin only if check_case is set to relaxed", 1
if $^O eq 'cygwin';
chdir './tmp';
open(FH,'>x') || die "Can't create x";
close(FH);
rename('x', 'X');
# this works on win32 only, because fs isn't casesensitive
ok(-e 'X', "rename working");
1 while unlink 'X';
chdir $wd || die "Can't cd back to $wd";
}
# check if rename() works on directories
if ($^O eq 'VMS') {
# must have delete access to rename a directory
`set file tmp.dir/protection=o:d`;
ok(rename('tmp.dir', 'tmp1.dir'), "rename on directories") ||
print "# errno: $!\n";
} else {
ok(rename('tmp', 'tmp1'), "rename on directories");
}
ok(-d 'tmp1', "rename on directories working");
# FIXME - for some reason change 26009/26011 merged as 26627 still segfaults
# after all the tests have completed:
# #0 0x08124dd0 in Perl_pop_scope (my_perl=0x81b5ec8) at scope.c:143
# #1 0x080e88d8 in Perl_pp_leave (my_perl=0x81b5ec8) at pp_hot.c:1843
# #2 0x080c7dc1 in Perl_runops_debug (my_perl=0x81b5ec8) at dump.c:1459
# #3 0x080660af in S_run_body (my_perl=0x81b5ec8, oldscope=1) at perl.c:2369
# #4 0x08065ab1 in perl_run (my_perl=0x81b5ec8) at perl.c:2286
# #5 0x080604c3 in main (argc=2, argv=0xbffffc64, env=0xbffffc70)
# at perlmain.c:99
#
# 143 const I32 oldsave = PL_scopestack[--PL_scopestack_ix];
# (gdb) p my_perl->Tscopestack_ix
# $1 = 136787683
#
if (0) {
# Change 26011: Re: A surprising segfault
# to make sure only that these obfuscated sentences will not crash.
map chmod(+()), ('')x68;
ok(1, "extend sp in pp_chmod");
map chown(+()), ('')x68;
ok(1, "extend sp in pp_chown");
}
# need to remove 'tmp' if rename() in test 28 failed!
END { rmdir 'tmp1'; rmdir 'tmp'; 1 while unlink "Iofs.tmp"; }
--- NEW FILE: through.t ---
#!./perl
BEGIN {
if ($^O eq 'VMS') {
print "1..0 # Skip on VMS -- too picky about line endings for record-oriented pipes\n";
exit;
}
chdir 't' if -d 't';
@INC = '../lib';
}
use strict;
require './test.pl';
my $Perl = which_perl();
my $data = <<'EOD';
x
yy
z
EOD
(my $data2 = $data) =~ s/\n/\n\n/g;
my $t1 = { data => $data, write_c => [1,2,length $data], read_c => [1,2,3,length $data]};
my $t2 = { data => $data2, write_c => [1,2,length $data2], read_c => [1,2,3,length $data2]};
$_->{write_c} = [1..length($_->{data})],
$_->{read_c} = [1..length($_->{data})+1, 0xe000] # Need <0xffff for REx
for (); # $t1, $t2;
my $c; # len write tests, for each: one _all test, and 3 each len+2
$c += @{$_->{write_c}} * (1 + 3*@{$_->{read_c}}) for $t1, $t2;
$c *= 3*2*2; # $how_w, file/pipe, 2 reports
$c += 6; # Tests with sleep()...
print "1..$c\n";
my $set_out = '';
$set_out = "binmode STDOUT, ':crlf'"
if defined $main::use_crlf && $main::use_crlf == 1;
sub testread ($$$$$$$) {
my ($fh, $str, $read_c, $how_r, $write_c, $how_w, $why) = @_;
my $buf = '';
if ($how_r eq 'readline_all') {
$buf .= $_ while <$fh>;
} elsif ($how_r eq 'readline') {
$/ = \$read_c;
$buf .= $_ while <$fh>;
} elsif ($how_r eq 'read') {
my($in, $c);
$buf .= $in while $c = read($fh, $in, $read_c);
} elsif ($how_r eq 'sysread') {
my($in, $c);
$buf .= $in while $c = sysread($fh, $in, $read_c);
} else {
die "Unrecognized read: '$how_r'";
}
close $fh or die "close: $!";
# The only contamination allowed is with sysread/prints
$buf =~ s/\r\n/\n/g if $how_r eq 'sysread' and $how_w =~ /print/;
is(length $buf, length $str, "length with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why");
is($buf, $str, "content with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why");
}
sub testpipe ($$$$$$) {
my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_;
(my $quoted = $str) =~ s/\n/\\n/g;;
my $fh;
if ($how_w eq 'print') { # AUTOFLUSH???
# Should be shell-neutral:
open $fh, '-|', qq[$Perl -we "$set_out;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!";
} elsif ($how_w eq 'print/flush') {
# shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|'
open $fh, '-|', qq[$Perl -we "$set_out;eval qq(\\x24\\x7c = 1) or die;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!";
} elsif ($how_w eq 'syswrite') {
### How to protect \$_
open $fh, '-|', qq[$Perl -we "$set_out;eval qq(sub w {syswrite STDOUT, \\x24_} 1) or die; w() for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!";
} else {
die "Unrecognized write: '$how_w'";
}
binmode $fh, ':crlf'
if defined $main::use_crlf && $main::use_crlf == 1;
testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why");
}
sub testfile ($$$$$$) {
my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_;
my @data = grep length, split /(.{1,$write_c})/s, $str;
open my $fh, '>', 'io_io.tmp' or die;
select $fh;
binmode $fh, ':crlf'
if defined $main::use_crlf && $main::use_crlf == 1;
if ($how_w eq 'print') { # AUTOFLUSH???
$| = 0;
print $fh $_ for @data;
} elsif ($how_w eq 'print/flush') {
$| = 1;
print $fh $_ for @data;
} elsif ($how_w eq 'syswrite') {
syswrite $fh, $_ for @data;
} else {
die "Unrecognized write: '$how_w'";
}
close $fh or die "close: $!";
open $fh, '<', 'io_io.tmp' or die;
binmode $fh, ':crlf'
if defined $main::use_crlf && $main::use_crlf == 1;
testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why");
}
# shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|'
open my $fh, '-|', qq[$Perl -we "eval qq(\\x24\\x7c = 1) or die; binmode STDOUT; sleep 1, print for split //, qq(a\nb\n\nc\n\n\n)"] or die "open: $!";
ok(1, 'open pipe');
binmode $fh, q(:crlf);
ok(1, 'binmode');
$c = undef;
my @c;
push @c, ord $c while $c = getc $fh;
ok(1, 'got chars');
is(scalar @c, 9, 'got 9 chars');
is("@c", '97 10 98 10 10 99 10 10 10', 'got expected chars');
ok(close($fh), 'close');
for my $s (1..2) {
my $t = ($t1, $t2)[$s-1];
my $str = $t->{data};
my $r = $t->{read_c};
my $w = $t->{write_c};
for my $read_c (@$r) {
for my $write_c (@$w) {
for my $how_r (qw(readline_all readline read sysread)) {
next if $how_r eq 'readline_all' and $read_c != 1;
for my $how_w (qw(print print/flush syswrite)) {
testfile($str, $write_c, $read_c, $how_w, $how_r, $s);
testpipe($str, $write_c, $read_c, $how_w, $how_r, $s);
}
}
}
}
}
unlink 'io_io.tmp';
1;
--- NEW FILE: tell.t ---
#!./perl
# $RCSfile: tell.t,v $$Revision: 1.2 $$Date: 2006-12-04 17:01:49 $
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
print "1..28\n";
$TST = 'tst';
$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'NetWare' or $^O eq 'dos' or
$^O eq 'os2' or $^O eq 'mint' or $^O eq 'cygwin' or
$^O =~ /^uwin/);
open($TST, 'harness') || (die "Can't open harness");
binmode $TST if $Is_Dosish;
if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
$firstline = <$TST>;
$secondpos = tell;
$x = 0;
while (<tst>) {
if (eof) {$x++;}
}
if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
$lastpos = tell;
unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
if (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
if ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
if (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
if (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
if (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
if ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
if ($. == 0) { print "not ok 14\n"; } else { print "ok 14\n"; }
$curline = $.;
open(other, 'harness') || (die "Can't open harness: $!");
binmode other if (($^O eq 'MSWin32') || ($^O eq 'NetWare'));
{
local($.);
if ($. == 0) { print "not ok 15\n"; } else { print "ok 15\n"; }
tell other;
if ($. == 0) { print "ok 16\n"; } else { print "not ok 16\n"; }
$. = 5;
scalar <other>;
if ($. == 6) { print "ok 17\n"; } else { print "not ok 17\n"; }
}
if ($. == $curline) { print "ok 18\n"; } else { print "not ok 18\n"; }
{
local($.);
scalar <other>;
if ($. == 7) { print "ok 19\n"; } else { print "not ok 19\n"; }
}
if ($. == $curline) { print "ok 20\n"; } else { print "not ok 20\n"; }
{
local($.);
tell other;
if ($. == 7) { print "ok 21\n"; } else { print "not ok 21\n"; }
}
close(other);
if (tell(other) == -1) { print "ok 22\n"; } else { print "not ok 22\n"; }
if (tell(ether) == -1) { print "ok 23\n"; } else { print "not ok 23\n"; }
# ftell(STDIN) (or any std streams) is undefined, it can return -1 or
# something else. ftell() on pipes, fifos, and sockets is defined to
# return -1.
my $written = "tell_write.txt";
END { 1 while unlink($written) }
close($tst);
open($tst,">$written") || die "Cannot open $written:$!";
binmode $tst if $Is_Dosish;
if (tell($tst) == 0) { print "ok 24\n"; } else { print "not ok 24\n"; }
print $tst "fred\n";
if (tell($tst) == 5) { print "ok 25\n"; } else { print "not ok 25\n"; }
print $tst "more\n";
if (tell($tst) == 10) { print "ok 26\n"; } else { print "not ok 26\n"; }
close($tst);
open($tst,"+>>$written") || die "Cannot open $written:$!";
binmode $tst if $Is_Dosish;
if (0)
{
# :stdio does not pass these so ignore them for now
if (tell($tst) == 0) { print "ok 27\n"; } else { print "not ok 27\n"; }
$line = <$tst>;
if ($line eq "fred\n") { print "ok 29\n"; } else { print "not ok 29\n"; }
if (tell($tst) == 5) { print "ok 30\n"; } else { print "not ok 30\n"; }
}
print $tst "xxxx\n";
if (tell($tst) == 15 ||
tell($tst) == 5) # unset PERLIO or PERLIO=stdio (e.g. HP-UX, Solaris)
{ print "ok 27\n"; } else { print "not ok 27\n"; }
close($tst);
open($tst,">$written") || die "Cannot open $written:$!";
print $tst "foobar";
close $tst;
open($tst,">>$written") || die "Cannot open $written:$!";
# This test makes a questionable assumption that the file pointer will
# be at eof after opening a file but before seeking, reading, or writing.
# Only known failure is on cygwin.
my $todo = $^O eq "cygwin" && &PerlIO::get_layers($tst) eq 'stdio'
&& ' # TODO: file pointer not at eof';
if (tell($tst) == 6)
{ print "ok 28$todo\n"; } else { print "not ok 28$todo\n"; }
close $tst;
--- NEW FILE: iprefix.t ---
#!./perl
$^I = 'bak*';
# Modified from the original inplace.t to test adding prefixes
print "1..2\n";
@ARGV = ('.a','.b','.c');
if ($^O eq 'MSWin32') {
$CAT = '.\perl -e "print<>"';
`.\\perl -le "print 'foo'" > .a`;
`.\\perl -le "print 'foo'" > .b`;
`.\\perl -le "print 'foo'" > .c`;
}
elsif ($^O eq 'NetWare') {
$CAT = 'perl -e "print<>"';
`perl -le "print 'foo'" > .a`;
`perl -le "print 'foo'" > .b`;
`perl -le "print 'foo'" > .c`;
}
elsif ($^O eq 'VMS') {
$CAT = 'MCR []perl. -e "print<>"';
`MCR []perl. -le "print 'foo'" > ./.a`;
`MCR []perl. -le "print 'foo'" > ./.b`;
`MCR []perl. -le "print 'foo'" > ./.c`;
}
elsif ($^O eq 'MacOS') {
$CAT = "$^X -e \"print<>\"";
`$^X -le "print 'foo'" > .a`;
`$^X -le "print 'foo'" > .b`;
`$^X -le "print 'foo'" > .c`;
}
else {
$CAT = 'cat';
`echo foo | tee .a .b .c`;
}
while (<>) {
s/foo/bar/;
}
continue {
print;
}
if (`$CAT .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";}
if (`$CAT bak.a bak.b bak.c` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
unlink '.a', '.b', '.c', 'bak.a', 'bak.b', 'bak.c';
--- NEW FILE: binmode.t ---
#!./perl -w
BEGIN {
chdir 't' if -d 't';
@INC = qw(. ../lib);
require './test.pl';
}
use Config;
BEGIN {
eval {require Errno; Errno->import;};
}
plan(tests => 9);
ok( binmode(STDERR), 'STDERR made binary' );
if (find PerlIO::Layer 'perlio') {
ok( binmode(STDERR, ":unix"), ' with unix discipline' );
} else {
ok(1, ' skip unix discipline without PerlIO layers' );
}
ok( binmode(STDERR, ":raw"), ' raw' );
ok( binmode(STDERR, ":crlf"), ' and crlf' );
# If this one fails, we're in trouble. So we just bail out.
ok( binmode(STDOUT), 'STDOUT made binary' ) || exit(1);
if (find PerlIO::Layer 'perlio') {
ok( binmode(STDOUT, ":unix"), ' with unix discipline' );
} else {
ok(1, ' skip unix discipline without PerlIO layers' );
}
ok( binmode(STDOUT, ":raw"), ' raw' );
ok( binmode(STDOUT, ":crlf"), ' and crlf' );
SKIP: {
skip "minitest", 1 if $ENV{PERL_CORE_MINITEST};
skip "no EBADF", 1 if (!exists &Errno::EBADF);
no warnings 'io', 'once';
$! = 0;
binmode(B);
ok($! == &Errno::EBADF);
}
More information about the dslinux-commit
mailing list