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