;#
;# Copyright (c) 1995-1998
;#	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: TCP.pm,v 1.20 1998/09/19 03:58:35 ikuo Exp $
;#
;# Description:
;#	TCP.pm - TCP Class definitions
;#	 - Socket based operations.
;#	 - Multiple addresses for a single server are supported.
;#
package Fan::TCP;

use strict;
use vars qw($VERSION $LOG $seq_id $sent_octets $recv_octets);

use Carp;
use Socket;

use Socket6;

use AutoLoader 'AUTOLOAD';

$VERSION = '0.03';

;#
BEGIN {
	$LOG = 5;
	$seq_id = 0;
	$sent_octets = 0;
	$recv_octets = 0;
}

;# status report...
END {
	&status_report if $LOG >= 6;
}

;# A special marker for AutoSplit.
1;
__END__

;# Show statistics report...
sub status_report ($) {
	my $this = shift;
	my $s = $sent_octets + 0;
	my $r = $recv_octets + 0;

	1 while $s =~ s/(\d+)(\d\d\d)/$1,$2/;
	1 while $r =~ s/(\d+)(\d\d\d)/$1,$2/;
	my $len = 0;
	$len = length($s) if $len < length($s);
	$len = length($r) if $len < length($r);

	warn("TCP status summary report:\n");
	warn(" total $seq_id objects created\n");
	warn(" sent". '.' x ($len + 3 - length($s)) . "$s octets\n");
	warn(" recv". '.' x ($len + 3 - length($r)) . "$r octets\n");
}

;# Constants - a very simple routine
sub FATAL () {
	0x5555; # magic number...
}

;# Destroy a TCP object.
sub DESTROY ($) {
	my $self = shift;

	# close and leave socket information
	$self->close;

	# count up...
	$sent_octets += $self->{tcp_sent_octets};
	$recv_octets += $self->{tcp_recv_octets};

	carp("TCP DESTROYING $self") if $LOG > 5;
}

;# Creat a new TCP object.
;#
;#	tcp_bindaddr	=> undef
;#	tcp_port	=> undef
;#	tcp_host	=> undef
;#	tcp_timeout	=> 120
;#
sub new ($%) {
	my $this = shift;
	my $class = ref($this) || $this;
	my %params = @_;
	my $self = \%params;

	# setup default values...
	$self->{tcp_timeout} = 120 if !defined($self->{tcp_timeout});
	$self->{tcp_state} = 1; # initial status is OK
	$self->{tcp_error} = ''; # error message will be stored.
	$self->{tcp_sent_octets} = 0;
	$self->{tcp_recv_octets} = 0;

	# bless me.
	bless $self, $class or return undef;

	# count up sequence #
	$seq_id++;

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

	# return myself.
	return $self;
}

;# Show statistics report...
sub stats ($) {
	my $self = shift;
	my $s = $self->{tcp_sent_octets} + 0;
	my $r = $self->{tcp_recv_octets} + 0;

	1 while $s =~ s/(\d+)(\d\d\d)/$1,$2/;
	1 while $r =~ s/(\d+)(\d\d\d)/$1,$2/;
	my $len = 0;
	$len = length($s) if $len < length($s);
	$len = length($r) if $len < length($r);

	warn("$self status report:\n");
	warn(" sent". '.' x ($len + 3 - length($s)) . "$s octets\n");
	warn(" recv". '.' x ($len + 3 - length($r)) . "$r octets\n");
}

;# $tcp->clearerror       trys clear error flag, or
;# $tcp->clearerror(1)    force to clear error flag.
;#
sub clearerror ($;$) {
	my $self = shift;
	my $force = @_ && shift(@_) ? 1 : 0;

	return undef if !$force && !defined($self->{tcp_state});

	$self->{tcp_state} = 1;		# status is o.k.
	$self->{tcp_error} = '';	# no error message
	1;
}

;# TCP object's error message at the last operation.
;#
sub error ($;$$) {
	my $self = shift;

	if (@_) {
		$self->{tcp_error} = shift;
		$self->{tcp_state} = @_ && (shift == &FATAL) ? undef : 0;
	}
	$self->{tcp_error};
}

;# Returns 1 if this TCP object has fatal error status.
sub fatal ($) {
	my $self = shift;

	if (@_) {
		my $force = shift;
		$self->{tcp_state} = undef if $force;
	}
	defined($self->{tcp_state}) ? 0 : 1;
}

;# refer or change current status of an object.
;# status may have OK, ERROR, FATAL.
sub status ($;$) {
	my $self = shift;

	# once status was undefined, you can't clear it.
	return undef if !defined($self->{tcp_state});

	# `change status' or `refer status' ?
	$self->{tcp_state} = shift if @_;

	# result is the current status.
	$self->{tcp_state};
}

