#!/bin/sh -- # A comment mentioning perl, indented for bash's sake.
eval 'exec perl -S $0 ${1+"$@"}'
        if 0;

chop($Program = `basename $0`);

$Verbose = 0;
$Quiet   = 0;
$Samples = 1;

select(STDERR); $| = 1;
select(STDOUT); $| = 1;

$Server_List = <<"END";
18.7.21.144     kerberos.mit.edu
18.72.0.144     kerberos-old.mit.edu
18.145.0.30     navobs1.mit.edu
131.243.64.11   tic.lbl.gov
18.26.4.105     bonehed.lcs.mit.edu	(SNTP BROKEN?)
140.142.16.34   bigben.cac.washington.edu  (CNAME ntp-wu.usno.navy.mil) 
24.147.1.16     ntp.ne.mediaone.net        (CNAME chftp01.ne.ipsvc.net)
END

$Host = '18.72.0.144';
$Port = 123;
$Sleep = 2.5;

$Usage = <<"END";

$Program: simple client for SNTP time protocol.

Usage: $Program [<options>] [<host>]

Options:
	-v	be verbose
	-q	be very quiet
	-L	list some servers
	-c <n>	average <n> samples
		-a is alias for -c
	-s <s>	sleep randomly between 0 and <s>

Notes:
	Default host is #1 (see below).
	If <host> is a number, that entry from the list is used.

	Offset is (time_there - time_here)
	so if our clock here is ahead,  then offset < 0
	or if out clock here is behind, then offest > 0

Servers:
$Server_List

END

