| 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 |