From: geddis@Xenon.Stanford.EDU (Don Geddis)
Subject: Re: Interprocess comms using Allegro 4.1
To: djasson@afterlife.ncsc.mil
Keywords: IPC, Allegro, socket, stream
Reply-To: Geddis@CS.Stanford.Edu
Organization: CS Department, Stanford University, California, USA
Distribution: usa
Date: 10 Sep 92 22:08:52 GMT

djasson@zion (Drew Asson) writes:
>This is a request for help to set up a unix-domain (socket file) server
>in Allegro (4.1), that will accept 1 connection from a C code client.
>The lisp side only need service one connection at a time (ergo no
>fork needed), but I'd like it to stay resident and be able to accept
>another connection when the last one is finished.

>I've looked at the sample code in the ipc.cl file.  Setting up a lisp
>client is no problem (just use open-network-stream), but I want a lisp
>server. So I started playing around w/ the function lisp-server-socket-daemon.
>I thought I took out all I needed.  But it didn't work.

Without analyzing your detailed problem, I'll just say that I had exactly
the same desire a few months ago.  Contacting Franz led to them sending me
an experimental copy of a new ipc.cl file.  With some minor modifications
by myself, it seems to work fine.  I'll include my modified ipc.cl and
some sample server code below.

-------------------------------------------------------------------------------
IPC.CL

;;					-[Wed Jan 15 14:27:09 1992 by layer]-
;;
;; Allegro CL IPC interface [cer version!!]
;;
;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Suppplement 252 52.227-7013 (c) (1) (ii), as
;; applicable.
;;

;;; Added 7/23/92 by Don Geddis (Geddis@CS.Stanford.Edu)
(defconstant new-ipc-installed t)

;;;;; I hacked this  to support the LEP protocol
;;;; This seems like a dreadful piece of code.
;;;; Changes:
;;;; 1. Support for multiple servers listening on different connections.
;;;; 2. The default behaviour is that the server reads a protocol name that specifies the type of the
;;;; server process to create.  Currently, supported protocols are:
;;;; a. :listener - RUN a listener
;;;; b. :lep - start up an LEP server

