# -*- perl -*-
#
# $Id: FTP.pm,v 1.31 1999/04/20 16:06:15 ejb Exp $
# $Source: /home/ejb/source/perl/modules/RCS/FTP.pm,v $
# $Author: ejb $
#

require 5.004;
use strict;

package FTP;
use FileHandle;
my $package = "FTP";

use Carp;
use IO::Socket;
require qutils;

# Field names
my $f_passive = "passive";
my $f_cmd_sock = "cmd_sock";

# Static Variables
my $timeout_length = 60;
my $tries = 20;
my $debug = 0;
my $default_passive = 0;

# Routines

sub debug
{
    $debug = $_[0];
    print "$package: debugging set to $debug\n" if $debug;
}

sub default_passive
{
    $default_passive = shift;
}

sub new
{
    my $class = shift;
    my $rep = +{$package => {} };

    my $passive = $default_passive;

    $rep->{$package}{$f_passive} = $passive;
    $rep->{$package}{$f_cmd_sock} = undef;

    bless $rep, $class;
}

sub p_cmd_sock
{
    my $rep = shift;
    $rep->{$package}{$f_cmd_sock};
}

sub passive
{
    my $rep = shift;
    $rep->{$package}{$f_passive} = $_[0] if @_;
    $rep->{$package}{$f_passive};
}

sub p_die_for
{
    my $rep = shift;
    my ($code) = @_;
    my $msg;
    if (! $rep->p_wait_for($code, \$msg))
    {
	print "==> die for wanted $code; got $msg\n" if $debug;
	die "$package: wanted $code; got $msg\n";
    }
    print "==> FTP CMD: $msg" if $debug;
    $msg;
}

sub p_wait_for
{
    my $rep = shift;
    my $cmd_sock = $rep->p_cmd_sock();
    my ($code, $msgp) = @_;
    my $l = undef;

    print "==> now waiting for $code\n" if $debug;
    my $timed_out = &qutils::timeout
	($timeout_length, sub
	 {
	     while (defined($l = $cmd_sock->getline()))
	     {
		 my $t = $l;
		 chomp($t);
		 print "==> while waiting, read $t\n" if $debug;
		 last if ($l =~ m/^\d\d\d /);
	     }
	 }, []);
    
    if ($timed_out)
    {
	$$msgp = "timeout";
	die "$package: timed out waiting for response code matching $code\n";
    }
    elsif (defined($l))
    {
	$$msgp = $l;
	$l =~ m/^$code /;
    }
    else
    {
	$$msgp = "";
	0;
    }
}

sub p_run
{
    my $rep = shift;
    my $cmd_sock = $rep->p_cmd_sock();
    my ($command, $code, $realcode) = @_;
    ($realcode = $code) unless defined $realcode;
    my $result = "---";
    my $maxtries = 10;
    my $try = 0;
    do
    {
	print "==> FTP CMD: $command\n" if $debug;
	$cmd_sock->print("$command\r\n") or
	    die "$package: failure printing to socket\n";
	$result = $rep->p_die_for($code);
	if ($result eq "")
	{
	    die "$package: got empty output waiting for response; " .
		"assuming server is gone\n";
	}
	elsif ($result !~ $realcode)
	{
	    $try++;
	    sleep 1;
	}
    } while (($try < $maxtries) && ($result !~ $realcode));
    if ($result !~ $realcode)
    {
	die "$package: too many retries waiting for $realcode\n";
    }
    $result;
}

sub p_open_listen
{
    my $rep = shift;
    my $cmd_sock = $rep->p_cmd_sock();
    my ($dataport, $addr);
    (undef, $addr) = unpack_sockaddr_in($cmd_sock->sockname());
    my $listen_sock = IO::Socket::INET->new(Listen => 5,
					    Proto => 'tcp');
    ($dataport, undef) = unpack_sockaddr_in($listen_sock->sockname());
    my @port_args = unpack('C4', $addr);
    push(@port_args, $dataport >> 8, $dataport & 0xff);
    my $port_args = join(",", @port_args);
    ($listen_sock, $port_args);
}

