# Net::FTP.pm

#

# Copyright (c) 1995-8 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.

#

# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.

package Net::FTP;

require 5.001;

use strict;

use vars qw(@ISA $VERSION);

use Carp;

use Socket 1.3;

use IO::Socket;

use Time::Local;

use Net::Cmd;

use Net::Config;

use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);

$VERSION = "2.72"; # $Id: //depot/libnet/Net/FTP.pm#80 $

@ISA     = qw(Exporter Net::Cmd IO::Socket::INET);

# Someday I will "use constant", when I am not bothered to much about

# compatability with older releases of perl

use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);

($TELNET_IAC,$TELNET_IP,$TELNET_DM) = (255,244,242);

# Name is too long for AutoLoad, it clashes with pasv_xfer

sub pasv_xfer_unique {

    my($sftp,$sfile,$dftp,$dfile) = @_;

    $sftp->pasv_xfer($sfile,$dftp,$dfile,1);

}

BEGIN {

  # make a constant so code is fast'ish

  my $is_os390 = $^O eq 'os390';

  *trEBCDIC = sub () { $is_os390 }

}

1;

# Having problems with AutoLoader

#__END__

sub new

{

 my $pkg  = shift;

 my $peer = shift;

 my %arg  = @_; 

 my $host = $peer;

 my $fire = undef;

 my $fire_type = undef;

 if(exists($arg{Firewall}) || Net::Config->requires_firewall($peer))

  {

   $fire = $arg{Firewall}

	|| $ENV{FTP_FIREWALL}

	|| $NetConfig{ftp_firewall}

	|| undef;

   if(defined $fire)

    {

     $peer = $fire;

     delete $arg{Port};

	 $fire_type = $arg{FirewallType}

	 || $ENV{FTP_FIREWALL_TYPE}

	 || $NetConfig{firewall_type}

	 || undef;

    }

  }

 my $ftp = $pkg->SUPER::new(PeerAddr => $peer, 

			    PeerPort => $arg{Port} || 'ftp(21)',

			    LocalAddr => $arg{'LocalAddr'},

			    Proto    => 'tcp',

			    Timeout  => defined $arg{Timeout}

						? $arg{Timeout}

						: 120

			   ) or return undef;

 ${*$ftp}{'net_ftp_host'}     = $host;		# Remote hostname

 ${*$ftp}{'net_ftp_type'}     = 'A';		# ASCII/binary/etc mode

 ${*$ftp}{'net_ftp_blksize'}  = abs($arg{'BlockSize'} || 10240);

 ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};

 ${*$ftp}{'net_ftp_firewall'} = $fire

	if(defined $fire);

 ${*$ftp}{'net_ftp_firewall_type'} = $fire_type

	if(defined $fire_type);

 ${*$ftp}{'net_ftp_passive'} = int

	exists $arg{Passive}

	    ? $arg{Passive}

	    : exists $ENV{FTP_PASSIVE}

		? $ENV{FTP_PASSIVE}

		: defined $fire

		    ? $NetConfig{ftp_ext_passive}

		    : $NetConfig{ftp_int_passive};	# Whew! :-)

 $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);

 $ftp->autoflush(1);

 $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 unless ($ftp->response() == CMD_OK)

  {

   $ftp->close();

   $@ = $ftp->message;

   undef $ftp;

  }

 $ftp;

}

##

## User interface methods

##

sub hash {

    my $ftp = shift;		# self

    my($h,$b) = @_;

    unless($h) {

      delete ${*$ftp}{'net_ftp_hash'};

      return [\*STDERR,0];

    }

    ($h,$b) = (ref($h)? $h : \*STDERR, $b || 1024);

    select((select($h), $|=1)[0]);

    $b = 512 if $b < 512;

    ${*$ftp}{'net_ftp_hash'} = [$h, $b];

}        

sub quit

{

 my $ftp = shift;

 $ftp->_QUIT;

 $ftp->close;

}

sub DESTROY {}

sub ascii  { shift->type('A',@_); }

sub binary { shift->type('I',@_); }

sub ebcdic

{

 carp "TYPE E is unsupported, shall default to I";

 shift->type('E',@_);

}

sub byte

{

 carp "TYPE L is unsupported, shall default to I";

 shift->type('L',@_);

}

