Commit | Line | Data |
406c51ee |
1 | # Net::Netrc.pm |
2 | # |
3 | # Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved. |
4 | # This program is free software; you can redistribute it and/or |
5 | # modify it under the same terms as Perl itself. |
6 | |
7 | package Net::Netrc; |
8 | |
9 | use Carp; |
10 | use strict; |
11 | use FileHandle; |
12 | use vars qw($VERSION); |
13 | |
12df23ee |
14 | $VERSION = "2.12"; # $Id: //depot/libnet/Net/Netrc.pm#13 $ |
406c51ee |
15 | |
16 | my %netrc = (); |
17 | |
18 | sub _readrc |
19 | { |
20 | my $host = shift; |
21 | my($home,$file); |
686337f3 |
22 | |
406c51ee |
23 | if($^O eq "MacOS") { |
24 | $home = $ENV{HOME} || `pwd`; |
25 | chomp($home); |
26 | $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc"); |
27 | } else { |
28 | # Some OS's don't have `getpwuid', so we default to $ENV{HOME} |
29 | $home = eval { (getpwuid($>))[7] } || $ENV{HOME}; |
302c2e6b |
30 | $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH}||'') if defined $ENV{HOMEDRIVE}; |
406c51ee |
31 | $file = $home . "/.netrc"; |
32 | } |
33 | |
34 | my($login,$pass,$acct) = (undef,undef,undef); |
35 | my $fh; |
36 | local $_; |
37 | |
38 | $netrc{default} = undef; |
39 | |
40 | # OS/2 and Win32 do not handle stat in a way compatable with this check :-( |
686337f3 |
41 | unless($^O eq 'os2' |
42 | || $^O eq 'MSWin32' |
43 | || $^O eq 'MacOS' |
44 | || $^O =~ /^cygwin/) |
406c51ee |
45 | { |
46 | my @stat = stat($file); |
47 | |
48 | if(@stat) |
49 | { |
50 | if($stat[2] & 077) |
51 | { |
52 | carp "Bad permissions: $file"; |
53 | return; |
54 | } |
55 | if($stat[4] != $<) |
56 | { |
57 | carp "Not owner: $file"; |
58 | return; |
59 | } |
60 | } |
61 | } |
62 | |
63 | if($fh = FileHandle->new($file,"r")) |
64 | { |
65 | my($mach,$macdef,$tok,@tok) = (0,0); |
66 | |
67 | while(<$fh>) |
68 | { |
69 | undef $macdef if /\A\n\Z/; |
70 | |
71 | if($macdef) |
72 | { |
73 | push(@$macdef,$_); |
74 | next; |
75 | } |
76 | |
77 | s/^\s*//; |
78 | chomp; |
12df23ee |
79 | |
80 | while(length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) { |
81 | (my $tok = $+) =~ s/\\(.)/$1/g; |
82 | push(@tok, $tok); |
83 | } |
406c51ee |
84 | |
85 | TOKEN: |
86 | while(@tok) |
87 | { |
88 | if($tok[0] eq "default") |
89 | { |
90 | shift(@tok); |
91 | $mach = bless {}; |
92 | $netrc{default} = [$mach]; |
93 | |
94 | next TOKEN; |
95 | } |
96 | |
97 | last TOKEN |
98 | unless @tok > 1; |
99 | |
100 | $tok = shift(@tok); |
101 | |
102 | if($tok eq "machine") |
103 | { |
104 | my $host = shift @tok; |
105 | $mach = bless {machine => $host}; |
106 | |
107 | $netrc{$host} = [] |
108 | unless exists($netrc{$host}); |
109 | push(@{$netrc{$host}}, $mach); |
110 | } |
111 | elsif($tok =~ /^(login|password|account)$/) |
112 | { |
113 | next TOKEN unless $mach; |
114 | my $value = shift @tok; |
115 | # Following line added by rmerrell to remove '/' escape char in .netrc |
116 | $value =~ s/\/\\/\\/g; |
117 | $mach->{$1} = $value; |
118 | } |
119 | elsif($tok eq "macdef") |
120 | { |
121 | next TOKEN unless $mach; |
122 | my $value = shift @tok; |
123 | $mach->{macdef} = {} |
124 | unless exists $mach->{macdef}; |
125 | $macdef = $mach->{machdef}{$value} = []; |
126 | } |
127 | } |
128 | } |
129 | $fh->close(); |
130 | } |
131 | } |
132 | |
133 | sub lookup |
134 | { |
135 | my($pkg,$mach,$login) = @_; |
136 | |
137 | _readrc() |
138 | unless exists $netrc{default}; |
139 | |
140 | $mach ||= 'default'; |
141 | undef $login |
142 | if $mach eq 'default'; |
143 | |
144 | if(exists $netrc{$mach}) |
145 | { |
146 | if(defined $login) |
147 | { |
148 | my $m; |
149 | foreach $m (@{$netrc{$mach}}) |
150 | { |
151 | return $m |
152 | if(exists $m->{login} && $m->{login} eq $login); |
153 | } |
154 | return undef; |
155 | } |
156 | return $netrc{$mach}->[0] |
157 | } |
158 | |
159 | return $netrc{default}->[0] |
160 | if defined $netrc{default}; |
161 | |
162 | return undef; |
163 | } |
164 | |
165 | sub login |
166 | { |
167 | my $me = shift; |
168 | |
169 | exists $me->{login} |
170 | ? $me->{login} |
171 | : undef; |
172 | } |
173 | |
174 | sub account |
175 | { |
176 | my $me = shift; |
177 | |
178 | exists $me->{account} |
179 | ? $me->{account} |
180 | : undef; |
181 | } |
182 | |
183 | sub password |
184 | { |
185 | my $me = shift; |
186 | |
187 | exists $me->{password} |
188 | ? $me->{password} |
189 | : undef; |
190 | } |
191 | |
192 | sub lpa |
193 | { |
194 | my $me = shift; |
195 | ($me->login, $me->password, $me->account); |
196 | } |
197 | |
198 | 1; |
199 | |
200 | __END__ |
201 | |
202 | =head1 NAME |
203 | |
204 | Net::Netrc - OO interface to users netrc file |
205 | |
206 | =head1 SYNOPSIS |
207 | |
208 | use Net::Netrc; |
686337f3 |
209 | |
406c51ee |
210 | $mach = Net::Netrc->lookup('some.machine'); |
211 | $login = $mach->login; |
212 | ($login, $password, $account) = $mach->lpa; |
213 | |
214 | =head1 DESCRIPTION |
215 | |
216 | C<Net::Netrc> is a class implementing a simple interface to the .netrc file |
217 | used as by the ftp program. |
218 | |
219 | C<Net::Netrc> also implements security checks just like the ftp program, |
220 | these checks are, first that the .netrc file must be owned by the user and |
221 | second the ownership permissions should be such that only the owner has |
222 | read and write access. If these conditions are not met then a warning is |
223 | output and the .netrc file is not read. |
224 | |
225 | =head1 THE .netrc FILE |
226 | |
227 | The .netrc file contains login and initialization information used by the |
228 | auto-login process. It resides in the user's home directory. The following |
229 | tokens are recognized; they may be separated by spaces, tabs, or new-lines: |
230 | |
231 | =over 4 |
232 | |
233 | =item machine name |
234 | |
235 | Identify a remote machine name. The auto-login process searches |
236 | the .netrc file for a machine token that matches the remote machine |
237 | specified. Once a match is made, the subsequent .netrc tokens |
238 | are processed, stopping when the end of file is reached or an- |
239 | other machine or a default token is encountered. |
240 | |
241 | =item default |
242 | |
243 | This is the same as machine name except that default matches |
244 | any name. There can be only one default token, and it must be |
245 | after all machine tokens. This is normally used as: |
246 | |
247 | default login anonymous password user@site |
248 | |
249 | thereby giving the user automatic anonymous login to machines |
250 | not specified in .netrc. |
251 | |
252 | =item login name |
253 | |
254 | Identify a user on the remote machine. If this token is present, |
255 | the auto-login process will initiate a login using the |
256 | specified name. |
257 | |
258 | =item password string |
259 | |
260 | Supply a password. If this token is present, the auto-login |
261 | process will supply the specified string if the remote server |
262 | requires a password as part of the login process. |
263 | |
264 | =item account string |
265 | |
266 | Supply an additional account password. If this token is present, |
267 | the auto-login process will supply the specified string |
268 | if the remote server requires an additional account password. |
269 | |
270 | =item macdef name |
271 | |
272 | Define a macro. C<Net::Netrc> only parses this field to be compatible |
273 | with I<ftp>. |
274 | |
275 | =back |
276 | |
277 | =head1 CONSTRUCTOR |
278 | |
279 | The constructor for a C<Net::Netrc> object is not called new as it does not |
280 | really create a new object. But instead is called C<lookup> as this is |
281 | essentially what it does. |
282 | |
283 | =over 4 |
284 | |
285 | =item lookup ( MACHINE [, LOGIN ]) |
286 | |
287 | Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given |
288 | then the entry returned will have the given login. If C<LOGIN> is not given then |
289 | the first entry in the .netrc file for C<MACHINE> will be returned. |
290 | |
291 | If a matching entry cannot be found, and a default entry exists, then a |
292 | reference to the default entry is returned. |
293 | |
302c2e6b |
294 | If there is no matching entry found and there is no default defined, or |
295 | no .netrc file is found, then C<undef> is returned. |
296 | |
406c51ee |
297 | =back |
298 | |
299 | =head1 METHODS |
300 | |
301 | =over 4 |
302 | |
303 | =item login () |
304 | |
305 | Return the login id for the netrc entry |
306 | |
307 | =item password () |
308 | |
309 | Return the password for the netrc entry |
310 | |
311 | =item account () |
312 | |
313 | Return the account information for the netrc entry |
314 | |
315 | =item lpa () |
316 | |
317 | Return a list of login, password and account information fir the netrc entry |
318 | |
319 | =back |
320 | |
321 | =head1 AUTHOR |
322 | |
323 | Graham Barr <gbarr@pobox.com> |
324 | |
325 | =head1 SEE ALSO |
326 | |
327 | L<Net::Netrc> |
328 | L<Net::Cmd> |
329 | |
330 | =head1 COPYRIGHT |
331 | |
332 | Copyright (c) 1995-1998 Graham Barr. All rights reserved. |
333 | This program is free software; you can redistribute it and/or modify |
334 | it under the same terms as Perl itself. |
335 | |
686337f3 |
336 | =for html <hr> |
337 | |
12df23ee |
338 | $Id: //depot/libnet/Net/Netrc.pm#13 $ |
686337f3 |
339 | |
406c51ee |
340 | =cut |