Commit | Line | Data |
---|---|---|
86530b38 AT |
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 | ||
14 | $VERSION = "2.12"; # $Id: //depot/libnet/Net/Netrc.pm#13 $ | |
15 | ||
16 | my %netrc = (); | |
17 | ||
18 | sub _readrc | |
19 | { | |
20 | my $host = shift; | |
21 | my($home,$file); | |
22 | ||
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}; | |
30 | $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH}||'') if defined $ENV{HOMEDRIVE}; | |
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 :-( | |
41 | unless($^O eq 'os2' | |
42 | || $^O eq 'MSWin32' | |
43 | || $^O eq 'MacOS' | |
44 | || $^O =~ /^cygwin/) | |
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; | |
79 | ||
80 | while(length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) { | |
81 | (my $tok = $+) =~ s/\\(.)/$1/g; | |
82 | push(@tok, $tok); | |
83 | } | |
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; | |
209 | ||
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 | ||
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 | ||
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 | ||
336 | =for html <hr> | |
337 | ||
338 | $Id: //depot/libnet/Net/Netrc.pm#13 $ | |
339 | ||
340 | =cut |