# Allow the user to send a command directly, BE CAREFUL !!

sub quot

{ 

 my $ftp = shift;

 my $cmd = shift;

 $ftp->command( uc $cmd, @_);

 $ftp->response();

}

sub site

{

 my $ftp = shift;

 $ftp->command("SITE", @_);

 $ftp->response();

}

sub mdtm

{

 my $ftp  = shift;

 my $file = shift;

 # Server Y2K defect workaround

 #

 # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of 

 # ("%d",tm.tm_year+1900).  This results in an extra digit in the

 # string returned. To account for this we allow an optional extra

 # digit in the year. Then if the first two digits are 19 we use the

 # remainder, otherwise we subtract 1900 from the whole year.

 $ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/

    ? timegm($8,$7,$6,$5,$4-1,$2 eq '19' ? $3 : ($1-1900))

    : undef;

}

sub size {

  my $ftp  = shift;

  my $file = shift;

  my $io;

  if($ftp->supported("SIZE")) {

    return $ftp->_SIZE($file)

	? ($ftp->message =~ /(\d+)\s*$/)[0]

	: undef;

 }

 elsif($ftp->supported("STAT")) {

   my @msg;

   return undef

       unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;

   my $line;

   foreach $line (@msg) {

     return (split(/\s+/,$line))[4]

	 if $line =~ /^[-rwxSsTt]{10}/

   }

 }

 else {

   my @files = $ftp->dir($file);

   if(@files) {

     return (split(/\s+/,$1))[4]

	 if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;

   }

 }

 undef;

}

sub login {

  my($ftp,$user,$pass,$acct) = @_;

  my($ok,$ruser,$fwtype);

  unless (defined $user) {

    require Net::Netrc;

    my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});

    ($user,$pass,$acct) = $rc->lpa()

	 if ($rc);

   }

  $user ||= "anonymous";

  $ruser = $user;

  $fwtype = ${*$ftp}{'net_ftp_firewall_type'}

  || $NetConfig{'ftp_firewall_type'}

  || 0;

  if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {

    if ($fwtype == 1 || $fwtype == 7) {

      $user .= '@' . ${*$ftp}{'net_ftp_host'};

    }

    else {

      require Net::Netrc;

      my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});

      my($fwuser,$fwpass,$fwacct) = $rc ? $rc->lpa() : ();

      if ($fwtype == 5) {

	$user = join('@',$user,$fwuser,${*$ftp}{'net_ftp_host'});

	$pass = $pass . '@' . $fwpass;

      }

      else {

	if ($fwtype == 2) {

	  $user .= '@' . ${*$ftp}{'net_ftp_host'};

	}

	elsif ($fwtype == 6) {

	  $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};

	}

	$ok = $ftp->_USER($fwuser);

	return 0 unless $ok == CMD_OK || $ok == CMD_MORE;

	$ok = $ftp->_PASS($fwpass || "");

	return 0 unless $ok == CMD_OK || $ok == CMD_MORE;

	$ok = $ftp->_ACCT($fwacct)

	  if defined($fwacct);

	if ($fwtype == 3) {

          $ok = $ftp->command("SITE",${*$ftp}{'net_ftp_host'})->response;

	}

	elsif ($fwtype == 4) {

          $ok = $ftp->command("OPEN",${*$ftp}{'net_ftp_host'})->response;

	}

	return 0 unless $ok == CMD_OK || $ok == CMD_MORE;

      }

    }

  }

  $ok = $ftp->_USER($user);

  # Some dumb firewalls don't prefix the connection messages

  $ok = $ftp->response()

	 if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);

  if ($ok == CMD_MORE) {

    unless(defined $pass) {

      require Net::Netrc;

      my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);

      ($ruser,$pass,$acct) = $rc->lpa()

	 if ($rc);

      $pass = '-anonymous@'

         if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));

    }

    $ok = $ftp->_PASS($pass || "");

  }

  $ok = $ftp->_ACCT($acct)

	 if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));

  if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {

    my($f,$auth,$resp) = _auth_id($ftp);

    $ftp->authorize($auth,$resp) if defined($resp);

  }

  $ok == CMD_OK;

}

sub account