sub p_open_data
{
    my $rep = shift;
    my ($command) = @_;
    my $data;

    if ($rep->passive())
    {
	my $pasv = $rep->p_run("PASV", "227");
	$data = $rep->p_open_pasv_data($pasv);
	$rep->p_run($command, "(150|425)", "150");
    }
    else
    {
	my ($listen_sock, $port_args) = $rep->p_open_listen();
	$rep->p_run("PORT $port_args", "200");
	$rep->p_run($command, "(150|425)", "150");
	my $timed_out = &qutils::timeout
	    ($timeout_length, sub
	     {
		 $data = $listen_sock->accept() or
		     die "$package: accepting connection: $!\n";
	     }, []);
	if ($timed_out)
	{
	    die "$package: timed out accepting data connection\n";
	}
    }

    $data;
}

sub p_finish_data
{
    my $rep = shift;
    $rep->p_die_for("226");
}

sub p_read_data
{
    my $rep = shift;
    my ($data) = @_;
    my @result = ();
    my $l;

    do
    {
	$l = undef;
	my $timed_out = &qutils::timeout
	    ($timeout_length, sub
	     {
		 $l = $data->getline();
	     }, []);
	if ($timed_out)
	{
	    die "$package: timed out reading data\n";
	}
	elsif (defined $l)
	{
	    push(@result, $l);
	}
    } while (defined $l);
    @result;
}

sub p_open_pasv_data
{
    my $rep = shift;
    my ($pasv) = @_;
    if ($pasv =~ m/\((\d+),(\d+),(\d+),(\d+),(\d+),(\d+)\)/)
    {
	my $addr = join('.', ($1, $2, $3, $4));
	my $port = 256 * $5 + $6;
	IO::Socket::INET->new(PeerAddr => $addr,
			      PeerPort => $port,
			      Proto => 'tcp');
    }
    else
    {
	die "$package: badly formed response to PASV command: $pasv\n";
    }
}

sub login
{
    my $rep = shift;
    my ($host, $user, $pass) = @_;
    my $service = $_[3] || "ftp";

    my $cmd_sock = IO::Socket::INET->new(PeerAddr => $host,
					 PeerPort => $service,
					 Proto => 'tcp');
    $rep->{$package}{$f_cmd_sock} = $cmd_sock;

    $rep->p_die_for("220");
    $rep->p_run("USER $user", "331");
    $rep->p_run("PASS $pass", "230");
    $rep->p_run("TYPE I", "200");
}

sub logout
{
    my $rep = shift;
    $rep->p_run("QUIT", "221");
    $rep->{$package}{$f_cmd_sock} = undef;
}

sub cwd
{
    my $rep = shift;
    my $dir = shift;
    $rep->p_run("CWD $dir", "2[50]0");
}

sub rename
{
    my $rep = shift;
    my ($from, $to) = @_;
    $rep->p_run("RNFR $from", "350");
    $rep->p_run("RNTO $to", "2[50]0");
}

sub list
{
    my $rep = shift;
    my $name = $_[0] || "";
    $name = " " . $name unless $name eq "";

    my @result;
    {
	print "==> about to call p_open_data\n" if $debug;
	my $data = $rep->p_open_data("LIST$name");
	print "==> about to call p_read_data\n" if $debug;
	@result = $rep->p_read_data($data);
	print "==> finished calling p_read_data\n" if $debug;
    }
    print "==> about to call p_finish_data\n" if $debug;
    $rep->p_finish_data();
    print "==> called p_finish_data\n" if $debug;
    print "==> List output:\n" if $debug;
    if ($debug)
    {
	map { print } @result;
    }
    print "==> List output done\n" if $debug;
    @result;
}

sub nlist
{
    my $rep = shift;
    my $name = $_[0] || "";
    $name = " " . $name unless $name eq "";

    my @result;
    {
	my $data = $rep->p_open_data("NLST$name");
	@result = $rep->p_read_data($data);
    }
    $rep->p_finish_data();
    print "==> List output:\n" if $debug;
    if ($debug)
    {
	map { print } @result;
    }
    print "==> List output done\n" if $debug;
    @result;
}

