From: Graham Barr 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/, <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 } +