dslinux/user/perl/ext/IO/t IO.t io_const.t io_dir.t io_dup.t io_file.t io_linenum.t io_multihomed.t io_pipe.t io_poll.t io_sel.t io_sock.t io_taint.t io_tell.t io_udp.t io_unix.t io_utf8.t io_xs.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:30 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/ext/IO/t
In directory antilope:/tmp/cvs-serv17422/ext/IO/t

Added Files:
	IO.t io_const.t io_dir.t io_dup.t io_file.t io_linenum.t 
	io_multihomed.t io_pipe.t io_poll.t io_sel.t io_sock.t 
	io_taint.t io_tell.t io_udp.t io_unix.t io_utf8.t io_xs.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: io_dup.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use Config;

BEGIN {
    if($ENV{PERL_CORE}) {
        if ($Config{'extensions'} !~ /\bIO\b/) {
	    print "1..0 # Skip: IO extension not compiled\n";
	    exit 0;
        }
    }
}

use IO::Handle;
use IO::File;

select(STDERR); $| = 1;
select(STDOUT); $| = 1;

print "1..6\n";

print "ok 1\n";

$dupout = IO::Handle->new->fdopen( \*STDOUT ,"w");
$duperr = IO::Handle->new->fdopen( \*STDERR ,"w");

$stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle";
$stderr = \*STDERR; bless $stderr, "IO::Handle";

$stdout->open( "Io.dup","w") || die "Can't open stdout";
$stderr->fdopen($stdout,"w");

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';
print `$cmd`;

$stderr->close;
$stdout->close;

$stdout->fdopen($dupout,"w");
$stderr->fdopen($duperr,"w");

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 6\n";

--- NEW FILE: io_poll.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
        chdir 't' if -d 't';
        @INC = '../lib';
    }
}

if ($^O eq 'mpeix') {
    print "1..0 # Skip: broken on MPE/iX\n";
    exit 0;
}

select(STDERR); $| = 1;
select(STDOUT); $| = 1;

print "1..10\n";

use IO::Handle;
use IO::Poll qw(/POLL/);

my $poll = new IO::Poll;

my $stdout = \*STDOUT;
my $dupout = IO::Handle->new_from_fd(fileno($stdout),"w");

$poll->mask($stdout => POLLOUT);

print "not "
	unless $poll->mask($stdout) == POLLOUT;
print "ok 1\n";

$poll->mask($dupout => POLLPRI);

print "not "
	unless $poll->mask($dupout) == POLLPRI;
print "ok 2\n";

$poll->poll(0.1);

if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS' || $^O eq 'beos') {
print "ok 3 # skipped, doesn't work on non-socket fds\n";
print "ok 4 # skipped, doesn't work on non-socket fds\n";
}
else {
print "not "
	unless $poll->events($stdout) == POLLOUT;
print "ok 3\n";

print "not "
	if $poll->events($dupout);
print "ok 4\n";
}

my @h = $poll->handles;
print "not "
	unless @h == 2;
print "ok 5\n";

$poll->remove($stdout);

@h = $poll->handles;

print "not "
	unless @h == 1;
print "ok 6\n";

print "not "
	if $poll->mask($stdout);
print "ok 7\n";

$poll->poll(0.1);

print "not "
	if $poll->events($stdout);
print "ok 8\n";

$poll->remove($dupout);
print "not "
    if $poll->handles;
print "ok 9\n";

my $stdin = \*STDIN;
$poll->mask($stdin => POLLIN);
$poll->remove($stdin);
close STDIN;
print "not "
    if $poll->poll(0.1);
print "ok 10\n";

--- NEW FILE: io_tell.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
	$tell_file = "TEST";
    }
    else {
	$tell_file = "Makefile";
    }
}

use Config;

BEGIN {
    if(-d "lib" && -f "TEST") {
        if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
	    print "1..0\n";
	    exit 0;
        }
    }
}

print "1..13\n";

use IO::File;

$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file");
binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos');
if ($tst->eof) { 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 ($tst->seek(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 ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }

if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; }

if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }

if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }

if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; }

unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }

--- NEW FILE: io_unix.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
        chdir 't' if -d 't';
        @INC = '../lib';
    }
}

use Config;

BEGIN {
    if(-d "lib" && -f "TEST") {
	my $reason;
	if (! $Config{'d_fork'}) {
	    $reason = 'no fork';
	}
	elsif ($Config{'extensions'} !~ /\bSocket\b/) {
	    $reason = 'Socket extension unavailable';
	}
	elsif ($Config{'extensions'} !~ /\bIO\b/) {
	    $reason = 'IO extension unavailable';
	}
	elsif ($^O eq 'os2') {
	    require IO::Socket;

	    eval {IO::Socket::pack_sockaddr_un('/foo/bar') || 1}
	      or $@ !~ /not implemented/ or
		$reason = 'compiled without TCP/IP stack v4';
	} elsif ($^O =~ m/^(?:qnx|nto|vos)$/ ) {
	    $reason = 'Not implemented';
	}
	if ($reason) {
	    print "1..0 # Skip: $reason\n";
	    exit 0;
        }
    }
}

