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: mmuegel@cssmp.corp.mot.com (Michael S. Muegel) #Subject: Re: socket-based server (not from inetd) Message-ID: <1993Feb25.190732.23418@ftpbox.mot.com> Sender: news@ftpbox.mot.com (C News) Organization: Corporate Information Office, Schaumburg, Illinois, Motorola, Inc. References: <1mimbd$ac3@milk.Warren.MENTORG.COM> Date: Thu, 25 Feb 1993 19:07:32 GMT Lines: 696 Previously, tal@Warren.MENTORG.COM (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 mmuegel@mot.com (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 # # More flexible argument syntax, better error checking, extra functions, # and documentation by Michael S. Muegel # # 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 ;# ;# 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 \"\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: 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 ... | +----------------------------------------------------------------------------+ .