spssig.spss.com!news.oc.com!lgc.com!cs.utexas.edu!zaphod.mps.ohio-state.edu!uwm.edu!linac!att!mcdchg!ftpbox!cssmp.corp.mot.com!mmuegel Mon Mar  1 16:51:04 CST 1993
Article: 1268 of comp.lang.perl
Xref: feenix.metronet.com comp.lang.perl:1268
Newsgroups: comp.lang.perl
Path: feenix.metronet.com!spssig.spss.com!news.oc.com!lgc.com!cs.utexas.edu!zaphod.mps.ohio-state.edu!uwm.edu!linac!att!mcdchg!ftpbox!cssmp.corp.mot.com!mmuegel
From: mmuegel@cssmp.corp.mot.com (Michael S. Muegel)
#Subject: Re: Socket <> Stdin/Stdout
Message-ID: <1993Feb27.065828.26470@ftpbox.mot.com>
Sender: news@ftpbox.mot.com (C News)
Organization: Corporate Information Office, Schaumburg, Illinois, Motorola, Inc.
References: <1993Feb26.224803.3189@bcrka451.bnr.ca>
Date: Sat, 27 Feb 1993 06:58:28 GMT
Lines: 1110

Previously, mds@.bnr.ca (Marty Sells) wrote:
> What I'd like to do is to proved a socket interface for other computers to connect
> to to allow exec/system type calls. That's do-able but is they a way I can also
> get the exec/system to use the socket for stdin/stdout ? For example I want to
> (I know grep is built in - it's only an example) do a:
>  
> exec (/bin/grep 'foo' < socket_in > socket_out);

When you are doing socket stuff in Perl you read and write from/to the
socket using the stanard Perl print and <> functions. 

> Also - could someone send me the missing examples from the perl socket code
> that someone posted. A pointer to a good perl ftp site with some socket stuff
> would also be appriciated.

I posted two TCP packages but quickly cancelled them because I later thought
they were not appropriate for the poster's question. I will post them here
anyway because people may find them useful. The first package, easy_tcp.pl,
is similar to another package that was recently posted. It provides two
nice functions to set up a socket connection for a client or server. It was
done by an intern. I just added documentation and made it more generic.

The second package, tcp_support.pl, I wrote to help when creating command-
oriented TCP clients and servers. That is, something like SMTP or NNTP
where you use human readable commands. It is really handy because it
does most of the hard work for you.

Please feel free to comment on either. This is the first stuff I have
done with Berkeley sockets under Perl. Even then, I just touched on
sockets in C many years ago. I think both packages provide nice, general
purpose interfaces to be used when creating TCP clients and servers.
Some of the functionality may overlap chat2.pl a little.

Finally, many examples are included for both packages. I forgot to
include those in my cancelled post anyway.

-Mike

---- Cut Here and feed the following to sh ----
#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 02/27/1993 06:59 UTC by mmuegel@mot.com (Michael S. Muegel)
# Source directory /home/ustart/NeXT/src/perl-stuff/libs
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   8293 -r--r--r-- local/easy_tcp.pl
#  11671 -r--r--r-- local/tcp_support.pl
#   1164 -r-xr-xr-x tests/easy_tcp1.pl
#   1526 -r-xr-xr-x tests/easy_tcp2.pl
#   2574 -r-xr-xr-x tests/tcp_support1.pl
#   2257 -r-xr-xr-x tests/tcp_support2.pl
#
# ============= local/easy_tcp.pl ==============
if test ! -d 'local'; then
    echo 'x - creating directory local'
    mkdir 'local'
fi
if test -f 'local/easy_tcp.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping local/easy_tcp.pl (File already exists)'
else
echo 'x - extracting local/easy_tcp.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'local/easy_tcp.pl' &&
X
# NAME
#    easy_tcp.pl - easy to use TCP package
#
# DESCRIPTION
#    Easy to use routines to set up a socket connection for a client (mk_user)
#    and server (mk_server). Get_Connection_Info will return information
#    about the other end of a socket connection.
#
#    See the test programs easy_tcp1.pl and easy_tcp2.pl in the 
#    test area (/usr/local/ustart/src/perl-stuff/libs/tests) for examples
#    of how to use these programs.
#
# NOTES
#    If you are interested in how this code works get a copy of Wally Mann's
#    easy_tcp.c.  This code is based on that.
#
# AUTHOR
#    John Newlin <jnewlin@fwrdc.rtsg.mot.com>
#
#    More flexible argument syntax, better error checking, extra functions,
#    and documentation by Michael S. Muegel <mmuegel@mot.com>
#    
# RCS INFORMATION
#    $Source: /usr/local/ustart/src/perl-stuff/libs/local/RCS/easy_tcp.pl,v $
#    $Revision: 1.7 $ of $Date: 1993/02/27 06:55:14 $
X
package easy_tcp;
X
# socket.ph is converted with h2ph from /usr/include/sys/socket.h
require 'sys/socket.ph';  
X
# This matches an IP address and sets $1 to it
$IP_EXPR = '^\s*((\d+\.){3}\d+)\s*$';
X
# This matches a port number and sets $1 to it
$PORT_EXPR = '^\s*(\d+)\s*$';
X
# Protocol of choice
$PROTOCOL = 'tcp';
X
# The pack/unpack template for the sockaddr structure
$SOCKADDR_TEMPLATE = 'S n a4 x8';
X
# The maximum length  the  queue of pending connections may grow to for
# the server listen()
$LISTEN_QUEUE = 5;
X
###############################################################################
# mk_user
#
# Opens a connection to a $Server host on port $Port. $Server can be
# either a hostname or an IP address. $Port can be either a service
# name or port number. Finally, $Socket_Handle should be the name of the
# file handle to which the connection should be bound to.
#
# If everything went AOK $Status is 1; otherwise, $Status is 0 and $Msg will
# be a text message of what went wrong.
#
# Arguments:
#   $Server, $Port, $Socket_Handle
#
# Returns:
#    $Status, $Msg
###############################################################################
sub main'mk_user 
{
X  
X  local ($Server, $Port, $Socket_Handle) = @_;
X
X  # Make sure $Socket_Handle is in the right package
X  ($Package) = caller;
X  $Socket_Handle = "$Package'$Socket_Handle" if ($Socket_Handle !~ /'/);
X
X  # Get raw address info for the host. Do it differently depending on whether
X  # $Server is a hostname or IP address.
X  if ($Server =~ /$IP_EXPR/)
X  {
X     $Server_Addr = pack ('C4', split (/\./, $1));
X  }
X  else
X  {
X     $Server_Addr = (gethostbyname ($Server))[4];
X     return (0, "no such host $Server") if (! length ($Server_Addr));
X  };
X
X  # Get the protocol number for TCP
X  $TCP_Protocol_Num = (getprotobyname ($PROTOCOL))[2];
X  return (0, "no such protocol $PROTOCOL") if ($TCP_Protocol_Num eq "");
X
X  # Convert service to port number if necessary
X  ($Status, $Msg, $Port) = &Service_Or_Port_To_Port ($Port);
X  return (0, $Msg) if (! $Status);
X
X  # Create the socket name structures for use with bind and connect
X  $My_Name = pack ($SOCKADDR_TEMPLATE, &AF_INET, 0, "\0\0\0\0");
X  $Server_Name = pack ($SOCKADDR_TEMPLATE, &AF_INET, $Port, $Server_Addr);
X
X  # Create the socket and bind to it
X  return (0, $!) 
X     if (! socket ($Socket_Handle, &AF_INET, &SOCK_STREAM, $TCP_Protocol_Num));
X  return (0, $!) if (! bind ($Socket_Handle, $My_Name)); 
X
X  # Call up server
X  return (0, $!) if (! connect ($Socket_Handle, $Server_Name));
X
X  # Set socket to be line buffered
X  $Present_Handle = select ($Socket_Handle);  
X  $| = 1;   
X  select ($Present_Handle);
X
X  return (1);
};
X
X
###############################################################################
# mk_server
#
# Listens on $Port for a connection and returns when a connection suceeds.
# $Port can be either a service name or port number. Finally, $Socket_Handle 
# should be the name of the file handle to which the connection should be 
# bound to.
#
# The parent process always hangs around looking for connections. It forks
# off a child for each connection. This child is what returns. So you
# just call mk_server once. See the example program easy_tcp2.pl for
# hints.
#
# If everything went AOK $Status is 1; otherwise, $Status is 0 and $Msg will
# be a text message of what went wrong. $Connection_Num starts at 1 and is 
# increaed for each connection.
#
# Arguments:
#   $Server, $Port, $Socket_Handle
#
# Returns:
#    $Status, $Msg, $Connection_Num
###############################################################################
sub main'mk_server 
{
X  local ($Port, $Socket_Handle) = @_;
X  local ($Status, $Msg, $My_Name, $TCP_Protocol_Num, $Present_Handle,
X	 $Child_Pid, $Connection_Num);
X
X  # Make sure $Socket_Handle is in the right package
X  local ($Package) = caller;
X  $Socket_Handle = "$Package'$Socket_Handle" if ($Socket_Handle !~ /'/);
X
X  # Convert service to port number if necessary
X  ($Status, $Msg, $Port) = &Service_Or_Port_To_Port ($Port);
X  return (0, $Msg) if (! $Status);
X
X  # Create the socket name structures for use with bind and connect
X  $My_Name = pack ($SOCKADDR_TEMPLATE, &AF_INET, $Port, "\0\0\0\0");
X
X  # Get the protocol number for TCP
X  $TCP_Protocol_Num = (getprotobyname ($PROTOCOL))[2];
X  return (0, "no such protocol $PROTOCOL") if ($TCP_Protocol_Num eq "");
X
X  # Crteate the temp socket, bind to it, and listen for connections
X  socket (LISTEN_SOCKET, &AF_INET, &SOCK_STREAM, $TCP_Protocol_Num) || return (0, $!);
X  bind (LISTEN_SOCKET, $My_Name) || return (0, $!);
X  listen (LISTEN_SOCKET, $LISTEN_QUEUE);
X
X  # Set temp socket to be line buffered
X  $Present_Handle = select (LISTEN_SOCKET);  
X  $| = 1;   
X  select ($Present_Handle);
X
X  while (1)
X  {
X    accept ($Socket_Handle, LISTEN_SOCKET) || return (0, $!);
X    ++$Connection_Num;
X
X    FORK:
X    {
X       # Parent continues to look for connections
X       if ($Child_Pid = fork)
X       {
X          close ($Socket_Handle);
X       }
X
X       # Child handles this connection
X       elsif (defined ($Child_Pid))
X       {
X          # Set socket to be line buffered
X          $Present_Handle = select ($Socket_Handle);  
X          $| = 1;   
X          select ($Present_Handle);
X          return (1, "", $Connection_Num);
X       }
X   
X       # Out of processes
X       elsif ($! =~ /No more process/)
X       {
X          sleep 5;
X          redo FORK;
X       }
X   
X       else
X       {
X          return (0, "can not fork: $!");
X       };
X     };
X  };
};
X
X
;###############################################################################
;# Get_Connection_Info
;#
;# Returns the $Port and $Host that is at the other end of $Socket_Handle.
;# $Host will be a hostname if the IP address maps into a hostname. $Port
;# will always be a number since it will be an ephemeral port number.
;#
;# Arguments:
;#    $Socket_Handle
;#
;# Returns:
;#    $Port, $Host
;###############################################################################
sub main'Get_Connection_Info
{
X   local ($Socket_Handle) = @_;
X   local ($Port, $Host, $Host_Addr);
X
X   # Make sure $Socket_Handle is in the right package
X   local ($Package) = caller;
X   $Socket_Handle = "$Package'$Socket_Handle" if ($Socket_Handle !~ /'/);
X
X   # Get port and addr info
X   ($Port, $Host_Addr) = 
X      (unpack ($SOCKADDR_TEMPLATE, getpeername ($Socket_Handle)))[1,2];
X
X   # Convert addr info to host name if possible
X   return ($Port, $Host) if ($Host = (gethostbyaddr ($Host_Addr, &AF_INET))[0]);
X
X   # Or just return addr info as IP address
X   $Host = join (".", unpack ('C4', $Host_Addr));
X   return ($Port, $Host);
};
X
X
;###############################################################################
;# Service_Or_Port_To_Port
;#
;# Converts $Port to a number if necessary. Returns a bad $Status and sets
;# $Msg on error.
;#
;# Arguments:
;#    $Service
;#
;# Returns:
;#    $Status, $Msg, $Port
;###############################################################################
sub Service_Or_Port_To_Port
{
X   local ($Port) = @_;
X   local ($Service);
X
X   # If the port is a service name look it up
X   if ($Port =~ /$PORT_EXPR/)
X   {
X      return (1, "", $1);
X   }
X   else
X   {
X      $Service = $Port;
X      $Port = (getservbyname ($Service, $PROTOCOL))[2];
X      return (0, "no such service $Service") if (! $Port);
X      return (1, "", $Port);
X   };
X
};
X
1;
SHAR_EOF
chmod 0444 local/easy_tcp.pl ||
echo 'restore of local/easy_tcp.pl failed'
Wc_c="`wc -c < 'local/easy_tcp.pl'`"
test 8293 -eq "$Wc_c" ||
	echo 'local/easy_tcp.pl: original size 8293, current size' "$Wc_c"
fi
# ============= local/tcp_support.pl ==============
if test -f 'local/tcp_support.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping local/tcp_support.pl (File already exists)'
else
echo 'x - extracting local/tcp_support.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'local/tcp_support.pl' &&
;# NAME
;#    tcp_support.pl - support functions for a TCP command-based client/server
;#
;# DESCRIPTION
;#    Command_Parse can be used to build a command parser for a TCP server.
;#    Code_Print is used to send output to the client from the server.
;#    Code_Parse is used to parse input from a server in a client.
;#
;#    The test program for the package shows in greater detail the calling
;#    semantics of these functions. It should have been distributed with
;#    this package. At the author's system it is in /usr/local/ustart/src/
;#    perl-stuff/libs/tests/tcp_support.pl.
;#
;# AUTHOR
;#    Michael S. Muegel <mmuegel@mot.com>
;#
;# RCS INFORMATION
;#    $Author: mmuegel $
;#    $Source: /usr/local/ustart/src/perl-stuff/libs/local/RCS/tcp_support.pl,v $
;#    $Revision: 1.3 $ of $Date: 1993/02/27 06:48:18 $
X
package tcp_support;
X
;###############################################################################
;# Command_Parse
;#
;# Used to parse for commands passed to a TCP server. When a command is
;# sucessfully entered the function will return; otherwise, and error message
;# will be printed. Commands are case-InSeNsItIvE.
;#
;# $Socket_Handle should contain the actual name of the handle for the
;# previously opened socket (maybe via easy_tcp.pl :-). If you do not supply
;# a package qualifier the main package is assumed.
;#
;# %Command_To_One_Liner maps the command to a short, one line description
;# of the command. This is required for each command you support. This
;# short description is printed in the server help. %Command_To_Help
;# should provide more detailed help on the command. The text may have 
;# multiple newlines in it. If help is not available for a command
;# (because you did not create an element for a command) a message
;# to that effect is printed when the user asks for help on the command.
;# 
;# Thus help is available both for the server and a command. Example:
;#
;#    HELP
;#    HELP FOO
;#
;# Both help types are recognized and automatically serviced. Since you 
;# might want to add something to the generic server help information you 
;# can include $Extra_Help. This will be displayed after the list of commands.
;# You might include information on the author of the server or the like
;# via this text.
;#
;# Similiar to the FTP and SMTP protocols, this function enforces a reply
;# code structure to its output. This ensures the server's output can
;# be easily parsed. The only codes this function will output on its own
;# are a code for information, bad command, and bad help usage. Specify these
;# reply codes via $Info_Code, $Command_Syntax_Code, and $Help_Syntax_Code,
;# respectfully. See the function header to Code_Print for a description of 
;# reply code quoting and the $Wrap_All argument to this function. No need 
;# to quote the help text yourself as Code_Print will take care of it for you.
;# 
;# Once a valid command is entered (non-HELP) the command is returned in
;# $Command and a $Status of -1 is set. If anything else (whitespace eaten 
;# up) was left over on the line it is returned in $Left_Over.
;#
;# Returns a $Status of -1 if $Socket_Handle returns EOF (the client
;# probably hung up). If something else went wrong $Status is 0 and 
;# $Msg tells what went wrong.
;#
;# Arguments:
;#    $Socket_Handle, $Info_Code, $Command_Syntax_Code, $Help_Syntax_Code,
;#    $Extra_Help, *Command_To_One_Liner, *Command_To_Help, $Wrap_All
;#
;# Returns:
;#    $Status, $Msg, $Command, $Left_Over
;###############################################################################
sub main'Command_Parse
{
X   local ($Socket_Handle, $Info_Code, $Command_Syntax_Code, $Help_Syntax_Code,
X      $Extra_Help, *Command_To_One_Liner, *Command_To_Help, $Wrap_All) = @_;
X   local ($Command, $*);
X
X   # Multi-line matching
X   $* = 1;
X
X   # Fix up socket handle 
X   $Socket_Handle = "main'$Socket_Handle" if ($Socket_Handle !~ /^\S+'/);
X
X   # For speed we only want do startup stuff once for each *new* socket
X   if (! $Socket_Status {$Socket_Handle})
X   {
X      $Socket_Status {$Socket_Handle} = 1;
X
X      # Check out some args
X      return (0, "info code \"$Info_Code\" is non-numeric") 
X         if ($Info_Code !~ /^\d+$/);
X      return (0, "syntax error code \"$Command_Syntax_Code\" is non-numeric") 
X         if ($Command_Syntax_Code !~ /^\d+$/);
X   
X      # Preparse the commands to:
X      #    - Convert all commands to upper case 
X      #    - Get info for server help text
X      #    - Set up default command help text
X      #    - Build a list of the sorted commands in @Commands
X      $Help = "Commands\n\n";
X      $Command_To_One_Liner {"HELP"} = "get help on the server or a command";
X
X      foreach $Command (sort (keys (%Command_To_One_Liner)))
X      {
X         # Index via UPPER case command name
X         $One_Liner = $Command_To_One_Liner {$Command};
X         delete $Command_To_One_Liner {$Command};
X         $Command =~ tr/a-z/A-Z/;
X         $Command_To_One_Liner {$Command} = $One_Liner;
X   
X         # Set default command help text
X         $Command_To_Help {$Command} = "No help available" 
X	    if ($Command_To_Help {$Command} eq "");
X         # Help text info
X         push (@Commands, $Command);
X         $Max_Command_Length = length ($Command) 
X	    if (length ($Command) > $Max_Command_Length);
X      };
X
X      # Add to server help text
X      foreach $Command (@Commands)
X      {
X         $Help .= sprintf ("   %-${Max_Command_Length}s   %s\n", 
X	    $Command, $Command_To_One_Liner {$Command});
X      };
X      $Help .= "\nFor more information use \"HELP <topic>\"\n";
X      $Help .= $Extra_Help;
X   };
X
X   # Once we find a valid non-HELP command return
X   while (<$Socket_Handle>)
X   {
X      # Delete leading and trailing whitespace
X      s/^\s+//;
X      s/\s+$//;
X
X      # Server help?
X      if (/^HELP$/i)
X      {
X	 &main'Code_Print ($Socket_Handle, $Help, $Info_Code, $Wrap_All);
X      }
X
X      # Command help?
X      elsif (/^HELP\s+(\S+)$/i)
X      {
X	 ($Topic = $1) =~ tr/a-z/A-Z/;
X	 if ($Command_To_Help {$Topic} eq "")
X	 {
X	    &main'Code_Print ($Socket_Handle, "HELP topic \"$Topic\" unknown",
X	       $Help_Syntax_Code, $Wrap_All);
X	 }
X	 else
X	 {
X	    &main'Code_Print ($Socket_Handle, $Command_To_Help {$Topic}, 
X	       $Info_Code, $Wrap_All);
X	 };
X      }
X
X      # Command?
X      else
X      {
X	 foreach $Command (@Commands)
X	 {
X	    if (/^($Command)\s*/i)
X	    {
X               $Command =~ tr/a-z/A-Z/;
X	       return (1, "", $Command, $');
X	    };
X	 };
X	 &main'Code_Print ($Socket_Handle, "Command unrecognized", $Command_Syntax_Code);
X      };
X   };
X
X   # EOF on socket if we get here
X   $Socket_Status {$Socket_Handle} = 0;
X   return (-1);
};
X
X
;###############################################################################
;# Code_Print
;#
;# Prints out $Buffer with $Reply_Code to $Socket_Handle wrapped as 
;# appropriately for reply code look-and-feel ala FTP or SMTP. That is, each
;# line in $Buffer is prepended by $Reply_Code. 
;#
;# If $Buffer just contains one line the line is prepended by the reply code
;# and a single space.
;#
;# Multi-line text in $Buffer can be handled one of two ways. If $Wrap_All
;# is 1 then each line except the last line is prepended by the reply code 
;# plus a dash (-). The last line is simply prepended by the reply code and
;# a space.
;#
;# If $Wrap_All is 0 then all text except the first and last is simply sent 
;# as is. The first and last obey the rules outlined above. If the reply code
;# appears as the first thing on a line in the middle text it is escaped
;# with a space.
;#
;# The last line in $Buffer need not contain a newline. So sending "Foo" and
;# "Foo\n" or "Foo\nFum" and "Foo\nFum\n" yields the same output.
;#
;# $Socket_Handle should contain the actual name of the handle for the
;# previously opened socket (maybe via easy_tcp.pl :-). If you do not supply
;# a package qualifier the main package is assumed.
;#
;# Examples:
;#    &Code_Print ("SOCKET", "Foo", 220) -> 
;#       220 Foo
;#
;#    &Code_Print ("SOCKET", "Line 1\nLine 2\nLine 3\n", 214, 1) ->
;#       214-Line 1
;#       214-Line 2
;#       214 Line 3
;#
;#    &Code_Print ("SOCKET", "Line 1\nLine 2\n220 Line 3\nLine 4\n", 220, 0) ->
;#       220-Line 1
;#       Line 2
;#        220 Line 3
;#       220 Line 4
;#
;# Arguments:
;#    $Socket_Handle, $Buffer, $Reply_Code, $Wrap_All
;#
;# Returns:
;#    Nothing exciting
;###############################################################################
sub main'Code_Print
{
X   local ($Socket_Handle, $Buffer, $Reply_Code, $Wrap_All) = @_;
X
X   # Make sure $Socket_Handle is in the right package
X   local ($Package) = caller;
X   $Socket_Handle = "$Package'$Socket_Handle" if ($Socket_Handle !~ /'/);
X
X   @Buffer = split (/\n/, $Buffer);
X
X   # Just one line, no need to print a dash
X   if ($#Buffer == 0)
X   {
X      print $Socket_Handle "$Reply_Code $Buffer[0]\n";
X   }
X
X   # Two or more lines
X   else
X   {
X      $First_Line = shift (@Buffer);
X      $Last_Line = pop (@Buffer);
X      print $Socket_Handle "$Reply_Code-$First_Line\n";
X      foreach (@Buffer)
X      {
X	 if ($Wrap_All)
X	 {
X	    print $Socket_Handle "$Reply_Code-$_\n";
X	 }
X	 else
X	 {
X	    print $Socket_Handle " " if (/^$Reply_Code/);
X	    print $Socket_Handle "$_\n";
X	 };
X      };
X      print $Socket_Handle "$Reply_Code $Last_Line\n";
X   };
};
X
X
;###############################################################################
;# Code_Parse
;#
;# Gets input from $Socket_Handle that has been formatted by any of the
;# formats supported by the Code_Print function. See its function header
;# for a description of the various formats.
;#
;# $Status is set to one of the following on return:
;#
;#    -1	EOF on the socket was reached while looking for a record. If 
;#		anything was found before the EOF it is returned in $Buffer
;#		and $Reply_Code is set.
;#
;#     0	The input was not in Code_Print format. The input fetched 
;#		is returned as is. Since the parsing could get mucked
;#		on the second plus line in the multi-line format more than one
;#		line may be returned in $Buffer.
;#
;#     1	The input was in Code_Print form. The entire "record" (all 
;#		lines) is returned in $Buffer. Reply codes are stripped. Also, 
;#		any quoted reply codes are unquoted. $Reply_Code is the code 
;#		for the record.
;#
;# $Buffer, if non-null, will always end in a newline.
;#
;# Examples:
;#       Just reverse the examples for Code_Print!
;#
;# Arguments:
;#    $Socket_Handle
;#
;# Returns:
;#    $Status, $Buffer, $Reply_Code
;###############################################################################
sub main'Code_Parse
{
X   local ($Socket_Handle) = @_;
X   local ($Buffer, $Reply_Code, $Line);
X
X   # Make sure $Socket_Handle is in the right package
X   local ($Package) = caller;
X   $Socket_Handle = "$Package'$Socket_Handle" if ($Socket_Handle !~ /'/);
X
X   while (<$Socket_Handle>)
X   {
X      # First line of input?
X      if (++$Line == 1)
X      {
X	 # Single line record?
X	 if (/^(\d+) (.*)/)
X	 {
X	    return (1, "$2\n", $1);
X	 }
X
X	 # Multi-line record?
X	 elsif (/^(\d+)-(.*)/)
X	 {
X	    $Reply_Code = $1;
X	    $Buffer = "$2\n";
X	 }
X
X	 # Does not match record format
X	 else
X	 {
X	    return (0, $_);
X	 };
X      }
X
X      # Middle input, reply code
X      elsif (/^$Reply_Code-(.*)/)
X      {
X	 $Buffer .= "$1\n";
X      }
X
X      # End of input
X      elsif (/^$Reply_Code (.*)/)
X      {
X         $Buffer .= "$1\n";
X	 return (1, $Buffer, $Reply_Code);
X      }
X      
X      # Middle of input, no reply code
X      else
X      {
X	 # Unescape reply code?
X	 s/^ $Reply_Code/$Reply_Code/;
X	 $Buffer .= $_;
X      };
X   };
X
X   # EOF on socket if we get here
X   return (-1, $Buffer, $Reply_Code);
};
X
X
1;
SHAR_EOF
chmod 0444 local/tcp_support.pl ||
echo 'restore of local/tcp_support.pl failed'
Wc_c="`wc -c < 'local/tcp_support.pl'`"
test 11671 -eq "$Wc_c" ||
	echo 'local/tcp_support.pl: original size 11671, current size' "$Wc_c"
fi
# ============= tests/easy_tcp1.pl ==============
if test ! -d 'tests'; then
    echo 'x - creating directory tests'
    mkdir 'tests'
fi
if test -f 'tests/easy_tcp1.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping tests/easy_tcp1.pl (File already exists)'
else
echo 'x - extracting tests/easy_tcp1.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'tests/easy_tcp1.pl' &&
#!/usr/local/ustart/bin/perl
X
# NAME
#    easy_tcp1.pl - tests the easy_tcp.pl package
#
# SYNOPSIS
#    easy_tcp.pl 
#
# DESCRIPTION
#    Trys to connect to the SMTP port of some hosts. Some should fail and
#    some should not. You can figure out which should and should not. When
#    a connect succeeds the SMTP welcome banner is printed.
#
# AUTHOR
#    Michael S. Muegel <mmuegel@mot.com>
#
# RCS INFORMATION
#    $Author: mmuegel $
#    $Source: /usr/local/ustart/src/perl-stuff/libs/tests/RCS/easy_tcp1.pl,v $
#    $Revision: 1.3 $ of $Date: 1993/02/27 06:24:30 $
X
# Get the basename of the script
($Script_Name = $0) =~ s/.*\///;
X
# Need these libs
require "../local/easy_tcp.pl";
X
# Some hosts/ports to try to connect to
@Args = ("foo", "smtp",
X	 "localhost", "foo", 
X	 "pts1.pts.mot.com", "smtp",
X	 "localhost", "smtp",
X	 "localhost", 25,
X	 "127.0.0.1", 25);
X
while (($Host, $Service) = splice (@Args, 0, 2))
{
X   print "\nTrying host \"$Host\" and port \"$Service\"\n";
X   ($Status, $Msg) = &mk_user ($Host, $Service, "SOCKET");
X   if (! $Status)
X   {
X      print "   $Msg\n";
X      next;
X   };
X
X   print STDOUT "   " . <SOCKET>;
X   close (SOCKET);
};
SHAR_EOF
chmod 0555 tests/easy_tcp1.pl ||
echo 'restore of tests/easy_tcp1.pl failed'
Wc_c="`wc -c < 'tests/easy_tcp1.pl'`"
test 1164 -eq "$Wc_c" ||
	echo 'tests/easy_tcp1.pl: original size 1164, current size' "$Wc_c"
fi
# ============= tests/easy_tcp2.pl ==============
if test -f 'tests/easy_tcp2.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping tests/easy_tcp2.pl (File already exists)'
else
echo 'x - extracting tests/easy_tcp2.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'tests/easy_tcp2.pl' &&
#!/usr/local/ustart/bin/perl
X
# NAME
#    easy_tcp2.pl - tests the easy_tcp.pl package
#
# SYNOPSIS
#    easy_tcp2.pl -c [ file ... ]
#    easy_tcp2.pl -s
#
# DESCRIPTION
#    Client/server cat program. The client (invoked with -c option)
#    passes each line of input to the server (-s option) where it is printed.
#
# AUTHOR
#    Michael S. Muegel <mmuegel@mot.com>
#
# RCS INFORMATION
#    $Author: mmuegel $
#    $Source: /usr/local/ustart/src/perl-stuff/libs/tests/RCS/easy_tcp2.pl,v $
#    $Revision: 1.1 $ of $Date: 1993/02/13 22:42:35 $
X
# Get the basename of the script
($Script_Name = $0) =~ s/.*\///;
X
# Need these libs
require "../local/easy_tcp.pl";
require "getopts.pl";
X
# Port to use
$PORT = 3823;
X
# Check options
die "$Script_Name: bad usage\n" if (! &Getopts ("sc"));
$opt_c = 1 if (! ($opt_c || $opt_s));
X
# Client code
if ($opt_c)
{
X   # Connet to the server
X   ($Status, $Msg) = &mk_user ("localhost", $PORT, "SOCKET");
X   die "$Script_Name: client: $Msg\n" if (! $Status);
X
X   # Print stdin to the socket
X   while (<>)
X   {
X      print SOCKET;
X   };
X   close (SOCKET);
}
X
# Server code
else
{
X   # Accept connections
X   ($Status, $Msg, $Connection) = &mk_server ($PORT, "SOCKET");
X   die "$Script_Name: server: $Msg\n" if (! $Status);
X
X   # Print out some status info on this connection
X   ($Port, $Host) = &Get_Connection_Info ("SOCKET");
X   print "\nConnection #$Connection from $Host:$Port\n";
X
X   # Print socket in to stdout
X   while (<SOCKET>)
X   {
X      print STDOUT;
X   };
X   close (SOCKET);
};
SHAR_EOF
chmod 0555 tests/easy_tcp2.pl ||
echo 'restore of tests/easy_tcp2.pl failed'
Wc_c="`wc -c < 'tests/easy_tcp2.pl'`"
test 1526 -eq "$Wc_c" ||
	echo 'tests/easy_tcp2.pl: original size 1526, current size' "$Wc_c"
fi
# ============= tests/tcp_support1.pl ==============
if test -f 'tests/tcp_support1.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping tests/tcp_support1.pl (File already exists)'
else
echo 'x - extracting tests/tcp_support1.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'tests/tcp_support1.pl' &&
#!/usr/local/ustart/bin/perl
X
# NAME
#    tcp_support1.pl - tests the tcp_support.pl package
#
# SYNOPSIS
#    tcp_support1.pl 
#
# DESCRIPTIOn
#    Start the test server by running this command. Then telnet to it via
#
#       % telnet host port
#
#    See the $PORT definition to determine which port.
#
# AUTHOR
#    Michael S. Muegel <mmuegel@mot.com>
#
# RCS INFORMATION
#    $Author: mmuegel $
#    $Source: /usr/local/ustart/src/perl-stuff/libs/tests/RCS/tcp_support1.pl,v $
#    $Revision: 1.2 $ of $Date: 1993/02/15 04:23:10 $
X
# Get the basename of the script
($Script_Name = $0) =~ s/.*\///;
X
# Need these libs
require "../local/tcp_support.pl";
require "easy_tcp.pl";
require "date.pl";
X
# Signal handler for server quit should close the socket
%SIG = ("INT",  "Cleanup",
X        "QUIT", "Cleanup",
X        "PIPE", "Cleanup",
X        "TERM", "Cleanup");
X
#
# Useful constants
#
X
# Port to listen to
$PORT 			= 3823;
X
# Return codes printed to the client
$INFO_CODE 		= 220;
$BAD_COMMAND_CODE 	= 500;
$BAD_TOPIC_CODE 	= 502;
X
# Help text printed in addition to the automatically generated text
$EXTRA_HELP 		= "\nThis is extra help text you can specify. For example, you\nmight say send bug reports to Michael S. Muegel <mmuegel@mot.com>";
X
# Set up command info
%COMMAND_TO_DESCR = ("QUIT", "close the connection",
X		     "ECHO", "echo to the server",
X		     "INFO", "print connection info to client"
X	            );
X
# Accept connections
($Status, $Msg, $Connection) = &mk_server ($PORT, "SOCKET");
die "$Script_Name: server: $Msg\n" if (! $Status);
X
# Print out some status info on this connection
($Port, $Host) = &Get_Connection_Info ("SOCKET");
$Date = &date (time);
print "Connection #$Connection from $Host:$Port at $Date\n";
&Code_Print ("SOCKET", "${Script_Name} tester \$Revision: 1.2 $ ready at $Date",
X   $INFO_CODE, 1);
X
# Now look for commands until the user QUITs
while (1)
{
X   ($Status, $Msg, $Command, $Left_Over) = &Command_Parse ("SOCKET", $INFO_CODE, $BAD_COMMAND_CODE, $BAD_TOPIC_CODE, $EXTRA_HELP,  *COMMAND_TO_DESCR, *Foo, 1);
X   &Client_Closed if ($Status == -1);
X   die "$Script_Name: $Msg\n" if (! $Status);
X
X   # Quit?
X   if ($Command eq "QUIT")
X   {
X      &Client_Closed;
X   }
X
X   elsif ($Command eq "ECHO")
X   {
X      print "$Left_Over\n";
X   }
X
X   else
X   {
X      &Code_Print ("SOCKET", 
X	 "You connected from $Host on port $Port at\n$Date\n", $INFO_CODE, 1);
X   };
};
X
sub Client_Closed
{
X   print "Connection #$Connection closed\n";
X   exit (0);
};
X
sub Cleanup
{
X   print "Server caught SIG$_[0]\n";
X   shutdown (SOCKET, 2);
};
SHAR_EOF
chmod 0555 tests/tcp_support1.pl ||
echo 'restore of tests/tcp_support1.pl failed'
Wc_c="`wc -c < 'tests/tcp_support1.pl'`"
test 2574 -eq "$Wc_c" ||
	echo 'tests/tcp_support1.pl: original size 2574, current size' "$Wc_c"
fi
# ============= tests/tcp_support2.pl ==============
if test -f 'tests/tcp_support2.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping tests/tcp_support2.pl (File already exists)'
else
echo 'x - extracting tests/tcp_support2.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'tests/tcp_support2.pl' &&
#!/usr/local/ustart/bin/perl
X
# NAME
#    tcp_support2.pl - tests the tcp_support.pl package
#
# SYNOPSIS
#    tcp_support2.pl -c 
#    tcp_support2.pl -s
#
# DESCRIPTION
#    Tests the Code_Print and Code_Parse functions. The server (invoked with 
#    -s option) prints some records upon connection that the client (-c)
#    unpacks and prints.
#
#    No neat little compare system (would be easy). Just eyeball the results.
#
# AUTHOR
#    Michael S. Muegel <mmuegel@mot.com>
#
# RCS INFORMATION
#    $Author: mmuegel $
#    $Source: /usr/local/ustart/src/perl-stuff/libs/tests/RCS/tcp_support2.pl,v $
#    $Revision: 1.1 $ of $Date: 1993/02/15 04:22:00 $
X
# Get the basename of the script
($Script_Name = $0) =~ s/.*\///;
X
# Need these libs
require "../local/tcp_support.pl";
require "easy_tcp.pl";
require "getopts.pl";
X
# Port to use
$PORT = 3823;
X
# Arguments to Code_Print of form (buffer, reply_code, wrap_all)
@RECORDS = ("Foo", 220, 1,
X	    "Line 1\nLine 2\nLine 3\n", 214, 1,
X	    "Line 1\nLine 2\n220 Line 3\nLine 4\n", 220, 0
X	   );
X
# Check options
die "$Script_Name: bad usage\n" if (! &Getopts ("sc"));
$opt_c = 1 if (! ($opt_c || $opt_s));
X
# Client code
if ($opt_c)
{
X   # Connet to the server
X   ($Status, $Msg) = &mk_user ("localhost", $PORT, "SOCKET");
X   die "$Script_Name: client: $Msg\n" if (! $Status);
X
X   # Get each record
X   while (1)
X   {
X      ($Status, $Buffer, $Reply_Code) = &Code_Parse ("SOCKET");
X      if ($Status == -1)
X      {
X         print "\nEOF reached\n";
X	 last;
X      }
X      elsif ($Status)
X      {
X	 print "\nRecord found with reply code $Reply_Code:\n$Buffer";
X      }
X      else
X      {
X	 print "\nNon-code input found:\n$Buffer";
X      };
X   };
X   close (SOCKET);
}
X
# Server code
else
{
X   # Accept connections
X   ($Status, $Msg, $Connection) = &mk_server ($PORT, "SOCKET");
X   die "$Script_Name: server: $Msg\n" if (! $Status);
X
X   # Print out some status info on this connection
X   ($Port, $Host) = &Get_Connection_Info ("SOCKET");
X   print "Connection #$Connection from $Host:$Port\n";
X
X   # Send test data to client
X   while (@Args = splice (@RECORDS, 0, 3))
X   {
X      &Code_Print ("SOCKET", @Args);
X   };
X   print SOCKET "Just a stray line that is not in reply code format\n";
X   close (SOCKET);
};
SHAR_EOF
chmod 0555 tests/tcp_support2.pl ||
echo 'restore of tests/tcp_support2.pl failed'
Wc_c="`wc -c < 'tests/tcp_support2.pl'`"
test 2257 -eq "$Wc_c" ||
	echo 'tests/tcp_support2.pl: original size 2257, current size' "$Wc_c"
fi
exit 0
-- 
+----------------------------------------------------------------------------+
| Michael S. Muegel                  | Internet E-Mail:    mmuegel@mot.com   |
| UNIX Applications Startup Group    | Moto Dist E-Mail:   X10090            |
| Corporate Information Office       | Voice:              (708) 576-0507    |
| Motorola                           | ... these are my opinions, honest ... |
+----------------------------------------------------------------------------+