$PATH = "sock-$$";

# Test if we can create the file within the tmp directory
if (-e $PATH or not open(TEST, ">$PATH") and $^O ne 'os2') {
    print "1..0 # Skip: cannot open '$PATH' for write\n";
    exit 0;
}
close(TEST);
unlink($PATH) or $^O eq 'os2' or die "Can't unlink $PATH: $!";

# Start testing
$| = 1;
print "1..5\n";

use IO::Socket;

$listen = IO::Socket::UNIX->new(Local=>$PATH, Listen=>0) || die "$!";
print "ok 1\n";

if($pid = fork()) {

    $sock = $listen->accept();

    if (defined $sock) {
	print "ok 2\n";

	print $sock->getline();

	print $sock "ok 4\n";

	$sock->close;

	waitpid($pid,0);
	unlink($PATH) || $^O eq 'os2' || warn "Can't unlink $PATH: $!";

	print "ok 5\n";
    } else {
	print "# accept() failed: $!\n";
	for (2..5) {
	    print "not ok $_ # accept failed\n";
	}
    }
} elsif(defined $pid) {

    $sock = IO::Socket::UNIX->new(Peer => $PATH) or die "$!";

    print $sock "ok 3\n";

    print $sock->getline();

    $sock->close;

    exit;
} else {
 die;
}

--- NEW FILE: io_sel.t ---
#!./perl -w

BEGIN {
    unless(grep /blib/, @INC) {
        chdir 't' if -d 't';
        @INC = '../lib';
    }
}

select(STDERR); $| = 1;
select(STDOUT); $| = 1;

print "1..23\n";

use IO::Select 1.09;

my $sel = new IO::Select(\*STDIN);
$sel->add(4, 5) == 2 or print "not ";
print "ok 1\n";

$sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
print "ok 2\n";

@handles = $sel->handles;
print "not " unless $sel->count == 4 && @handles == 4;
print "ok 3\n";
#print $sel->as_string, "\n";

$sel->remove(\*STDIN) == 1 or print "not ";
print "ok 4\n",
;
$sel->remove(\*STDIN, 5, 6) == 1  # two of there are not present
  or print "not ";
print "ok 5\n";

print "not " unless $sel->count == 2;
print "ok 6\n";
#print $sel->as_string, "\n";

$sel->remove(1, 4);
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 7\n";

$sel = new IO::Select;
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 8\n";

$sel->remove([\*STDOUT, 5]);
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 9\n";

if ( grep $^O eq $_, qw(MSWin32 NetWare dos VMS riscos beos) ) {
    for (10 .. 15) { 
        print "ok $_ # skip: 4-arg select is only valid on sockets\n"
    }
    $sel->add(\*STDOUT);  # update
    goto POST_SOCKET;
}

@a = $sel->can_read();  # should return imediately
print "not " unless @a == 0;
print "ok 10\n";

# we assume that we can write to STDOUT :-)
$sel->add([\*STDOUT, "ok 12\n"]);

@a = $sel->can_write;
print "not " unless @a == 1;
print "ok 11\n";

my($fd, $msg) = @{shift @a};
print $fd $msg;

$sel->add(\*STDOUT);  # update

@a = IO::Select::select(undef, $sel, undef, 1);
print "not " unless @a == 3;
print "ok 13\n";

($r, $w, $e) = @a;

print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
print "ok 14\n";

$fd = $w->[0];
print $fd "ok 15\n";

POST_SOCKET:
# Test new exists() method
$sel->exists(\*STDIN) and print "not ";
print "ok 16\n";

