Subject: ANNOUNCE: "comm_utils.pl" -- perl4/5 easy client/server IPC
From: [email-masked] (Eric Arnold)
Date: 11 Jun 1995 17:51:34 GMT
Newsgroups: comp.lang.perl.announce,comp.lang.perl.misc,comp.lang.perl

This is the perl4/5 client/server package that I try to keep updated
for myself.  I just included it in the posting of my "shelltalk"
program, but it's useful in its own right.

-Eric

#                         "comm_utils.pl"
#
# This is a library of IPC goodies.  There is no warrenty, but I'd
# be happy to get ideas for improvements.
#
# 		- [email-masked]
#
# It's been tested with Perl4/Perl5 and SunOS4.x and Solaris2.3 - 2.5.
# It's normally put into a file and "require"'d, but can also be simply
# concatinated to the end of some other perl script.
#
# A lot was borrowed from "chat2.pl", and then diverged as its goals became 
# generalized client/server IPC, support for SVR4/Solaris, and to facilitate
# my "shelltalk" program.
#
# Function summary:
#
#   &init();
#
#   $handle = &comm'open_port($host, $port, $timeout);
#   $handle = &comm'open_listen( $port );
#   ( $Proc_handle, $Proc_tty_handle, $Proc_pid ) = &comm'open_proc($Shell_cmd);
#
#   ( $new_handle, $rem_host ) = &comm'accept_it( $handle );
#   @ready_handles = &comm'select_it( $timeout, $handle1, $handle2, ..... );
#
#   $string = &comm'gets( $handle );
#   &comm'sysread( $handle, $buf, $num_bytes );
#   &comm'print( $handle, $buf );
#   &comm'system( $Proc_tty_handle, $command );
#
#   &comm'close_noshutdown( $handle );
#   &comm'close( $handle )
#
#   &comm'ioctl( $Proc_tty_handle, $ioctl_command, $var );
#   &comm'stty_sane( $handle );
#   &comm'stty_raw( $handle );
#   &comm'get_ioctl_from_stty( $stty_cmd );
#   &comm'dump_ioctl( $stty_cmd );
#
#
# See the end for example programs demonstrating usage.
#
# Bugs:
#   - SOCK_STREAM (see comm_utils.pl) is different for SVR4/Solaris,
#     but if you use a perl compiled under SunOS, then the old value is
#     needed.  How do I tell whether I'm running a SunOS4.x perl or Solaris2?
#     I finally gave up and it first tries 1 for SOCK_STREAM, and if that 
#     fails, then it tries 2.
#
# 09/11/94 07:03:04 PM;  eric:	fixed for Solaris and /dev/tty
# 09/14/94 02:11:19 AM;  eric:	close correct file handle in open_listen
# 09/15/94 03:33:31 AM;  eric:	added sock'system 
# 09/19/94 10:48:11 AM;  eric:	added cheapo/easy ioctl dump/do
# 10/11/94 11:07:14 AM;  eric:	added I_POP to clear stream on pty
# 11/08/94 03:03:19 PM;  eric:	changed to first try SOCK_STREAM=1, then =2
# 02/28/95 12:53:22 PM;  eric:	found the right place to set SO_LINGER!
# 03/18/95 08:19:46 PM;  eric:	added timeout arg to open_port
# 05/07/95 10:56:25 PM;  eric:	fixed shutdown/close order bug in close()
#				added close_noshutdown
# 06/08/95 01:06:03 PM;  eric:	fixed Sol2.4 problem with string literal
#				as last arg to syscall($SYS_ioctl

package comm;

&init;

sub init{
  *Debug = *main'Debug;

  if ( -f "/vmunix" )
  {
    $OS_type = "BSD";
    $SOCK_STREAM=1;
  }
  else
  {
    $OS_type = "SVR4";
    if ( $] >= 5 ){
      $SOCK_STREAM=1;
    }else{
      $SOCK_STREAM=2;}
  }

  print STDERR "OS_type=$OS_type\n" if $Debug;

  chop( $thishost = `uname -n ` );

  $next_handle="stuff000000";
  $sockaddr = 'S n a4 x8';

  $thisaddr = (gethostbyname($thishost))[4];
  $thisproc = pack($sockaddr, 2, 0, $thisaddr);

  $SYS_ioctl = 54;

  if ( $OS_type eq "SVR4" ){
    # These must be syscalls because Perl's ioctl doesn't know about I_PUSH
    #syscall($SYS_ioctl, fileno($_TTY), $I_PUSH, "ptem" );
    #syscall($SYS_ioctl, fileno($_TTY), $I_PUSH, "ldterm");

    # from /usr/include/sys/termios.h
    $tIOC    	=( unpack("C", 't') << 8);
    $TIOCGETP       =($tIOC|8);
    $TIOCSETP       =($tIOC|9);

    $TIOC     	=( unpack("C", 'T' ) <<8);
    $TCGETS         =($TIOC|13);
    $TCSETS         =($TIOC|14);
    $TCSANOW        =(( unpack("C",'T')<<8)|14); #/* same as TCSETS */
    $TCGETA  	=($TIOC|1);
    $TCSETA  	=($TIOC|2);

    # From /usr/include/sys/stropts.h
    $STR =             ( unpack("C", "S") <<8 );
    $I_PUSH =          ($STR|02);	#$I_PUSH = 21250;
    $I_POP =           ($STR|03);
    $I_LOOK =          ($STR|04);
    #define I_FLUSH         (STR|05)
    
  }else{
    $TIOCGETP=0x40067408;	#d(1074164744)
    $TIOCSETP=0x80067409;	#d(-2147060727)
  }

  $SOL_SOCKET      =0xffff          ;#/* options for socket level */
  $SO_DEBUG        =0x0001          ;#* turn on debugging info recording */
  $SO_ACCEPTCONN   =0x0002          ;#* socket has had listen() */
  $SO_REUSEADDR    =0x0004          ;#* allow local address reuse */
  $SO_KEEPALIVE    =0x0008          ;#* keep connections alive */
  $SO_DONTROUTE    =0x0010          ;#* just use interface addresses */
  $SO_BROADCAST    =0x0020          ;#* permit sending of broadcast msgs */
  $SO_USELOOPBACK  =0x0040          ;#* bypass hardware when possible */
  $SO_LINGER       =0x0080          ;#* linger on close if data present */
  $SO_OOBINLINE    =0x0100          ;#* leave received OOB data in line */

}

sub open_port{

  local( $server, $port, $timeout ) = @_;
  local( $new_handle ) = ++$next_handle;
  local( %saveSIG, $ret );

  if ($server =~ /^(\d+)+\.(\d+)\.(\d+)\.(\d+)$/) {
	  $serveraddr = pack('C4', $1, $2, $3, $4);
  } else {
	  local(@x) = gethostbyname($server);
	  return undef unless @x;
	  $serveraddr = $x[4];
	  printf( "server=$server,serveraddr=%x\n", $serveraddr) if $Debug;
  }

  $serverproc = pack($sockaddr, 2, $port, $serveraddr);
  print STDERR "\$serverproc = pack($sockaddr, 2, $port, ",
    join(".", unpack("C*", $serveraddr)), ");\n" if $Debug;

  unless (socket( $new_handle, 2, 1, 6)) {
    unless (socket( $new_handle, 2, 2, 6)) {
	  # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
	  # but who the heck would change these anyway? (:-)
	  ($!) = ($!, close( $new_handle)); # close new_handle while saving $!
	  #die "socket failed";
	  print STDERR "Socket error $!\n" if $Debug;
	  return undef;
    }
  }
  unless (bind( $new_handle, $thisproc)) {
	  ($!) = ($!, close( $new_handle)); # close new_handle while saving $!
	  #die "bind failed";
	  print STDERR "bind error $!\n" if $Debug;
	  return undef;
  }

  %saveSIG=%SIG;
  if ( $timeout )
  {
    $SIG{ALRM} = "timedout";
    alarm($timeout);
  }
  eval { $ret = connect( $new_handle, $serverproc) };

  if ( !$ret || ($@ =~ /^timedout/) ) {
	  ($!) = ($!, close( $new_handle)); # close new_handle while saving $!
	  #die "connect failed, $!";
	  print STDERR "connect error eval=($@)$!\n" if $Debug;
	  if ( $@ =~ /^timedout/ ) {
	    $! .= ", timeout after $timeout seconds";}
	  return undef;
  }

  if ( $timeout )
  {
    %SIG = %saveSIG;
    alarm(0);
  }

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

  return $new_handle;
}

