Commit | Line | Data |
---|---|---|
0d375cdb GB |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
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 | ||
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 | |
12df23ee | 50 | if ($^O =~ /os2|win32|macos|cygwin/i or $] < 5.005); |
0d375cdb GB |
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' ); | |
12df23ee GB |
61 | ok( scalar($warn =~ /^Bad permissions:/), |
62 | '... and should warn about it' ); | |
0d375cdb GB |
63 | |
64 | # the owner field should still not match | |
65 | $stat[2] = 0; | |
860599f1 | 66 | |
8c81eb11 JH |
67 | if ($<) { |
68 | ok( !defined(Net::Netrc::_readrc()), | |
69 | '_readrc() should not read file owned by someone else' ); | |
12df23ee GB |
70 | ok( scalar($warn =~ /^Not owner:/), |
71 | '... and should warn about it' ); | |
8c81eb11 | 72 | } else { |
12df23ee | 73 | skip("testing as root",2); |
8c81eb11 | 74 | } |
0d375cdb GB |
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 { | |
12df23ee | 141 | my ($class, $file, $mode) = @_[0,2,3]; |
0d375cdb GB |
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 |