dslinux/user/perl/lib/Net/t config.t datasend.t ftp.t hostname.t libnet_t.pl netrc.t nntp.t require.t smtp.t time.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:00:54 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/Net/t
In directory antilope:/tmp/cvs-serv17422/lib/Net/t
Added Files:
config.t datasend.t ftp.t hostname.t libnet_t.pl netrc.t
nntp.t require.t smtp.t time.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: nntp.t ---
#!./perl -w
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
}
if (!eval "require Socket") {
print "1..0 # no Socket\n"; exit 0;
}
if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
use Net::Config;
use Net::NNTP;
use Net::Cmd qw(CMD_REJECT);
unless(@{$NetConfig{nntp_hosts}} && $NetConfig{test_hosts}) {
print "1..0\n";
exit;
}
print "1..4\n";
my $i = 1;
$nntp = Net::NNTP->new(Debug => 0)
or (print("not ok 1\n"), exit);
print "ok 1\n";
my $grp;
foreach $grp (qw(test alt.test control news.announce.newusers)) {
@grp = $nntp->group($grp);
last if @grp;
}
if($nntp->status == CMD_REJECT) {
# Command was rejected, probably because we need authinfo
map { print "ok ",$_,"\n" } 2,3,4;
exit;
}
print "not " unless @grp;
print "ok 2\n";
if(@grp && $grp[2] > $grp[1]) {
$nntp->head($grp[1]) or print "not ";
}
print "ok 3\n";
if(@grp) {
$nntp->quit or print "not ";
}
print "ok 4\n";
--- NEW FILE: require.t ---
#!./perl -w
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
}
if (!eval "require Socket") {
print "1..0 # no Socket\n"; exit 0;
}
if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
print "1..9\n";
my $i = 1;
eval { require Net::Config; } || print "not "; print "ok ",$i++,"\n";
eval { require Net::Domain; } || print "not "; print "ok ",$i++,"\n";
eval { require Net::Cmd; } || print "not "; print "ok ",$i++,"\n";
eval { require Net::Netrc; } || print "not "; print "ok ",$i++,"\n";
eval { require Net::FTP; } || print "not "; print "ok ",$i++,"\n";
eval { require Net::SMTP; } || print "not "; print "ok ",$i++,"\n";
eval { require Net::NNTP; } || print "not "; print "ok ",$i++,"\n";
eval { require Net::POP3; } || print "not "; print "ok ",$i++,"\n";
eval { require Net::Time; } || print "not "; print "ok ",$i++,"\n";
--- NEW FILE: ftp.t ---
#!./perl -w
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
}
if (!eval "require Socket") {
print "1..0 # no Socket\n"; exit 0;
}
if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
use Net::Config;
use Net::FTP;
unless(defined($NetConfig{ftp_testhost}) && $NetConfig{test_hosts}) {
print "1..0\n";
exit 0;
}
my $t = 1;
print "1..7\n";
$ftp = Net::FTP->new($NetConfig{ftp_testhost})
or (print("not ok 1\n"), exit);
printf "ok %d\n",$t++;
$ftp->login('anonymous') or die($ftp->message . "\n");
printf "ok %d\n",$t++;
$ftp->pwd or do {
print STDERR $ftp->message,"\n";
print "not ";
};
printf "ok %d\n",$t++;
$ftp->cwd('/pub') or do {
print STDERR $ftp->message,"\n";
print "not ";
};
if ($data = $ftp->stor('libnet.tst')) {
my $text = "abc\ndef\nqwe\n";
printf "ok %d\n",$t++;
$data->write($text,length $text);
$data->close;
$data = $ftp->retr('libnet.tst');
$data->read($buf,length $text);
$data->close;
print "not " unless $text eq $buf;
printf "ok %d\n",$t++;
$ftp->delete('libnet.tst') or print "not ";
printf "ok %d\n",$t++;
}
else {
print "# ",$ftp->message,"\n";
printf "ok %d\n",$t++;
printf "ok %d\n",$t++;
printf "ok %d\n",$t++;
}
$ftp->quit or do {
print STDERR $ftp->message,"\n";
print "not ";
};
printf "ok %d\n",$t++;
--- NEW FILE: hostname.t ---
#!./perl -w
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
}
if (!eval "require Socket") {
print "1..0 # no Socket\n"; exit 0;
}
if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
use Net::Domain qw(hostname domainname hostdomain);
use Net::Config;
unless($NetConfig{test_hosts}) {
print "1..0\n";
exit 0;
}
print "1..2\n";
$domain = domainname();
if(defined $domain && $domain ne "") {
print "ok 1\n";
}
else {
print "not ok 1\n";
}
# This checks thats hostanme does not overwrite $_
my @domain = qw(foo.example.com bar.example.jp);
my @copy = @domain;
my @dummy = grep { defined hostname() and hostname() eq $_ } @domain;
($domain[0] && $domain[0] eq $copy[0])
? print "ok 2\n"
: print "not ok 2\n";
--- NEW FILE: smtp.t ---
#!./perl -w
BEGIN {
unless (-d 'blib') {
chdir 't' if -d 't';
@INC = '../lib';
}
if (!eval "require Socket") {
print "1..0 # no Socket\n"; exit 0;
}
if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
use Net::Config;
use Net::SMTP;
unless(@{$NetConfig{smtp_hosts}} && $NetConfig{test_hosts}) {
print "1..0\n";
exit 0;
}
print "1..3\n";
my $i = 1;
$smtp = Net::SMTP->new(Debug => 0)
or (print("not ok 1\n"), exit);
print "ok 1\n";
$smtp->domain or print "not ";
print "ok 2\n";
$smtp->quit or print "not ";
print "ok 3\n";
--- NEW FILE: netrc.t ---
#!./perl
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
@INC = '../lib';
}
if (!eval "require Socket") {
print "1..0 # no Socket\n"; exit 0;
}
if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
}
use strict;
use Cwd;
print "1..20\n";
# for testing _readrc
$ENV{HOME} = Cwd::cwd();
# avoid "used only once" warning
local (*CORE::GLOBAL::getpwuid, *CORE::GLOBAL::stat);
*CORE::GLOBAL::getpwuid = sub ($) {
((undef) x 7, Cwd::cwd());
};
# for testing _readrc
my @stat;
*CORE::GLOBAL::stat = sub (*) {
return @stat;
};
# for testing _readrc
$INC{'FileHandle.pm'} = 1;
(my $libnet_t = __FILE__) =~ s/\w+.t$/libnet_t.pl/;
require $libnet_t;
# now that the tricks are out of the way...
eval { require Net::Netrc; };
ok( !$@, 'should be able to require() Net::Netrc safely' );
ok( exists $INC{'Net/Netrc.pm'}, 'should be able to use Net::Netrc' );
SKIP: {
skip('incompatible stat() handling for OS', 4), next SKIP
if ($^O =~ /os2|win32|macos|cygwin/i or $] < 5.005);
my $warn;
local $SIG{__WARN__} = sub {
$warn = shift;
};
# add write access for group/other
$stat[2] = 077;
ok( !defined(Net::Netrc::_readrc()),
'_readrc() should not read world-writable file' );
ok( scalar($warn =~ /^Bad permissions:/),
'... and should warn about it' );
# the owner field should still not match
$stat[2] = 0;
if ($<) {
ok( !defined(Net::Netrc::_readrc()),
'_readrc() should not read file owned by someone else' );
ok( scalar($warn =~ /^Not owner:/),
'... and should warn about it' );
} else {
skip("testing as root",2);
}
}
# this field must now match, to avoid the last-tested warning
$stat[4] = $<;
# this curious mix of spaces and quotes tests a regex at line 79 (version 2.11)
FileHandle::set_lines(split(/\n/, <<LINES));
macdef bar
login baz
machine "foo"
login nigol "password" drowssap
machine foo "login" l2
password p2
account tnuocca
default login "baz" password p2
default "login" baz password p3
macdef
LINES
# having set several lines and the uid, this should succeed
is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
# on 'foo', the login is 'nigol'
is( Net::Netrc->lookup('foo')->{login}, 'nigol',
'lookup() should find value by host name' );
# on 'foo' with login 'l2', the password is 'p2'
is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2',
'lookup() should find value by hostname and login name' );
# the default password is 'p3', as later declarations have priority
is( Net::Netrc->lookup()->{password}, 'p3',
'lookup() should find default value' );
# lookup() ignores the login parameter when using default data
is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3',
'lookup() should ignore passed login when searching default' );
# lookup() goes to default data if hostname cannot be found in config data
is( Net::Netrc->lookup('abadname')->{login}, 'baz',
'lookup() should use default for unknown machine name' );
# now test these accessors
my $instance = bless({}, 'Net::Netrc');
for my $accessor (qw( login account password )) {
is( $instance->$accessor(), undef,
"$accessor() should return undef if $accessor is not set" );
$instance->{$accessor} = $accessor;
is( $instance->$accessor(), $accessor,
"$accessor() should return value when $accessor is set" );
}
# and the three-for-one accessor
is( scalar( () = $instance->lpa()), 3,
'lpa() should return login, password, account');
is( join(' ', $instance->lpa), 'login password account',
'lpa() should return appropriate values for l, p, and a' );
package FileHandle;
sub new {
tie *FH, 'FileHandle', @_;
bless \*FH, $_[0];
}
sub TIEHANDLE {
my ($class, $file, $mode) = @_[0,2,3];
bless({ file => $file, mode => $mode }, $class);
}
my @lines;
sub set_lines {
@lines = @_;
}
sub READLINE {
shift @lines;
}
sub close { 1 }
--- NEW FILE: datasend.t ---
#!./perl -w
BEGIN {
package Foo;
use IO::File;
use Net::Cmd;
@ISA = qw(Net::Cmd IO::File);
sub timeout { 0 }
sub new {
my $fh = shift->new_tmpfile;
binmode($fh);
$fh;
}
sub output {
my $self = shift;
seek($self,0,0);
local $/ = undef;
scalar(<$self>);
}
sub response {
return Net::Cmd::CMD_OK;
}
}
(my $libnet_t = __FILE__) =~ s/datasend.t/libnet_t.pl/;
require $libnet_t or die;
print "1..51\n";
sub check {
my $expect = pop;
my $cmd = Foo->new;
ok($cmd->datasend, 'datasend') unless @_;
foreach my $line (@_) {
ok($cmd->datasend($line), 'datasend');
}
ok($cmd->dataend, 'dataend');
is(
unpack("H*",$cmd->output),
unpack("H*",$expect)
);
}
my $cmd;
check(
# nothing
".\015\012"
);
check(
"a",
"a\015\012.\015\012",
);
check(
"a\r",
"a\015\015\012.\015\012",
);
check(
"a\rb",
"a\015b\015\012.\015\012",
);
check(
"a\rb\n",
"a\015b\015\012.\015\012",
);
check(
"a\rb\n\n",
"a\015b\015\012\015\012.\015\012",
);
check(
"a\r",
"\nb",
"a\015\012b\015\012.\015\012",
);
check(
"a\r",
"\nb\n",
"a\015\012b\015\012.\015\012",
);
check(
"a\r",
"\nb\r\n",
"a\015\012b\015\012.\015\012",
);
check(
"a\r",
"\nb\r\n\n",
"a\015\012b\015\012\015\012.\015\012",
);
check(
"a\n.b\n",
"a\015\012..b\015\012.\015\012",
);
check(
".a\n.b\n",
"..a\015\012..b\015\012.\015\012",
);
check(
".a\n",
".b\n",
"..a\015\012..b\015\012.\015\012",
);
check(
".a",
".b\n",
"..a.b\015\012.\015\012",
);
check(
"a\n.",
"a\015\012..\015\012.\015\012",
);
--- NEW FILE: time.t ---
#!./perl -w
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
@INC = '../lib';
}
if (!eval "require Socket") {
print "1..0 # no Socket\n"; exit 0;
}
if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
$INC{'IO/Socket.pm'} = 1;
$INC{'IO/Select.pm'} = 1;
$INC{'IO/Socket/INET.pm'} = 1;
}
(my $libnet_t = __FILE__) =~ s/time.t/libnet_t.pl/;
require $libnet_t;
print "1..12\n";
# cannot use(), otherwise it will use IO::Socket and IO::Select
eval{ require Net::Time; };
ok( !$@, 'should be able to require() Net::Time safely' );
ok( exists $INC{'Net/Time.pm'}, 'should be able to use Net::Time' );
# force the socket to fail
make_fail('IO::Socket::INET', 'new');
my $badsock = Net::Time::_socket('foo', 1, 'bar', 'baz');
is( $badsock, undef, '_socket() should fail if Socket creation fails' );
# if socket is created with protocol UDP (default), it will send a newline
my $sock = Net::Time::_socket('foo', 2, 'bar');
ok( $sock->isa('IO::Socket::INET'), 'should be an IO::Socket::INET object' );
is( $sock->{sent}, "\n", 'should send \n with UDP protocol set' );
is( $sock->{timeout}, 120, 'timeout should default to 120' );
# now try it with a custom timeout and a different protocol
$sock = Net::Time::_socket('foo', 3, 'bar', 'tcp', 11);
ok( $sock->isa('IO::Socket::INET'), 'should be an IO::Socket::INET object' );
is( $sock->{sent}, undef, '_socket() should send nothing unless UDP protocol' );
is( $sock->{PeerAddr}, 'bar', '_socket() should set PeerAddr in socket' );
is( $sock->{timeout}, 11, '_socket() should respect custom timeout value' );
# inet_daytime
# check for correct args (daytime, 13)
IO::Socket::INET::set_message('z');
is( Net::Time::inet_daytime('bob'), 'z', 'inet_daytime() should receive data' );
# magic numbers defined in Net::Time
my $offset = $^O eq 'MacOS' ?
(4 * 31536000) : (70 * 31536000 + 17 * 86400);
# check for correct args (time, 13)
# pretend it is only six seconds since the offset, create a fake message
# inet_time
IO::Socket::INET::set_message(pack("N", $offset + 6));
is( Net::Time::inet_time('foo'), 6,
'inet_time() should calculate time since offset for time()' );
my %fail;
sub make_fail {
my ($pack, $func, $num) = @_;
$num = 1 unless defined $num;
$fail{$pack}{$func} = $num;
}
package IO::Socket::INET;
$fail{'IO::Socket::INET'} = {
new => 0,
'send' => 0,
};
sub new {
my $class = shift;
return if $fail{$class}{new} and $fail{$class}{new}--;
bless( { @_ }, $class );
}
sub send {
my $self = shift;
my $class = ref($self);
return if $fail{$class}{'send'} and $fail{$class}{'send'}--;
$self->{sent} .= shift;
}
my $msg;
sub set_message {
if (ref($_[0])) {
$_[0]->{msg} = $_[1];
} else {
$msg = shift;
}
}
sub do_recv {
my ($len, $msg) = @_[1,2];
$_[0] .= substr($msg, 0, $len);
}
sub recv {
my ($self, $buf, $length, $flags) = @_;
my $message = exists $self->{msg} ?
$self->{msg} : $msg;
if (defined($message)) {
do_recv($_[1], $length, $message);
}
1;
}
package IO::Select;
sub new {
my $class = shift;
return if defined $fail{$class}{new} and $fail{$class}{new}--;
bless({sock => shift}, $class);
}
sub can_read {
my ($self, $timeout) = @_;
my $class = ref($self);
return if defined $fail{$class}{can_read} and $fail{class}{can_read}--;
$self->{sock}{timeout} = $timeout;
1;
}
1;
--- NEW FILE: libnet_t.pl ---
my $number = 0;
sub ok {
my ($condition, $name) = @_;
my $message = $condition ? "ok " : "not ok ";
$message .= ++$number;
$message .= " # $name" if defined $name;
print $message, "\n";
return $condition;
}
sub is {
my ($got, $expected, $name) = @_;
for ($got, $expected) {
$_ = 'undef' unless defined $_;
}
unless (ok($got eq $expected, $name)) {
warn "Got: '$got'\nExpected: '$expected'\n" . join(' ', caller) . "\n";
}
}
sub skip {
my ($reason, $num) = @_;
$reason ||= '';
$number ||= 1;
for (1 .. $num) {
$number++;
print "ok $number # skip $reason\n";
}
}
1;
--- NEW FILE: config.t ---
#!./perl -w
BEGIN {
if ($ENV{PERL_CORE}) {
chdir 't' if -d 't';
@INC = '../lib';
}
if (!eval "require Socket") {
print "1..0 # no Socket\n"; exit 0;
}
undef *{Socket::inet_aton};
undef *{Socket::inet_ntoa};
if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
}
$INC{'Socket.pm'} = 1;
}
package Socket;
sub import {
my $pkg = caller();
no strict 'refs';
*{ $pkg . '::inet_aton' } = \&inet_aton;
*{ $pkg . '::inet_ntoa' } = \&inet_ntoa;
}
my $fail = 0;
my %names;
sub set_fail {
$fail = shift;
}
sub inet_aton {
return if $fail;
my $num = unpack('N', pack('C*', split(/\./, $_[0])));
$names{$num} = $_[0];
return $num;
}
sub inet_ntoa {
return if $fail;
return $names{$_[0]};
}
package main;
(my $libnet_t = __FILE__) =~ s/config.t/libnet_t.pl/;
require $libnet_t;
print "1..10\n";
use Net::Config;
ok( exists $INC{'Net/Config.pm'}, 'Net::Config should have been used' );
ok( keys %NetConfig, '%NetConfig should be imported' );
Socket::set_fail(1);
undef $NetConfig{'ftp_firewall'};
is( Net::Config->requires_firewall(), 0,
'requires_firewall() should return 0 without ftp_firewall defined' );
$NetConfig{'ftp_firewall'} = 1;
is( Net::Config->requires_firewall('a.host.not.there'), -1,
'... should return -1 without a valid hostname' );
Socket::set_fail(0);
delete $NetConfig{'local_netmask'};
is( Net::Config->requires_firewall('127.0.0.1'), 0,
'... should return 0 without local_netmask defined' );
$NetConfig{'local_netmask'} = '127.0.0.1/24';
is( Net::Config->requires_firewall('127.0.0.1'), 0,
'... should return false if host is within netmask' );
is( Net::Config->requires_firewall('192.168.10.0'), 1,
'... should return true if host is outside netmask' );
# now try more netmasks
$NetConfig{'local_netmask'} = [ '127.0.0.1/24', '10.0.0.0/8' ];
is( Net::Config->requires_firewall('10.10.255.254'), 0,
'... should find success with mutiple local netmasks' );
is( Net::Config->requires_firewall('192.168.10.0'), 1,
'... should handle failure with multiple local netmasks' );
is( \&Net::Config::is_external, \&Net::Config::requires_firewall,
'is_external() should be an alias for requires_firewall()' );
More information about the dslinux-commit
mailing list