LOOP:	
while (@ARGV) {
    $_ = shift;
    CASE: {
	/^(-c|-a)$/ && ($Samples = shift, last CASE);
	/^-s$/ && ($Sleep = shift, last CASE);
	/^-v$/ && ($Verbose++, last CASE);
	/^-q$/ && ($Quiet = 1, last CASE);
	/^-L$/ && ((print STDERR $Server_List), exit 0, last CASE);
	/^--$/ && (last LOOP);	# -- means end of switches
	/^-(-.*)$/ && (unshift(@ARGV, $1), last CASE);
	/^(-h|-help)$/ && ((print STDERR $Usage), exit 0, last CASE);
	if ( /^-(..+)$/ ) {	# split bundled switches:
		local($y, $x) = ($1, '');
		foreach $x (reverse(split(//, $y))) { unshift(@ARGV,"-$x") };
		last CASE;
	}
	/^-/ && ((print STDERR "Invalid arg: $_\n$Usage"), exit 1, last CASE);
	unshift(@ARGV,$_);
	last LOOP;
    }
}

$Quiet = 0 if $Verbose;

if ( $ARGV[0] ne '' ) {
	$Host = $ARGV[0];
}

if ( $Host =~ /^\d+$/ ) {
	$h = (split(/\n/, $Server_List))[$Host - 1];
	($Host, $rest) = split(/\s+/, $h);
	print "Set host to: $h\n";
}

if ( $Host =~ /^\s*$/ ) {
	print "NO HOST\n";
	exit 1;
}

&Use_Ksockets();	# my home-brew sockets.

#######################################################################
# Make packet to send.
#
# first octet:
# LI VN  MOD	LI=00 VN=1 MODE=3 (client)
# XX-XXX-XXX
# 00 001 011 = 8 + 2 + 1 = 11
$n1 = 11;

$b1   = pack("C", $n1);
$null = pack("C", 0);

if ( $Verbose ) {
	$bits = unpack("b8", $b1);
	print "send bits: $bits\n\n";
}

$packet = $b1 . $null x (3 + 4 * 11);	# remaining 47 octets are zero.

#######################################################################
# Prime the gettimeofday() pump a bit
foreach (1..3) {
	$time = &gettime();	
}

#######################################################################
# Initialize socket plumbing:
($fh, $host_ip, $loc_ip, $hsock, $lsock) = &Connect($Host, $Port, 'udp');
die "$fh" if &SocketError($fh);

#######################################################################
# Do queries:
for ($i=0; $i< $Samples; $i++) {
	&query();	# not fancy: all data is global here and there.
	$delays  .= "$Delay\n";
	$offsets .= "$Offset\n";
	fsleep($Sleep * rand() ) unless $i == $Samples - 1;
}

#######################################################################
# Average if appropriate:
if ( $Samples > 1 ) {
	print "\nAVE OFFSET: ";
	open(AVE, "|sum.pl -pm") || die "$!";
	print AVE $offsets;
	close(AVE);
	#wait;
	
	print "AVE DELAY:  ";
	open(AVE, "|sum.pl -pm") || die "$!";
	print AVE $delays;
	close(AVE);
	#wait;
}

exit $ERRORS;
####################################################################


sub query {
	
	my($start, $finish);
	### Begin time critical:
	$start = &gettime();

	$n =  &Send($fh, $packet, $hsock);

	($data, $rinfo) = &Recv($fh, 48);

	$finish = '';	# gettime() segv 2004	
	$finish = &gettime();
	### End time critical:

	if ( ! defined($data) ) {
		$ERRORS++;
		return;
	}

	$cnt = 0;
	print "received packet:\n" if $Verbose;
	while ($data =~ /^..../ ) {
		$word = $&;
		$data = $';
		if ($Verbose > 1) {
			print "Word: $word\n"
		}
		$word2 = '';
		foreach $c (split(//, $word)) {
			$c = pack("b8", unpack("B8", $c));
			$word2 .= $c;
		}

		$cnt++;
		$N = unpack("N", $word);
		$W[$cnt] = $N;
		$bits = unpack("b32", $word2);
		$B[$cnt] = $bits;
		print "$bits	$cnt\n" if $Verbose;
	}
	if ( $cnt < 12 ) {
		print "WARNING: short packet: $cnt words long.\n";
		$ERRORS++;
	}
	print "\n" if $Verbose;

	$R{LI}    = &b2i( substr($B[1], 0, 2) );
	$R{VN}    = &b2i( substr($B[1], 2, 3) );
	$R{MODE}  = &b2i( substr($B[1], 5, 3) );
	$R{STRAT} = &b2i( substr($B[1], 8, 8) );
	$R{POLL}  = &b2i( substr($B[1], 16, 8) );
	$R{PREC}  = &b2i( substr($B[1], 24, 8) );
	 
	$R{PREC}  = $R{PREC} - 256;

	if ( $Verbose ) {
		foreach $case (qw(LI VN MODE STRAT POLL PREC)) {
			print "$case	$R{$case}\n"; 
		}
		print "\n";
	}
	if ( $R{LI} == 1 ) {
		print "NOTICE: LI=1, last minute has 61 seconds\n";
	} elsif ( $R{LI} == 2 ) {
		print "NOTICE: LI=2, last minute has 59 seconds\n";
	} elsif ( $R{LI} == 3 ) {
		print "WARNING: LI=3 alarm condition (server clock not synchronized)\n";
		$ERRORS++;
	}
	if ( $R{MODE} != 4 ) {
		print "WARNING: MODE = $R{MODE} =! 4 NOT SERVER MODE.\n";
		$ERRORS++;
	}
	$S = $R{STRAT};
	if ( $S < 1 || $S > 14 ) {
		print "WARNING: BAD STRATUM: $S\n";
		$ERRORS++;
	}
	print "\n" if $Verbose;

	$t_32 = 2 ** 32;
	$y_1900 = 2208988800;

	$t = $W[5] - $y_1900;

	$ref_time = $t + $W[6]/$t_32;
	print "ref:    $ref_time\n\n" if $Verbose;

	$t = $W[9] - $y_1900;
	$recv_time = $t + $W[10]/$t_32;

	$t = $W[11] - $y_1900;
	$xmit_time = $t + $W[12]/$t_32;

	print "strt:   $start\n" unless $Quiet;
	print "recv:   $recv_time\n" unless $Quiet;
	print "xmit:   $xmit_time\n" unless $Quiet;
	print "fini:   $finish\n" unless $Quiet;

	$Delay = ( $finish - $start ) - ($xmit_time - $recv_time);
	$Offset = ( ( $recv_time - $start ) + ( $xmit_time - $finish ) ) / 2.;

	if ( ! $Quiet || $Samples == 1 ) {
		print "offset: $Offset\n";
		print "delay:  $Delay\n";
	}

	if ( $Offset < -5000 || $Offset > 5000 ) {
		print "WARNING: huge offset\n";
		$ERRORS++;
	}
	if ( $Delay < 0 || $Delay > 1 ) {
		print "WARNING: huge delay\n";
		$ERRORS++;
	}
}

##############################################################################
#                      1                   2                   3
#       0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |LI | VN  |Mode |    Stratum    |     Poll      |   Precision   |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                          Root Delay                           |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                       Root Dispersion                         |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                     Reference Identifier                      |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                                                               |
#      |                   Reference Timestamp (64)                    |
#      |                                                               |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                                                               |
#      |                   Originate Timestamp (64)                    |
#      |                                                               |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                                                               |
#      |                    Receive Timestamp (64)                     |
#      |                                                               |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                                                               |
#      |                    Transmit Timestamp (64)                    |
#      |                                                               |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                 Key Identifier (optional) (32)                |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#      |                                                               |
#      |                                                               |
#      |                 Message Digest (optional) (128)               |
#      |                                                               |
#      |                                                               |
#      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
#
#
#      LI       Value     Meaning
#      -------------------------------------------------------
#      00       0         no warning
#      01       1         last minute has 61 seconds
#      10       2         last minute has 59 seconds)
#      11       3         alarm condition (clock not synchronized)
#
# Version Number (VN): This is a three-bit integer indicating the
#   NTP/SNTP version number. The version number is 3 for Version 3 (IPv4
#   only) and 4 for Version 4 (IPv4, IPv6 and OSI). If necessary to
#   distinguish between IPv4, IPv6 and OSI, the encapsulating context
#   must be inspected.
#
# Mode: This is a three-bit integer indicating the mode, with values
#   defined as follows:
#
#      Mode     Meaning
#      ------------------------------------
#      0        reserved
#      1        symmetric active
#      2        symmetric passive
#      3        client
#      4        server
#      5        broadcast
#      6        reserved for NTP control message
#      7        reserved for private use
#
#
###############################################################################
# subroutines

sub fsleep {
	local($time) = @_;
	select(undef, undef, undef, $time) if $time;
}

sub b2i {
	local($str) = @_;

	local($sum) = 0;
	local($fac) = 1;
	local($b);

	# this is slow, but is not used when timing is critical
	foreach $b ( reverse( split(//, $str) ) ) {
		$sum += $fac * $b;
		$fac *= 2;
	}
	return $sum;
}

sub gettime {
	if ( ! $GetTime_Syscall_Init ) {
		my ($dir, $found_it);
		$found_it = 0;
		foreach $dir (@INC) {
			if ( -f "$dir/sys/syscall.ph" ) {
				$found_it = 1; # whew!
				last;
			}
		}
		if ( ! $found_it ) {
			# bummer... try to guess the syscall #
			$OS_Name = `uname -s` unless $OS_Name;
			if ( $OS_Name =~ /sunos/i ) {
				eval "sub SYS_gettimeofday { return 156; }";
			} elsif ( $OS_Name =~ /linux/i ) {
				eval "sub SYS_gettimeofday { return 78; }";
			} elsif ( $OS_Name =~ /Darwin/i ) {
				eval "sub SYS_gettimeofday { return 116; }";
			}
		} else {
			require 'sys/syscall.ph';
		}
		&SYS_gettimeofday() || die "$!";
		$GetTime_Syscall_Init = &SYS_gettimeofday();
		print STDERR "Initialized: GetTime_Syscall\n" if $Debug;
	}

	# let's keep these global...
	# my ($tv, $tv_sec, $tv_usec);
	# Allocate the "timeval" space:
	if ($OS_Name eq "Darwin") {
		use Time::HiRes qw( usleep ualarm gettimeofday tv_interval );
		($tv_sec, $tv_usec) = Time::HiRes::gettimeofday();
	} else {
		
		$tv = ("\0" x 4) x 2;	# assumes long is 4 bytes.
		$tz = ("\0" x 4) x 2;	# assumes long is 4 bytes.
		syscall($GetTime_Syscall_Init, $tv, $tz);
		($tv_sec, $tv_usec) = unpack("L2", $tv);
	}

#	$tv_sec  = substr($tv, 0, 4);
#	$tv_usec = substr($tv, 4, 4);
#	$tv_sec  = unpack("l", $tv_sec);
#	$tv_usec = unpack("l", $tv_usec);

	$tv_usec2 = sprintf("%8.6f", $tv_usec/1000000.0);
	if ( $tv_usec2 =~ /^0\./ ) {
		$tv_usec2 =~ s/^0\././;
		$tv_sec = "$tv_sec$tv_usec2";
	} else {
		$tv_sec = $tv_sec + ($tv_usec/1000000.0);
	}
	if ( $StartTime ne '' ) {
		$tv_sec -= $StartTime;
	}
	return $tv_sec;
}

#----------------------------------------------------------------------
package Ksockets;

#===========================================================================
# Ksockets v0.3: Karl's sockets. Copyright (c) 1996-2006 by Karl J. Runge
# Socket macros to perl's low level socket interface. <runge@karlrunge.com>
#===========================================================================

sub main'Use_Ksockets {

    ###################################################################
    #
    # Initialize Ksockets Package
    #
    # USAGE:
    #
    # &Use_Ksockets();
    #
    ###################################################################

	if ( defined($ksockets_initialized) ) {
		return;
	}

	if (0) {
		# List of functions in this package:
		&main'Use_Ksockets;
		&main'Server;
		&main'Connect;
		&main'AcceptConnection;
		&main'Recv;
		&main'Send;
		&main'Ready;
		&main'SocketError;
		&main'IP_From_Name;
		&main'SocketInfo;
		&main'Local_IP;
		&main'spit_ksockets;
		&get_sock_type;

		# List of variables referenced:
		$main'Debug;
	}

	$pkg = 'Ksockets';

	$Server_Handles  = 'KSOCKETSSERVER00000';
	$Connect_Handles = 'KSOCKETSCONNECT0000';
	$Ksockets_Handle_String = 'KSOCKETS';

	$AF_INET = 2;			# choose INET family

	my $is_svr4 = '';

	if ( defined($main'IS_SYSV) ) {
		if ( $main'IS_SYSV ) {
			$is_svr4 = 1;
		} else {
			$is_svr4 = 0;
		}
	} elsif ( defined($main'Is_Sysv) ) {
		if ( $main'Is_Sysv ) {
			$is_svr4 = 1;
		} else {
			$is_svr4 = 0;
		}
	} else {
		if ( -x "/bin/uname" || -x "/usr/bin/uname" ) {
			# OK, this is quite a hack...
			my $osname  = `uname -s`;
			my $release = `uname -r`;
			if ( $osname =~ /sunos/i && $release !~ /^4\./ ) {
				$is_svr4 = 1;
			}
			# add others ...
		}
	}
	if ( ! $is_svr4 ) {
		$SOCK_STREAM = 1;		# BSD flavor
		$SOCK_DGRAM  = 2;		# known to work on Linux
						# SunOS 4.
	} else {
		$SOCK_STREAM = 2;		# SVR4 flavor
		$SOCK_DGRAM  = 1;		# known to work on solaris
	}

	# todo: SOCK_RAW SOCK_SEQPACKET SOCK_RDM

	$Default_Proto = 'tcp';
	$Default_Backlog = '8';

	# template for packing socket address into binary.
	$SockAddr = 'S n a4 x8';

	if ( $main'Local ne '' ) {
		$Hostname = $main'Local;
	} else {
		chop($Hostname = `hostname`);
	}
	my($name,$aliases,$type,$len,$localaddr) =
						gethostbyname($Hostname);

	$Local_IP = join('.', unpack('C4',$localaddr));

	$ksockets_initialized = 1;

}  # end Use_Ksockets

sub main'Server {

    ###################################################################
    #
    # Open a listening socket on a port.
    #
    # USAGE:
    #
    # $file_handle = &Server($port, $backlog[OPT], $proto_in[OPT])
    #
    # Then use $file_handle in  &AcceptConnection($file_handle) calls
    # Test for errors via a call to: &SocketError($file_handle)
    #
    # e.g:
    # 	$Server = &Server('8888');
    # 	die "$Server" if &SocketError($Server);
    # 	($Client) = &AcceptConnection($Server);
    # 	die "$Client" if &SocketError($Client);
    # 	... <read and write from $Client file handle>
    ###################################################################


	my($port, $backlog, $proto_in) = @_;
	my($name, $aliases, $proto);

	if ( !defined($proto_in) || $proto_in eq '' ) {
		$proto_in = $Default_Proto;
	}

	if ($port !~ /^\d+$/) {
		# port could be "smtp" though not likely
		($name, $aliases, $port, $proto) =
					getservbyname($port, $proto_in);
	}

	($name, $aliases, $proto) = getprotobyname($proto_in);

	$backlog = $Default_Backlog unless $backlog;

	print STDERR "Server:port:$port\n" if $main'Debug;

	# pack our address
	my $us = pack($SockAddr, $AF_INET, $port, "\0\0\0\0");

	my $listen = ++$Server_Handles;

	# force filehandles into callers' package
	my $package = caller;
	$listen =~ s/^[^']+$/$package'$&/;

	my $old = select($listen); $| = 1; select($old);

	my $SOCK_TYPE = &get_sock_type($proto_in);

	if ( ! socket($listen, $AF_INET, $SOCK_TYPE, $proto) ) {
		return "Error:$pkg:Server:socket($listen, $AF_INET, $SOCK_TYPE, $proto): \"$!\"";
	}

	if ( ! bind($listen, $us) ) {
		return "Error:$pkg:Server:bind($listen, SOCKADDR): \"$!\"";
	}

	if ( $proto_in eq 'tcp' ) {
	    if ( ! listen($listen, $backlog) ) {
		return "Error:$pkg:Server:listen($listen, $backlog): \"$!\"";
	    }
	}

	return $listen;

}  # end Server

sub main'Connect {

    ###################################################################
    #
    # Make a connection to a remote host port.
    #
    # USAGE:
    #
    # ($file_handle, $host_ip, $Local_IP, $host_sockaddr, $local_sockaddr) =
    #		&Connect($host, $port, $proto_in[OPT])
    #
    # Then use $file_handle in to read and write from remote connection
    #
    # Test for errors via a call to: &SocketError($file_handle)
    #
    # Use $host_ip and $local_ip as IP address information.
    # The $host_sockaddr and $local_sockaddr are packed socket addresses
    # for us in connectionless sockets (e.g. 'udp')
    #
    # e.g:
    # 	($Remote) = &Connect('www.netscape.com', '80');
    # 	die "$Remote" if &SocketError($Remote);
    # 	... <read and write from $Remote file handle>
    ###################################################################

	my($host, $port, $proto_in) = @_;
	my($name, $aliases, $proto);
	my($type,$len);
	my($local_addr, $local_sockaddr); # , $local_ip);
	my($host_addr,  $host_sockaddr,  $host_ip);

	if ( !defined($proto_in) || $proto_in eq '' ) {
		$proto_in = $Default_Proto;
	}

	if ($port !~ /^\d+$/) {
	    # port could be "smtp"
	    ($name, $aliases, $port, $proto) =
				getservbyname($port, $proto_in);
	    if ( $port eq '' ) {
		return ("Error:$pkg:Connect:getservbyname($port, $proto_in): Empty port returned", '', '', '', '');
	    }
	}

	($name, $aliases, $proto) = getprotobyname($proto_in);
	if ( !defined($proto) || $proto eq '' ) {
		return ("Error:$pkg:Connect:getprotobyname($proto_in): Empty proto returned", '', '', '', '');
	}

	if ( $host =~ /^\d+/ ) {
		$host_ip = $host;
		$host_addr = pack('C4', split(/\./, $host, 4));
	} else {
		($name,$aliases,$type,$len,$host_addr) =
						gethostbyname($host);
		if ( !defined($host_addr) || $host_addr eq '' ) {
		    return ("Error:$pkg:Connect:gethostbyname($host): Empty host_addr returned", '', '', '', '');
		}
		$host_ip = join('.', unpack('C4', $host_addr));
	}

#	$local_addr = pack('C4', split(/\./, $Local_IP, 4));
	$local_addr = pack('C4', split(/\./, "0.0.0.0", 4));

	$local_sockaddr = pack($SockAddr, $AF_INET, 0, $local_addr);

	$host_sockaddr  = pack($SockAddr, $AF_INET, $port, $host_addr);

	my $connection = ++$Connect_Handles;

	# force filehandles into callers' package
	my $package = caller;
	$connection =~ s/^[^']+$/$package'$&/;

	my $old = select($connection); $| = 1; select($old);

	my $SOCK_TYPE = &get_sock_type($proto_in);

	if ( ! socket($connection, $AF_INET, $SOCK_TYPE, $proto) ) {
	    return ("Error:$pkg:Connect:socket($connection, $AF_INET, $SOCK_TYPE, $proto): \"$!\"", '', '', '', '');
	}

	if ( ! bind($connection, $local_sockaddr) ) {
	    return ("Error:$pkg:Connect:bind($connection, $Local_IP): \"$!\"", '', '', '', '');
	}

	if ( $proto_in eq 'tcp' ) {
	    if ( ! connect($connection, $host_sockaddr) ) {
		return ("Error:$pkg:Connect:connect($connection, $host_ip): \"$!\"", '', '', '', '');
	    }
	}

	return ($connection, $host_ip, $Local_IP, $host_sockaddr, $local_sockaddr);

}  # end Connect

sub main'AcceptConnection {

    ###################################################################
    #
    # Wait for and accept a connection on a listening port.
    #
    # Listening port created with &Server();
    #
    # USAGE:
    #
    # ($file_handle, $address, $client_port) =
    #		&AcceptConnection($listen_file_handle))
    #
    # Then use $file_handle in to read and write from remote connection
    # Test for errors via a call to: &SocketError($file_handle)
    #
    # e.g:
    #   ($OurService) = &Server('8888');
    # 	die "$OurService" if &SocketError($OurService);
    # 	($Guest) = &AcceptConnection($OurService);
    # 	die "$Guest" if &SocketError($Guest);
    # 	... <read and write from $Guest file handle>
    ###################################################################

	my($listen_socket) = @_;
	my $real_socket = ++$Server_Handles;

	# force filehandles into callers' package
	my $package = caller;
	$real_socket =~ s/^[^']+$/$package'$&/;

	my $old = select($real_socket); $| = 1; select($old);
	my $address = '';
	my $fail = '';

	($address = accept($real_socket, $listen_socket)) ||
		($fail = "Error:$pkg:AcceptConnection:accept($real_socket, $listen_socket): \"$!\"");

	if ( $fail ne '' ) {
		close($real_socket);
		return ($fail, '', '');
	}

	my($af,$c_port,$inetaddr) = unpack($SockAddr,$address);
	$address = join('.', unpack('C4',$inetaddr));

	return ($real_socket, $address, $c_port);

}  # end AcceptConnection

sub main'Ready {

    ###################################################################
    #
    # See if a socket handle is ready to be read or written to.
    #
    # USAGE:
    #
    # ($handle_ready, $time_left ) =
    #			&Ready($socket_handle, $time_out, $mode[OPT])
    #
    # Given handle will be checked for readiness up to $time_out seconds
    # Default for $mode is 'read', but it could be 'write' or 'error'
    #
    # $handle_ready will be the integer result of the select() call,
    # i.e. the number of 'ready' handles. Should be 0 (problem) or
    # 1 (handle ready).
    #
    # If time_out is undef, it should block waiting for readiness.
    #
    # E.g.:
    # ($ready) = &Ready($socket, '30');
    # if ($ready) {
    #    <read from $socket>
    # } else {
    #    <not ready, do a wait or handle somehow>
    # }
    #
    ###################################################################

	my($socket, $time_out, $mode) = @_;
	my($handle_ready, $time_left, $in, $out) = ('', '', '','');

	vec($in, fileno($socket), 1) = 1;

	# note, the $out = $in stuff is not useful since they are
	# reset every time.

	if ( ! defined($mode) || $mode eq 'read' ) {
		($handle_ready, $time_left) =
			select($out = $in, undef, undef, $time_out);

	} elsif ( $mode eq 'write' ) {
		($handle_ready, $time_left) =
			select(undef, $out = $in, undef, $time_out);

	} elsif ( $mode eq 'error' ) {
		($handle_ready, $time_left) =
			select(undef, undef, $out = $in, $time_out);

	} elsif ( $mode eq 'sleep' ) { # undoc'd floating pt sleep
		($handle_ready, $time_left) =
			select(undef, undef, undef, $time_out);

	} else {			# should handle error case better
		$handle_ready = undef;
		$time_left = 'Error:Ready:unknown mode';
	}

	return ($handle_ready, $time_left);

}  # end Ready

sub main'Recv {

    ###################################################################
    #
    # Receive data from a socket.
    #
    # USAGE:
    #
    # ($data, $recv_address_info ) = &Recv($socket_handle, $size)
    #
    #
    ###################################################################

	my($socket, $size) = @_;
	my($recv_info, $buf) = ('', '');

	$recv_info = recv($socket, $buf, $size, 0);

	return ($buf, $recv_info);

}  # end Recv

sub main'Send {

    ###################################################################
    #
    # Send data to a socket.
    #
    # USAGE:
    #
    # $nchars = &Send($socket_handle, $message, $TO[OPT])
    #
    # $nchars is number of characters sent.
    # optional $TO is for 'udp' sockets. The Remote sockaddr
    # returned on Connect() say.
    #
    #
    ###################################################################

	my($socket, $message, $to) = @_;
	my $send_info = '';

	if ( !defined($to) || $to eq '' ) {
		$send_info = send($socket, $message, 0);
	} else {
		$send_info = send($socket, $message, 0, $to);
	}

	if ( !defined($send_info) ) {
		$send_info = "Error:$pkg:Send:send($socket, $message, 0, $to): \"$!\"";
	}

	return $send_info;

}  # end Send

sub main'SocketError {

    ###################################################################
    #
    # Test for error on a Ksocket command.
    #
    # USAGE:
    #
    # ($socket_file_handle, .... ) = &Ksocket_Command(...)
    #
    # Ksocket_Command can be:
    #		Server()
    #		Connect()
    #		AcceptConnection()
    #		IP_From_Name()
    #
    # $error = &SocketError($socket_file_handle)
    #
    # if ( $error ) {
    #  	<error condition>
    # } else {
    #  	<ok condition>
    # }
    #
    ###################################################################

	my($msg) = @_;

	if ( $msg  =~ /^\s*$/ ) {
		return 1;
	}
	if ( $msg  =~ /^\s*ERROR/i ) {
		return 1;
	}
	if ( $msg  !~ /$Ksockets_Handle_String/ && $msg !~ /^\d+\.\d+\.\d+\.\d+$/ ) {
		return 1;
	}
	return 0;

}  # end SocketError

sub main'IP_From_Name {

    ###################################################################
    #
    # Translate a machine host name into IP number nnn.nnn.nnn.nnn
    #
    # USAGE:
    #
    # $ip_number = &IP_From_Name($name)
    #
    # e.g.
    #  $ip_number = &IP_From_Name('www.netscape.com');
    #  die "$ip_number" if &SocketError($ip_number);
    #  ... <use $ip_number where needed>
    #
    ###################################################################

	my($input_name) = @_;
	my($remote_address);
	my($name, $aliases, $type, $len, $ip);

	if ( $input_name =~ /^\d+\./ ) {
		return $input_name;
	}

	# Turn name -> ddd.ddd.ddd.ddd
	($name,$aliases,$type,$len,$remote_address) =
					gethostbyname($input_name);

	if ( !defined($remote_address) || $remote_address eq '' ) {
		return "Error:$pkg:IP_From_Name:gethostbyname($input_name): \"$!\"";
	}
	$ip = join(".", unpack('C4',$remote_address));

	return $ip;

}  # end IP_From_Name

sub main'SocketInfo {

    ###################################################################
    #
    # Translate a internal address format into human readable information
    #
    # USAGE:
    #
    # ($r_port, $r_ip, $af) = &SocketInfo($address)
    #
    # $address comes from some socket operation, like recv
    # NOTE: not finished
    #
    ###################################################################

	my($input_address) = @_;
	my($af, $remote_port, $remote_address) =
					unpack($SockAddr, $input_address);
	$remote_address = join('.', unpack('C4', $remote_address));
	return ($remote_port, $remote_address, $af)

}  # end SocketInfo

sub get_sock_type {

    ###################################################################
    #
    # INTERNAL ROUTINE not available in main'.
    #
    # Translate string protocol name (e.g. tcp or udp)
    # into Socket type.
    #
    # USAGE:
    #
    # $SOCK_TYPE = &get_sock_type($name)
    #
    # e.g.
    #  $SOCK_TYPE = &get_sock_type('udp');
    #  ... <use $SOCK_TYPE where needed>
    #
    ###################################################################

	my($name) = @_;

	if ( $name eq 'tcp' || $name eq '' ) {
		return $SOCK_STREAM;
	} elsif ( $name eq 'udp' ) {
		return $SOCK_DGRAM;
	}

}  # end get_sock_type

sub main'Local_IP {
	my($ip) = @_;
	if ( $ip ne '' ) {
		$Local_IP = $ip;
	}
	return $Local_IP;

}  # end Local_IP

sub main'spit_ksockets {
	open(THIS_FILE, "$0");
	my $ok_to_print = '';
	my $first = 1;

	while (<THIS_FILE>) {

		if (0 && $first ) {
			$first = '';
			print STDOUT <<'EOQ';
  #!/bin/sh -- # A comment mentioning perl, to prevent perl from looping. Indented to work with bash.
eval 'exec perl -S $0 ${1+"$@"}'
        if 0;
EOQ
			print STDOUT "\n";
			print STDOUT "&Use_Ksockets();\n";
			print STDOUT "\n";
			print STDOUT "#----------------------------------------------------------------------\n";
		}
		if ( /^package Ksockets/ ) {
			$ok_to_print = 1;
		}
		print STDOUT if $ok_to_print;
		if ( /^[\s\#]*END OF PACKAGE Ksockets/ ) {
			$ok_to_print = '';
		}
	}
}

# END OF PACKAGE Ksockets