;;
;;
;;
;; Copyright (c) 1986-1996 Franz Inc, Berkeley, CA
;;
;; Allegro CL IPC interface
;;
;; This code is provided to licensed users of Allegro CL as an example
;; and for restricted reuse.

;;; This is part of ipc.cl, modified to support the use of Allegro Cl with
;;; the GclTk interface by Bill Shelter

(in-package :tk)

(ff:defcstruct sockaddr-in
  (family :unsigned-short)		; short sin_family
  (port :unsigned-short)		; u_short sin_port
  (addr :unsigned-int)			; struct in_addr sin_addr
  (zero 8 :char)			; char sin_zero[8]
  )

(ff:defcstruct (hostent :malloc)
  (name * :char)			; char *h_name
  (aliases * * :char)			; char **h_aliases
  (addrtype :int)			; int h_addrtype
  (length :int)				; int h_length
  (addr * :char)			; char *h_addr   --or--
					; char **h_addr_list (for SunOS 4.0)
  )

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


(ff:defcstruct unsigned-int
  (unsigned-int :unsigned-int))


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


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


;;; this is very much reduced to do only what I need for GclTk-CMU



(defun setup-gcltk-connection (host can-rsh gcltksrv display args)
  (block good-news
  (block bad-news
    (let (listen-socket-fd
	  client-address
	  inet-port
	  (listen-sockaddr
	   (let ((sin (ff:make-cstruct 'sockaddr-in)))
	     (excl::memset sin 0 (ff::cstruct-length 'sockaddr-in))
	     sin))
	  (int (ff:make-cstruct 'unsigned-int))
	  stream
	  fd)
      
      (unwind-protect
	  (progn
	    (setq listen-socket-fd (ipc::socket *af-inet*
				    *sock-stream*
				    0))
	    (when (< listen-socket-fd 0)
	      (ipc::perror "socket")
	      (setq listen-socket-fd nil)
	      (return-from bad-news))

	    (mp:waiting-for-input-available (listen-socket-fd)
	       (setf (sockaddr-in-family listen-sockaddr) *af-inet*)
	       (do ((port 1024 (1+ port)))
		   ((progn
		      (setf (sockaddr-in-port listen-sockaddr)
			    (ipc::lisp_htons (setq inet-port port)))
		      (zerop (ipc::bind listen-socket-fd
					listen-sockaddr
					(ff::cstruct-length 'sockaddr-in)))))
		 (when (= port 2048)
		      (ipc::perror "bind") (return-from bad-news)))
 
	       (start-gcltk-server host can-rsh gcltksrv inet-port
				  display args)
	     (unless (zerop (ipc::unix-listen listen-socket-fd 5))
	       (ipc::perror "listen") (return-from bad-news))
	     
	     (setf (unsigned-int-unsigned-int int)
	       (ff::cstruct-length 'sockaddr-in))
	     (setf fd
		   ;;for some reason, allegro sparc returns from accept after few
		   ;;seconds, not waiting for a connection, but without error message
		   ;;from perror. This helps, but hangs if there is a different error.
		   ;;If I could read errno, I could test for the reason...
	       #+sparc (do
			   ((fd (ipc::accept listen-socket-fd listen-sockaddr int)
				(ipc::accept listen-socket-fd listen-sockaddr int)))
			   ((> fd -1) 
			    (setq client-address
				  (ipc::format-in-addr nil (sockaddr-in-addr listen-sockaddr)))
			    fd))
	       #-sparc (prog1 (ipc::accept listen-socket-fd listen-sockaddr int)
			 (setq client-address
			       (ipc::format-in-addr nil (sockaddr-in-addr listen-sockaddr))))
	       )
	     (when (< fd 0) (ipc::perror "accept") (return-from bad-news))
	     (setq stream
		   (ipc::make-ipc-terminal-stream
		    fd
		    :element-type 'character
		    :class 'stream:bidirectional-terminal-stream
		    :pretty-id (format nil "from ~a" client-address)))
	     
	     (return-from good-news
	       (make-cs
		:stream stream
		:fd fd
		:port inet-port) ;this is actually port#
	       ))))))
  (error "couldn't start listener daemon")))








