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
CommitLineData
0d375cdb
GB
1#!./perl
2
3BEGIN {
4 if ($ENV{PERL_CORE}) {
5 chdir 't' if -d 't';
6 @INC = '../lib';
7 }
1a8dcddb
JH
8 if (!eval "require Socket") {
9 print "1..0 # no Socket\n"; exit 0;
10 }
8b14f033
JH
11 if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
12 print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
13 }
0d375cdb
GB
14}
15
16use strict;
17
18use Cwd;
19print "1..20\n";
20
21# for testing _readrc
22$ENV{HOME} = Cwd::cwd();
23
24# avoid "used only once" warning
25local (*CORE::GLOBAL::getpwuid, *CORE::GLOBAL::stat);
26
27*CORE::GLOBAL::getpwuid = sub ($) {
28 ((undef) x 7, Cwd::cwd());
29};
30
31# for testing _readrc
32my @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/;
41require $libnet_t;
42
43# now that the tricks are out of the way...
44eval { require Net::Netrc; };
45ok( !$@, 'should be able to require() Net::Netrc safely' );
46ok( exists $INC{'Net/Netrc.pm'}, 'should be able to use Net::Netrc' );
47
48SKIP: {
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' );
860599f1 61 ok( $warn =~ /^Bad permissions:/, '... and should warn about it' );
0d375cdb
GB
62
63 # the owner field should still not match
64 $stat[2] = 0;
860599f1
JH
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)
0d375cdb
GB
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)
85FileHandle::set_lines(split(/\n/, <<LINES));
86macdef bar
87login baz
88 machine "foo"
89login nigol "password" drowssap
90machine foo "login" l2
91 password p2
92account tnuocca
93default login "baz" password p2
94default "login" baz password p3
95macdef
96LINES
97
98# having set several lines and the uid, this should succeed
99is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
100
101# on 'foo', the login is 'nigol'
102is( 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'
106is( 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
110is( Net::Netrc->lookup()->{password}, 'p3',
111 'lookup() should find default value' );
112
113# lookup() ignores the login parameter when using default data
114is( 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
118is( Net::Netrc->lookup('abadname')->{login}, 'baz',
119 'lookup() should use default for unknown machine name' );
120
121# now test these accessors
122my $instance = bless({}, 'Net::Netrc');
123for 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
132is( scalar( () = $instance->lpa()), 3,
133 'lpa() should return login, password, account');
134is( join(' ', $instance->lpa), 'login password account',
135 'lpa() should return appropriate values for l, p, and a' );
136
137package FileHandle;
138
139sub new {
140 tie *FH, 'FileHandle', @_;
141 bless \*FH, $_[0];
142}
143
144sub TIEHANDLE {
145 my ($class, undef, $file, $mode) = @_;
146 bless({ file => $file, mode => $mode }, $class);
147}
148
149my @lines;
150sub set_lines {
151 @lines = @_;
152}
153
154sub READLINE {
155 shift @lines;
156}
157
158sub close { 1 }
159