;;; -*- Mode:LISP; Package:USER; Readtable:ZL; Base:8; Patch-File:T -*-
;;; Private patches made by keith
;;; Reason:
;;; Fix problems using si:set-sys-host and (update-site-configuration-info).
;;; 
;;; In FS:SET-LOGICAL-PATHNAME-HOST:
;;;   1) Get rid of code that pushed the new host on the FS:PATHNAME-HOST-LIST.
;;;   2) Don't allow "unknown" hosts to be assigned to logical hosts.
;;; In SI:SET-SYS-HOST:
;;;   3) Uppercase the input host name.
;;;   4) Shadow-bind PATHNAME-HOST-LIST, so we never cache a temporary
;;;   host.
;;;
;;; #1,3,4 above fix a problem that arised if you set sys host to an
;;; unknown host, unless you specified the
;;; actual primary host name in upper case; you could generate a serious
;;; problem, such that the temporary host object generated by
;;; set-sys-host got remembered on the fs:*pathname-host-list*.  This
;;; meant you had two non-EQ versions of the same host!  Symptoms were
;;; very strange, and hard to work around; basically, connections to the
;;; sys host failed in various spectacular ways.
;;;
;;; #2 fixes a problem with logical pathnames:
;;; SET-LOGICAL-PATHNAME-HOST and its callers formerly allowed an unknown
;;; host to be created.  This can prevent you from adding/redefining the
;;; host later.  Now, error out when an unknown host is specified.

Written 6-Jan-88 19:07:16 by keith (Keith Corbett) at site LMI
;;; while running on Opus from band 1
;;; with Experimental System 123.174, Experimental Local-File 73.3, Experimental FILE-Server 22.1, Experimental Unix-Interface 11.0, Experimental Tape 18.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Tiger 27.0, Experimental Site Data Editor 8.4, Experimental Laser1+ 2.0, microcode 1754, SDU Boot Tape 3.14, SDU ROM 8, Beta I/site/dvi.



; From modified file OPUS: L.IO.FILE; PATHST.LISP#212 at 6-Jan-88 19:09:54
#8R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; PATHST  "