;# dump all key/val pairs.
;# for debug purpose only.
sub dump ($@) {
	my $self = shift;
	my @index = @_ ? @_ : sort keys %{$self};
	my $count = 0;

	print("TCP dump $self");
	for my $key (@index) {
		if (exists($self->{$key})) {
			print(" $key => $self->{$key}\n");
			$count++;
		}
	}
	$count;
}

;# Send a line with CR/LF.
sub putln ($$) {
	my $self = shift;
	my $sock = $self->handle;
	my $line = shift;
	my $ok = 0;

	# DEBUG only - check socket!
	defined($sock) or confess("TCP: socket is not defined");

	# try to clear current status.
	$self->clearerror || return undef;

	# remove trailing spaces. DO NOT in this version.
	# $line =~ s/\s+$//;

	# print a line with CR/LF.
	eval {
		local $SIG{'ALRM'} = sub { die("alarm\n") };
		alarm($self->{tcp_timeout});
		$ok = print $sock ($line."\r\n");
		alarm(0);
	};

	# check result.
	if ($@) {
		if ($@ eq "alarm\n") {
			warn("putln: TIME OUT\n") if $LOG > 5;
			$self->error("operation timed out", &FATAL);
			return undef;
		}
		croak($@); # other evaluation error
	}

	# check result.
	unless ($ok) {
		my $e = $!.'';
		return $self->error($e, &FATAL);
		warn("TCP putln($line): $e\n") if $LOG > 6;
		carp("$self: print - $e");
		return undef;
	}

	# debug log
	if ($LOG > 6 || $self->{tcp_debug}) {
		my $fno = fileno($self->{tcp_sock});
		warn("$self [$fno] putln: $line\n");
	}

	# count up sent data size
	$self->{tcp_sent_octets} += length($line) + 2;

	# success to put lines.
	1;
}

;# recieve one line respone from server.
sub getln ($) {
	my $self = shift;
	my $sock = $self->handle;
	my $line = undef;

	# DEBUG only - check socket!
	defined($sock) or confess("TCP: socket is not defined");

	# try to clear current status.
	$self->clearerror || return undef;

	# if we already found end-of-file, return undef
	return undef if $self->{endoffile};

	# get a line from socket
	eval {
		local $SIG{'ALRM'} = sub { die("alarm\n") };
		alarm($self->{tcp_timeout});
		$line = <$sock>;
		alarm(0);
	};

	# check result.
	if ($@) {
		if ($@ eq "alarm\n") {
			warn("getln: TIME OUT\n") if $LOG > 5;
			$self->error("operation timed out", &FATAL);
			return undef;
		}
		carp($@); # other evaluation error
	}

	# check result
	unless (defined($line)) { # this is not an error
		warn("TCP getln: END-OF-FILE detected.\n") if $LOG > 6;
		$self->{endoffile}++, return undef;
	}

	# or success to read a line
	chomp($line);
	$line =~ s/\r?$//;

	# debug log
	if ($LOG > 6 || $self->{tcp_debug}) {
		my $fno = fileno($self->{tcp_sock});
		warn("$self [$fno] getln: $line\n");
	}

	# count up sent data size
	$self->{tcp_recv_octets} += length($line) + 2;

	# success, and return this line.
	$line;
}

;# send data to server
sub putdata ($$) {
	my $self = shift;
	my $data = shift;
	my $length = length($data);
	my $sock = $self->handle;
	my $ok = undef;

	# DEBUG only - check socket!
	defined($sock) or confess("TCP: socket is not defined");

	# try to clear current status.
	$self->clearerror || return undef;

	# if we already found end-of-file, return undef
	return undef if $self->{endoffile};

	# get a line from socket
	eval {
		local $SIG{'ALRM'} = sub { die("alarm\n") };
		alarm($self->{tcp_timeout});
		$ok = print $sock ($data);
		alarm(0);
	};

	# check result.
	if ($@) {
		if ($@ eq "alarm\n") {
			warn("putdata: TIME OUT\n") if $LOG > 5;
			$self->error("operation timed out", &FATAL);
			return undef;
		}
		croak($@); # other evaluation error
	}

	# check result
	unless ($ok) {
		my $e = $!.'';
		$self->error($e, &FATAL);
		carp("$self: print - $e");
		return undef;
	}

	# or success to send data
	if ($LOG > 6 || $self->{tcp_debug}) {
		my $fno = fileno($self->{tcp_sock});
		warn("$self [$fno] wrote $length octets.\n");
	}

	# count up sent data size
	$self->{tcp_sent_octets} += $length;

	# success, and return this line.
	1;
}

