This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Root is the lizard king.
[perl5.git] / 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