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#12 $
  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      push(@tok, $+)
  80        while(length && s/^("([^"]*)"|(\S+))\s*//);
  81
  82 TOKEN:
  83      while(@tok)
  84       {
  85        if($tok[0] eq "default")
  86         {
  87          shift(@tok);
  88          $mach = bless {};
  89          $netrc{default} = [$mach];
  90
  91          next TOKEN;
  92         }
  93
  94        last TOKEN
  95             unless @tok > 1;
  96
  97        $tok = shift(@tok);
  98
  99        if($tok eq "machine")
 100         {
 101          my $host = shift @tok;
 102          $mach = bless {machine => $host};
 103
 104          $netrc{$host} = []
 105             unless exists($netrc{$host});
 106          push(@{$netrc{$host}}, $mach);
 107         }
 108        elsif($tok =~ /^(login|password|account)$/)
 109         {
 110          next TOKEN unless $mach;
 111          my $value = shift @tok;
 112          # Following line added by rmerrell to remove '/' escape char in .netrc
 113          $value =~ s/\/\\/\\/g;
 114          $mach->{$1} = $value;
 115         }
 116        elsif($tok eq "macdef")
 117         {
 118          next TOKEN unless $mach;
 119          my $value = shift @tok;
 120          $mach->{macdef} = {}
 121             unless exists $mach->{macdef};
 122          $macdef = $mach->{machdef}{$value} = [];
 123         }
 124       }
 125     }
 126    $fh->close();
 127   }
 128 }
 129
 130 sub lookup
 131 {
 132  my($pkg,$mach,$login) = @_;
 133
 134  _readrc()
 135     unless exists $netrc{default};
 136
 137  $mach ||= 'default';
 138  undef $login
 139     if $mach eq 'default';
 140
 141  if(exists $netrc{$mach})
 142   {
 143    if(defined $login)
 144     {
 145      my $m;
 146      foreach $m (@{$netrc{$mach}})
 147       {
 148        return $m
 149             if(exists $m->{login} && $m->{login} eq $login);
 150       }
 151      return undef;
 152     }
 153    return $netrc{$mach}->[0]
 154   }
 155
 156  return $netrc{default}->[0]
 157     if defined $netrc{default};
 158
 159  return undef;
 160 }
 161
 162 sub login
 163 {
 164  my $me = shift;
 165
 166  exists $me->{login}
 167     ? $me->{login}
 168     : undef;
 169 }
 170
 171 sub account
 172 {
 173  my $me = shift;
 174
 175  exists $me->{account}
 176     ? $me->{account}
 177     : undef;
 178 }
 179
 180 sub password
 181 {
 182  my $me = shift;
 183
 184  exists $me->{password}
 185     ? $me->{password}
 186     : undef;
 187 }
 188
 189 sub lpa
 190 {
 191  my $me = shift;
 192  ($me->login, $me->password, $me->account);
 193 }
 194
 195 1;
 196
 197 __END__
 198
 199 =head1 NAME
 200
 201 Net::Netrc - OO interface to users netrc file
 202
 203 =head1 SYNOPSIS
 204
 205     use Net::Netrc;
 206
 207     $mach = Net::Netrc->lookup('some.machine');
 208     $login = $mach->login;
 209     ($login, $password, $account) = $mach->lpa;
 210
 211 =head1 DESCRIPTION
 212
 213 C<Net::Netrc> is a class implementing a simple interface to the .netrc file
 214 used as by the ftp program.
 215
 216 C<Net::Netrc> also implements security checks just like the ftp program,
 217 these checks are, first that the .netrc file must be owned by the user and
 218 second the ownership permissions should be such that only the owner has
 219 read and write access. If these conditions are not met then a warning is
 220 output and the .netrc file is not read.
 221
 222 =head1 THE .netrc FILE
 223
 224 The .netrc file contains login and initialization information used by the
 225 auto-login process.  It resides in the user's home directory.  The following
 226 tokens are recognized; they may be separated by spaces, tabs, or new-lines:
 227
 228 =over 4
 229
 230 =item machine name
 231
 232 Identify a remote machine name. The auto-login process searches
 233 the .netrc file for a machine token that matches the remote machine
 234 specified.  Once a match is made, the subsequent .netrc tokens
 235 are processed, stopping when the end of file is reached or an-
 236 other machine or a default token is encountered.
 237
 238 =item default
 239
 240 This is the same as machine name except that default matches
 241 any name.  There can be only one default token, and it must be
 242 after all machine tokens.  This is normally used as:
 243
 244     default login anonymous password user@site
 245
 246 thereby giving the user automatic anonymous login to machines
 247 not specified in .netrc.
 248
 249 =item login name
 250
 251 Identify a user on the remote machine.  If this token is present,
 252 the auto-login process will initiate a login using the
 253 specified name.
 254
 255 =item password string
 256
 257 Supply a password.  If this token is present, the auto-login
 258 process will supply the specified string if the remote server
 259 requires a password as part of the login process.
 260
 261 =item account string
 262
 263 Supply an additional account password.  If this token is present,
 264 the auto-login process will supply the specified string
 265 if the remote server requires an additional account password.
 266
 267 =item macdef name
 268
 269 Define a macro. C<Net::Netrc> only parses this field to be compatible
 270 with I<ftp>.
 271
 272 =back
 273
 274 =head1 CONSTRUCTOR
 275
 276 The constructor for a C<Net::Netrc> object is not called new as it does not
 277 really create a new object. But instead is called C<lookup> as this is
 278 essentially what it does.
 279
 280 =over 4
 281
 282 =item lookup ( MACHINE [, LOGIN ])
 283
 284 Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
 285 then the entry returned will have the given login. If C<LOGIN> is not given then
 286 the first entry in the .netrc file for C<MACHINE> will be returned.
 287
 288 If a matching entry cannot be found, and a default entry exists, then a
 289 reference to the default entry is returned.
 290
 291 If there is no matching entry found and there is no default defined, or
 292 no .netrc file is found, then C<undef> is returned.
 293
 294 =back
 295
 296 =head1 METHODS
 297
 298 =over 4
 299
 300 =item login ()
 301
 302 Return the login id for the netrc entry
 303
 304 =item password ()
 305
 306 Return the password for the netrc entry
 307
 308 =item account ()
 309
 310 Return the account information for the netrc entry
 311
 312 =item lpa ()
 313
 314 Return a list of login, password and account information fir the netrc entry
 315
 316 =back
 317
 318 =head1 AUTHOR
 319
 320 Graham Barr <gbarr@pobox.com>
 321
 322 =head1 SEE ALSO
 323
 324 L<Net::Netrc>
 325 L<Net::Cmd>
 326
 327 =head1 COPYRIGHT
 328
 329 Copyright (c) 1995-1998 Graham Barr. All rights reserved.
 330 This program is free software; you can redistribute it and/or modify
 331 it under the same terms as Perl itself.
 332
 333 =for html <hr>
 334
 335 $Id: //depot/libnet/Net/Netrc.pm#12 $
 336
 337 =cut