;#
;# Copyright (c) 1995-1997
;#	Ikuo Nakagawa. All rights reserved.
;#
;# Redistribution and use in source and binary forms, with or without
;# modification, are permitted provided that the following conditions
;# are met:
;#
;# 1. Redistributions of source code must retain the above copyright
;#    notice unmodified, this list of conditions, and the following
;#    disclaimer.
;# 2. Redistributions in binary form must reproduce the above copyright
;#    notice, this list of conditions and the following disclaimer in the
;#    documentation and/or other materials provided with the distribution.
;#
;# THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
;# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;# PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS
;# BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
;# OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
;# OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;# BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
;# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;#
;# $Id: FTP.pm,v 1.28 1999/10/28 10:32:19 ikuo Exp $
;#
;# Description:
;#	FTP.pm - FTP Class definitions
;#	 - Socket based operations.
;#	 - Passive mode transfer is supported.
;#	 - Multiple addresses for a single server are supported.
;#	 - Multiple sessions are supported.
;#
;# Usage:
;#	$dir = "/pub/FreeBSD";
;#	chdir($dir);
;#	$ftp = FTP->new(
;#		ftp_user => "anonymous",
;#		ftp_pass => "ikuo\@intec.co.jp",
;#		ftp_gateway => "proxy.isl.intec.co.jp",
;#		ftp_server => "localhost"
;#	);
;#	$ftp->login || die("Can't login ftp server.\n");
;#	$ftp->cwd($dir) || die("Can't change directory to $dir.\n");
;#	scalar(@array = $ftp->stat(".")) || die("Can't get status.\n");
;#	for $i (@array) {
;#		$ftp->get($i) or warn("Can't get $i\n"), last;
;#	}
;#	$ftp->quit || warn("QUIT failed.\n");
;#
;#
package Fan::FTP;

use strict;
use vars qw(@ISA $VERSION $LOG
	$ftp_port $hostname $sockaddr_in $n_session %stats);

use Carp;
use Socket;

use Socket6;

use Fan::TCP;
use AutoLoader 'AUTOLOAD';

@ISA = qw(Fan::TCP);
$VERSION = '0.03';
$LOG = 5 unless defined($LOG);
$ftp_port = (getservbyname('ftp', 'tcp'))[2];
chomp($hostname = `hostname`);

;# A special marker for AutoSplit.
1;
__END__

;# Show statistics report.
sub stats ($) {
	my $self = shift;
	my $name = $self->{ftp_server};
	my $p;

	exists($stats{$name}) && ref($p = $stats{$name}) or return undef;

	my $cs = $p->{ctrl_sent} + 0;
	my $cr = $p->{ctrl_recv} + 0;
	my $ds = $p->{data_sent} + 0;
	my $dr = $p->{data_recv} + 0;

	1 while $cs =~ s/(\d+)(\d\d\d)/$1,$2/;
	1 while $cr =~ s/(\d+)(\d\d\d)/$1,$2/;
	1 while $ds =~ s/(\d+)(\d\d\d)/$1,$2/;
	1 while $dr =~ s/(\d+)(\d\d\d)/$1,$2/;

	my $len = 0;
	$len = length($cs) if $len < length($cs);
	$len = length($cr) if $len < length($cr);
	$len = length($ds) if $len < length($ds);
	$len = length($dr) if $len < length($dr);

	warn("$self status reports (server name: $name)\n");
	warn(" sent(ctrl)". '.' x ($len + 3 - length($cs)) . " $cs octets\n");
	warn(" recv(ctrl)". '.' x ($len + 3 - length($cr)) . " $cr octets\n");
	warn(" sent(data)". '.' x ($len + 3 - length($ds)) . " $ds octets\n");
	warn(" recv(data)". '.' x ($len + 3 - length($dr)) . " $dr octets\n");

	1;
}

;# destroy an object.
sub DESTROY ($) {
	my $self = shift;
	$self->quit;

	my $p = \%{$stats{$self->{ftp_server}}};
	$p->{ctrl_sent} += $self->{tcp_sent_octets};
	$p->{ctrl_recv} += $self->{tcp_recv_octets};
	$self->stats if $self->{ftp_stats};

	carp("FTP DESTROYING $self") if $LOG > 5;
	Fan::TCP::DESTROY($self);
}