($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
print "ok 17\n";

$fd = $sel->exists(\*STDOUT);
if ($fd) {
    print $fd "ok 18\n";
} else {
    print "not ok 18\n";
}

$fd = $sel->exists([1, 'foo']);
if ($fd) {
    print $fd "ok 19\n";
} else {
    print "not ok 19\n";
}

# Try self clearing
$sel->add(5,6,7,8,9,10);
print "not " unless $sel->count == 7;
print "ok 20\n";

$sel->remove($sel->handles);
print "not " unless $sel->count == 0 && !defined($sel->bits);
print "ok 21\n";

# check warnings
$SIG{__WARN__} = sub { 
    ++ $w 
      if $_[0] =~ /^Call to deprecated method 'has_error', use 'has_exception'/ ;
    } ;
$w = 0 ;
{
no warnings 'IO::Select' ;
IO::Select::has_error();
}
print "not " unless $w == 0 ;
$w = 0 ;
print "ok 22\n" ;
{
use warnings 'IO::Select' ;
IO::Select::has_error();
}
print "not " unless $w == 1 ;
$w = 0 ;
print "ok 23\n" ;

--- NEW FILE: io_multihomed.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use Config;

BEGIN {
    if(-d "lib" && -f "TEST") {
	my $reason;
	if (! $Config{'d_fork'}) {
	    $reason = 'no fork';
	}
	elsif ($Config{'extensions'} !~ /\bSocket\b/) {
	    $reason = 'Socket extension unavailable';
	}
	elsif ($Config{'extensions'} !~ /\bIO\b/) {
	    $reason = 'IO extension unavailable';
	}
	if ($reason) {
	    print "1..0 # Skip: $reason\n";
	    exit 0;
        }
    }
}

$| = 1;

print "1..8\n";

eval {
    $SIG{ALRM} = sub { die; };
    alarm 60;
};

package Multi;
require IO::Socket::INET;
@ISA=qw(IO::Socket::INET);

use Socket qw(inet_aton inet_ntoa unpack_sockaddr_in);

sub _get_addr
{
    my($sock,$addr_str, $multi) = @_;
    #print "_get_addr($sock, $addr_str, $multi)\n";

    print "not " unless $multi;
    print "ok 2\n";

    (
     # private IP-addresses which I hope does not work anywhere :-)
     inet_aton("10.250.230.10"),
     inet_aton("10.250.230.12"),
     inet_aton("127.0.0.1")        # loopback
    )
}

sub connect
{
    my $self = shift;
    if (@_ == 1) {
	my($port, $addr) = unpack_sockaddr_in($_[0]);
	$addr = inet_ntoa($addr);
	#print "connect($self, $port, $addr)\n";
	if($addr eq "10.250.230.10") {
	    print "ok 3\n";
	    return 0;
	}
	if($addr eq "10.250.230.12") {
	    print "ok 4\n";
	    return 0;
	}
    }
    $self->SUPER::connect(@_);
}



package main;

use IO::Socket;

$listen = IO::Socket::INET->new(Listen => 2,
				Proto => 'tcp',
				Timeout => 5,
			       ) or die "$!";

print "ok 1\n";

$port = $listen->sockport;

if($pid = fork()) {

    $sock = $listen->accept() or die "$!";
    print "ok 5\n";

    print $sock->getline();
    print $sock "ok 7\n";

    waitpid($pid,0);

    $sock->close;

    print "ok 8\n";

} elsif(defined $pid) {

    $sock = Multi->new(PeerPort => $port,
		       Proto => 'tcp',
		       PeerAddr => 'localhost',
		       MultiHomed => 1,
		       Timeout => 1,
		      ) or die "$!";

    print $sock "ok 6\n";
    sleep(1); # race condition
    print $sock->getline();

    $sock->close;

    exit;
} else {
    die;
}

--- NEW FILE: io_const.t ---

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use Config;

BEGIN {
    if($ENV{PERL_CORE}) {
        if ($Config{'extensions'} !~ /\bIO\b/) {
            print "1..0 # Skip: IO extension not compiled\n";
            exit 0;
        }
    }
}

use IO::Handle;

print "1..6\n";
my $i = 1;
foreach (qw(SEEK_SET SEEK_CUR SEEK_END     _IOFBF    _IOLBF    _IONBF)) {
    my $d1 = defined(&{"IO::Handle::" . $_}) ? 1 : 0;
    my $v1 = $d1 ? &{"IO::Handle::" . $_}() : undef;
    my $v2 = IO::Handle::constant($_);
    my $d2 = defined($v2);

    print "not "
	if($d1 != $d2 || ($d1 && ($v1 != $v2)));
    print "ok ",$i++,"\n";
}

--- NEW FILE: io_pipe.t ---
#!./perl

my $perl;

BEGIN {
    unless(grep /blib/, @INC) {
	$perl = './perl';
	chdir 't' if -d 't';
	@INC = '../lib';
    }
    else {
	$perl = $^X;
    }
}

use Config;

BEGIN {
    if(-d "lib" && -f "TEST") {
	my $reason;
	if (! $Config{'d_fork'}) {
	    $reason = 'no fork';
	}
	elsif ($Config{'extensions'} !~ /\bIO\b/) {
	    $reason = 'IO extension unavailable';
	}
	if ($reason) {
	    print "1..0 # Skip: $reason\n";
	    exit 0;
        }
    }
}

use IO::Pipe;


$| = 1;
print "1..10\n";

$pipe = new IO::Pipe->reader($perl, '-e', 'print "not ok 1\n"');
while (<$pipe>) {
  s/^not //;
  print;
}
$pipe->close or print "# \$!=$!\nnot ";
print "ok 2\n";

$cmd = 'BEGIN{$SIG{ALRM} = sub {print "not ok 4\n"; exit}; alarm 10} s/not //';
$pipe = new IO::Pipe->writer($perl, '-pe', $cmd);
print $pipe "not ok 3\n" ;
$pipe->close or print "# \$!=$!\nnot ";
print "ok 4\n";

# Check if can fork with dynamic extensions (bug in CRT):
if ($^O eq 'os2' and
    system "$^X -I../lib -MOpcode -e 'defined fork or die'  > /dev/null 2>&1") {
    print "ok $_ # skipped: broken fork\n" for 5..10;
    exit 0;
}

$pipe = new IO::Pipe;

$pid = fork();

if($pid)
 {
  $pipe->writer;
  print $pipe "Xk 5\n";
  print $pipe "oY 6\n";
  $pipe->close;
  wait;
 }
elsif(defined $pid)
 {
  $pipe->reader;
  $stdin = bless \*STDIN, "IO::Handle";
  $stdin->fdopen($pipe,"r");
  exec 'tr', 'YX', 'ko';
 }
else
 {
  die "# error = $!";
 }

$pipe = new IO::Pipe;
$pid = fork();

if($pid)
 {
  $pipe->reader;
  while(<$pipe>) {
      s/^not //;
      print;
  }
  $pipe->close;
  wait;
 }
elsif(defined $pid)
 {
  $pipe->writer;

  $stdout = bless \*STDOUT, "IO::Handle";
  $stdout->fdopen($pipe,"w");
  print STDOUT "not ok 7\n";
  exec 'echo', 'not ok 8';
 }
else
 {
  die;
 }

$pipe = new IO::Pipe;
$pipe->writer;

$SIG{'PIPE'} = 'broken_pipe';

sub broken_pipe {
    print "ok 9\n";
}

print $pipe "not ok 9\n";
$pipe->close;

sleep 1;

print "ok 10\n";


--- NEW FILE: io_utf8.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
    unless ($] >= 5.008 and find PerlIO::Layer 'perlio') {
	print "1..0 # Skip: not perlio\n";
	exit 0;
    }
}