;# recv data to server
sub getdata ($$) {
	my $self = shift;
	my $length = shift;
	my $sock = $self->handle;
	my $data = '';
	my $len = 0;
	my $ok = undef;

	# DEBUG only - check socket!
	defined($sock) or confess("TCP: socket is not defined");

	# try to clear current status.
	$self->clearerror || return undef;

	# get a line from socket
	eval {
		local $SIG{'ALRM'} = sub { die("alarm\n") };
		alarm($self->{tcp_timeout});
		$len = read($sock, $data, $length);
		alarm(0);
	};

	# check result.
	if ($@) {
		if ($@ eq "alarm\n") {
			warn("getdata: TIME OUT\n") if $LOG > 5;
			$self->error("operation timed out", &FATAL);
			return undef;
		}
		croak($@); # other evaluation error
	}

	# check result
	unless (defined($len) && $len > 0) {
		$self->{endoffile}++, return undef;
	}

	# or success to recv data
	if ($LOG > 6 || $self->{tcp_debug}) {
		my $fno = fileno($self->{tcp_sock});
		warn("$self [$fno] read $len octets.\n");
	}

	# count up sent data size
	$self->{tcp_recv_octets} += $len;

	# success, and return this line.
	$data;
}

;#
sub nowait ($) {
	my $self = shift;
	my $sock = $self->handle;

	defined($sock) || return undef;
	my $a = select($sock); $| = 1; select($a);
	1;
}

;# opening socket...
;# and if bindport / bindaddr was specified, we try to 
;# bind the socket.
;# this should be a internal routine.
sub open_socket ($%) {
	my $self = shift;
	my %params = @_;

	# try clear error first.
	$self->clearerror || return undef;

	# if we already have a socket, close it first.
	$self->close;

	# check local side port #.
	my $port = $params{tcp_bindport} || $self->{tcp_bindport} || 0;

	# define local side address if bindaddr is not null string.
	my $family = $params{tcp_family} ? $params{tcp_family} : AF_INET;
	my $tcp_bindaddr = $params{tcp_bindaddr} || $self->{tcp_bindaddr} ||
			   (($family == AF_INET) ? '0.0.0.0' : '::');

	my ($socktype, $proto, $me, $canonname);
	($family, $socktype, $proto, $me, $canonname)
		= getaddrinfo($tcp_bindaddr, $port, $family, SOCK_STREAM);

	# local file handle...
	local *SOCKET;

	# creating a stream socket.
	unless (socket(SOCKET, $family, $socktype, $proto)) {
		my $e = $!.'';
		$self->error($e, &FATAL);
		carp("$self: socket - $e") if $LOG >= 5;
		return undef;
	}

	# bind addresses.
	unless (bind(SOCKET, $me)) {
		my $e = $!.'';
		$self->close;
		$self->error($e, &FATAL);
		carp("$self: bind - $e") if $LOG >= 5;
		return undef;
	}

	# debug log...
	if ($LOG > 5 || $self->{tcp_debug}) {
		warn("$self [".fileno(SOCKET)."] was opened.\n");
	}

	# save it
	$self->{tcp_sock} = *SOCKET;

	# success to create and bind socket.
	*SOCKET;
}

;# connecting the server.
sub do_client ($%) {
	my $self = shift;
	my %params = @_;
	my $sock;

	# close handle if exists
	$self->close;

	# clear error or return
	$self->clearerror(1);

	# parse argument
	my $port = $params{tcp_port} || $self->{tcp_port};
	my $host = $params{tcp_host} || $self->{tcp_host};

	# check required parameters
	if ($port eq '') {
		$self->error("no tcp_port", &FATAL);
		carp("$self: tcp_port not defined");
		return undef;
	}
	if ($host eq '') {
		$self->error("no tcp_host", &FATAL);
		carp("$self: tcp_host not defined");
		return undef;
	}

	# check server name and try to parse port number
	my @infos = getaddrinfo($host, $port, AF_UNSPEC, SOCK_STREAM);
	if ($#infos < 1) {
		carp("$self: getaddrinfo($host, $port) - $?");
		my $e = $?.'';
		$self->error($e, &FATAL);
		carp("$self: getaddrinfo($host, $port) - $e");
		return undef;
	}

	# Perl's bug? once connect fails, we could not any more
	# connect (connect returns "Invalid Argument"). So we
	# create/close a socket in each iteration.
	while ($#infos >= 1) {
		my ($family, $socktype, $proto, $peer, $canonname)
		    = splice(@infos, 0, 5);

		# open socket stores any error
		$params{tcp_family} = $family;
		$self->open_socket(%params) || return undef;

		my $result = undef;

		# do real work.
		eval {
			local $SIG{'ALRM'} = sub { die("alarm\n") };
			alarm($self->{tcp_timeout});
			$result = connect($self->{tcp_sock}, $peer);
			alarm(0);
		};

		# check result.
		if ($result) {
			$self->nowait; # let this socket non-blocking
warn("$self connect ok, local="
	.$self->sockname.", remote=".$self->peername."\n")
	if $LOG > 5 || $self->{tcp_debug};
			return 1; # success
		}
		if ($@) {
			if ($@ ne "alarm\n") {
				croak($@); # other evaluation error
			}
			warn("do_client: TIME OUT\n") if $LOG > 5;
			$self->error("operation timed out"); # not fatal.
		} else {
			# this is not a critical error, yet.
			my $e = $!.'';
			$self->error($e);
			carp("$self: connect - $e") if $LOG >= 6;
		}

		# perhaps, this is a perl's bug...
		$self->close; # or error found.
	}

	# or all connect were failed.
	# carp("all connect sessions were failed");
	$self->error($self->error, &FATAL);
	undef;
}

