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