1 files changed, 333 insertions, 0 deletions
diff --git a/lib/Net/Netrc.pm b/lib/Net/Netrc.pm
new file mode 100644
index 0000000..fbe8d6d
--- /dev/null
+++ b/lib/Net/Netrc.pm
@@ -0,0 +1,333 @@
+# Net::Netrc.pm
+#
+# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Net::Netrc;
+
+use Carp;
+use strict;
+use FileHandle;
+use vars qw($VERSION $TESTING);
+
+$VERSION = "2.14";
+
+my %netrc = ();
+
+
+sub _readrc {
+  my $host = shift;
+  my ($home, $file);
+
+  if ($^O eq "MacOS") {
+    $home = $ENV{HOME} || `pwd`;
+    chomp($home);
+    $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
+  }
+  else {
+
+    # Some OS's don't have "getpwuid", so we default to $ENV{HOME}
+    $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
+    $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
+    if (-e $home . "/.netrc") {
+      $file = $home . "/.netrc";
+    }
+    elsif (-e $home . "/_netrc") {
+      $file = $home . "/_netrc";
+    }
+    else {
+      return unless $TESTING;
+    }
+  }
+
+  my ($login, $pass, $acct) = (undef, undef, undef);
+  my $fh;
+  local $_;
+
+  $netrc{default} = undef;
+
+  # OS/2 and Win32 do not handle stat in a way compatible with this check :-(
+  unless ($^O eq 'os2'
+    || $^O eq 'MSWin32'
+    || $^O eq 'MacOS'
+    || $^O =~ /^cygwin/)
+  {
+    my @stat = stat($file);
+
+    if (@stat) {
+      if ($stat[2] & 077) {
+        carp "Bad permissions: $file";
+        return;
+      }
+      if ($stat[4] != $<) {
+        carp "Not owner: $file";
+        return;
+      }
+    }
+  }
+
+  if ($fh = FileHandle->new($file, "r")) {
+    my ($mach, $macdef, $tok, @tok) = (0, 0);
+
+    while (<$fh>) {
+      undef $macdef if /\A\n\Z/;
+
+      if ($macdef) {
+        push(@$macdef, $_);
+        next;
+      }
+
+      s/^\s*//;
+      chomp;
+
+      while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
+        (my $tok = $+) =~ s/\\(.)/$1/g;
+        push(@tok, $tok);
+      }
+
+    TOKEN:
+      while (@tok) {
+        if ($tok[0] eq "default") {
+          shift(@tok);
+          $mach = bless {};
+          $netrc{default} = [$mach];
+
+          next TOKEN;
+        }
+
+        last TOKEN
+          unless @tok > 1;
+
+        $tok = shift(@tok);
+
+        if ($tok eq "machine") {
+          my $host = shift @tok;
+          $mach = bless {machine => $host};
+
+          $netrc{$host} = []
+            unless exists($netrc{$host});
+          push(@{$netrc{$host}}, $mach);
+        }
+        elsif ($tok =~ /^(login|password|account)$/) {
+          next TOKEN unless $mach;
+          my $value = shift @tok;
+
+          # Following line added by rmerrell to remove '/' escape char in .netrc
+          $value =~ s/\/\\/\\/g;
+          $mach->{$1} = $value;
+        }
+        elsif ($tok eq "macdef") {
+          next TOKEN unless $mach;
+          my $value = shift @tok;
+          $mach->{macdef} = {}
+            unless exists $mach->{macdef};
+          $macdef = $mach->{machdef}{$value} = [];
+        }
+      }
+    }
+    $fh->close();
+  }
+}
+
+
+sub lookup {
+  my ($pkg, $mach, $login) = @_;
+
+  _readrc()
+    unless exists $netrc{default};
+
+  $mach ||= 'default';
+  undef $login
+    if $mach eq 'default';
+
+  if (exists $netrc{$mach}) {
+    if (defined $login) {
+      my $m;
+      foreach $m (@{$netrc{$mach}}) {
+        return $m
+          if (exists $m->{login} && $m->{login} eq $login);
+      }
+      return undef;
+    }
+    return $netrc{$mach}->[0];
+  }
+
+  return $netrc{default}->[0]
+    if defined $netrc{default};
+
+  return undef;
+}
+
+
+sub login {
+  my $me = shift;
+
+  exists $me->{login}
+    ? $me->{login}
+    : undef;
+}
+
+
+sub account {
+  my $me = shift;
+
+  exists $me->{account}
+    ? $me->{account}
+    : undef;
+}
+
+
+sub password {
+  my $me = shift;
+
+  exists $me->{password}
+    ? $me->{password}
+    : undef;
+}
+
+
+sub lpa {
+  my $me = shift;
+  ($me->login, $me->password, $me->account);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Net::Netrc - OO interface to users netrc file
+
+=head1 SYNOPSIS
+
+    use Net::Netrc;
+
+    $mach = Net::Netrc->lookup('some.machine');
+    $login = $mach->login;
+    ($login, $password, $account) = $mach->lpa;
+
+=head1 DESCRIPTION
+
+C<Net::Netrc> is a class implementing a simple interface to the .netrc file
+used as by the ftp program.
+
+C<Net::Netrc> also implements security checks just like the ftp program,
+these checks are, first that the .netrc file must be owned by the user and 
+second the ownership permissions should be such that only the owner has
+read and write access. If these conditions are not met then a warning is
+output and the .netrc file is not read.
+
+=head1 THE .netrc FILE
+
+The .netrc file contains login and initialization information used by the
+auto-login process.  It resides in the user's home directory.  The following
+tokens are recognized; they may be separated by spaces, tabs, or new-lines:
+
+=over 4
+
+=item machine name
+
+Identify a remote machine name. The auto-login process searches
+the .netrc file for a machine token that matches the remote machine
+specified.  Once a match is made, the subsequent .netrc tokens
+are processed, stopping when the end of file is reached or an-
+other machine or a default token is encountered.
+
+=item default
+
+This is the same as machine name except that default matches
+any name.  There can be only one default token, and it must be
+after all machine tokens.  This is normally used as:
+
+    default login anonymous password user@site
+
+thereby giving the user automatic anonymous login to machines
+not specified in .netrc.
+
+=item login name
+
+Identify a user on the remote machine.  If this token is present,
+the auto-login process will initiate a login using the
+specified name.
+
+=item password string
+
+Supply a password.  If this token is present, the auto-login
+process will supply the specified string if the remote server
+requires a password as part of the login process.
+
+=item account string
+
+Supply an additional account password.  If this token is present,
+the auto-login process will supply the specified string
+if the remote server requires an additional account password.
+
+=item macdef name
+
+Define a macro. C<Net::Netrc> only parses this field to be compatible
+with I<ftp>.
+
+=back
+
+=head1 CONSTRUCTOR
+
+The constructor for a C<Net::Netrc> object is not called new as it does not
+really create a new object. But instead is called C<lookup> as this is
+essentially what it does.
+
+=over 4
+
+=item lookup ( MACHINE [, LOGIN ])
+
+Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
+then the entry returned will have the given login. If C<LOGIN> is not given then
+the first entry in the .netrc file for C<MACHINE> will be returned.
+
+If a matching entry cannot be found, and a default entry exists, then a
+reference to the default entry is returned.
+
+If there is no matching entry found and there is no default defined, or
+no .netrc file is found, then C<undef> is returned.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item login ()
+
+Return the login id for the netrc entry
+
+=item password ()
+
+Return the password for the netrc entry
+
+=item account ()
+
+Return the account information for the netrc entry
+
+=item lpa ()
+
+Return a list of login, password and account information for the netrc entry
+
+=back
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 SEE ALSO
+
+L<Net::Netrc>
+L<Net::Cmd>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995-1998 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut