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