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
  66         my $olduid = $>;
  67         eval { $> = 1 }; # switch uid away from root (may not be impelemented)
  68
  69       SKIP: {
  70           skip("don't you know what absolutely power does to you?", 2)
  71               if $> == 0;
  72
  73           ok( !defined(Net::Netrc::_readrc()),
  74               '_readrc() should not read file owned by someone else' );
  75           ok( $warn =~ /^Not owner:/, '... and should warn about it' );
  76       }
  77
  78         eval { $> = $olduid }; # switch uid back (may not be implemented)
  79 }
  80
  81 # this field must now match, to avoid the last-tested warning
  82 $stat[4] = $<;
  83
  84 # this curious mix of spaces and quotes tests a regex at line 79 (version 2.11)
  85 FileHandle::set_lines(split(/\n/, <<LINES));
  86 macdef bar
  87 login   baz
  88  machine "foo"
  89 login   nigol "password" drowssap
  90 machine foo "login"     l2
  91         password p2
  92 account tnuocca
  93 default login "baz" password p2
  94 default "login" baz password p3
  95 macdef
  96 LINES
  97
  98 # having set several lines and the uid, this should succeed
  99 is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
 100
 101 # on 'foo', the login is 'nigol'
 102 is( Net::Netrc->lookup('foo')->{login}, 'nigol',
 103         'lookup() should find value by host name' );
 104
 105 # on 'foo' with login 'l2', the password is 'p2'
 106 is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2',
 107         'lookup() should find value by hostname and login name' );
 108
 109 # the default password is 'p3', as later declarations have priority
 110 is( Net::Netrc->lookup()->{password}, 'p3',
 111         'lookup() should find default value' );
 112
 113 # lookup() ignores the login parameter when using default data
 114 is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3',
 115         'lookup() should ignore passed login when searching default' );
 116
 117 # lookup() goes to default data if hostname cannot be found in config data
 118 is( Net::Netrc->lookup('abadname')->{login}, 'baz',
 119         'lookup() should use default for unknown machine name' );
 120
 121 # now test these accessors
 122 my $instance = bless({}, 'Net::Netrc');
 123 for my $accessor (qw( login account password )) {
 124         is( $instance->$accessor(), undef,
 125                 "$accessor() should return undef if $accessor is not set" );
 126         $instance->{$accessor} = $accessor;
 127         is( $instance->$accessor(), $accessor,
 128                 "$accessor() should return value when $accessor is set" );
 129 }
 130
 131 # and the three-for-one accessor
 132 is( scalar( () = $instance->lpa()), 3,
 133         'lpa() should return login, password, account');
 134 is( join(' ', $instance->lpa), 'login password account',
 135         'lpa() should return appropriate values for l, p, and a' );
 136
 137 package FileHandle;
 138
 139 sub new {
 140         tie *FH, 'FileHandle', @_;
 141         bless \*FH, $_[0];
 142 }
 143
 144 sub TIEHANDLE {
 145         my ($class, undef, $file, $mode) = @_;
 146         bless({ file => $file, mode => $mode }, $class);
 147 }
 148
 149 my @lines;
 150 sub set_lines {
 151         @lines = @_;
 152 }
 153
 154 sub READLINE {
 155         shift @lines;
 156 }
 157
 158 sub close { 1 }
 159