sub timedout {
  die "timedout";
}

sub open_listen{
  local( $port ) = @_;

  ( $thisproc_local ) = pack( $sockaddr, 2, $port, $thisaddr );
  #print "( $thisproc_local ) = pack( $sockaddr, 2, $port, $thisaddr );\n";

  $new_handle = ++$next_handle;

  unless (socket( $new_handle, 2, 1, 6)) {
    unless (socket( $new_handle, 2, 2, 6)) {
	  # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
	  # but who the heck would change these anyway? ( :- )
	  #die "socket failed: $!";
	  print STDERR "socket failed: $!\n" if $Debug;
	  ($!) = ($!, close($new_handle)); # close S while saving $!
	  return undef;
    }
  }

  # We want it it release the socket for immediate reuse if the server is
  # shutdown/restarted.  It seems that SO_LINGER and SO_REUSEADDR are most
  # pertinant, but SO_KEEPALIVE seems like it might be nice too, for
  # notification of peer disappearance.
  $linger = pack("II", 0, 0 );	# linger is a C struct in socket.h
  setsockopt( $new_handle, $SOL_SOCKET, $SO_LINGER, $linger);
  setsockopt( $new_handle, $SOL_SOCKET, $SO_KEEPALIVE, 1);
  setsockopt( $new_handle, $SOL_SOCKET, $SO_REUSEADDR, 1);

  unless ( bind( $new_handle, $thisproc_local )) {
	  #die "bind failed: $!";
	  print STDERR "bind failed: $!\n" if $Debug;
	  ($!) = ($!, close($new_handle)); # close S while saving $!
	  return undef;
  }
  unless ( listen( $new_handle, 1 )) {
	  #die "listen failed: $!";
	  print STDERR  "listen failed: $!\n" if $Debug;
	  ($!) = ($!, close($new_handle)); # close S while saving $!
	  return undef;
  }

  select( (select( $new_handle ), $| = 1 )[0] ); 
  local( $family, $port, @myaddr ) = unpack( "S n C C C C x8", 
		getsockname( $new_handle ));

  #print " local( family, port, myaddr ) = local( $family, $port, @myaddr) \n"; 
  return  $new_handle; 
}

sub accept_it{ local( $handle ) = @_; local( $addr, $af, $port,
  $inetaddr, $acceptaddr ) = ();

  $new_handle = ++$next_handle;

  unless( ( $addr = accept( $new_handle, $handle ) ) ) {
	  print STDERR "accept failed: $!";
  }

  ( $af, $port, $inetaddr ) = unpack( $sockaddr, $addr );
  @inetaddr = unpack( 'C4', $inetaddr );
  #print "accept: $af $port @inetaddr(", join('.', @inetaddr), ")\n";

  #print "host=", gethostbyaddr( join('.', @inetaddr), 2 ), "\n";
  #print "host=", gethostbyaddr( join(' ', @inetaddr), 2 ), "\n";
  ($name, $aliases, $type, $len, $acceptaddr) =
	gethostbyaddr( pack( 'C4', @inetaddr ), 2 );
  #print "accept: host=$name, port=$port\n";

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

  $name = join(".", @inetaddr ) unless $name;
  return $new_handle,$name;
}

sub select_it { 
  local( $timeout, @handles ) = @_;

  local( @ready ) = ( );
  local( $rout, $rmask, $handle, $eout, $emask );

  for $handle ( @handles ) {
    vec( $rmask, fileno( $handle ), 1 ) = 1;
    vec( $emask, fileno( $handle ), 1 ) = 1;
  }
  ( $nfound, $timeleft ) = select( $rout=$rmask, undef, $eout=$emask, $timeout );

  print "nfound=$nfound\n" if $DEBUG;
  if ( $nfound < 1 ){
    if ( $nfound < 0 ){
      print "error=$!\n" if $DEBUG; }
    return @ready;
  }

  # You could also do:
  #   @bit = split(//,unpack('b*',$rout));
  #   if ($bit[fileno(STDIN)] == 1){ ... };

  for $handle ( @handles ) { 
    if ( vec( $rout, fileno( $handle ), 1 ) == 1 ) {
      print "fh=$handle is ready\n" if $DEBUG;
      push( @ready, $handle ); }
    if ( vec( $eout, fileno( $handle ), 1 ) == 1 ) {
      print "Exception on read_handle=$handle\n" if $DEBUG; }
  }

  return @ready;
}

