cpan/libnet/t/netrc.t

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