(defun set-logical-pathname-host (logical-host &key physical-host translations)
  "Define a logical host named LOGICAL-HOST, which translates to PHYSICAL-HOST.
TRANSLATIONS is a list of translations to use: each element looks like
 (logical-pattern physical-pattern),
 where each pattern is a file namestring with wildcards.
 Omitted components default to * (:WILD)."
  (let (log phys)
    (tagbody
	retry
	   (setq log (get-pathname-host logical-host t nil))
	   (unless (typep log '(or null logical-host))
	     (multiple-cerror () () ("~Creating the logical host with name /"~A/"
will override that name for the physical host ~S,
making /"~:2*~A/" unacceptable as a name for the physical host~" logical-host log)
	       ("Create the logical host anyway"
		(setq log nil))
	       ("Don't create the logical host"
		(return-from set-logical-pathname-host nil))
	       ("Supply a new name for the logical host"
		(let ((*query-io* *debug-io*))
		  (setq logical-host
			(string-upcase (prompt-and-read :string-trim
							"New name for logical host: "))))
		(go retry))))
	   ;;Chnaged (get-pathname-host ... NIL) - Don't want "unknown" physical hosts
	   ;;getting added for logical hosts!!! Causes bad brains. -KmC
	   (setq phys (or (get-pathname-host physical-host nil)
			  (si:parse-host physical-host)))
	   ;;Also do this below after getting physical host -- don't add to list
	   ;;if it isn't real. -KmC
	   (unless log
	     (setq log (make-instance 'logical-host :name logical-host))
	     (push log *logical-pathname-host-list*)))
    ;; Here is a bit of a kludge for SI:SET-SITE.  If the physical host is not defined yet,
    ;; add it now.
    ;;(unless (typep phys 'logical-host)
    ;;  (pushnew phys *pathname-host-list* :test 'eq))
    ;;**** NO! Also wrong, and extremely dangerous.   All I know, this is part of
    ;;what caused a si:set-sys-host to a previously unknown host to lay a bomb:
    ;;you can end up with non-EQ phys's (one on si:host-alist and another
    ;;one on *pathname-host-list*).  This occurred if you don't happen to type in
    ;;the exact (case-matching) real name of the sys host.  After doing
    ;;(update-site-configuration-info), the world went mad -- can't get at the
    ;;physical host anymore.  A fix was also needed in set-sys-host.
    ;;-KmC 1/6/88
    (send log :set-physical-host phys)
    (if translations
	(send log :set-translations
	      (loop for trans in translations
		    collect (decode-translation log (car trans) (cadr trans)))))
    (pushnew log *logical-pathname-host-list* :test 'eq)
    log))

))

; From modified file OPUS: L.SYS; QMISC.LISP#730 at 6-Jan-88 19:48:31
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QMISC  "

(DEFUN SET-SYS-HOST (HOST-NAME &OPTIONAL OPERATING-SYSTEM-TYPE HOST-ADDRESS SITE-FILE-DIRECTORY
		     &AUX HOST-OBJECT)
  "Specify the host to read system files from.
You can specify the operating system type (a keyword), host address, and the directory
for finding the site files, in case the system does not know that host yet."
  (and (stringp host-name)
       (setq host-name (string-upcase host-name)))
  (CHECK-TYPE HOST-NAME (OR STRING HOST) "a host name")
  ;; DWIM the operating system type for those who insist...
  (when (and operating-system-type
	     (typep operating-system-type '(or string (and symbol (not keyword)))))
    (setq operating-system-type
	  (intern (string-upcase (string-trim " " (string operating-system-type)))
		  'keyword)))
  (CHECK-ARG OPERATING-SYSTEM-TYPE (OR (NULL OPERATING-SYSTEM-TYPE)
				       (GET OPERATING-SYSTEM-TYPE 'SYSTEM-TYPE-FLAVOR))
	     "an operating system type")
  (AND (SETQ HOST-OBJECT (OR (FS:GET-PATHNAME-HOST HOST-NAME T NIL)
			     (si:PARSE-HOST HOST-NAME T NIL)))
       OPERATING-SYSTEM-TYPE
       (NEQ OPERATING-SYSTEM-TYPE (SEND HOST-OBJECT :SYSTEM-TYPE))
       (FERROR "~A is ~A, not ~A." HOST-OBJECT
	       (SEND HOST-OBJECT :SYSTEM-TYPE) OPERATING-SYSTEM-TYPE))
  (cond ((null host-address)
	 (unless host-object
	   (error "No address specified, but unknown host")))
	((stringp host-address)
	 (setq host-object (funcall (get 'si:new-host-validation-function :internet)
				    (or host-object host-name) operating-system-type host-address)))
	((numberp host-address)
	 (setq host-object (funcall (get 'si:new-host-validation-function :chaos)
				    (or host-object host-name) operating-system-type host-address)))
	(t
	 (error "Unrecognizable address ~A" host-address)))
  ;; FS:MAKE-LOGICAL-PATHNAME-HOST property T lets this host be redefined.
  ;; But we don't want to put it on the fs:*pathname-host-list* -
  ;; see SET-LOGICAL-PATHNAME-HOST. (kmc)
  (let((fs:*pathname-host-list* fs:*pathname-host-list*))
    (send (fs:set-logical-pathname-host "SYS" :physical-host host-object :translations
					(if site-file-directory
					    `(("SITE" ,site-file-directory) ("CHAOS" ,site-file-directory))
					  '()))
	  :set :get 'fs:make-logical-pathname-host t))
  T)
))

#| Forms for testing:

(defun kk()
  (setq fs:*pathname-host-list*
	(remove-if #'(lambda(host)(when (typep host 'si:host)(print host) t)) fs:*pathname-host-list*))
  (let((syshost (send (fs:get-pathname-host "SYS") :host)))
    (when syshost
      (setq si:host-alist
	    (remove-if #'(lambda(hostl)
			   (cl:intersection
			     (send syshost :host-names)
			     (send (second hostl) :host-names)
			     :test #'string-equal))
		       si:host-alist))))
	)

(defun pp()
  (let((stars (make-string 60 :Initial-element #\*)))
    (princ stars)(terpri)
    (pprint fs:*pathname-host-list*)
    (princ stars)(terpri)
    (pprint si:host-alist)))

|#