;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*- ;;; Patch file for System version 124.43 ;;; Reason: ;;; Fixes found while examining Server FTP error messages: ;;; - When connection is refused for a tcp-stream, print the host ;;; name rather than just a raw address. ;;; - (open "tcp-host:167344452.123") should open host "167344452" ;;; and remote port "123". Didn't parse right for that... ;;; - (tcp-socket :open) with local-port already in use said ;;; "local-port T already in use" -- backwards arguments to format. ;;; Written 9-Jun-88 13:11:39 by pld (Peter L. DeWolf) at site Gigamos Cambridge ;;; while running on Cthulhu from band 1 ;;; with Experimental System 124.41, Experimental Local-File 74.1, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones. ; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP-STREAM.LISP#62 at 9-Jun-88 13:11:40 #10R TCP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP-STREAM  " (defmethod (tcp-stream-mixin :open) (&optional keyword &rest args) (setq args (copy-list args)) (let* ((host-list (member :remote-address args :test #'eq)) (host (second host-list)) (user-timeout (member :send-timeout args :test #'eq)) (current-timeout (* 30 60)) (open-socket (null args))) (setq args (append args `(:auto-push ,auto-push))) (if user-timeout (setq current-timeout (second user-timeout)) (setq args (append args `(:send-timeout ,current-timeout)))) (when (null socket) (setq socket (make-tcp-socket :keyword keyword))) (setq closing nil) (cond (open-socket ;Is socket already open? (setq open t) (send self :build-buffers) self) (t ;If user specified open keywords, open socket (flet ((host-name (host) (and (stringp host) (not (global:string-search-not-set "0123456789" host)) (setq host (global:parse-number host))) (cond ((numberp host) (let ((object (si:get-host-from-address host :internet))) (if object (send object :name) (canonical-ip host)))) ((typep host 'si:host) (send host :name)) (t host)))) (loop (setq open (apply socket :open args)) (if (tcp:tcp-user-active socket) (ecase (send self :handle-replies) (:open ;All is well! (return self)) (:unreachable (cerror "Try again." "Remote Host ~S is unreachable" (host-name host))) (:reset (cerror "Try again." "Connection refused by ~S" (host-name host))) (:timeout (setq open nil) (send socket :abort) (incf current-timeout current-timeout) (cerror (format nil "Try again with timeout of ~D ticks." current-timeout) "Connection timed out") (let ((user-timeout (member :send-timeout args :test #'eq))) (setf (second user-timeout) current-timeout)))) (return self)))))))) )) ; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; EASY.LISP#27 at 9-Jun-88 13:33:21 #10R TCP-APPLICATION#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP-APPLICATION"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; EASY  " (defun tcp-host-parse-namestring (namestring &optional (start 0) (end (length namestring))) (flet ((skip-dotted-fields (string count test start end &aux (dot start) last-dot) (loop (when (null dot) (return nil)) (and count (zerop count) (return dot)) (unless (funcall test (char string (1+ dot))) (return dot)) (when count (decf count)) (setq last-dot dot) (setq dot (string-search "." string (1+ dot) end)) (when (null dot) (return (cond ((null count) last-dot) ;skipped as many as we could ((zerop count) nil) ;used up all dots (t start))))))) ;didn't find enough (let ((remote-address :wild) (remote-port nil) (local-port nil) (remote-port-start nil) (local-port-start nil) temp) (unless (= start end) (let ((first (char namestring start)) (dot (string-search "." namestring start end)) (pound (string-search "#" namestring start end)) (name-end nil) (remote-port-end nil) (local-port-end nil)) (when (and dot (alphanumericp first)) (if (digit-char-p first) ;skip dotted decimal address (setq dot (skip-dotted-fields namestring 3 #'digit-char-p dot (or pound end))) (setq dot (skip-dotted-fields namestring nil #'alpha-char-p dot (or pound end))))) (setq name-end (or dot pound end)) (setq remote-address (substring namestring start name-end)) (when (and pound dot) (setq local-port-start (1+ pound)) (setq local-port-end end) (setq local-port (substring namestring local-port-start local-port-end))) (setq remote-port-start (cond (dot (1+ dot)) (pound (1+ pound)))) (when remote-port-start (setq remote-port-end (if local-port-start pound end)) (setq remote-port (substring namestring remote-port-start remote-port-end))))) (cond ((null remote-port)) ((setq temp (global:parse-number remote-port)) (setq remote-port temp)) ((and (setq temp (global:intern-soft (string-append "IPPORT-" (string-upcase remote-port)) "TCP-APPLICATION")) (sym-boundp temp)) (setq remote-port (sym-value temp))) (t (global:ferror :parse-pathname-error "Bad REMOTE-PORT specification \"~A\" in: ~S" remote-port namestring))) (cond ((null local-port)) ((setq temp (global:parse-number local-port)) (setq local-port temp)) ((and (setq temp (global:intern-soft (string-append "IPPORT-" (string-upcase local-port)) "TCP-APPLICATION")) (sym-boundp temp)) (setq local-port (sym-value temp))) (t (global:ferror :parse-pathname-error "Bad LOCAL-PORT specification \"~A\" in: ~S" local-port namestring))) (values :unspecific :unspecific (or remote-address :wild) ;name == remote address (or remote-port :wild) ;type == remote port (or local-port :wild))))) ;version == local port )) ; From modified file DJ: L.NETWORK.IP-TCP.KERNEL; TCP.LISP#294 at 9-Jun-88 13:37:07 #10R TCP#: (COMPILER-LET ((*PACKAGE* (GLOBAL:PKG-FIND-PACKAGE "TCP"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; IP-TCP; KERNEL; TCP  " (defop (tcp-socket :open) (&key active local-port remote-port remote-address auto-push (optimistic t) open-timeout send-timeout ip-header-options (initial-gauges nil ig-p) gauge-name &aux header parsed-remote-address) (unless (tcp-user-enabled self) (when (tcp-enabled *tcp-stream*) (assert (or (setq parsed-remote-address nil) ;This branch always fails, but reinitializes local (cond ((null remote-port) ;;If no remote-port, must be inactive and have no remote-address (and (not active) (null remote-address))) ((setq parsed-remote-address (parse-internet-address remote-address)) ;;If have a remote-port, remote-address must be valid AND remote-port must be valid (typep remote-port '(unsigned-byte 16))) (t ;;If remote-port and remote-address invalid, error nil))) (remote-port remote-address) "~[Active connection must specify both REMOTE-PORT and REMOTE-ADDRESS~;REMOTE-PORT ~D out of range~;REMOTE-ADDRESS ~S unknown~;REMOTE-PORT and REMOTE-ADDRESS must be both nil or both non-nil~]" (cond ((null remote-port) (if active 0 3)) (parsed-remote-address 1) (t 2)) (if parsed-remote-address remote-port remote-address)) (if local-port (assert (and (typep local-port '(unsigned-byte 16)) (unused-local-port local-port remote-port remote-address)) (local-port) "LOCAL-PORT ~D is ~:[out of range~;already in use~]" local-port (typep local-port '(unsigned-byte 16))) (setq local-port (assign-local-port remote-port remote-address))) (setf (SND.UNA self) 0) (setf (SND.NXT self) 0) (setf (SND.WND self) 0) (setf (SND.UP self) nil) (setf (SND.WL1 self) 0) (setf (SND.WL2 self) 0) (setf (ISS self) 0) (setf (RCV.NXT self) 0) (setf (RCV.WND self) 0) (setf (RCV.UP self) nil) (setf (IRS self) 0) (setf (tcp-user-active self) active) (setf (tcp-user-fully-specified self) (not (null remote-port))) (setf (tcp-user-local-port self) local-port) (setf (tcp-user-remote-port self) remote-port) (setf (tcp-user-remote-address self) parsed-remote-address) (setf (tcp-user-packet-list self) (make-fifo)) (setf (tcp-user-saved-packets self) (make-fifo)) (let ((buffer (get-tcp-buffer))) (push-fifo (make-rcv-data :buffer buffer :holes (ncons (cons 0 (1- (array-length buffer))))) (tcp-user-saved-packets self))) (setf (tcp-user-smoothed-round-trip-time self) nil) (setf (tcp-user-retransmission-timeout self) *rto-lbound*) (setf (tcp-user-send-data self) (make-fifo)) (setf (tcp-user-send-data-length self) 0) (setf (tcp-user-send-data-offset self) 0) (setf (tcp-user-receive-data self) (make-fifo)) (setf (tcp-user-receive-data-length self) 0) (setf (tcp-user-receive-data-offset self) 0) (setf (tcp-user-auto-push self) auto-push) (setf (tcp-user-push-sequence-number self) NIL) (setf (SND.LAST self) 0) (setf (RCV.LAST self) 0) (setf (tcp-user-gauge-name self) (or gauge-name (format nil "TCP ~D" (tcp-user-local-port self)))) (array-initialize (tcp-user-statistics-block self) 0) (array-initialize (tcp-user-stats self) 0 1) (dolist (g (tcp-user-inactive-gauges self)) (send (cdr g) :set-margin-name (tcp-user-gauge-name self))) (when ig-p ;;If initial-gauges specified, NIL means no gauges, T means default, anything else specifies gauges ;;The reason to add no gauges is to have the statistics block looked at by the clock function (if (eq initial-gauges t) (setq initial-gauges '(:apr :aps :abr :abs))) (set-gauges (tcp-user-statistics-block self) (locf (tcp-user-active-gauges self)) (locf (tcp-user-inactive-gauges self)) (tcp-user-gauge-name self) initial-gauges) (add-network-statistics-block (tcp-user-statistics-block self))) (setf (tcp-user-remote-mss self) 536) ;The default MSS (setq header (apply 'make-ip-header (append ip-header-options (if parsed-remote-address `(:destination ,parsed-remote-address)) '(:ttl 60) ;drop segments after 60 seconds `(:protocol ,tcp-protocol)))) (setf (tcp-user-ip-header self) header) (multiple-value-bind (precedence security compartment handling tcc) (find-security-and-precedence header) (setf (tcp-user-precedence self) precedence) (setf (tcp-user-security-options self) (list security compartment handling tcc))) (setf (tcp-user-open-timeout self) open-timeout) (setf (tcp-user-send-timeout self) send-timeout) (setf (tcp-user-cumulative-timeout self) 0) (setf (tcp-user-last-time self) nil) (setf (tcp-user-timeout-alist self) nil) (setf (tcp-user-rtt-sequence-time-alist self) nil) (setf (tcp-user-closed-p self) nil) (setf (tcp-user-local-fin-sequence-number self) nil) (setf (tcp-user-remote-fin-sequence-number self) nil) (setf (tcp-user-lock self) nil) (setf (tcp-user-discard-p self) nil) (setf (tcp-user-optimistic-window-p self) optimistic) (setf (tcp-user-ack-needed-p self) nil) (setf (tcp-user-ack-delay self) *ack-delay*) (setf (tcp-user-fin-needed-p self) nil) (push (cons local-port self) (tcp-user-socket-alist *tcp-stream*)) (tcp-log :open self) (cond (active (tcp-stat-incf nil out-connection-requests) (set-interface-mss self parsed-remote-address header) (setf (RCV.WND self) (if optimistic ;Initial window includes one max packet (tcp-user-interface-mss self) 0)) (change-state self :SYN-SENT) (setf (ISS self) (choose-iss)) (setf (SND.UNA self) (ISS self)) (setf (SND.NXT self) (ISS self)) (setf (SND.LAST self) (ISS self)) (send-tcp-packets self)) (t (tcp-stat-incf nil in-connection-requests) (change-state self :LISTEN) (when open-timeout (start-timeout open-timeout 'listen-timeout self)))) local-port))) ))