require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");

plan(tests => 5);

my $io;

use_ok('IO::File');

$io = IO::File->new;

ok($io->open("io_utf8", ">:utf8"), "open >:utf8");
ok((print $io chr(256)), "print chr(256)");
undef $io;

$io = IO::File->new;
ok($io->open("io_utf8", "<:utf8"), "open <:utf8");
is(ord(<$io>), 256, "readline chr(256)");
undef $io;

END {
  1 while unlink "io_utf8";
}

--- NEW FILE: io_dir.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
        chdir 't' if -d 't';
        @INC = '../lib';
    }
    require Config; import Config;
    if ($] < 5.00326 || not $Config{'d_readdir'}) {
	print "1..0 # Skip: readdir() not available\n";
	exit 0;
    }
}

select(STDERR); $| = 1;
select(STDOUT); $| = 1;

use IO::Dir qw(DIR_UNLINK);

my $tcount = 0;

sub ok {
  $tcount++;
  my $not = $_[0] ? '' : 'not ';
  print "${not}ok $tcount\n";
}

print "1..10\n";

my $DIR = $^O eq 'MacOS' ? ":" : ".";

$dot = new IO::Dir $DIR;
ok(defined($dot));

@a = sort <*>;
do { $first = $dot->read } while defined($first) && $first =~ /^\./;
ok(+(grep { $_ eq $first } @a));

@b = sort($first, (grep {/^[^.]/} $dot->read));
ok(+(join("\0", @a) eq join("\0", @b)));

$dot->rewind;
@c = sort grep {/^[^.]/} $dot->read;
ok(+(join("\0", @b) eq join("\0", @c)));

$dot->close;
$dot->rewind;
ok(!defined($dot->read));

open(FH,'>X') || die "Can't create x";
print FH "X";
close(FH) or die "Can't close: $!";

tie %dir, IO::Dir, $DIR;
my @files = keys %dir;

# I hope we do not have an empty dir :-)
ok(scalar @files);

my $stat = $dir{'X'};
ok(defined($stat) && UNIVERSAL::isa($stat,'File::stat') && $stat->size == 1);

delete $dir{'X'};

ok(-f 'X');

tie %dirx, IO::Dir, $DIR, DIR_UNLINK;

my $statx = $dirx{'X'};
ok(defined($statx) && UNIVERSAL::isa($statx,'File::stat') && $statx->size == 1);

delete $dirx{'X'};

ok(!(-f 'X'));

--- NEW FILE: io_sock.t ---
#!./perl -w

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use Config;

BEGIN {
    if (-d "lib" && -f "TEST") {
	my $reason;
	if (! $Config{'d_fork'}) {
	    $reason = 'no fork';
	}
	elsif ($Config{'extensions'} !~ /\bSocket\b/) {
	    $reason = 'Socket extension unavailable';
	}
	elsif ($Config{'extensions'} !~ /\bIO\b/) {
	    $reason = 'IO extension unavailable';
	}
	if ($reason) {
	    print "1..0 # Skip: $reason\n";
	    exit 0;
        }
    }
}

my $has_perlio = $] >= 5.008 && find PerlIO::Layer 'perlio';

$| = 1;
print "1..26\n";

eval {
    $SIG{ALRM} = sub { die; };
    alarm 120;
};

use IO::Socket;

$listen = IO::Socket::INET->new(Listen => 2,
				Proto => 'tcp',
				# some systems seem to need as much as 10,
				# so be generous with the timeout
				Timeout => 15,
			       ) or die "$!";

print "ok 1\n";

# Check if can fork with dynamic extensions (bug in CRT):
if ($^O eq 'os2' and
    system "$^X -I../lib -MOpcode -e 'defined fork or die'  > /dev/null 2>&1") {
    print "ok $_ # skipped: broken fork\n" for 2..5;
    exit 0;
}

