cpan/libnet/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 $Net::Netrc::TESTING=$Net::Netrc::TESTING=1;
  48
  49 SKIP: {
  50         skip('incompatible stat() handling for OS', 4), next SKIP
  51                 if ($^O =~ /os2|win32|macos|cygwin/i or $] < 5.005);
  52
  53         my $warn;
  54         local $SIG{__WARN__} = sub {
  55                 $warn = shift;
  56         };
  57
  58         # add write access for group/other
  59         $stat[2] = 077;
  60         ok( !defined(Net::Netrc::_readrc()),
  61                 '_readrc() should not read world-writable file' );
  62         ok( scalar($warn =~ /^Bad permissions:/),
  63                 '... and should warn about it' );
  64
  65         # the owner field should still not match
  66         $stat[2] = 0;
  67
  68         if ($<) {
  69           ok( !defined(Net::Netrc::_readrc()),
  70               '_readrc() should not read file owned by someone else' );
  71           ok( scalar($warn =~ /^Not owner:/),
  72                 '... and should warn about it' );
  73         } else {
  74           skip("testing as root",2);
  75         }
  76 }
  77
  78 # this field must now match, to avoid the last-tested warning
  79 $stat[4] = $<;
  80
  81 # this curious mix of spaces and quotes tests a regex at line 79 (version 2.11)
  82 FileHandle::set_lines(split(/\n/, <<LINES));
  83 macdef   bar
  84 login    baz
  85 machine  "foo"
  86 login    nigol "password" drowssap
  87 machine  foo "login" l2
  88 password p2
  89 account  tnuocca
  90 default  login "baz" password p2
  91 default  "login" baz password p3
  92 macdef
  93 LINES
  94
  95 # having set several lines and the uid, this should succeed
  96 is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
  97
  98 # on 'foo', the login is 'nigol'
  99 is( Net::Netrc->lookup('foo')->{login}, 'nigol',
 100         'lookup() should find value by host name' );
 101
 102 # on 'foo' with login 'l2', the password is 'p2'
 103 is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2',
 104         'lookup() should find value by hostname and login name' );
 105
 106 # the default password is 'p3', as later declarations have priority
 107 is( Net::Netrc->lookup()->{password}, 'p3',
 108         'lookup() should find default value' );
 109
 110 # lookup() ignores the login parameter when using default data
 111 is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3',
 112         'lookup() should ignore passed login when searching default' );
 113
 114 # lookup() goes to default data if hostname cannot be found in config data
 115 is( Net::Netrc->lookup('abadname')->{login}, 'baz',
 116         'lookup() should use default for unknown machine name' );
 117
 118 # now test these accessors
 119 my $instance = bless({}, 'Net::Netrc');
 120 for my $accessor (qw( login account password )) {
 121         is( $instance->$accessor(), undef,
 122                 "$accessor() should return undef if $accessor is not set" );
 123         $instance->{$accessor} = $accessor;
 124         is( $instance->$accessor(), $accessor,
 125                 "$accessor() should return value when $accessor is set" );
 126 }
 127
 128 # and the three-for-one accessor
 129 is( scalar( () = $instance->lpa()), 3,
 130         'lpa() should return login, password, account');
 131 is( join(' ', $instance->lpa), 'login password account',
 132         'lpa() should return appropriate values for l, p, and a' );
 133
 134 package FileHandle;
 135
 136 sub new {
 137         tie *FH, 'FileHandle', @_;
 138         bless \*FH, $_[0];
 139 }
 140
 141 sub TIEHANDLE {
 142         my ($class, $file, $mode) = @_[0,2,3];
 143         bless({ file => $file, mode => $mode }, $class);
 144 }
 145
 146 my @lines;
 147 sub set_lines {
 148         @lines = @_;
 149 }
 150
 151 sub READLINE {
 152         shift @lines;
 153 }
 154
 155 sub close { 1 }
 156