;#
;# open accept socket, and listen at specified addr/port.
;#
sub do_server ($%) {
	my $self = shift;
	my %param = @_;

	# close handle if exists
	$self->close;

	# clear error first
	$self->clearerror(1);

	# default backlog is 5.
	my $backlog = $param{tcp_backlog} > 0 ? $param{tcp_backlog} : 5;

	# opening new socket.
	$self->open_socket(%param) || return undef;

	# try real work
	unless (listen($self->{tcp_sock}, $backlog)) {
		my $e = $!.'';
		$self->error($e, &FATAL);
		carp("$self: listen - $e");
		return undef;
	}

	# success to listen
	1;
}

;#
;# Accept a new connection at listening socket,
;# and create a new TCP object.
;#
sub new_client ($) {
	my $self = shift;
	my $sock;

	defined($sock = $self->handle) || return undef;

	my $client = $self->new; # client = new TCP object.
	my $result = 0;

	local *SOCKET;

	eval {
		local $SIG{'ALRM'} = sub { die("alarm\n") };
		alarm($self->{tcp_timeout});
		$result = accept(SOCKET, $sock);
		alarm(0);
	};

	# check result.
	if ($@) {
		if ($@ eq "alarm\n") {
			warn("new_client: TIME OUT\n") if $LOG > 5;
			$self->error("operation timed out", &FATAL);
			return undef;
		}
		croak($@); # other evaluation error
	}

	# result of accept
	unless ($result) {
		my $e = $!.'';
		$self->error($e, &FATAL);
		carp("accept: $e");
		return undef;
	}

	# store...
	$client->{tcp_sock} = *SOCKET;

	# debug log...
	if ($LOG > 5 || $self->{tcp_debug}) {
		my $fno = fileno($client->{tcp_sock});
		warn("$self [$fno] was accepted.\n");
	}

	# set no wait
	$client->nowait;
	$client;
}

;#
sub close ($) {
	my $self = shift;
	my $sock = $self->handle;

	# close socket if already we have opened.
	if (defined($sock)) {
		my $fno = fileno($sock);
		shutdown($sock, 2);
		CORE::close($sock);
		# debug log...
		if ($LOG > 5 || $self->{tcp_debug}) {
			warn("$self [$fno] was closed.\n");
		}
	}

	# delete socket file handle
	delete($self->{tcp_sock});

	#
	1;
}

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

	# check existence of tcp_sock - we must have this.
	unless (exists($self->{tcp_sock})) {
		carp("$self has no tcp_sock") if $LOG > 6;
		return undef;
	}

	# copy to a local variable.
	my $s = $self->{tcp_sock};

	# validate our socket.
	unless (defined($s) && defined(fileno($s))) {
		carp("$self->tcp_sock is not a file handle") if $LOG > 7;
		return undef;
	}

	# DEBUG information.
	if ($LOG > 7) {
		my $fno = fileno($s);
		warn("$self->tcp_sock=[$fno]\n");
	}

	# return file handle itself.
	$s;
}

;#
sub sockname ($) {
	my $self = shift;
	my $sock = $self->handle;

	if (defined($sock)) {
		my $sa = getsockname($sock);
		my $family = (unpack('CC', $sa))[1];
		my ($addr, $port) = getnameinfo($sa, NI_NUMERICHOST |
						     NI_NUMERICSERV);
		carp("$self sockname=$addr|$port|$family") if $LOG > 7;
		return wantarray ? ($port, $addr, $family)
				 : "$addr|$port|$family";
	}
	return wantarray ? () : undef;
}

;#
sub peername ($) {
	my $self = shift;
	my $sock = $self->handle;

	if (defined($sock)) {
		my $sa = getpeername($sock);
		my $family = (unpack('CC', $sa))[1];
		my ($addr, $port) = getnameinfo($sa, NI_NUMERICHOST |
						     NI_NUMERICSERV);
		carp("$self sockpeer=$addr|$port|$family") if $LOG > 7;
		return wantarray ? ($port, $addr, $family)
				 : "$addr|$port|$family";
	}
	return wantarray ? () : undef;
}

;# end of Fan::TCP module