(eval-when (compile eval load)
  (if (find-symbol (symbol-name :rcsnote) (find-package :si))
      (push :has-rcsnote *features*))
  
  #-(or little-endian big-endian)
  (pushnew
   (let ((x '#(1)))
     (if (not (= 0 (sys::memref x #.(comp::mdparam 'comp::md-svector-data0-adj)
				0 :unsigned-byte)))
	 :little-endian
       :big-endian))
   *features*)
  )

#+has-rcsnote
(si::rcsnote
 "ipc"
 "$aclHeader: ipc.cl,v 1.50 91/12/04 01:10:45 cox acl4_1 $")

(eval-when (compile eval load)
  (excl::require :process)
  (excl::require :foreign)
  (excl::provide :ipc))

#+(version>= 4 0)
(defpackage :ipc (:use :lisp :excl :ff :mp)
	    (:export #:start-lisp-listener-daemon #:open-network-stream
		     #:*inet-port-min* #:*inet-port-max* #:*inet-port-used*
		     #:start-process-for-network-stream
		     ))

#+(version>= 4 0)
(in-package :ipc)

#-(version>= 4 0)
(in-package :ipc :use '(:lisp :excl :ff :mp))

#-(version>= 4 0)
(export '(start-lisp-listener-daemon open-network-stream
	  *inet-port-min* *inet-port-max* *inet-port-used*))

#+allegro-v3.1
(progn
  (excl::require :cstructs)
  (defmacro ff::cstruct-length (x) `(ff::cstruct-len ,x))
  )

#+(or allegro-v3.2 (version>= 4 0))
(eval-when (compile eval load)
  (excl::require :defctype))

(defvar *unix-domain* nil
  ;; If non-nil then use a UNIX domain socket, otherwise use an internet
  ;; domain port (see *inet-port* variable).
  )

(defvar *socket-pathname* nil
  ;; When the UNIX domain is used, then if non-nil this is the pathname of
  ;; the socket file to use for the communication between GNU Emacs and
  ;; Allegro CL.
  )

(defparameter *inet-port-min* 1025 
  "The smallest internet service port number on which Lisp listens for
connections.")

(defparameter *inet-port-max* 2025
  "The largest internet service port number on which Lisp listens for
connections.")

(defvar *inet-port-used* 0
  "Port actually in use for lisp listeners.")

(defvar *inet-listener-password* 0
  ;; A magic number that mnust be supplied to verify that someone trying to
  ;; connect to our listener is really the person who started the lisp
  )

(defvar *ipc-version* 1  
  ;; This indicates the version of the IPC protocol
  )

(defconstant *af-unix* 1
  ;; The AF_UNIX constant from /usr/include/sys/socket.h.
  )

(defconstant *af-inet* 2
  ;; The AF_INET constant from /usr/include/sys/socket.h.
  )

(defconstant *sock-stream* 1
  ;; The SOCK_STREAM constant from /usr/include/sys/socket.h.
  )

;; from <netinet/in.h>
(defcstruct sockaddr-in
  (family :unsigned-short)		; short sin_family
  (port :unsigned-short)		; u_short sin_port
  (addr :unsigned-long)			; struct in_addr sin_addr
  (zero 8 :char)			; char sin_zero[8]
  )

;; from <??>
(defcstruct sockaddr-un
  (family :unsigned-short)
  (path 109 :char))

;; from <netdb.h>
(defcstruct (hostent :malloc)
  (name * :char)			; char *h_name
  (aliases * * :char)			; char **h_aliases
  (addrtype :long)			; int h_addrtype
  (length :long)			; int h_length
  (addr * :char)			; char *h_addr   --or--
					; char **h_addr_list (for SunOS 4.0)
  )

(defcstruct (servent :malloc)		; Returned by getservent
  (name * :char)
  (aliases * * :char)
  (port :signed-long)
  (proto * :char))

(defcstruct timeval
  (sec :long)
  (usec :long))

(defcstruct unsigned-long
  (unsigned-long :unsigned-long))

(defvar .lisp-listener-daemon-ff-loaded. nil)
(defvar .lisp-listener-daemon. nil)

(defparameter .needed-funcs.
    (mapcar #'convert-to-lang
	    ;; this list appears in makefile.cl, too
	    '("socket" "bind" "listen" "accept" "getsockname"
	      "gethostbyname" "getservbyname"
	      "connect" "bcopy" "bcmp" "bzero")))

(defvar .junk-name. (make-array 1))
(defvar .junk-address. (make-array 1 :element-type '(unsigned-byte 32)))

(defun entry-point-exists-p (string)
  (setf (aref .junk-name. 0) string)
  (setf (aref .junk-address. 0) 0)
  (= 0 (get-entry-points .junk-name. .junk-address.)))

(eval-when (load eval)
  (unless .lisp-listener-daemon-ff-loaded.
    (excl::machine-case :host
      ((:apollo :tek4300 :rs6000))
      (t (unless (dolist (name .needed-funcs. t)
		   (if (not (entry-point-exists-p name))
		       (return nil)))
	   (princ ";  Loading TCP routines from C library...")
	   (force-output)
	   (unless (load ""
			 :verbose nil
			 :unreferenced-lib-names .needed-funcs.
			 #+(target sgi4d) :system-libraries
			 #+(target sgi4d) '("bsd")
			 )
	     (error "foreign load failed"))
	   (princ "done")
	   (terpri)
	   (force-output))))

    (setq .lisp-listener-daemon-ff-loaded. t)
    (defforeign-list '((getuid :entry-point #,(convert-to-lang "getuid"))
		       (socket :entry-point #,(convert-to-lang "socket"))
		       (bind :entry-point #,(convert-to-lang "bind"))
		       (accept :entry-point #,(convert-to-lang "accept"))
		       (getsockname :entry-point #,(convert-to-lang
						    "getsockname"))
		       (gethostbyname :entry-point #,(convert-to-lang
						      "gethostbyname"))
		       (getservbyname :entry-point #,(convert-to-lang
						      "getservbyname"))
		       (select :entry-point #,(convert-to-lang "select"))
		       (connect :entry-point #,(convert-to-lang "connect"))
		       (bcopy :entry-point #,(convert-to-lang "bcopy"))
		       (bzero :entry-point #,(convert-to-lang "bzero"))
		       (bcmp :entry-point #,(convert-to-lang "bcmp"))
		       (perror :entry-point #,(convert-to-lang "perror"))
		       (unix-listen :entry-point #,(convert-to-lang "listen"))
		       (unix-close :entry-point #,(convert-to-lang "close")))
		     :print nil)))

(if* (entry-point-exists-p (convert-to-lang "lisp_htons"))
   then ;; Allegro CL 3.1 or later...
	(defforeign-list '((lisp_htons :entry-point #,(convert-to-lang
						       "lisp_htons"))
			   (lisp_htonl :entry-point #,(convert-to-lang
						       "lisp_htonl"))
			   (lisp_ntohs :entry-point #,(convert-to-lang
						       "lisp_ntohs"))
			   (lisp_ntohl :entry-point #,(convert-to-lang
						       "lisp_ntohl")))
			 :print nil)
   else ;; pre-3.1 Allegro CL.  Do it the hard way...
	#+little-endian
	(progn
	  (setf (symbol-function 'lisp_htons)
	    #'(lambda (x)
		(logior (ash (logand x #x00ff) 8)
			(ash (logand x #xff00) -8))))
	  (setf (symbol-function 'lisp_ntohs)
	    #'(lambda (x) (lisp_htons x)))

	  (setf (symbol-function 'lisp_htonl)
	    #'(lambda (x)
		(logior (ash (logand x #x000000ff)  24)
			(ash (logand x #x0000ff00)   8)
			(ash (logand x #x00ff0000)  -8)
			(ash (logand x #xff000000) -24))))
	  (setf (symbol-function 'lisp_ntohl)
	    #'(lambda (x) (lisp_htonl x))))

	#+big-endian
	(progn
	  (setf (symbol-function 'lisp_htons) #'(lambda (x) x))
	  (setf (symbol-function 'lisp_htonl) #'(lambda (x) x))
	  (setf (symbol-function 'lisp_ntohs) #'(lambda (x) x))
	  (setf (symbol-function 'lisp_ntohl) #'(lambda (x) x))))

(defun start-lisp-listener-daemon (&rest args)
  "Starts a daemon process which listens to a socket for attempts to
connect, and starts a lisp listener for each connection.  If the Lisp
listener ever completes, the daemon makes sure its connection is closed."
  (cond ((or (null .lisp-listener-daemon.)
	     (not (member .lisp-listener-daemon. mp::*all-processes*
			  :test #'eq)))
	 (setq .lisp-listener-daemon.
	   (apply #'process-run-function "TCP Listener Socket Daemon"
		  'lisp-server-socket-daemon
		  args))
	 (setf (mp::process-interruptable-p .lisp-listener-daemon.) nil)
	 (setf (getf (process-property-list .lisp-listener-daemon.)
		     ':survive-dumplisp)
	   'mp:process-kill))
	(t (warn "the listener daemon is already running"))))

(defun kill-lisp-listener-daemon ()
  (if* (or (null .lisp-listener-daemon.)
	   (not (member .lisp-listener-daemon. mp::*all-processes*
			:test #'eq))
	   (progn
	     (mp:process-kill .lisp-listener-daemon.)
	     ;; this makes sure the kill is allowed to complete:
	     (mp:process-allow-schedule)
	     t))
     then (setq .lisp-listener-daemon. nil)
	  t
     else (error "couldn't kill the listener daemon")))

(defun start-lisp-server-process (&rest args 
				  &key (server-name
					"TCP Listener Socket Daemon")
				  &allow-other-keys)
  (remf args :server-name)
  (let ((proc
	 (apply #'process-run-function server-name
		'lisp-server-socket-daemon
		args)))
    (setf (mp::process-interruptable-p proc) nil)
    (setf (getf (process-property-list proc) ':survive-dumplisp) 't)
    proc))

;;;============================================================================
;;; New "lisp-server-socket-daemon" added 7/7/92 by Don Geddis
;;; Code from smh@franz.com (Steve Haflich)

(defun lisp-server-socket-daemon (&rest args &key
				  (use-lep nil)
				  (startup-stream-process
				   (if use-lep 
				       #'new-default-stream-startup
				     #'default-stream-startup))
				  ((:unix-domain *unix-domain*) *unix-domain*)
				  (inet-port 0 inet-port-p)
 				  ((:inet-port-min *inet-port-min*) 
 				   (if inet-port-p inet-port *inet-port-min*))
 				  ((:inet-port-max *inet-port-max*) 
 				   (if inet-port-p inet-port *inet-port-max*))
				  ((:socket-pathname *socket-pathname*) 
				   *socket-pathname*)
				  (raw-connection nil)
				  &allow-other-keys
;;; We should decide this if we
;;; implement background streams 
;;; then it is no good just outputting to random locations.
				  &aux 
				  (*standard-output* *initial-terminal-io*)
				  (*debug-io* *initial-terminal-io*)
				  (*terminal-io* *initial-terminal-io*)
				  (*error-output* *initial-terminal-io*))

  ;; Code added 7/19/92 by Don Geddis (Geddis@CS.Stanford.Edu)
  (when raw-connection
	(setq startup-stream-process #'don-stream-startup) )
  
  ;; use-lep should default to Nil and the LEP should start things up with T
  ;; In this way a new lisp can work with the old Emacs interface
  (block bad-news
    (let (listen-socket-fd
	  (listen-sockaddr
	   (if *unix-domain*
	       (make-cstruct 'sockaddr-un)
	     (let ((sin (make-cstruct 'sockaddr-in)))
	       (bzero sin (ff::cstruct-length 'sockaddr-in))
	       sin)))
	  (timeval (make-cstruct 'timeval))
	  (mask-obj (make-cstruct 'unsigned-long))
	  (int (make-cstruct 'unsigned-long))
	  mask
	  stream
	  fd)
    
      (unless *socket-pathname*
	(setq *socket-pathname* (format nil "/tmp/GnuToAcl~d" (getuid))))

      (setf (timeval-sec timeval) 0
	    (timeval-usec timeval) 0)
      (unwind-protect
	  (progn
	    (if *unix-domain* (errorset (delete-file *socket-pathname*)))
	    (setq listen-socket-fd (socket
				    (if *unix-domain* *af-unix* *af-inet*)
				    *sock-stream*
				    0))
	    (when (< listen-socket-fd 0)
	      (perror "socket")
	      (setq listen-socket-fd nil)
	      (return-from bad-news))
	    (mp::mpwatchfor listen-socket-fd)

	    ;; Compute a select mask for the daemon's socket.
	    (setq mask (ash 1 listen-socket-fd))

	    (if* *unix-domain*
	       then (setf (sockaddr-un-family listen-sockaddr) *af-unix*)
	       ;; Set pathname.
		    (dotimes (i (length *socket-pathname*)
			       (setf (sockaddr-un-path listen-sockaddr i) 0))
		      (setf (sockaddr-un-path listen-sockaddr i)
			(char-int (elt *socket-pathname* i))))
		    (unless (zerop (bind listen-socket-fd
					 listen-sockaddr
					 (+ (length *socket-pathname*) 2)))
		      (perror "bind")
		      (return-from bad-news))
	       else (setf (sockaddr-in-family listen-sockaddr) *af-inet*)
		    (do ((port *inet-port-min* (1+ port)))
			((progn
			   (setf (sockaddr-in-port listen-sockaddr)
			     (lisp_htons (setq *inet-port-used* port)))
			   (zerop (bind listen-socket-fd
					listen-sockaddr
					(ff::cstruct-length 'sockaddr-in)))))
		      (if* (= port *inet-port-max*)
			 then (perror "bind")
			      (return-from bad-news))))

	    (finish-output)
	    (unless (zerop (unix-listen listen-socket-fd 5))
	      (perror "listen")
	      (return-from bad-news))
	    
	    (if* (not raw-connection)
	       then (format t "~d ~d ~a ~s ~d" 
			    ;; ^Aport password case-mode socket-file ipc-version^A
			    (if* *unix-domain*
			       then 0
			       else *inet-port-used*)
			    (setq *inet-listener-password* 
			      (random 1000000 (make-random-state t)))
			    (case excl::*current-case-mode*
			      ((:case-insensitive-upper
				:case-sensitive-upper) ":upper")
			      ((:case-insensitive-lower
				:case-sensitive-lower) ":lower"))
			    (if* *unix-domain*
			       then *socket-pathname*
			       else nil)
			    *ipc-version*)
		    
		    (finish-output))
	    (loop
	      (process-wait "waiting for a connection"
			    #'(lambda (mask mask-obj timeout)
				(setf (unsigned-long-unsigned-long
				       mask-obj)
				  mask)
				(not (zerop (select 32 mask-obj 0 0 timeout))))
			    mask mask-obj timeval)
	      (setf (unsigned-long-unsigned-long int)
		(if *unix-domain*
		    (ff::cstruct-length 'sockaddr-un)
		  (ff::cstruct-length 'sockaddr-in)))
	      (setq fd (accept listen-socket-fd listen-sockaddr int))
	      (finish-output *standard-output*)
	      (finish-output *error-output*)
	      (when (< fd 0)
		(perror "accept")
		(return-from bad-news))
	    
	      (setq stream (make-ipc-terminal-stream fd))
	   
	      ;; the first thing that comes over the stream is the name of the
	      ;; emacs buffer which was created--we name the process the
	      ;; same.
	      ;; For internet sockets, the next thing is the password.
	      (apply startup-stream-process stream :fd fd 
		     :listen-sockaddr listen-sockaddr  
		     ;; unused? -smh
		     ;; :listen-sockaddr-len int
		     args)))
	(when listen-socket-fd
	  (mp::mpunwatchfor listen-socket-fd)
	  (unix-close listen-socket-fd)
	  (if* (not raw-connection)
	     then (setq .lisp-listener-daemon. nil))
	  ))))
  (error "couldn't start listener daemon"))

;; added function, corresponds to start-lisp-server-process

(defun kill-lisp-server-process (process)
  (if* (or (null process)
	   (not (member process mp::*all-processes* :test #'eq))
	   (progn
	     (mp:process-kill process)
	     ;; this makes sure the kill is allowed to complete:
	     (mp:process-allow-schedule)
	     t))
     then t
     else (error "couldn't kill the listener daemon")))

;;;============================================================================

;;;; The first thing that comes over is the name of the protocol to use.
;;;; The old scheme is the listener protocol which means fire up a listener.
;;;; The LEP uses the :lep protocol

(defun new-default-stream-startup (stream &rest args)
  (declare (ignore function))
  (apply #'start-process-for-network-stream stream (read stream) args))

(defgeneric start-process-for-network-stream (stream protocol &rest arguments)
	    (:documentation "Create the process to serve the stream"))

(defmethod start-process-for-network-stream (stream (protocol (eql :listener)) &rest args)
  (apply #'default-stream-startup stream args))

(defmethod start-process-for-network-stream (stream protocol &rest args)
  (declare (ignore args))
  (warn "Tried to start unknown protocol ~S for stream ~S" protocol stream))

;;; Code added 7/19/92 by Don Geddis (Geddis@CS.Stanford.Edu)
(defun don-stream-startup
  (stream 
   &key (function 'lisp-listener-with-stream-as-terminal-io)
   listen-sockaddr fd
   &allow-other-keys)
  (process-run-function "Don-Process" function stream) )

(defun default-stream-startup (stream 
			       &key (function 'lisp-listener-with-stream-as-terminal-io)
				    listen-sockaddr fd
			       &allow-other-keys)
  (let ((proc-name (read stream))
	(password
	 (if (null *unix-domain*)
	     (read stream))))
    (if* *unix-domain*
       then (process-run-function
	     proc-name
	     function
	     stream)
       else (if* (not (and (numberp password)
			   (= password *inet-listener-password*)))
	       then (let ((hostaddr
			   (lisp_ntohl
			    (sockaddr-in-addr listen-sockaddr))))
		      (format t ";; access denied for host ")
		      (format-in-addr t hostaddr)
		      (format t ", password ~s~%" password))
		    (refuse-connection fd)
	       else (process-run-function
		     proc-name
		     function
		     stream)))))

(defun refuse-connection (fd &aux s)
  (setq s (make-ipc-terminal-stream fd))
  #-(version>= 4 0)
  (setf (excl::sm_read-char s) #'mp::stm-bterm-read-string-char-wait)
  (format s "connection refused.~%")
  (force-output s)
  #-(version>= 4 0) (setf (excl::sm_bterm-out-pos s) 0)
  #+(version>= 4 0) (excl::clear-output-1 s)
  (close s))

(defun lisp-listener-with-stream-as-terminal-io (s)
  (unwind-protect
      #+(version>= 4 0)
      (tpl:start-interactive-top-level
       s 'tpl:top-level-read-eval-print-loop nil)
      #-(version>= 4 0)
      (progn
	(setf (excl::sm_read-char s) #'mp::stm-bterm-read-string-char-wait)
	(tpl:start-interactive-top-level
	 s 'tpl:top-level-read-eval-print-loop nil))
    ;; This next crock is to prevent the force-output done by close from
    ;; signalling an error if there are characters buffered to the output
    ;; stream, which there will be if the remote client closed the connection.
    ;; This should be changed to a clear-output once that works on a buffered
    ;; terminal stream.
    #-(version>= 4 0) (setf (excl::sm_bterm-out-pos s) 0)
    #+(version>= 4 0) (excl::clear-output-1 s)
    (close s)))

(defun open-network-stream (&key host port socket-file)
  "Open a stream to a port, which is a TCP/IP communication channel.  There
are two types of ports supported, UNIX and INTERNET domain.  The domain is
chosen based on the keyword arguments supplied:
For internet domain:
 HOST is the string host name or an integer internet address.
 PORT is the string service name or a port number.
For Unix domain:
 SOCKET-FILE is the string pathname of the socket."
  (when (or (and host port socket-file)
	    (and (or (null host) (null port))
		 (null socket-file)))
    (error "Must either supply HOST and PORT *or* SOCKET-FILE keywords."))
  (if* socket-file
     then ;; UNIX domain
	  (let ((server (make-cstruct 'sockaddr-un))
		socket-fd)
	    (setf (sockaddr-un-family server) *af-unix*)
	    (dotimes (i (length socket-file)
		      (setf (sockaddr-un-path server i) 0))
	      (setf (sockaddr-un-path server i)
		(char-int (elt socket-file i))))
	    (setq socket-fd (socket *af-unix* *sock-stream* 0))
	    (if (< (connect socket-fd server (+ 2 (length socket-file))) 0)
		(error "connect failed to ~s" socket-file))
	    (make-ipc-terminal-stream socket-fd))
     else ;; INTERNET domain
	  (let (sock server hostaddress)
	    ;; Open a socket
	    (when (< (setf sock (socket *af-inet* *sock-stream* 0)) 0)
	      (error "couldn't open socket"))
	    ;; construct a socket address
	    (setf server (make-cstruct 'sockaddr-in))
	    (bzero server (ff::cstruct-length 'sockaddr-in))
	    (if* (integerp host)
	       then (setq hostaddress (lisp_htonl host))
	     elseif (stringp host)
	       then (when (= (setq hostaddress (gethostbyname host)) 0)
		      (error "unknown host: ~a" host))
		    (if (not (= 4 (hostent-length hostaddress)))
			(error "address length not 4"))
		    (setq hostaddress
		      (let ((addr (hostent-addr hostaddress)))
			(si:memref-int
			 ;; SunOS 4.0 requires an extra indirection
			 (if (or (member comp::.target.
					 '(:hp :sgi4d :sony :dec3100 :rs6000)
					 :test #'eq)
				 (probe-file "/lib/ld.so"))
			     (si:memref-int addr 0 0 :unsigned-long)
			   addr)
			 0 0 :unsigned-long)))
	       else (error "HOST not a string or integer internet address:"
			   host))
	    (setf (sockaddr-in-addr server) hostaddress)

	    (setf (sockaddr-in-port server)
	      (if* (integerp port)
		 then (lisp_htons port)
	       elseif (stringp port)
		 then (let ((serv (getservbyname port "tcp")))
			(if* (= 0 serv)
			   then (error "Unknown service name: ~s" port))
			(servent-port serv))
		 else (error "PORT not a string or integer internet service:"
			     port)))

	    (setf (sockaddr-in-family server) *af-inet*)
	    ;; open the connection
	    ;; Modified 7/21/92 by Don Geddis (Geddis@CS.Stanford.Edu)
	    ;;   so that connection failure returns nil instead of an error
	    ;; 8/12/92 Replace perror/error with format to *error-output*
	    (if (< (connect sock server (ff::cstruct-length 'sockaddr-in)) 0)
		(progn
		  (format *error-output* "Connect failure: ")
		  (unix-close sock)
		  (format *error-output* "couldn't connect to socket")
		  nil )
	      ;; build and return the stream
	      (make-ipc-terminal-stream sock)))))

(defun make-ipc-terminal-stream (fd)
  #+allegro-v3.1 (excl::make-buffered-terminal-stream fd fd t t)
  #+(version>= 4 0) (make-instance 'excl::bidirectional-terminal-stream
		   :fn-in  fd
		   :fn-out fd)
  )

(defun format-in-addr (stm addr)	; assumes host byte order
  (format stm "[~11,1,1,'.<~2,'0D~;~2,'0D~;~2,'0D~;~2,'0D~>]"
	  (ldb (byte 8 24) addr)
	  (ldb (byte 8 16) addr)
	  (ldb (byte 8  8) addr)
	  (ldb (byte 8  0) addr)))

#|
;;; Allegro Common Lisp as the client side of `finger'.
;;; This is a simple demo of how easily a lisp program can become the
;;; client of a client/server connection.

(defun finger (host &optional (name ""))
  (with-open-stream (s (open-network-stream :host host
					    :port "finger"))
    ;; The first interaction of the finger protocol is to send the
    ;; name in which we are interested.  The empty string will
    ;; report on all current users.
    (format s "~a~%" name)
    ;; Then we read back multiple lines of information.
    (do ((line (read-line s nil nil) (read-line s nil nil)))
	((null line) (values))
      ;; The returned data contains extra #\return characters
      ;; which we might not want to print.
      (write-line (remove #\return line)))))
|#

-------------------------------------------------------------------------------
MY SAMPLE CODE TO USE IPC.CL

(unless (boundp 'new-ipc-installed)
  (load "/local/lib/cl/code/ipc") )	; Use the modified IPC code

;;;----------------------------------------------------------------------------

(defconstant *myself* 2130706433 "Self IP address: 127.0.0.1")

(defun test-port-send
    (port &optional (str (format nil "Test of send to ~A" port)))
  (with-open-stream
      (s (ipc:open-network-stream :host *myself* :port port))
    (format s "~A~%" str)
    (force-output s) ))

(defvar *test-process* nil)

(defun test-port-daemon (tcp-stream)
  (let ((str (read-line tcp-stream)))
    (format t "Got ~S~%" str) ))

(defun setup-test-daemon (port)
  (when *test-process*
    (ipc::kill-lisp-server-process *test-process*) )
  (setq *test-process*
    (ipc::start-lisp-server-process
     :server-name "Test Daemon" :function #'test-port-daemon
     :inet-port port :raw-connection t ) ))

;;;----------------------------------------------------------------------------

Hope this helps.

	-- Don Geddis
-- 
Don Geddis		"It's too bad that whole families have to be torn apart
Geddis@CS.Stanford.Edu	 by something as simple as wild dogs." -- DT on SNL
Hi, I'm a replicating signature virus!  Join in the fun and copy me into yours!
Newsgroups: comp.lang.lisp