{

 @_ == 2 or croak 'usage: $ftp->account( ACCT )';

 my $ftp = shift;

 my $acct = shift;

 $ftp->_ACCT($acct) == CMD_OK;

}

sub _auth_id {

 my($ftp,$auth,$resp) = @_;

 unless(defined $resp)

  {

   require Net::Netrc;

   $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};

   my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)

        || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});

   ($auth,$resp) = $rc->lpa()

     if ($rc);

  }

  ($ftp,$auth,$resp);

}

sub authorize

{

 @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';

 my($ftp,$auth,$resp) = &_auth_id;

 my $ok = $ftp->_AUTH($auth || "");

 $ok = $ftp->_RESP($resp || "")

	if ($ok == CMD_MORE);

 $ok == CMD_OK;

}

sub rename

{

 @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';

 my($ftp,$from,$to) = @_;

 $ftp->_RNFR($from)

    && $ftp->_RNTO($to);

}

sub type

{

 my $ftp = shift;

 my $type = shift;

 my $oldval = ${*$ftp}{'net_ftp_type'};

 return $oldval

	unless (defined $type);

 return undef

	unless ($ftp->_TYPE($type,@_));

 ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);

 $oldval;

}

sub alloc

{

 my $ftp = shift;

 my $size = shift;

 my $oldval = ${*$ftp}{'net_ftp_allo'};

 return $oldval

	unless (defined $size);

 return undef

	unless ($ftp->_ALLO($size,@_));

 ${*$ftp}{'net_ftp_allo'} = join(" ",$size,@_);

 $oldval;

}

sub abort

{

 my $ftp = shift;

 send($ftp,pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC),MSG_OOB);

 $ftp->command(pack("C",$TELNET_DM) . "ABOR");

 ${*$ftp}{'net_ftp_dataconn'}->close()

    if defined ${*$ftp}{'net_ftp_dataconn'};

 $ftp->response();

 $ftp->status == CMD_OK;

}

sub get

{

 my($ftp,$remote,$local,$where) = @_;

 my($loc,$len,$buf,$resp,$data);

 local *FD;

 my $localfd = ref($local) || ref(\$local) eq "GLOB";

 ($local = $remote) =~ s#^.*/##

	unless(defined $local);

 croak("Bad remote filename '$remote'\n")

	if $remote =~ /[\r\n]/s;

 ${*$ftp}{'net_ftp_rest'} = $where

	if ($where);

 delete ${*$ftp}{'net_ftp_port'};

 delete ${*$ftp}{'net_ftp_pasv'};

 $data = $ftp->retr($remote) or

	return undef;

 if($localfd)

  {

   $loc = $local;

  }

 else

  {

   $loc = \*FD;

   unless(sysopen($loc, $local, O_CREAT | O_WRONLY | ($where ? O_APPEND : O_TRUNC)))

    {

     carp "Cannot open Local file $local: $!\n";

     $data->abort;

     return undef;

    }

  }

 if($ftp->type eq 'I' && !binmode($loc))

  {

   carp "Cannot binmode Local file $local: $!\n";

   $data->abort;

   close($loc) unless $localfd;

   return undef;

  }

 $buf = '';

 my($count,$hashh,$hashb,$ref) = (0);

 ($hashh,$hashb) = @$ref

   if($ref = ${*$ftp}{'net_ftp_hash'});

 my $blksize = ${*$ftp}{'net_ftp_blksize'};

 local $\; # Just in case

 while(1)

  {

   last unless $len = $data->read($buf,$blksize);

   if (trEBCDIC && $ftp->type ne 'I')

    {

     $buf = $ftp->toebcdic($buf);

     $len = length($buf);

    }

   if($hashh) {

    $count += $len;

    print $hashh "#" x (int($count / $hashb));

    $count %= $hashb;

   }

   unless(print $loc $buf)

    {

     carp "Cannot write to Local file $local: $!\n";

     $data->abort;

     close($loc)

        unless $localfd;

     return undef;

    }

  }

 print $hashh "\n" if $hashh;

 unless ($localfd)

  {

   unless (close($loc))

    {

     carp "Cannot close file $local (perhaps disk space) $!\n";

     return undef;

    }

  }

 unless ($data->close()) # implied $ftp->response

  {

   carp "Unable to close datastream";

   return undef;

  }