;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.80
;;; Reason:
;;;  Implement simple nicknames for logical hosts.  Use :NICKNAMES keyword on
;;;  FS:SET-LOGICAL-PATHNAME-HOST to add nicknames when defining/modifying a
;;;  logical host.
 FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; PATHST  "


(defmethod (logical-host :nicknames) ()
  (send self :get 'nicknames))

))

; From modified file DJ: L.IO.FILE; PATHST.LISP#218 at 13-Sep-88 19:25:13
#8R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; PATHST  "


(defmethod (logical-host :host-names) ()
  (append (send self :nicknames)
	  (ncons (send self :name))))

))

; From modified file DJ: L.IO.FILE; PATHST.LISP#218 at 13-Sep-88 19:25:14
#8R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; PATHST  "


(defmethod (logical-host :set-nicknames) (nicknames)
  (send self :putprop (mapcar #'string nicknames) 'nicknames))

))

; From modified file DJ: L.IO.FILE; PATHST.LISP#218 at 13-Sep-88 19:25:16
#8R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; PATHST  "


(defmethod (logical-host :pathname-host-namep) (testname)
  (car (mem #'string-equal testname (send self :host-names))))

;;;; Actual installation and use of translations.

))

; From modified file DJ: L.IO.FILE; PATHST.LISP#218 at 13-Sep-88 19:25:19
#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 nicknames)
  "Define a logical host named LOGICAL-HOST, which translates to PHYSICAL-HOST.
NICKNAMES is a list of strings, nicknames for LOGICAL-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)."
  (declare (zwei:indentation 1 1))
  (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))))
	   ;;Changed (get-pathname-host ... NIL) - Don't want "unknown" physical hosts
	   ;;getting added for logical hosts!!! Causes bad brains. -KmC
	   (unless (setq phys (or (get-pathname-host physical-host nil)
			       (si:parse-host physical-host)))
		;;Also continue only if we have physical host -- don't add to list
		;;if it isn't real. -KmC
		(error "Cannot define logical host without corresponding physical host"))
	   (unless log (setq log (make-instance 'logical-host :name logical-host)))
	   ;;The new logical host must be accessible via GET-PATHNAME-HOST now
	   (pushnew log *logical-pathname-host-list* :test 'eq))
    ;; 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
    ;;
    ;;;Add physical host
    (send log :set-physical-host phys)
    ;;;Add nicknames to existing host
    (dolist (name nicknames)
      (let ((test (get-pathname-host name t t)))
	(when (and test (neq test log))
	  (warn "Not using existing host name ~A as nickname for ~A" name logical-host)
	  (setq nicknames (lisp:delete name nicknames :test #'string-equal)))))
    (when nicknames
      (send log :set-nicknames
	    (mapcar #'string
		    (lisp:union (send log :nicknames) nicknames :test #'string-equal))))
    ;;;Add translations
    (if translations
	(send log :set-translations
	      (loop for trans in translations
		    collect (decode-translation log (car trans) (cadr trans)))))
    log))

))