1;

## $handle = &chat'open_proc("command","arg1","arg2",...);
## opens a /bin/sh on a pseudo-tty

sub open_proc { ## public
	local(@cmd) = @_;

	#local(*TTY,*PTY);	# PTY must not die when sub returns
	local( $pty_handle, $tty_handle );

	$pty_handle = "proc" . ++$next_handle;
	*PTY = $pty_handle;
	$tty_handle = "proc" . ++$next_handle;
	*TTY = $tty_handle;

	local($pty,$tty) = &_getpty(PTY,TTY);

	die "Cannot find a new pty" unless defined $pty;
	local($pid) = fork;
	die "Cannot fork: $!" unless defined $pid;
	unless ($pid) {
		close STDIN; close STDOUT; close STDERR;
		if ( $OS_type eq "SVR4" ){
		  syscall(39,3); #* setsid():: syscall(39,3)
		}else{
		  #syscall(175);#setsid , doesn't seem to work well
		  setpgrp(0,$$); 
		  # this ioctl is necessary for "isig" to work right,
		  # and otherwise "csh" freaks out and hangs:
		  if (open(DEVTTY, "/dev/tty")) {
		      ioctl(DEVTTY,0x20007471,0);	# XXX s/b &TIOCNOTTY
		      close DEVTTY;
		  }
		}
		open(STDIN,"<$tty");
		#open(STDIN,"<&TTY");	# fails to assign controlling tty!
		if ( $OS_type eq "BSD" ){
		  # doesn't seem to be necessary if open by filename
		  #TIOCSCTTY,d(536900740)0x(20007484)
		  #syscall(54, fileno(STDIN), 0x20007484,  1 );
		}

		open(STDOUT,">$tty");
		open(STDERR,">&STDOUT");
		die "Oops" unless fileno(STDERR) == 2;	# sanity
		close(PTY) || print "error closing master handle:$!\n";

		exec @cmd;
		die "Cannot exec @cmd: $!";
	}
	#close(TTY);
	return ($pty_handle,$tty_handle,$pid); # return symbol for switcharound

}

sub _getpty { ## private
	local($_PTY,$_TTY)=@_;
	local($pty,$tty);
	$_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
	$_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
	for $bank (112..127) {
		next unless -e sprintf("/dev/pty%c0", $bank);
		for $unit (48..57) {
			$pty = sprintf("/dev/pty%c%c", $bank, $unit);
			open($_PTY,"+>$pty") || next;
			select((select($_PTY), $| = 1)[0]);
			($tty = $pty) =~ s/pty/tty/;
			# some stupid magic says I can't use a variable
			# name in the open for a TTY open
			open($_TTY,"+>$tty") || next;
			select((select($_TTY), $| = 1)[0]);
			if ( $OS_type eq "SVR4" )
			{
			  local( $pop ) = pack( "p", $pop );
			  syscall($SYS_ioctl, fileno($_TTY), $I_POP, 0 );
			  syscall($SYS_ioctl, fileno($_TTY), $I_POP, 0 );
			  #syscall($SYS_ioctl, fileno($_TTY), $I_LOOK, $pop );
			  #print "looked: len=", length($pop),"($pop)\n";
			  #$pop = pack( "p", $pop );
			  #syscall($SYS_ioctl, fileno($_TTY), $I_LOOK, $pop );
			  #print "looked: len=", length($pop),"($pop)\n";

			  local($tmp);
			  # $tmp needed because Solaris2.4,2.5 complains:
			  # Modification of a read-only value attempted at 
			  # comm_utils.pl line  ...
			  # if you use a string literal instead
			  syscall($SYS_ioctl, fileno($_TTY), $I_PUSH, $tmp="ptem" );
			  syscall($SYS_ioctl, fileno($_TTY), $I_PUSH, $tmp="ldterm");
			}
			system "stty nl>$tty <$tty";
			return ($pty,$tty);
		}
	}
	undef;
}

