;;; -*- Mode:Common-Lisp; Package:IP; Base:10; Fonts:(COURIER TR12I TR12BI TR12 MEDFNTB); Patch-file:T -*-

;1 File name: TCP-MEDIUM.LISP*
;1 Redfines the CONNECT function for TCP Streams*
;1 Started 3-9-1989 by Eric Karlson, UC-Berkeley under Robert Wilensky*
;1 Phone: (415) 642-9076, E-mail Address: karlson@ucbarpa.berkeley.edu*

;1-----------------------------------------------*
;1 Redefine the TCP-STREAM-CONNECT function*
;1-----------------------------------------------*

(defun 4tcp-stream-connect-function* (host logical-contact-name connection
				       &key (connect-string "") (stream-type :character-stream) (timeout 600)
				       (error t) (timeout-after-open 18000) window-size (local-port 0)
				       &allow-other-keys)
"2The function used to create TCP Stream Connections.*"
  (declare (function tcp-stream-connect-function
		     (net:HOST STRING T &rest LIST &key STRING T FIXNUM T FIXNUM (or NULL FIXNUM) FIXNUM)
		     STREAM)
	   (values TCP-STREAM))
  (let ((port (net:translate-logical-contact-name logical-contact-name :tcp))
	(stream-type (net:find-stream-type-flavor stream-type :tcp-stream))
	(addresses (send host :network-address-list :ip)))
    (declare (type (or NULL FIXNUM) port)
	     (LIST addresses)
	     (LIST stream-type))

    (when port
      (do ((address addresses (rest addresses)))
	  ((null address))
	(declare (LIST address))
	(condition-case-if (second address) ()
	    (progn
	     (setf connection
		   (open-stream (first address)
				:local-port local-port
				:remote-port port
				:direction (first stream-type)
				:characters (second stream-type)
				:timeout (and timeout (floor timeout 60))
				:timeout-after-open (and timeout-after-open (floor timeout-after-open 60))
				:input-buffer-size (or window-size *DEFAULT-TCP-STREAM-INPUT-BUFFER-SIZE*)
				:error error))
	     (unless (errorp connection)
	       (unless (string-equal connect-string "")
		 (write-string connect-string connection)
		 (send connection :force-output)))
	     (return-from tcp-stream-connect-function connection))
	  (sys:network-error))))))