lib/Net/t/netrc.t

   1 #!./perl
   2
   3 BEGIN {
   4     if ($ENV{PERL_CORE}) {
   5         chdir 't' if -d 't';
   6         @INC = '../lib';
   7     }
   8 }
   9
  10 use strict;
  11
  12 use Cwd;
  13 print "1..20\n";
  14
  15 # for testing _readrc
  16 $ENV{HOME} = Cwd::cwd();
  17
  18 # avoid "used only once" warning
  19 local (*CORE::GLOBAL::getpwuid, *CORE::GLOBAL::stat);
  20
  21 *CORE::GLOBAL::getpwuid = sub ($) {
  22         ((undef) x 7, Cwd::cwd());
  23 };
  24
  25 # for testing _readrc
  26 my @stat;
  27 *CORE::GLOBAL::stat = sub (*) {
  28         return @stat;
  29 };
  30
  31 # for testing _readrc
  32 $INC{'FileHandle.pm'} = 1;
  33
  34 (my $libnet_t = __FILE__) =~ s/\w+.t$/libnet_t.pl/;
  35 require $libnet_t;
  36
  37 # now that the tricks are out of the way...
  38 eval { require Net::Netrc; };
  39 ok( !$@, 'should be able to require() Net::Netrc safely' );
  40 ok( exists $INC{'Net/Netrc.pm'}, 'should be able to use Net::Netrc' );
  41
  42 SKIP: {
  43         skip('incompatible stat() handling for OS', 4), next SKIP
  44                 if ($^O =~ /os2|win32|macos|cygwin/i);
  45
  46         my $warn;
  47         local $SIG{__WARN__} = sub {
  48                 $warn = shift;
  49         };
  50
  51         # add write access for group/other
  52         $stat[2] = 077;
  53         ok( !defined(Net::Netrc::_readrc()),
  54                 '_readrc() should not read world-writable file' );
  55         ok( $warn =~ /^Bad permissions/, '... and should warn about it' );
  56
  57         # the owner field should still not match
  58         $stat[2] = 0;
  59         ok( !defined(Net::Netrc::_readrc()),
  60                 '_readrc() should not read file owned by someone else' );
  61         ok( $warn =~ /^Not owner/, '... and should warn about it' );
  62 }
  63
  64 # this field must now match, to avoid the last-tested warning
  65 $stat[4] = $<;
  66
  67 # this curious mix of spaces and quotes tests a regex at line 79 (version 2.11)
  68 FileHandle::set_lines(split(/\n/, <<LINES));
  69 macdef bar
  70 login   baz
  71  machine "foo"
  72 login   nigol "password" drowssap
  73 machine foo "login"     l2
  74         password p2
  75 account tnuocca
  76 default login "baz" password p2
  77 default "login" baz password p3
  78 macdef
  79 LINES
  80
  81 # having set several lines and the uid, this should succeed
  82 is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
  83
  84 # on 'foo', the login is 'nigol'
  85 is( Net::Netrc->lookup('foo')->{login}, 'nigol',
  86         'lookup() should find value by host name' );
  87
  88 # on 'foo' with login 'l2', the password is 'p2'
  89 is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2',
  90         'lookup() should find value by hostname and login name' );
  91
  92 # the default password is 'p3', as later declarations have priority
  93 is( Net::Netrc->lookup()->{password}, 'p3',
  94         'lookup() should find default value' );
  95
  96 # lookup() ignores the login parameter when using default data
  97 is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3',
  98         'lookup() should ignore passed login when searching default' );
  99
 100 # lookup() goes to default data if hostname cannot be found in config data
 101 is( Net::Netrc->lookup('abadname')->{login}, 'baz',
 102         'lookup() should use default for unknown machine name' );
 103
 104 # now test these accessors
 105 my $instance = bless({}, 'Net::Netrc');
 106 for my $accessor (qw( login account password )) {
 107         is( $instance->$accessor(), undef,
 108                 "$accessor() should return undef if $accessor is not set" );
 109         $instance->{$accessor} = $accessor;
 110         is( $instance->$accessor(), $accessor,
 111                 "$accessor() should return value when $accessor is set" );
 112 }
 113
 114 # and the three-for-one accessor
 115 is( scalar( () = $instance->lpa()), 3,
 116         'lpa() should return login, password, account');
 117 is( join(' ', $instance->lpa), 'login password account',
 118         'lpa() should return appropriate values for l, p, and a' );
 119
 120 package FileHandle;
 121
 122 sub new {
 123         tie *FH, 'FileHandle', @_;
 124         bless \*FH, $_[0];
 125 }
 126
 127 sub TIEHANDLE {
 128         my ($class, undef, $file, $mode) = @_;
 129         bless({ file => $file, mode => $mode }, $class);
 130 }
 131
 132 my @lines;
 133 sub set_lines {
 134         @lines = @_;
 135 }
 136
 137 sub READLINE {
 138         shift @lines;
 139 }
 140
 141 sub close { 1 }
 142