;# creat a new object.
;#	bindaddress	undef
;#	server		nont
;#	port		21
;#	user		anonymous
;#	pass		"$user\@$hostname"
sub new ($%) {
	my $this = shift;
	my $class = ref($this) || $this;
	my %param = @_;

	# if we required verbose output, set tcp_debug.
	$param{tcp_debug} = 1 if $LOG > 5;

	# bless myself.
	my $self = bless Fan::TCP->new(%param), $class;
	ref($self) or return undef;

	# log message
	carp("FTP CREATING $self") if $LOG > 5;

	# some default values.
	$self->{ftp_retry} = 3 if !exists($self->{ftp_retry});
	$self->{ftp_login_retry} = 0 if !exists($self->{ftp_login_retry});
	$self->{ftp_login_delay} = 60 if !exists($self->{ftp_login_delay});

	# result is myself.
	$self;
}

;#
sub passive ($;$) {
	my $self = shift;

	if (@_) {
		my $t = shift;
		if ($LOG > 6) {
			warn("FTP $self passive mode "
				.($t ? "enabled" : "disabled").".\n");
		}
		$self->{ftp_passive} = $t;
	}
	$self->{ftp_passive};
}

;# send FTP request.
sub putreq ($$) {
	my $self = shift;
	my $req = shift;
	my $i = $self->{ftp_retry};

	$self->clearerror || return undef;

	$self->{lastcode} = 0;
	$self->{lastmesg} = '';

	do {
		# if we have no connection, try login.
		unless ($self->handle || $self->login) {
			$self->{lastmesg} = "can't login to the server";
			return undef;
		}

		# try send command.
		unless ($self->putln($req)) {
			$self->{lastmesg} = $self->error;
			return undef;
		}

		# check result, 421 means connection closed.
		unless ($self->getres == 421) {
			return $self->{lastcode}; # this is good!
		}

		# or 421 was returned.
		warn("FTP: server said code=421, try again.\n") if $LOG > 4;
		$self->quit;

	} while ($i-- > 0 && sleep(10)) ;

	warn("FTP: gave up \"$req\".\n") if $LOG > 4;
	$self->{lastmesg} = "putreq: too many retries";
	undef;
}

