From: Graham Barr <gbarr@pobox.com>
Date: Mon, 26 Nov 2001 12:41:45 +0000 (+0000)
Subject: Sync-up tests with libnet distribution
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0d375cdb6a7ca319ee2637b1b2bab48dfeb945f2;p=p5sagit%2Fp5-mst-13.2.git
Sync-up tests with libnet distribution
p4raw-id: //depot/perl@13284
---
diff --git a/MANIFEST b/MANIFEST
index 57c9a2d..2b8b218 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1135,6 +1135,7 @@ lib/Net/t/config.t libnet
lib/Net/t/ftp.t libnet
lib/Net/t/hostname.t libnet
lib/Net/t/libnet_t.pl libnet
+lib/Net/t/netrc.t libnet
lib/Net/t/nntp.t libnet
lib/Net/t/require.t libnet
lib/Net/t/smtp.t libnet
diff --git a/lib/Net/t/config.t b/lib/Net/t/config.t
index 95a77aa..4643971 100644
--- a/lib/Net/t/config.t
+++ b/lib/Net/t/config.t
@@ -5,8 +5,40 @@ BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
+ $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;
@@ -16,14 +48,16 @@ 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(''), -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' );
diff --git a/lib/Net/t/hostname.t b/lib/Net/t/hostname.t
index 3bbe2cf..8c37472 100644
--- a/lib/Net/t/hostname.t
+++ b/lib/Net/t/hostname.t
@@ -15,7 +15,7 @@ unless($NetConfig{test_hosts}) {
exit 0;
}
-print "1..1\n";
+print "1..2\n";
$domain = domainname();
@@ -25,3 +25,13 @@ if(defined $domain && $domain ne "") {
else {
print "not ok 1\n";
}
+
+# This check thats hostanme does not overwrite $_
+my @domain = qw(foo.example.com bar.example.jp);
+my @copy = @domain;
+
+my @dummy = grep { hostname eq $_ } @domain;
+
+($domain[0] && $domain[0] eq $copy[0])
+ ? print "ok 2\n"
+ : print "not ok 2\n";
diff --git a/lib/Net/t/netrc.t b/lib/Net/t/netrc.t
new file mode 100644
index 0000000..a4dd778
--- /dev/null
+++ b/lib/Net/t/netrc.t
@@ -0,0 +1,142 @@
+#!./perl
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+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);
+
+ 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( $warn =~ /^Bad permissions/, '... and should warn about it' );
+
+ # the owner field should still not match
+ $stat[2] = 0;
+ ok( !defined(Net::Netrc::_readrc()),
+ '_readrc() should not read file owned by someone else' );
+ ok( $warn =~ /^Not owner/, '... and should warn about it' );
+}
+
+# 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, undef, $file, $mode) = @_;
+ bless({ file => $file, mode => $mode }, $class);
+}
+
+my @lines;
+sub set_lines {
+ @lines = @_;
+}
+
+sub READLINE {
+ shift @lines;
+}
+
+sub close { 1 }
+