sub gets{
  local(*FH)=shift;
  scalar(<FH>);
}

sub sysread{
  local(*FH)=shift;
  sysread(FH, $_[0], $_[1]);
}

sub ioctl{
  local($fh)=shift;
  syscall( 54, fileno($fh), @_ ) == 0;
}

sub print{
  local($fh)=shift;
  local($ret)= print $fh @_;
  unless ( $ret ){
    print STDERR "Error printing to fh($fh),$!\n"; }
  return $ret;
}

# This is useful when there a parent and child share the file descriptor,
# because the shutdown affects both.
sub close_noshutdown{
  for (@_){
    next unless $_;
    close( $_ );
  }
}

sub close{
  for (@_){
    next unless $_;
    unless ( /^proc/ ){
      print STDERR "Doing shutdown on $_\n" if $DEBUG;
      shutdown($_,2) ;	# must happen before close
    }
    #print "comm'close: $_\n";
    #local( *fh ) = $_;	# some god-aweful magic
    #close( $fh );	# some god-aweful magic
    close( $_ );
  }
}

# This is so you can run commands in the pty process without routing
# through the shell, which is ugly

sub system{
  local( $handle, @args ) = @_;
  unless ( fork() ){
    close(STDIN);close(STDOUT);
    open(STDIN,"<&$handle" );
    open(STDOUT,">&$handle" );
    exec ( @args );
    exit;
  }
}

sub stty_sane{
  local( $handle ) = @_;
  local( $packed ) = ();
  #&dump_ioctl( "stty sane erase '^H' " );
  if ( $OS_type eq "SVR4" ){
    $packed = pack("C*", 37,38,0,5,5,173,138,59,0,3,28,8,21,4 );
    ioctl( $handle, $TCSETA, $packed);
  }else{
    $packed = pack("C*", 15,15,8,21,0,216 );
    #$packed = &get_ioctl_from_stty( "stty sane erase '^H' " );
    ioctl( $handle, $TIOCSETP, $packed);
  }
}

sub stty_raw{
  local( $handle ) = @_;
  local( $packed ) = ();
  #&dump_ioctl( "stty raw -echo -icanon eol '^a'" );
  if ( $OS_type eq "SVR4" ){
    $packed = pack("C*", 0,0,0,4,4,189,138,48,0,3,28,8,21,1,1,0,0,22 );
    ioctl( $handle, $TCSETA, $packed);
  }else{
    $packed = pack("C*", 15,15,8,21,0,240 );
    #$packed = &get_ioctl_from_stty( "stty raw -echo -icanon eol '^a'" );
    ioctl( $handle, $TIOCSETP, $packed);
  }
}

sub get_ioctl_from_stty{
  local( $stty_cmd ) = @_;
  local( $ioctl_struct, $get_cmd, $set_cmd, $out, $ret ) = ();

  #print $stty_cmd,"\n";
  system $stty_cmd;

  # These only return 4 bytes.  Why?
  # $p = pack("p", $ioctl_struct );
  #$ret = syscall($SYS_ioctl, fileno(STDIN), $TIOCGETP, $p);
  #$ret = syscall($SYS_ioctl, fileno(STDIN), $TCGETA, $p);

  if ( $OS_type eq "SVR4" ){
    $get_cmd = $TCGETA;
  }else{
    $get_cmd = $TIOCGETP;
  }

  $!=0;
  $ret = ioctl(STDIN, $get_cmd, $ioctl_struct );

  return $ioctl_struct;
  #return ( $ioctl_struct, $ret );	# blows up $ioctl_struct on the stack
}

sub dump_ioctl{
  local( $stty_cmd ) = @_;
  local( $ioctl_struct, $c, $out ) = ();

  $ioctl_struct = &get_ioctl_from_stty( $stty_cmd );
  for $c ( unpack("C*", $ioctl_struct) ){
    #$out .= sprintf("0x%2.2x,", $c );
    $out .= sprintf("%d,", $c );
  }
  print "$stty_cmd = $out \n";
  # I don't know off hand how much of the returned buffer is actually
  # significant; certainly less than the full 256 bytes.
  return $ioctl_struct;
}