$port = $listen->sockport;

if($pid = fork()) {

    $sock = $listen->accept() or die "accept failed: $!";
    print "ok 2\n";

    $sock->autoflush(1);
    print $sock->getline();

    print $sock "ok 4\n";

    $sock->close;

    waitpid($pid,0);

    print "ok 5\n";

} elsif(defined $pid) {

    $sock = IO::Socket::INET->new(PeerPort => $port,
				  Proto => 'tcp',
				  PeerAddr => 'localhost'
				 )
         || IO::Socket::INET->new(PeerPort => $port,
				  Proto => 'tcp',
				  PeerAddr => '127.0.0.1'
				 )
	or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";

    $sock->autoflush(1);

    print $sock "ok 3\n";

    print $sock->getline();

    $sock->close;

    exit;
} else {
 die;
}

# Test various other ways to create INET sockets that should
# also work.
$listen = IO::Socket::INET->new(Listen => '', Timeout => 15) or die "$!";
$port = $listen->sockport;

if($pid = fork()) {
  SERVER_LOOP:
    while (1) {
       last SERVER_LOOP unless $sock = $listen->accept;
       while (<$sock>) {
           last SERVER_LOOP if /^quit/;
           last if /^done/;
           print;
       }
       $sock = undef;
    }
    $listen->close;
} elsif (defined $pid) {
    # child, try various ways to connect
    $sock = IO::Socket::INET->new("localhost:$port")
         || IO::Socket::INET->new("127.0.0.1:$port");
    if ($sock) {
	print "not " unless $sock->connected;
	print "ok 6\n";
       $sock->print("ok 7\n");
       sleep(1);
       print "ok 8\n";
       $sock->print("ok 9\n");
       $sock->print("done\n");
       $sock->close;
    }
    else {
	print "# $@\n";
	print "not ok 6\n";
	print "not ok 7\n";
	print "not ok 8\n";
	print "not ok 9\n";
    }

    # some machines seem to suffer from a race condition here
    sleep(2);

    $sock = IO::Socket::INET->new("127.0.0.1:$port");
    if ($sock) {
       $sock->print("ok 10\n");
       $sock->print("done\n");
       $sock->close;
    }
    else {
	print "# $@\n";
	print "not ok 10\n";
    }

    # some machines seem to suffer from a race condition here
    sleep(1);

    $sock = IO::Socket->new(Domain => AF_INET,
                            PeerAddr => "localhost:$port")
         || IO::Socket->new(Domain => AF_INET,
                            PeerAddr => "127.0.0.1:$port");
    if ($sock) {
       $sock->print("ok 11\n");
       $sock->print("quit\n");
    } else {
       print "not ok 11\n";
    }
    $sock = undef;
    sleep(1);
    exit;
} else {
    die;
}

# Then test UDP sockets
$server = IO::Socket->new(Domain => AF_INET,
                          Proto  => 'udp',
                          LocalAddr => 'localhost')
       || IO::Socket->new(Domain => AF_INET,
                          Proto  => 'udp',
                          LocalAddr => '127.0.0.1');
$port = $server->sockport;

if ($pid = fork()) {
    my $buf;
    $server->recv($buf, 100);
    print $buf;
} elsif (defined($pid)) {
    #child
    $sock = IO::Socket::INET->new(Proto => 'udp',
                                  PeerAddr => "localhost:$port")
         || IO::Socket::INET->new(Proto => 'udp',
                                  PeerAddr => "127.0.0.1:$port");
    $sock->send("ok 12\n");
    sleep(1);
    $sock->send("ok 12\n");  # send another one to be sure
    exit;
} else {
    die;
}

print "not " unless $server->blocking;
print "ok 13\n";

if ( $^O eq 'qnx' ) {
  # QNX4 library bug: Can set non-blocking on socket, but
  # cannot return that status.
  print "ok 14 # skipped on QNX4\n";
} else {
  $server->blocking(0);
  print "not " if $server->blocking;
  print "ok 14\n";
}

### TEST 15
### Set up some data to be transfered between the server and
### the client. We'll use own source code ...
#
local @data;
if( !open( SRC, "< $0")) {
    print "not ok 15 - $!\n";
} else {
    @data = <SRC>;
    close(SRC);
    print "ok 15\n";
}

### TEST 16
### Start the server
#
my $listen = IO::Socket::INET->new( Listen => 2, Proto => 'tcp', Timeout => 15) ||
    print "not ";
