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