lib/Net/Netrc.pm

   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