sub retrieve
{
    my $rep = shift;
    my ($srcname, $srcsize, $destname) = @_;
    my $blocksize = 10 << 10;

    my $out = new FileHandle(">$destname");
    if (! defined $out)
    {
	warn "$package: can't create $destname locally: $!\n";
	warn "$package: not retrieving $destname\n";
	return;
    }

    my $data = $rep->p_open_data("RETR $srcname");
    my $so_far = 0;
    my $pipe = $SIG{'PIPE'};
    $SIG{'PIPE'} = 'IGNORE';
    my $done = 0;
    do
    {
	my $buf = "";
	my $len = undef;
	my $timed_out = &qutils::timeout
	    ($timeout_length, sub { $len = read($data, $buf, $blocksize) }, []);
	if ($timed_out)
	{
	    warn "$package: timed out reading data after" .
		" $so_far bytes.\n";
	    $done = 1;
	}
	else
	{
	    if ($len == 0)
	    {
		$done = 1;
	    }
	    else
	    {
		$so_far += $len;
		if (! $out->print($buf))
		{
		    warn "$package: write failure ($destname) " .
			"after $so_far bytes: $!\n";
		    $done = 1;
		}
	    }
	}
	if ((! $done) && ($srcsize > 0))
	{
	    $done = ($so_far >= $srcsize);
	}
    }
    while (! $done);

    close($out);
    {
	my $old_warn = $^W;
	$^W = 0;
	$SIG{'PIPE'} = $pipe;
	$^W = $old_warn;
    }

    my $okay = 1;
    if (($srcsize > 0) && ($so_far != $srcsize))
    {
	warn "$package: in reading $srcname, read $so_far bytes " .
	    "and expected $srcsize\n";
	$okay = 0;
    }
    &qutils::timeout
	($timeout_length, sub { $data->close() }, []);
    $rep->p_finish_data();
    $okay;
}

sub store
{
    my $rep = shift;
    my ($srcname, $destname) = @_;
    my $blocksize = 10 << 10;

    my @stat = stat($srcname);
    if (@stat == 0)
    {
	warn "$package: can't stat file just opened ($srcname): $!\n";
	warn "$package: not storing $srcname\n";
	return;
    }
    if (! -f $srcname)
    {
	warn "$package: $srcname is not a plain file; not storing\n";
	return;
    }
    
    my $in = new FileHandle("<$srcname");
    if (! defined $in)
    {
	warn "$package: can't read $srcname locally: $!\n";
	warn "$package: not storing $srcname\n";
	return;
    }

    my $size = $stat[7];

    my $pipe = $SIG{'PIPE'};
    $SIG{'PIPE'} = 'IGNORE';
    my $so_far = 0;
    {
	# Must be in a block so that $data gets destroyed before
	# we call finish_data()
	my $data = $rep->p_open_data("STOR $destname");
	while ($so_far < $size)
	{
	    my $buf = "";
	    my $len = read($in, $buf, $blocksize);
	    last if $len == 0;
	    $so_far += $len;
	    my $r = undef;
	    my $timed_out = 0;
	    $timed_out = &qutils::timeout
		($timeout_length, sub { $r = $data->print($buf) }, []);
	    if ($timed_out)
	    {
		warn "$package: write ($srcname -> $destname) timed out" .
		    " after $so_far bytes.\n";
		last;
	    }
	    elsif (! $r)
	    {
		warn "$package: write failure ($srcname -> $destname) after " .
		    "reading $so_far bytes from source: $!\n";
		last;
	    }
	}
	&qutils::timeout($timeout_length, sub { $data->print("") }, []);

	# This call to close should not be necessary, but emperical
	# observation shows that it sometimes is.  Without it, perl
	# seems not to close and shut down the connection in some
	# cases until after the call to p_finish_data() below.  This
	# creates a deadlock.
	&qutils::timeout
	    ($timeout_length, sub { $data->close() }, []);
    }
    close($in);
    {
	my $old_warn = $^W;
	$^W = 0;
	$SIG{'PIPE'} = $pipe;
	$^W = $old_warn;
    }

    my $okay = 1;
    if ($so_far != $size)
    {
	warn "$package: while storing $srcname, transfered $so_far bytes; " .
	    "expected $size\n";
	$okay = 0;
	
    }
    $rep->p_finish_data();
    $okay;
}

sub delete
{
    my $rep = shift;
    my $file = shift;
    $rep->p_run("DELE $file", "2[50]0");
}

sub mkdir
{
    my $rep = shift;
    my $file = shift;
    # Although rfc 959 does not list 521 as a valid response code for
    # MKD, some ftp servers (wu-2.4.2-academ[BETA-18] at least) return
    # 521 when the directory already exists.
    $rep->p_run("MKD $file", "(257|550|553|521)");
}

1;

#
# END OF FTP
#