news.utdallas.edu!hermes.chpc.utexas.edu!cs.utexas.edu!uwm.edu!linac!att!mcdchg!ftpbox!cssmp.corp.mot.com!mmuegel Thu Feb 25 18:29:27 CST 1993
Article: 1234 of comp.lang.perl
Xref: feenix.metronet.com comp.lang.perl:1234
Newsgroups: comp.lang.perl
Path: feenix.metronet.com!news.utdallas.edu!hermes.chpc.utexas.edu!cs.utexas.edu!uwm.edu!linac!att!mcdchg!ftpbox!cssmp.corp.mot.com!mmuegel
From: [email protected] (Michael S. Muegel)
#Subject: Re: socket-based server (not from inetd)
Message-ID: <[email protected]>
Sender: [email protected] (C News)
Organization: Corporate Information Office, Schaumburg, Illinois, Motorola, Inc.
References: <[email protected]>
Date: Thu, 25 Feb 1993 19:07:32 GMT
Lines: 696

Previously, [email protected] (Tom Limoncelli) wrote:
> In the past people have posted code fragments that show how to write a
> perl program that is started via "inetd".
>
> I would like to develop a long-running daemon that accepts connections
> via sockets but never spawns.  (i.e. all connections are handled by one
> program, a lot like INN's innd).

The following may help with ideas. easy_tcp.pl does fork a child to
handle the connection. I am unsure of whatyou mean by "... but never
spawns." That would indicate you have a very fast server or a fast
service you provide.

Let me know if these are useful...
-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/25/1993 19:08 UTC by [email protected] (Michael S. Muegel)
# Source directory /home/ustart/NeXT/contrib/lib/perl
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   7794 -r--r--r-- easy_tcp.pl
#  11557 -r--r--r-- tcp_support.pl
#
# ============= easy_tcp.pl ==============
if test -f 'easy_tcp.pl' -a X"$1" != X"-c"; then
       echo 'x - skipping easy_tcp.pl (File already exists)'
else
echo 'x - extracting easy_tcp.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > '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 <[email protected]>
#
#    More flexible argument syntax, better error checking, extra functions,
#    and documentation by Michael S. Muegel <[email protected]>
#
# RCS INFORMATION
#    $Source: /usr/local/ustart/src/perl-stuff/libs/local/RCS/easy_tcp.pl,v $
#    $Revision: 1.5 $ of $Date: 1993/02/13 22:45:04 $
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 mk_user
{
X
X  local ($Server, $Port, $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 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  # 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 Get_Connection_Info
{
X   local ($Socket_Handle) = @_;
X   local ($Port, $Host, $Host_Addr);
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 easy_tcp.pl ||
echo 'restore of easy_tcp.pl failed'
Wc_c="`wc -c < 'easy_tcp.pl'`"
test 7794 -eq "$Wc_c" ||
       echo 'easy_tcp.pl: original size 7794, current size' "$Wc_c"
fi
# ============= tcp_support.pl ==============
if test -f 'tcp_support.pl' -a X"$1" != X"-c"; then
       echo 'x - skipping tcp_support.pl (File already exists)'
else
echo 'x - extracting tcp_support.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > '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 <[email protected]>
;#
;# RCS INFORMATION
;#    $Author: mmuegel $
;#    $Source: /usr/local/ustart/src/perl-stuff/libs/local/RCS/tcp_support.pl,v $
;#    $Revision: 1.2 $ of $Date: 1993/02/15 04:23:32 $
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   # Fix up socket handle
X   $Socket_Handle = "main'$Socket_Handle" if ($Socket_Handle !~ /^\S+'/);
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   # Fix up socket handle
X   $Socket_Handle = "main'$Socket_Handle" if ($Socket_Handle !~ /^\S+'/);
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 tcp_support.pl ||
echo 'restore of tcp_support.pl failed'
Wc_c="`wc -c < 'tcp_support.pl'`"
test 11557 -eq "$Wc_c" ||
       echo 'tcp_support.pl: original size 11557, current size' "$Wc_c"
fi
exit 0

--
+----------------------------------------------------------------------------+
| Michael S. Muegel                  | Internet E-Mail:    [email protected]   |
| UNIX Applications Startup Group    | Moto Dist E-Mail:   X10090            |
| Corporate Information Office       | Voice:              (708) 576-0507    |
| Motorola                           | ... these are my opinions, honest ... |
+----------------------------------------------------------------------------+

You are viewing proxied material from ftp.icm.edu.pl. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.