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