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