print "ok 16\n";
die if( !defined( $listen));
my $serverport = $listen->sockport;
my $server_pid = fork();
if( $server_pid) {

    ### TEST 17 Client/Server establishment
    #
    print "ok 17\n";

    ### TEST 18
    ### Get data from the server using a single stream
    #
    $sock = IO::Socket::INET->new("localhost:$serverport")
         || IO::Socket::INET->new("127.0.0.1:$serverport");

    if ($sock) {
	$sock->print("send\n");

	my @array = ();
	while( <$sock>) {
	    push( @array, $_);
	}

	$sock->print("done\n");
	$sock->close;

	print "not " if( @array != @data);
    } else {
	print "not ";
    }
    print "ok 18\n";

    ### TEST 21
    ### Get data from the server using a stream, which is
    ### interrupted by eof calls.
    ### On perl-5.7.0 at 7673 this failed in a SOCKS environment, because eof
    ### did an getc followed by an ungetc in order to check for the streams
    ### end. getc(3) got replaced by the SOCKS funktion, which ended up in
    ### a recv(2) call on the socket, while ungetc(3) put back a character
    ### to an IO buffer, which never again was read.
    #
    ### TESTS 19,20,21,22
    ### Try to ping-pong some Unicode.
    #
    $sock = IO::Socket::INET->new("localhost:$serverport")
         || IO::Socket::INET->new("127.0.0.1:$serverport");

    if ($has_perlio) {
	print binmode($sock, ":utf8") ? "ok 19\n" : "not ok 19\n";
    } else {
	print "ok 19 - Skip: no perlio\n";
    }

    if ($sock) {

	if ($has_perlio) {
	    $sock->print("ping \x{100}\n");
	    chomp(my $pong = scalar <$sock>);
	    print $pong =~ /^pong (.+)$/ && $1 eq "\x{100}" ?
		"ok 20\n" : "not ok 20\n";

	    $sock->print("ord \x{100}\n");
	    chomp(my $ord = scalar <$sock>);
	    print $ord == 0x100 ?
		"ok 21\n" : "not ok 21\n";

	    $sock->print("chr 0x100\n");
	    chomp(my $chr = scalar <$sock>);
	    print $chr eq "\x{100}" ?
		"ok 22\n" : "not ok 22\n";
	} else {
	    print "ok $_ - Skip: no perlio\n" for 20..22;
	}

	$sock->print("send\n");

	my @array = ();
	while( !eof( $sock ) ){
	    while( <$sock>) {
		push( @array, $_);
		last;
	    }
	}

	$sock->print("done\n");
	$sock->close;

	print "not " if( @array != @data);
    } else {
	print "not ";
    }
    print "ok 23\n";

    ### TEST 24
    ### Stop the server
    #
    $sock = IO::Socket::INET->new("localhost:$serverport")
         || IO::Socket::INET->new("127.0.0.1:$serverport");

    if ($sock) {
	$sock->print("done\n");
	$sock->close;

	print "not " if( 1 != kill 0, $server_pid);
    } else {
	print "not ";
    }
    print "ok 24\n";

} elsif (defined($server_pid)) {
   
    ### Child
    #
    SERVER_LOOP: while (1) {
	last SERVER_LOOP unless $sock = $listen->accept;
	# Do not print ok/not ok for this binmode() since there's
	# a race condition with our client, just die if we fail.
	if ($has_perlio) { binmode($sock, ":utf8") or die }
	while (<$sock>) {
	    last SERVER_LOOP if /^quit/;
	    last if /^done/;
	    if (/^ping (.+)/) {
		print $sock "pong $1\n";
		next;
	    }
	    if (/^ord (.+)/) {
		print $sock ord($1), "\n";
		next;
	    }
	    if (/^chr (.+)/) {
		print $sock chr(hex($1)), "\n";
		next;
	    }
	    if (/^send/) {
		print $sock @data;
		last;
	    }
	    print;
	}
	$sock = undef;
    }
    $listen->close;
    exit 0;

} else {

    ### Fork failed
    #
    print "not ok 17\n";
    die;
}

# test Blocking option in constructor

$sock = IO::Socket::INET->new(Blocking => 0)
    or print "not ";
print "ok 25\n";

if ( $^O eq 'qnx' ) {
  print "ok 26 # skipped on QNX4\n";
  # QNX4 library bug: Can set non-blocking on socket, but
  # cannot return that status.
} else {
  my $status = $sock->blocking;
  print "not " unless defined $status && !$status;
  print "ok 26\n";
}

--- NEW FILE: io_taint.t ---
#!./perl -T

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use Config;

BEGIN {
    if(-d "lib" && -f "TEST") {
        if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
	    print "1..0\n";
	    exit 0;
        }
    }
}

END { unlink "./__taint__$$" }

print "1..3\n";
use IO::File;
$x = new IO::File "> ./__taint__$$" || die("Cannot open ./__taint__$$\n");
print $x "$$\n";
$x->close;

$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n");
chop($unsafe = <$x>);
eval { kill 0 * $unsafe };
print "not " if ((($^O ne 'MSWin32') && ($^O ne 'NetWare')) and ($@ !~ /^Insecure/o));
print "ok 1\n";
$x->close;

# We could have just done a seek on $x, but technically we haven't tested
# seek yet...
$x = new IO::File "< ./__taint__$$" || die("Cannot open ./__taint__$$\n");
$x->untaint;
print "not " if ($?);
print "ok 2\n"; # Calling the method worked
chop($unsafe = <$x>);
eval { kill 0 * $unsafe };
print "not " if ($@ =~ /^Insecure/o);
print "ok 3\n"; # No Insecure message from using the data
$x->close;

