Commit | Line | Data |
0d375cdb |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | if ($ENV{PERL_CORE}) { |
5 | chdir 't' if -d 't'; |
6 | @INC = '../lib'; |
7 | } |
1a8dcddb |
8 | if (!eval "require Socket") { |
9 | print "1..0 # no Socket\n"; exit 0; |
10 | } |
8b14f033 |
11 | if (ord('A') == 193 && !eval "require Convert::EBCDIC") { |
12 | print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0; |
13 | } |
0d375cdb |
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' ); |
1d662fb6 |
61 | ok( scalar( $warn =~ /^Bad permissions:/ ), |
62 | '... and should warn about it' ); |
0d375cdb |
63 | |
64 | # the owner field should still not match |
65 | $stat[2] = 0; |
860599f1 |
66 | |
8c81eb11 |
67 | if ($<) { |
68 | ok( !defined(Net::Netrc::_readrc()), |
69 | '_readrc() should not read file owned by someone else' ); |
1d662fb6 |
70 | ok( scalar( $warn =~ /^Not owner:/ ), |
71 | '... and should warn about it' ); |
8c81eb11 |
72 | } else { |
73 | ok(1, "Skip - testing as root") for 1..2; |
74 | } |
0d375cdb |
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, undef, $file, $mode) = @_; |
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 | |