;# recieve FTP response.
sub getres ($) {
	my $self = shift;
	my $buffer = '';
	my $line;

	while (defined($line = $self->getln)) {
		$buffer .= "\n" if $buffer ne '';
		$buffer .= $line;
		if ($line =~ /^(\d\d\d) /) {
			$self->{lastcode} = $1;
			($self->{lastmesg} = $') =~ s/\s+$//;
			$self->{buffer} = $buffer;
			return $self->{lastcode};
		}
	}

	$self->{lastcode} = 0;
	$self->{lastmesg} = "no response from server";
	undef; # status may be changed in getln or end-of-file
}

;# quit session.
sub quit ($) {
	my $self = shift;

	$self->cleardataconn;

	if ($self->handle) { # has connection
		$self->putreq("QUIT") && $self->getres; # ignore result
		$self->close;
	}
}

;#
sub login ($) {
	my $self = shift;
	my $i = $self->{ftp_login_retry};

	# log...
	warn("login: connecting to the server...\n") if $LOG > 4.5;

	# loop for retries...
	do {
		# try login
		if ($self->do_login) { # success to login
			warn("login: success.\n") if $LOG > 4.5;
			return 1;
		}

		# check result code
		if ($self->{lastcode} != 421) {
			$self->error($self->{lastmesg});
			return undef;
		}

	} while ($i-- > 0 && sleep($self->{ftp_retry_delay})) ;

	# retry timed out
	warn("login: too many login failure, gave up.\n") if $LOG > 4.5;
	$self->error("too many login failure, ".$self->{lastmesg});
	undef;
}

;# connecting the server.
sub do_login ($) {
	my $self = shift;

	# close existing connection first.
	$self->quit;

	# force to clear status.
	$self->clearerror(1);

	# clear some FTP flags
	delete($self->{no_size});
	delete($self->{no_mdtm});
	delete($self->{no_chmod});
	delete($self->{no_umask});
	delete($self->{no_idle});

	# get values.
	my $user = $self->{ftp_user};
	my $pass = $self->{ftp_pass};
	my $server = $self->{ftp_server};
	my $port = $self->{ftp_port} || $ftp_port;
	my $bindaddr = $self->{ftp_bindaddr};
	my $group = $self->{ftp_group};
	my $gpass = $self->{ftp_gpass};
	my $passive = $self->{ftp_passive};
	my $idle = $self->{ftp_idle};
	my $dir = $self->{ftp_directory};

	# check default values.
	if ($user eq '') {
		$user = 'anonymous';
	}
	if ($pass eq '') {
		$pass = getpwuid($<).'@'.$hostname;
	}
	if ($server eq '') {
		carp("FTP server not defined"), return undef;
	}
	if ($self->{ftp_gateway} ne '') {
		$user .= '@'.$server;
		$server = $self->{ftp_gateway};
	}

	# opening connection.
	$self->do_client(
		tcp_bindaddr => $bindaddr,
		tcp_host => $server,
		tcp_port => $port
	) or carp("FTP opening connection failed"), return undef;

	# we want initial message
	if ($self->getres != 220) {
		carp("do_login: can't connect") if $LOG > 5;
		$self->quit;
		return undef;
	}

	# try to send USER command
	unless ($self->putln("USER $user")) {
		carp("do_login: putln ".$self->error) if $LOG > 5;
		$self->quit;
		return undef;
	}

	# check response for USER command
	if ($self->getres == 331) {
		unless ($self->putln("PASS $pass")) {
			carp("do_login: putln ".$self->error) if $LOG > 5;
			$self->quit;
			return undef;
		}
		$self->getres; # to catch response code.
	}

	# check response for USER or PASS command
	if ($self->{lastcode} != 230) {
		carp("do_login: PASS: ".$self->error);
		$self->quit;
		return undef;
	}

	# if we are required to setup group...
	unless ($group eq '' || $self->group($group, $gpass)) {
		carp("do_login: GROUP: ".$self->error);
		$self->quit;
		return undef;
	}

	# is passive mode prefered?
	if ($passive) {
		$self->passive(1); # no error should occur.
	}

	# shall we change idle timer?
	if ($idle > 0 || $idle == -1) {
		my($i, $maxi) = $self->idle;
		$i = $idle == -1 || $idle > $maxi ? $maxi : $idle;
		$self->idle($i); # ignore result.
	}

	# we can change initial directory.
	unless ($dir eq '' || $self->chdir($dir)) {
		carp("do_login CHDIR: ".$self->error);
		$self->quit;
		return undef;
	}

	# success code.
	1;
}

;#
;# open accept socket, and send PORT command to the server.
;#
sub port ($) {
	my $self = shift;

	$self->clearerror || return undef;
	$self->cleardataconn;	# always success

	my ($port, $addr, $family) = $self->sockname;

	my $acpt = Fan::TCP->new();
	unless (defined($acpt)) {
		warn("Fan::TCP->new failed");
		return undef;
	}

	unless ($acpt->do_server(tcp_family => $family,
				 tcp_bindaddr => $addr)) {
		warn("Fan::TCP->do_server failed");
		return undef;
	}

	($port, $addr, $family) = $acpt->sockname;
	my $command;
	if ($family == AF_INET) {
		unless ($addr =~ tr/./,/ == 3) {
			warn("ADDRESS=$addr must have just 3 dots");
			return undef;
		}
		$addr .= sprintf(",%d,%d", ($port >> 8) & 0xff, $port & 0xff);
		$command = 'PORT';
	} else {
		$addr = "|2|$addr|$port|";
		$command = 'EPRT';
	}

	unless ($self->putreq("$command $addr") =~ /^2/) {
		warn("$command command failed\n") if $LOG > 5;
		$self->error($self->{lastmesg});
		return undef;
	}

	$self->{ftp_acpt} = $acpt; # now, ready to accept
	1;
}

;#
sub acpt ($) {
	my $self = shift;

	$self->clearerror	|| return undef;

	my $data = $self->{ftp_acpt}->new_client;
	delete($self->{ftp_acpt}); # this cause close.
	$self->{ftp_data} = $data;
	1;
}

;#
;# open passive socket
;#
sub pasv ($) {
	my $self = shift;

	$self->clearerror	&&
	$self->cleardataconn	|| return undef;

	my $family = ($self->sockname)[2];
	my ($a_regexp, $command);
	if ($family == AF_INET) {
		$a_regexp = '\((\d+),(\d+),(\d+),(\d+),(\d+),(\d+)\)';
		$command = 'PASV';
	} else {
		$a_regexp = '\([^\d\s]{3}(\d+)[^\d\s]\)';
		$command = 'EPSV';
	}
	if ($self->putreq($command) !~ /^2/) {
		$self->error($self->{lastmesg});
		return undef;
	}
	if ($self->{lastmesg} !~ $a_regexp) {
		$self->error("pasv: no ADDR,PORT pair found");
		return undef;
	}

	my $bindaddr = $self->{ftp_bindaddr};
	my ($port, $addr);
	if ($family == AF_INET) {
		$port = $5 * 256 + $6;
		$addr = join('.', $1, $2, $3, $4);
	} else {
		$port = $1;
		$addr = ($self->peername)[1];
	}
	my $data = Fan::TCP->new();

	$data && $data->do_client(
		tcp_family => $family,
		tcp_bindaddr => $bindaddr,
		tcp_host => $addr,
		tcp_port => $port
	) or $self->error("can't do_client"), return undef;

	$self->{ftp_data} = $data;
	1;
}

;# clear data connection.
;# accept socket will be also closed.
sub cleardataconn ($) {
	my $self = shift;

	# count up
	if (ref($self->{ftp_data})) {
		my $x = $self->{ftp_data};
		$x->close;
		my $p = \%{$stats{$self->{ftp_server}}};
		$p->{data_sent} += $x->{tcp_sent_octets};
		$p->{data_recv} += $x->{tcp_recv_octets};
	}

	# clean up
	delete($self->{ftp_acpt});
	delete($self->{ftp_data});

	# always success
	1;
}

;#
sub makedataconn ($$) {
	my $self = shift;
	my $command = shift;

	($self->passive ? $self->pasv : $self->port)		&&
	$self->putreq($command) == 150				&&
	($self->passive || $self->acpt)				?
	$self->{ftp_data} : $self->status(0);
}

;#
sub list ($$) {
	my $self = shift;
	my $path = shift;

	# ASCII mode was required for listing directory.
	$self->ascii or return undef;

	my $data = $self->makedataconn("LIST $path");
	ref($data) && $data->isa('Fan::TCP')
		or $self->status(0), return undef;

	my $line = $data->getln;
	my @list = $line =~ /^total\s/ ? () : ($line);
	while (defined($line = $data->getln)) {
		push(@list, $line);
	}

	undef $data;
	$self->cleardataconn;
	$self->getres =~ /^2/
		or $self->status(0), return undef;

	join("\n", @list);
}

;#
sub get ($$;$) {
	my $self = shift;
	my ($rx, $lx) = @_;
	my ($temp, $length);
	$lx = $rx if $lx eq '';
	($temp = $lx) =~ s%[^/]+$%.in.$&%;

	local *FILE;
	unless (CORE::open(FILE, ">$temp")) {
		return $self->status(0);
	}

	my $data = $self->makedataconn("RETR $rx");
	unless (ref($data) && $data->isa('Fan::TCP')) {
		CORE::close(FILE);
		unlink($temp);
		return $self->status(0);
	}

	local $_;
	while (defined($_ = $data->getdata(4096))) {
		(print FILE $_) || last;
	}

	undef $data;
	$self->cleardataconn;
	CORE::close(FILE);

	if ($self->getres !~ /^2/) {
		unlink($temp);
		return $self->status(0);
	}
	unless (CORE::rename($temp, $lx)) {
		my $e = $!.'';
		$self->error($e);
		return undef;
	}
	1;
}

;#
sub put ($$;$) {
	my $self = shift;
	my ($lx, $rx) = @_;
	my $length;
	local ($_, *FILE);

	-f $lx && CORE::open(FILE, $lx) or return undef;
	$rx = $lx if $rx eq '';

	my $data = $self->makedataconn("STOR $rx");
	CORE::close(FILE), return $self->status(0) if ref($data) ne 'Fan::TCP';

	while (($length = read(FILE, $_, 2048)) > 0) {
		$data->putdata($_) || last;
	}

	undef $data;
	$self->cleardataconn;
	CORE::close(FILE);

	if ($length || $self->getres !~ /^2/) {
		return $self->status(0);
	}
	1;
}

;#
sub stat ($;$) {
	my $self = shift;
	my $command = "STAT";
	$command .= ' '.shift if @_;

	if ($self->putreq($command) !~ /^2/) {
		$self->error($self->{lastmesg});
		return undef;
	}

	local $_ = $self->{buffer};
	s/\r//g;			# ignore "\r".
	1 while s/^\d\d\d-[^\n]*\n//;	# skip prepended messages
	s/^total\s+\d+\n//;		# ignore first "total ..."
	s/(^|\n)2\d\d ([^\n]*$)//;	# skip result message

	# Some FTP servers or FTP gateways close connection by STAT
	# command. Check it now!
	my $tmp = $2;
	if ($tmp =~ /good\s?bye/i) {
		if ($LOG > 4) {
			warn("stat: server said \"$self->{lastmesg}\"\n");
			warn("stat: connection might be closed.\n");
			warn("stat: check your server.\n");
		}
		$self->error("stat: connection might be closed");
		return undef;
	}

	# or concatinated string will be returned.
	$_;
}

;# CAUTION
;# CHDIR SHOULD SUPPORT "" IN DIRECTORY NAME
;#
sub chdir ($$) {
	my $self = shift;
	my $dir = shift;

	if ($self->putreq("CWD $dir") !~ /^2/) {
		$self->error($self->{lastmesg});
		return undef;
	}
	1;
}

;#
sub cwd ($$) {
	my $self = shift;
	$self->chdir(shift);
}

;# CAUTION
;# PWD SHOULD SUPPORT "" IN DIRECTORY NAME
;#
sub pwd ($) {
	my $self = shift;

	if ($self->putreq("PWD") !~ /^2/) {
		$self->error($self->{lastmesg});
		return undef;
	}
	if ($self->{lastmesg} !~ /^"(\S+)"/) {
		$self->error("pwd: no directory name found");
		return undef;
	}
	$1;
}

;#
;#
sub type ($;$) {
	my $self = shift;

	if (@_) {
		my $type = shift;
		if ($self->putreq("TYPE $type") !~ /^2/) {
			$self->error("type: $self->{lastmesg}");
			return undef;
		}
		$self->{ftp_type} = $type;
	}
	$self->{ftp_type};
}

;#
sub image ($) {
	my $self = shift;
	$self->type eq 'I' || $self->type('I');
}

;#
sub ascii ($) {
	my $self = shift;
	$self->type eq 'A' || $self->type('A');
}

;#
sub size ($$) {
	my $self = shift;
	my $path = shift;

	if ($self->{no_size}) {
		$self->error("SIZE: not supported.");
		return undef;
	}
	if ($self->putreq("SIZE $path") !~ /^2/) {
		$self->{no_size}++ if $self->{lastcode} =~ /^5/;
		$self->error("size: $self->{lastmesg}");
		return undef;
	}
	if ($self->{lastmesg} !~ /^\d+$/) {
		$self->error("size: no SIZE found");
		return undef;
	}
	return $&;
}

;#
sub mtime ($$) {
	my $self = shift;
	my $path = shift;

	if ($self->{no_mdtm}){
		$self->error("MDTM: not supported.");
		return undef;
	}
	if ($self->putreq("MDTM $path") !~ /^2/) {
		$self->{no_mdtm}++ if $self->{lastcode} =~ /^5/;
		$self->error("mdtm: $self->{lastmesg}");
		return undef;
	}
	if ($self->{lastmesg} !~ /^\d+$/) {
		$self->error("mdtm: no MTIME found");
		return undef;
	}
	return $&;
}

;#
sub unlink ($$) {
	my $self = shift;
	my $path = shift;

	if ($self->putreq("DELE $path") !~ /^2/) {
		$self->error("dele: $self->{lastmesg}");
		return undef;
	}
	1;
}

;#
sub mkdir ($$) {
	my $self = shift;
	my $path = shift;

	if ($self->putreq("MKD $path") !~ /^2/) {
		$self->error("MKD: $self->{lastmesg}");
		return undef;
	}
	1;
}

;#
sub rmdir ($$) {
	my $self = shift;
	my $path = shift;

	if ($self->putreq("RMD $path") !~ /^2/) {
		$self->error("RMD: $self->{lastmesg}");
		return undef;
	}
	1;
}

;#
sub rename ($$$) {
	my $self = shift;
	my $old = shift;
	my $new = shift;

	if ($self->putreq("RNFR $old") != 350) {
		$self->error("RNFR: $self->{lastmesg}");
		return undef;
	}
	if ($self->putreq("RNTO $new") !~ /^2/) {
		$self->error("RNTO: $self->{lastmesg}");
		return undef;
	}
	1;
}

;#
sub chmod ($$$) {
	my $self = shift;
	my $mode = shift; # number, not a octal string
	my $file = shift;
	my $perm = sprintf("%o", $mode);

	if ($self->{no_chmod}) {
		$self->error("SITE CHMOD: not supported.");
		return undef;
	}
	if ($self->putreq("SITE CHMOD $perm $file") != 200) {
		$self->{no_chmod}++ if $self->{lastcode} =~ /^5/;
		$self->error("SITE CHMOD: $self->{lastmesg}");
		return undef;
	}
	1;
}

;#
sub umask ($$) {
	my $self = shift;
	my $umask = shift;

	if ($self->{no_umask}){
		$self->error("SITE UMASK: not supported.");
		return undef;
	}
	if ($self->putreq("SITE UMASK $umask") !~ /^2/) {
		$self->{no_umask}++ if $self->{lastcode} =~ /^5/;
		$self->error("UMASK: $self->{lastmesg}");
		return undef;
	}
	1;
}

;#
sub group ($$$) {
	my $self = shift;
	my $group = shift;
	my $gpass = shift;

	if ($self->putreq("SITE GROUP $group") !~ /^2/) {
		$self->error("GROUP: $self->{lastmesg}");
		return undef;
	}
	if ($self->putreq("SITE GPASS $gpass") !~ /^2/) {
		$self->error("GPASS: $self->{lastmesg}");
		return undef;
	}
	1;
}

;#
sub idle {
	my $self = shift;

	if ($self->{no_idle}) {
		$self->error("SITE IDLE: not supported.");
		return wantarray ? () : undef;
	}
	if (@_) {
		if ($self->putreq("SITE IDLE $_[$[]") !~ /^2/) {
			$self->{no_idle}++ if $self->{lastcode} =~ /^5/;
			$self->error("IDLE: $self->{lastmesg}");
			return undef;
		}
		if ($self->{lastmesg} !~ /\d+/) {
			$self->error("IDLE: no IDLE timer found");
			return undef;
		}
		return $&;
	} else {
		if ($self->putreq("SITE IDLE") !~ /^2/) {
			$self->{no_idle}++ if $self->{lastcode} =~ /^5/;
			$self->error("IDLE: $self->{lastmesg}");
			return undef;
		}
		if ($self->{lastmesg} !~ /(\d+)\D+(\d+)/) {
			$self->error("IDLE: no IDLE,MAXIDLE timers found");
			return undef;
		}
		return wantarray ? ($1, $2) : $1;
	}
}

;# end of Fan::FTP module