exit 0;

--- NEW FILE: IO.t ---
#!/usr/bin/perl -w

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
	require Config;
	if ($Config::Config{'extensions'} !~ /\bSocket\b/) {
		print "1..0 # Skip: Socket not built - IO.pm uses Socket";
		exit 0;
	}
}

use strict;
use File::Path;
use File::Spec;
require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
plan(tests => 18);

{
	require XSLoader;

	my @load;
	local $^W;
	local *XSLoader::load = sub {
		push @load, \@_;
	};

	# use_ok() calls import, which we do not want to do
	require_ok( 'IO' );
	ok( @load, 'IO should call XSLoader::load()' );
	is( $load[0][0], 'IO', '... loading the IO library' );
	is( $load[0][1], $IO::VERSION, '... with the current .pm version' );
}

my @default = map { "IO/$_.pm" } qw( Handle Seekable File Pipe Socket Dir );
delete @INC{ @default };

my $warn = '' ;
local $SIG{__WARN__} = sub { $warn = "@_" } ;

{
    no warnings ;
    IO->import();
    is( $warn, '', "... import default, should not warn");
    $warn = '' ;
}

{
    local $^W = 0;
    IO->import();
    is( $warn, '', "... import default, should not warn");
    $warn = '' ;
}

{
    local $^W = 1;
    IO->import();
    like( $warn, qr/^Parameterless "use IO" deprecated at/, 
              "... import default, should warn");
    $warn = '' ;
}

{
    use warnings 'deprecated' ;
    IO->import(); 
    like( $warn, qr/^Parameterless "use IO" deprecated at/, 
              "... import default, should warn");
    $warn = '' ;
}

{
    use warnings ;
    IO->import();
    like( $warn, qr/^Parameterless "use IO" deprecated at/, 
              "... import default, should warn");
    $warn = '' ;
}

foreach my $default (@default)
{
	ok( exists $INC{ $default }, "... import should default load $default" );
}

eval { IO->import( 'nothere' ) };
like( $@, qr/Can.t locate IO.nothere\.pm/, '... croaking on any error' );

my $fakedir = File::Spec->catdir( 'lib', 'IO' );
my $fakemod = File::Spec->catfile( $fakedir, 'fakemod.pm' );

my $flag;
if ( -d $fakedir or mkpath( $fakedir ))
{
	if (open( OUT, ">$fakemod"))
	{
		(my $package = <<'		END_HERE') =~ tr/\t//d;
		package IO::fakemod;

		sub import { die "Do not import!\n" }

		sub exists { 1 }

		1;
		END_HERE

		print OUT $package;
	}

	if (close OUT)
	{
		$flag = 1;
		push @INC, 'lib';
	}
}

SKIP:
{
	skip("Could not write to disk", 2 ) unless $flag;
	eval { IO->import( 'fakemod' ) };
	ok( IO::fakemod::exists(), 'import() should import IO:: modules by name' );
	is( $@, '', '... and should not call import() on imported modules' );
}

END
{
	1 while unlink $fakemod;
	rmdir $fakedir;
}

--- NEW FILE: io_linenum.t ---
#!./perl

# test added 29th April 1999 by Paul Johnson (pjcj at transeda.com)
# updated    28th May   1999 by Paul Johnson

my $File;

BEGIN {
    $File = __FILE__;
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	$File =~ s/^t\W+//;                                 # Remove first directory
	@INC = '../lib';
    }
    require strict; import strict;
}

use Test;

BEGIN { plan tests => 12 }

use IO::File;

sub lineno
{
  my ($f) = @_;
  my $l;
  $l .= "$. ";
  $l .= $f->input_line_number;
  $l .= " $.";                     # check $. before and after input_line_number
  $l;
}

my $t;

open (F, $File) or die $!;
my $io = IO::File->new($File) or die $!;

<F> for (1 .. 10);
ok(lineno($io), "10 0 10");

$io->getline for (1 .. 5);
ok(lineno($io), "5 5 5");

<F>;
ok(lineno($io), "11 5 11");

$io->getline;
ok(lineno($io), "6 6 6");

$t = tell F;                                        # tell F; provokes a warning
ok(lineno($io), "11 6 11");

<F>;
ok(lineno($io), "12 6 12");

select F;
ok(lineno($io), "12 6 12");

<F> for (1 .. 10);
ok(lineno($io), "22 6 22");

$io->getline for (1 .. 5);
ok(lineno($io), "11 11 11");

$t = tell F;
# We used to have problems here before local $. worked.
# input_line_number() used to use select and tell.  When we did the
# same, that mechanism broke.  It should work now.
ok(lineno($io), "22 11 22");

{
  local $.;
  $io->getline for (1 .. 5);
  ok(lineno($io), "16 16 16");
}

ok(lineno($io), "22 16 22");

--- NEW FILE: io_udp.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use Config;