1;

__END__

#--------------------------------Example server---------------------------------
#
# Allows multiple client connections, and rebroadcasts data between them.

eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
& eval 'exec perl -S $0 $argv:q'
if 0;

require "comm_utils.pl" unless defined &comm'init;

$Listen_port = 5050;
$Listen_port = $ARGV[0] if $ARGV[0];  

$SIG{'HUP'} = "my_exit";
$SIG{'INT'} = "my_exit";
$SIG{'QUIT'} = "my_exit";

$DEBUG = 1;
$|=1;

&comm'init;

if(1)
{
  $Listen_handle = &comm'open_listen( $Listen_port );
  die "open_listen failed on port $Listen_port" unless $Listen_handle;
}
else
{
  # This is optional; it can be useful to use a range of ports
  # if your sockets don't always release a port right away when you kill
  # a process.  However, the "setsockopt()" calls should release the ports
  # for you, so this should no longer be necessary.
  $start_port = $Listen_port;
  {
    if ( ! ( $Listen_handle = &comm'open_listen( $Listen_port ) ) )
    {
      redo unless ( ++$Listen_port <= $start_port + 10 );
      die "open_listen failed on port $Listen_port";
    }
  }
}

print "Listening on port $Listen_port\n" if $DEBUG;

while (1)
{
  @ready_handles = &comm'select_it(1, keys(%Client_handles), $Listen_handle );
  print "Handles ready: @ready_handles\n" if $DEBUG && @ready_handles;
  
  foreach $handle (@ready_handles)
  {  
    if ($handle eq $Listen_handle)
    { 
      ($new_handle, $rem_host) = &comm'accept_it($handle);
      $Client_handles{$new_handle} = $rem_host;
      print "New connection from $rem_host\n" if $DEBUG;
    }
    else
    {
      #print &comm'gets($handle);	# if new-line oriented
      if ( &comm'sysread($handle, $buf, 10000) )
      {
        $buf = $Client_handles{$handle} . ": $buf";
	$buf =~ s/[\n]*$/\n/;
        print $buf;
	# rebroadcast data to all clients:
	for $client_handle ( keys %Client_handles ) {
	  &comm'print( $client_handle, $buf ); }
      }
      else
      {
	print "Closing handle $handle, host $rem_host\n";
        &comm'close( $handle );
        delete $Client_handles{ $handle };
      }
    }
  }
}

sub my_exit 
{
  &comm'close( $Listen_handle );
  print "Closing listen port\n" if $DEBUG;
  exit;
}

#--------------------------------Example client---------------------------------

# Connect to a server, and send STDIN data to it.
# Usage:  tstclient <host> <port>

eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}'
& eval 'exec perl -S $0 $argv:q'
if 0;

require "comm_utils.pl" unless defined &comm'init;

$Server_port = 5050;
$Server_host = "serverhost.domain";

( $Server_host, $Server_port ) = @ARGV if @ARGV;

$SIG{'HUP'} = "my_exit";
$SIG{'INT'} = "my_exit";
$SIG{'QUIT'} = "my_exit";

$|=1;
$DEBUG = 1;

&comm'init;

if ( ! ( $Server_handle = &comm'open_port($Server_host, $Server_port, 5) ) )
{
  die "open_port failed on host $Server_host, port $Server_port";
}

print "Connected to host $Server_host, port $Server_port\n" if $DEBUG;

while (1)
{
  @ready_handles = &comm'select_it(1, $Server_handle, STDIN);
  
  foreach $handle (@ready_handles)
  {  
    if ($handle eq "STDIN")
    {
      $buf = <STDIN>;
      &comm'print( $Server_handle, $buf );
    }
    else	# server
    {
      unless ( &comm'sysread($handle, $buf, 1000) )
      {
        print "Server connection broken\n";
        &my_exit;
      }
      print $buf;
    }
  }
}

sub my_exit 
{
  &comm'close($HANDLE);
  exit;
}