BEGIN {
    if(-d "lib" && -f "TEST") {
	my $reason;

	if ($Config{'extensions'} !~ /\bSocket\b/) {
	  $reason = 'Socket was not built';
	}
	elsif ($Config{'extensions'} !~ /\bIO\b/) {
	  $reason = 'IO was not built';
	}
	elsif ($^O eq 'apollo') {
	  $reason = "unknown *FIXME*";
	}
	undef $reason if $^O eq 'VMS' and $Config{d_socket};
	if ($reason) {
	    print "1..0 # Skip: $reason\n";
	    exit 0;
	}
    }
}

sub compare_addr {
    no utf8;
    my $a = shift;
    my $b = shift;
    if (length($a) != length $b) {
	my $min = (length($a) < length $b) ? length($a) : length $b;
	if ($min and substr($a, 0, $min) eq substr($b, 0, $min)) {
	    printf "# Apparently: %d bytes junk at the end of %s\n# %s\n",
		abs(length($a) - length ($b)),
		$_[length($a) < length ($b) ? 1 : 0],
		"consider decreasing bufsize of recfrom.";
	    substr($a, $min) = "";
	    substr($b, $min) = "";
	}
	return 0;
    }
    my @a = unpack_sockaddr_in($a);
    my @b = unpack_sockaddr_in($b);
    "$a[0]$a[1]" eq "$b[0]$b[1]";
}

$| = 1;
print "1..7\n";

use Socket;
use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);

$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
     || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
    or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";

print "ok 1\n";

$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost')
     || IO::Socket::INET->new(Proto => 'udp', LocalAddr => '127.0.0.1')
    or die "$! (maybe your system does not have a localhost at all, 'localhost' or 127.0.0.1)";

print "ok 2\n";

$udpa->send("ok 4\n",0,$udpb->sockname);

print "not "
  unless compare_addr($udpa->peername,$udpb->sockname, 'peername', 'sockname');
print "ok 3\n";

my $where = $udpb->recv($buf="",5);
print $buf;

my @xtra = ();

unless(compare_addr($where,$udpa->sockname, 'recv name', 'sockname')) {
    print "not ";
    @xtra = (0,$udpa->sockname);
}
print "ok 5\n";

$udpb->send("ok 6\n", at xtra);
$udpa->recv($buf="",5);
print $buf;

print "not " if $udpa->connected;
print "ok 7\n";

--- NEW FILE: io_xs.t ---
#!./perl

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use Config;

BEGIN {
    if($ENV{PERL_CORE}) {
        if ($Config{'extensions'} !~ /\bIO\b/) {
	    print "1..0 # Skip: IO extension not built\n";
	    exit 0;
        }
    }
    if( $^O eq 'VMS' && $Config{'vms_cc_type'} ne 'decc' ) {
        print "1..0 # Skip: not compatible with the VAXCRTL\n";
        exit 0;
    }
}

use IO::File;
use IO::Seekable;

print "1..4\n";

$x = new_tmpfile IO::File or print "not ";
print "ok 1\n";
print $x "ok 2\n";
$x->seek(0,SEEK_SET);
print <$x>;

$x->seek(0,SEEK_SET);
print $x "not ok 3\n";
$p = $x->getpos;
print $x "ok 3\n";
$x->flush;
$x->setpos($p);
print scalar <$x>;

$! = 0;
$x->setpos(undef);
print $! ? "ok 4 # $!\n" : "not ok 4\n";


--- NEW FILE: io_file.t ---
#!./perl -w

BEGIN {
    unless(grep /blib/, @INC) {
	chdir 't' if -d 't';
	@INC = '../lib';
    }
}

use strict;
require($ENV{PERL_CORE} ? "./test.pl" : "./t/test.pl");
plan(tests => ($^O =~ /MSWin32/ ? 9 : 6));

my $Class       = 'IO::File';
my $All_Chars   = join '', "\r\n", map( chr, 1..255 ), "zzz\n\r";
my $File        = 'bin.'.$$;
my $Expect      = quotemeta $All_Chars;

use_ok( $Class );
can_ok( $Class,                 "binmode" );

### file the file with binary data;
### use standard open to make sure we can compare binmodes
### on both.
{   my $tmp;
    open $tmp, ">$File" or die "Could not open '$File': $!";
    binmode $tmp;
    print $tmp $All_Chars; 
    close $tmp;
}

### now read in the file, once without binmode, once with.
### without binmode should fail at least on win32...
if( $^O =~ /MSWin32/ ) {
    my $fh = $Class->new;

    isa_ok( $fh,                $Class );
    ok( $fh->open($File),       "   Opened '$File'" );
    
    my $cont = do { local $/; <$fh> };
    unlike( $cont, qr/$Expect/, "   Content match fails without binmode" );
}    

### now with binmode, it must pass 
{   my $fh = $Class->new;

    isa_ok( $fh,                $Class );
    ok( $fh->open($File),       "   Opened '$File' $!" );
    ok( $fh->binmode,           "   binmode enabled" );
    
    my $cont = do { local $/; <$fh> };
    like( $cont, qr/$Expect/,   "   Content match passes with binmode" );
}
    
unlink $File;    




More information about the dslinux-commit mailing list