;;; -*- Mode:LISP; Package:SITE-DATA-EDIT; Readtable:CL; Base:10 -*-
;;; Copyright (c) Lisp Machine Inc., 1986.

(defvar *need-to-look-at-external-data* t)

(defun forget-buffered-data ()
  (setq *need-to-look-at-external-data* t
	*store-alist* '()
	*machine-location-alist* nil
	*site-name* nil
	*site-option-alist* nil))

(defvar *data-loaded-once-p* nil)

(defun reset-for-next-boot ()
  (forget-buffered-data)
  (setq *data-loaded-once-p* nil))

(add-initialization "Site Editor Data Decache"
		    '(flush-database)
		    '(:site-option :normal))

(add-initialization "Forget Site Editor Data" '(reset-for-next-boot) '(:before-cold))
(add-initialization "Forget Site Editor Data" '(forget-buffered-data) '()
		    'gc:full-gc-initialization-list)
  

(defmacro writing-lisp-site-file ((stream filename) &body body)
  `(with-open-file (,stream ,filename :direction :output)
     (with-standard-lisp-io-parameters
       (let ((*package* (find-package 'si)))
	 (format ,stream ";;; -*- Mode:Lisp; Package: ~A; Base: ~D; Readtable: ~A; patch-file: t -*-
;;; This file (~A) was generated by the Site Data Edit program.~%"
		 *package* *print-base* (second (si::rdtbl-names *readtable*)) (truename ,stream))
	 (si::write-responsibility-comment ,stream)
	 ,@body))))

(defvar *machine-location-alist-file* "SYS: SITE; LMLOCS LISP >")
(defun dump-machine-location-alist (alist &optional (file *machine-location-alist-file*))
  (writing-lisp-site-file (o file) 
    (format o "(~S ~S '(~%" 'defconst 'si::machine-location-alist)
    (dolist (me alist)
      (when (me-pretty-name me)
	(format o "  (~S ~S~40T~S ~S~%   ~S~%   (" ; open paren for local options
		(me-name me) (me-pretty-name me) (me-finger-location me) (me-location me)
		(me-associated-machine me))
	(dolist (option (me-options me))
	  (format o "(~S " (car option))
	  (unless (self-evaluating-p (cadr option))
	    (write-char #\' o))
	  (format o "~S)~%    " (cadr option)))
	(format o "))~2%")))
    (write-line " ))" o)))


(defvar *site-option-file* "SYS: SITE; SITE LISP >")
(defun dump-site-options (alist &optional (file *site-option-file*))
  (writing-lisp-site-file (o file)
    (format o "(~S ~S~%" 'si::defsite *site-name*)
    (dolist (entry alist)
      (let ((symbol (car entry)) (value (cdr entry)))
	(format o "  (~S " symbol)
	(unless (self-evaluating-p value)
	  (write-char #\' o))
	(format o "~S)~%" value)))
    (write-line "  )" o)))

;;; Saving out the data
(defun save-as-site-files ()
  (let ((*machine-location-alist* nil)
	(*site-option-alist* nil))
    (do-all-objects (o) (send o :dump-to-site-info))
    (setq *machine-location-alist* (sortcar *machine-location-alist* #'string<))
    (dump-machine-location-alist *machine-location-alist*)
    (dump-site-options *site-option-alist*)
    (write-hosts2-table)))

;;; Main window

(defvar *site-editor-frame* :unbound
  "If there's a Site Editor frame, this is it -- there's only one.
Call SITED:SITED to create it.")

;;; Menu Commands

(defvar *main-menu-commands* '())

(defun set-menu-command (function item)
  (let ((sublist (member function *main-menu-commands* :key #'(lambda (i) (get i :funcall)))))
    (if sublist
	(setf (car sublist) item)
      (push item *main-menu-commands*)))
  (if (and (boundp '*site-editor-frame*)
	   *site-editor-frame*)
      (send *site-editor-frame* :sort-menu-commands))
  function)
  
(defmacro defcommand (function menu-string documentation &body body)
  `(progn
     (defun ,function () ,@body)
     (set-menu-command ',function
		       '(,menu-string :funcall ,function :documentation ,documentation))))

;;; Menu Comments

(defvar *menu-comment-font* fonts:tr10i)

(defun set-menu-comment (item &optional documentation)
  (let ((sublist (member item *main-menu-commands* :test #'string-equal :key #'car))
	(item2 (if (stringp item) `(,item
				    :no-select t
				    :documentation ,documentation
				    :font ,*menu-comment-font*)
		 item)))
    (if sublist
	(setf (car sublist) item2)
      (push item2 *main-menu-commands*))
    (if (boundp '*site-editor-frame*)
	(send *site-editor-frame* :sort-menu-commands))
    item2))

(defmacro defcomment (item documentation)
  `(set-menu-comment ,item ,documentation))

;;; Panes

(defvar *edit-pane*)
(defvar *typeout-pane*)
(defvar *menu-pane*)

(defun _help ()
  (format *typeout-pane* "~:|You are using the Site Data Editor.~%
The basic idea is to select objects (like printers, the site, or hosts) and edit
their attributes.  When you have made a desired change to an object, you save
the changes to that object.  Then you can save out the new site files after you
have completed all the changes.

You can figure out how edit the attributes by paying attention to the who-line
documentation.  Be aware that some attributes can appear more than once or be
deleted.  Menus are used for choices among a set of alternatives.

The major commands appear in the Command Menu:~2%")

  (dolist (c *main-menu-commands*)
    (when (neq (second c) :no-select)
      (format *typeout-pane* "~A: ~A~%" (car c) (get c :documentation))))
  (format *typeout-pane* "~%See the Site Data Editor guide for more information.~2%"))

(defflavor menu-pane
	   ()
	   (tv:command-menu)
  (:default-init-plist
    :borders 5
    :border-margin-width 3
    :label nil
    :font-map (list fonts:tr12b)
    :default-font fonts:tr12b))

(defmethod (menu-pane :constraint-size) (&rest ignore)
  (* (+ (length (send self :item-list))	3)
     (send self :line-height)))

(defmethod (menu-pane :sort-menu-commands) (&optional (commands *main-menu-commands*))
  (let ((preferred '("-- Site Editor Database --"
		     "Flush Database" "Reload"
		     "-- External Site Files --"
		     "Point to Site Files"
		     "Load Site Files" "Save Site Files"
		     "Compile Files"
		     "-- Editing Objects --"
		     "Edit" "Copy" "Delete" "Save Object Changes"
		     "-- Special Commands --"
		     "Parameters"
		     "Configure Window")))
    (send self :set-item-list
	       (sort (copy-list commands)
		     #'(lambda (a b)
			 (when (zl:mem #'string-equal (car a) preferred)
			   (> (length (zl:mem #'string-equal (car a) preferred))
			      (length (zl:mem #'string-equal (car b) preferred)))))))))

;;; The site editor frame

(defflavor site-editor-frame ()
           (tv:inferiors-not-in-select-menu-mixin tv:alias-for-inferiors-mixin
	    process-mixin select-mixin bordered-constraint-frame-with-shared-io-buffer
	    tv:top-box-label-mixin)
           (:default-init-plist
	     :panes `((edit-pane object-editor-window
				 :margin-scroll-regions ((:top) (:bottom)))
		      (typeout-pane tv:window :save-bits t
				    :blinker-p :blink
				    :blinker-deselected-visibility :off
				    :label "Site Editor Interaction Pane"
				    :name "Site Editor Interaction Pane")
		      (command-menu menu-pane
				    :deexposed-typein-action :normal
				    :deexposed-typeout-action :permit
				    :label "Commands"
				    :save-bits t
				    :item-list ,*main-menu-commands*))
	     :constraints
	     '((expert (command-menu edit-pane typeout-pane)
		       ((command-menu :ask :pane-size))
		       ((typeout-pane 12 :lines))
		       ((edit-pane :even)))
	       (longmenu (whole)
			 ((whole :horizontal (:even)
				 (left black right)
				 ((left :vertical (:ask-window command-menu :constraint-size)
					(command-menu)
					((command-menu :even))))
				 ((black :blank :black 0.02s0))
				 ((right :vertical (:even)
					 (edit-pane typeout-pane)
					 ((typeout-pane 12 :lines))
					 ((edit-pane :even)))))))
	       (normal (top bottom)
		       ((bottom :horizontal (24 :lines typeout-pane)
				(blank2 typeout-pane)
				((blank2 :blank :black 0.01s0))
				((typeout-pane :even))))
		       ((top :horizontal
			       (:even)
			       (command-space blank1 edit-pane)
			       ((command-space :vertical (:limit (300) :ask-window command-menu :constraint-size)
				  (blank4 command-menu blank5)
				  ((command-menu :ask :pane-size)
				   (blank4 :blank :black 0.1s0)
				   (blank5 :blank :black :even))))
			       ((blank1 :blank :black 0.02s0))
			       ((edit-pane :even))))
		       ))
	     :name "Site Editor"
	     :process '(command-loop)
	     :configuration (configure-appropriately)))

(defvar *initial-frame-configuration* 'normal)

(defun configure-appropriately(&optional (configure *initial-frame-configuration*))
  (if (or (eq configure 'expert) (= (send tv:main-screen :width) 800.))
      'expert
    'normal))

(defmethod (site-editor-frame :sort-menu-commands) (&optional (mode tv:configuration))
  (let ((command-menu (send self :get-pane 'command-menu)))
    (send command-menu :sort-menu-commands
		       ;;Exclude comment items in expert mode
		       (case mode
			 (expert
			  (loop for item in *main-menu-commands*
				as  itype = (second item)
				when (neq itype :no-select)
				collect item))
			 (t *main-menu-commands*)))
    (send command-menu :item-list)))

(defmethod (site-editor-frame :after :init) (ignore)
  (send self :send-all-panes :set-selection-substitute self)
  (multiple-value-bind(major minor)
      (si:get-system-version 'site-editor)
    (send self :set-label
	  `(:string
	     ,(format nil "Lambda Site Data Editor (V. ~:[0~;~d.~d~])"
		      (numberp major) major minor)
	     :font fonts:metsi
	     :centered)))
  (send self :sort-menu-commands))

(defmethod (site-editor-frame :after :kill) (&rest ignore)
  (and (boundp '*site-editor-frame*)
       (eq *site-editor-frame* self)
       (setq *site-editor-frame* nil)))

(defmethod (site-editor-frame :interactor-pane) ()
  (send self :get-pane 'typeout-pane))

(defmethod (site-editor-frame :after :select) (&rest ignore)
  ;;>> How are you sure to get the TEXT blinker ?
  (let ((blinker (car (send self :send-pane 'typeout-pane :blinker-list))))
    (send blinker :set-visibility :blink)))

(defmethod (site-editor-frame :selectable-windows) ()
  `(("Site Editor" ,self)))

(compile-flavor-methods site-editor-frame)

(defvar *menu-button* nil)

(defun read-if-needed ()
  (when *need-to-look-at-external-data*
    (if *data-loaded-once-p*
	(complain "Database needs to be (re)loaded; Use [Reload]")
      (read-outside-data))))

(defun command-loop-process-thing (thing)
  (catch 'abort-edit
    (typecase thing
      ((number character)
       (case (coerce thing 'character)
	 ((#\Help #\?) (_help)) ; not HELP, since that would cause lossage after package-dwim
	 ((#\Control-L #\Clear-Screen)
	  (send *edit-pane* :refresh)
	  (send *typeout-pane* :clear-window))
	 (otherwise (tv:beep 'no-command))))
      (cons 
       (case (first thing)
	 (:menu
	  (let ((*menu-button* (third thing)))
	    (send (fourth thing) :execute (second thing))))
	 (:mouse-button ())
	 (otherwise ; it's a blip to edit an object
	  (send (third thing) :edit-object (first thing) (second thing) (fourth thing)))))
      (t
       (complain "~&What is ~S ?" thing)))))

(defun command-loop (window)
  (let* ((*site-editor-frame* window)
	 (*edit-pane* (send window :get-pane 'edit-pane))
	 (*typeout-pane* (send window :get-pane 'typeout-pane))
	 (*menu-pane* (send window :get-pane 'command-menu))
	 (*terminal-io* (send window :interactor-pane)))
    (error-restart-loop ((error sys:abort) "Return to Site Editor command loop")
      (command-loop-process-thing (send *edit-pane* :any-tyi)))))

(defun complain (format-string &rest format-args)
  (fresh-line *error-output*)
  (tv:beep 'complain)
  (apply #'format *error-output* format-string format-args)
  (terpri *error-output*))

(defun init-site-variables ()
  (let (si:site-name si:site-option-alist)
    (load *site-option-file* :set-default-pathname nil)
    (setq *site-name* si:site-name
	  *site-option-alist* si:site-option-alist))
  (let (si:machine-location-alist)
    (remprop 'si:machine-location-alist :source-file)
    (load *machine-location-alist-file* :set-default-pathname nil)
    (setq *machine-location-alist* si:machine-location-alist)))

(defun read-outside-data ()
  (format t "~&Loading data from:~
             ~%  Site Wide Option Table: ~S~
             ~%  Host    Option   Table: ~S~
             ~%  Host    Address  Table: ~S"
	  *site-option-file*
	  *machine-location-alist-file*
	  *hosts2-table-file*)
  (assure-class-stores)
  (clear-all-stores)
  (init-site-variables)
  (make-printers)
  (make-site *site-name* *site-option-alist*)
  (init-hosts)
  (make-hosts-complete)
  (make-networks)
  (setq *need-to-look-at-external-data* nil)
  (setq *data-loaded-once-p* t))

;;; Menu comments

(defcomment "-- Site Editor Database --" "Options for modifying site editor's view of the world")
(defcomment "-- External Site Files --"  "Options for site files - (re)writing, loading, etc.")
(defcomment "-- Editing Objects --"      "Options for manipulating networks, hosts, printers, etc.")
(defcomment "-- Special Commands --"     "Special options")

;;; Menu commands

(defcommand reload-data "Reload" "Load the latest site information into the editor"
  (if *need-to-look-at-external-data*
    (read-outside-data)
    (progn
      (fresh-line *typeout-pane*)
      (write-line "You actually don't need to reload; use [Flush Database] and
this command again if you really want to do this." *typeout-pane*))))

(defcommand save-site-files "Save Site Files" "Save this site information"
  (when (mouse-y-or-n-p "Save out changes")
    (save-as-site-files)))

#|
(defcommand check-site-configuration "Check Site Configuration"
  "Check the consistency of the site information"
  (complain "Not yet implemented")
  )
|#

(defcommand change-parameters "Parameters"
	    "Change some parameters of the editor."
  (choose-variable-values
    '((*hosts2-table-file* "Chaosnet Host Table Output File" :pathname)
      (*machine-location-alist-file* "\"LMLOCS\" Output File" :pathname)
      (*site-option-file* "\"DEFSITE\" Output File" :pathname)
      (*keyboard-choose-threshold* "Keyboard Choice Threshold"
       :documentation "More than this many items causes the keyboard to be used when choosing"
       :number)
      (*choose-any-character* "Choose-Any Character"
       :documentation "Lifts restrictions on type of an object when choosing with the keyboard"
       :character))
    :label "Site Editor Parameters")
  (SETQ *LISP-HOST-TABLE-FILE*
	(SEND (FS:PARSE-PATHNAME *SITE-OPTION-FILE*) :NEW-NAME
	      (SEND (FS:PARSE-PATHNAME *LISP-HOST-TABLE-FILE*) :NAME))))

(defcommand edit-object "Edit" "Edit a host, network, printer, or this site"
  (read-if-needed)
  (let ((old (editor-window-changed-object *edit-pane*)))
    (unless (and old
		 (not (yes-or-no-p "You have changed ~A; do you want to annul the changes ?"
				   old)))
      (let ((object (choose-any-object :use "to edit")))
	(when object
	  (send *edit-pane* :set-object object)
	  (send *typeout-pane* :clear-window))))))

(defcommand delete-object "Delete" "Delete an object; confirmation is necessary"
  (read-if-needed) ; 'cos you must have something to delete
  (let ((object (choose-any-object :use "to delete")))
    (when object
      (if (send object :deletable-p)
	  (let ((referrers (send object :all-object-referrers)))
	    (if (null referrers)
		(when
		  (tv:mouse-y-or-n-p (format () "Delete ~A" (send object :name)))
		  (send object :remove)
		  (when (eq object (send *edit-pane* :object))
		    (send *edit-pane* :set-object nil)))
	      (progn
		(complain "Some objects are currently referring to this object:")
		(terpri *error-output*)
		(format:print-list *error-output* "~A" referrers)
		(terpri *error-output*))))
	(complain "You can't delete this object.")))))

(defcommand save-object "Save Object Changes" "Save changes to the current object"
  (let ((object (send *edit-pane* :object))
	(deleted (send *edit-pane* :deleted-attributes))
	(changed (send *edit-pane* :changed-attributes)))
    (when object
      (if (not (or deleted changed))
	  (complain "You haven't changed anything.")
	(progn
	  (dolist (a deleted)
	    (send object :delete-property (send a :attribute-symbol) (send a :old-value)))
	  (dolist (a changed)
	    (send object :update-property (send a :attribute-symbol)
		  (send a :value-as-site-attribute) (send a :old-value)))
	  (send object :consolidate-changes)
	  (send *edit-pane* :set-object object)))))) ; refresh, clear changed/deleted attributes

(defcommand copy-object "Copy" "Copy the currently edited object"
  (let* ((o (or (send *edit-pane* :object)
		(return-from copy-object (complain "No current object"))))
	 (new (send o :make-copy)))
    (when new
      (send *edit-pane* :set-object new))))

(defcommand compile-site-files "Compile Files" "Translate and/or Compile the site files now on disk"
  (format t "~&Translating ~A into ~A" *hosts2-table-file* *lisp-host-table-file*)
  (let ((si:*force-package* NIL))
    (net:generate-from-hosts2-table-1 *hosts2-table-file* *lisp-host-table-file*))
  (let ((compiler:*qc-file-output-same-version* nil))
    (dolist (f '(*site-option-file* *machine-location-alist-file* *lisp-host-table-file*))
    (format t "~&Compiling ~A" (symbol-value f))
    (compile-file (symbol-value f))))
  (format t "~&Done~%"))

(defcommand flush-database "Flush Database" "Forget any changes; will need to reload later"
  (when (boundp '*edit-pane*)
    (send *edit-pane* :set-object nil))
  (forget-buffered-data)
  (assure-class-stores))

(defcommand load-site-files "Load Site Files"
	    "Update running configuration information from the current site files"
  (FORMAT T "~&Updating active running configuration from info in disk files~%")
  (REMPROP 'SI:MACHINE-LOCATION-ALIST :SOURCE-FILE-NAME)
  (dolist (f '(*site-option-file* *machine-location-alist-file* *lisp-host-table-file*))
    (LOAD (SEND (FS:PARSE-PATHNAME (SYMBOL-VALUE F)) :NEW-PATHNAME :TYPE "QFASL" :VERSION :NEWEST)
	  :SET-DEFAULT-PATHNAME NIL))
  (FORMAT T "~&Running initializations...")
  (CHAOS:SETUP-MY-ADDRESS) ;; AN INIT, BUT IN WRONG ORDER IN INIT LIST.
  (LET ((SI:HOST-TABLE-FILE-ALIST NIL))
    ;; must bind above to keep reset-non-site-hosts from reading site files again.
    (INITIALIZATIONS 'SI:SITE-INITIALIZATION-LIST T))
  (FORMAT T " done.~%")
  (read-if-needed))

;;; POINT TO SITE FILES command

(defun print-sited-directory-item (dirlist stream)
  (typecase dirlist
    (null (format stream "<unspecified>"))
    (list (format stream "~{~:@(~a~)~^.~};" dirlist))
    ((or string symbol) (format stream "~:@(~a~);" dirlist))
    (t "<---error--->")))

(defun read-sited-directory-item (stream)
  (do ((string (substitute #\. #\; (string-right-trim ";" (readline stream))))
       (i 0 (1+ j))
       (j)
       (string-list nil))
      (nil)
    (when (= (string-length (string-trim ".; " string)) 0) (return nil))
    (setq j (string-search-char #\. string i))
    (push (string-trim '(#\sp #\tab) (nsubstring string i j)) string-list)
    (or j (return (nreverse string-list)))))

(defprop :sited-read-directory
	 (print-sited-directory-item
	  read-sited-directory-item
	  nil nil nil
	  "Click left to enter a new directory. Use standard syntax: 'FOO-DIR;' or 'FOO.DIR.SUBDIR;'")
	   tv:choose-variable-values-keyword)


(defun sys-host-window-option-validation-function(window var old new &aux redisp)
  (declare(special sys-type))
  (setq redisp
	(case var
	    (sys-type
	     (or (and new
		      (typep new '(or string  symbol))
		      (setq sys-type
			    (intern (string-upcase (string-trim " " (string new)))
				    'keyword))
		      (get sys-type 'si:system-type-flavor))
		 (setq sys-type old)))))
  (when redisp
    (send window :refresh)))

(defun set-sys-host-smart(&optional (stream terminal-io))
  (multiple-value-bind (args aborted)
      (get-sys-host-smart)
    (or aborted
	(and (listp args)
	     (let((host (first args))
		  (type (second args))
		  (addr (third args))
		  (sdir (fourth args)))
	       (and
		 (yes-or-no-p
		   (if (or type addr)
		       "Set SYS HOST to host ~a, type ~a, address is ~:[#o~o~;~s~],~%  directory is ~s.~%Confirm: "
		     "Set SYS HOST to local machine; ~4*directory is ~s.~%Confirm: ")
		   host type
		   (not(numberp addr)) addr
		   sdir)
		 (or (not (catch-error (si:parse-host host) nil))
		     (progn
		       (format t "~2%Warning: ~a is already a known host." host)
		       (format t "~%If you try to change its address 'on the fly', SET-SYS-HOST will fail.")
		       (format t "~%Instead, we can generate a phony host name to contact.")
		       (if (y-or-n-p "Just to be safe - use a phony name? ")
			   (setq host (string (let((si:*gensym-prefix* "$syshost"))(gensym))))))
		     t)
		 (or 
		   (catch-error (si:set-sys-host host type addr sdir))
		   (format stream "~%??? SET SYS HOST failed."))
		 (let((file (catch-error (truename "sys:site;sys.translations"))))
		   (if file
		       (progn 
			 (load file)
			 (format stream "~%You probably should load site files, now."))
		     (progn
		       (beep)
		       (format stream "~%??? Warning: SET SYS HOST failed - couldn't load SYS.TRANSLATIONS;"))))))))))

(defun get-sys-host-smart(&optional (stream terminal-io))
  (let((msg-ok "***")
       (msg-ng "???"))
    (case 
      (tv:menu-choose '(local remote)
		      "Is the SYS HOST the LOCAL machine or a REMOTE host?"
		      (list :window stream))
      (NIL (values nil :abort))
      (LOCAL (list "LM" nil nil 
		   (send
		     (fs:translated-pathname
		       (let((default "LM:RELEASE-4.CUSTOMER-SITE;"))
			 (prompt-and-read
			   `(:pathname :defaults ,default)
			   "~%Specify the directory containing site files (~a is default): "
			   default)))
		     :string-for-directory)))
      (REMOTE
       (let(sys-site-translation sys-host-option sys-host
	    sys-host-name sys-type sys-directory
	    which-addr sys-chaos sys-internet)
	 (declare(special sys-host-name sys-type sys-directory
			  which-addr sys-chaos sys-internet))
	 (flet ((valid-host(host)
			   (multiple-value-bind(result error-p)
			       (catch-error (si:parse-host host))
			     (if error-p
				 (format stream "~%~a ~s is not a valid host"))
			     (return-from valid-host
			       (and (not error-p) result)))))
	   ;;Get defaults for current sys host
	   (Or
	     (And (setq sys-site-translation (catch-error (fs:translated-pathname "sys:site;")))
		  (let((ok (and (pathnamep sys-site-translation)
				(setq sys-host (valid-host (pathname-host sys-site-translation)))
				(setq sys-host-name (send sys-host :name))
				(setq sys-type (send sys-host :system-type)))))
		    (format stream "~%~a Current SYS:SITE; translates to ~s"
			    (if ok msg-ok msg-ng)
			    sys-site-translation)
		    (If (not ok)
			(format stream "~& ...which is not a valid host/pathname")
		      sys-host-name)))
	     (format stream "~%~a No translation for SYS: SITE;" msg-ng)
	     (If (setq sys-host-option (si:get-site-option :sys-host))
		 (typecase sys-host-option
		   (string (setq sys-host-name sys-host-option)
			   (setq sys-host (valid-host sys-host-name)))
		   (si:host (setq sys-host-name (send sys-host-option :name))
			    (setq sys-host sys-host-option)))
	       (format stream "~%~a No value for site option :SYS-HOST" msg-ng)))
	   ;;If we got a remote host, set other defaults
	   (cond
	     (sys-host
	      (setq sys-directory (send sys-site-translation :directory))
	      (if (stringp sys-directory) (setq sys-directory (ncons sys-directory)))
	      (setq sys-chaos (send sys-host :chaos-address))
	      (setq sys-internet (car (send sys-host :unparsed-network-addresses :internet)))
	      (setq which-addr (if sys-chaos :chaos :internet)))
	     ;;Got nothing, set defaults
	     (t (setq sys-host-name "LAMA")
		(setq sys-type :lispm)
		(setq sys-directory '("RELEASE-4" "CUSTOMER-SITE"))
		(setq sys-chaos #o3430)))
	   ;;Pop up menu for entering remote host info
	   (let((*print-base* #o10)
		(*read-base* #o10))
	     (tv:choose-variable-values
	       '((sys-host-name
		   "Sys Host Name           " :string)
		 (sys-type
		   "System Host Type        " :sexp
		   :documentation "Click left to enter system type keyword (use :LISPM if in doubt.)")
		 (sys-directory
		   "Site Directory          " :sited-read-directory)
		 ""
		 "Specify which network to use and the address"
		 "  (Chaos is used by preference):"
		 ""
		 (which-addr
		   "Network                 " :choose (:chaos :internet))
		 (sys-chaos
		   "Chaos Address <Octal>   " :number-or-nil)
		 (sys-internet
		   "Internet Address x.x.x.x" :string))
	       :function #'sys-host-window-option-validation-function
	       :label "Enter Sys Host / Site Directory Information")
	     (list
	       sys-host-name
	       (intern sys-type 'keyword)
	       (let((valid-chaos (and (typep sys-chaos '(integer 0))
				      sys-chaos))
		    (valid-internet (and (typep sys-internet 'string)
					 (>= (string-length sys-internet) 7)
					 sys-internet)))
		 (cond
		   ((null (or valid-chaos valid-internet))
		    (ferror "You must specify a valid Chaos or Internet address for the SYS HOST"))
		   ((and (eq which-addr :chaos) valid-chaos))
		   ((eq which-addr :chaos)
		    (if valid-internet
			(progn
			  (cerror "Use the Internet address ~a"
				  "No Chaos address specified for SYS HOST"
				  sys-internet)
			  sys-internet)
		      (ferror "No address specified for SYS HOST")))
		   ((and (eq which-addr :internet) valid-internet))
		   ((eq which-addr :internet)
		    (if valid-chaos
			(progn
			  (cerror "Use the Chaos address #o~o"
				  "No Internet address specified for SYS HOST"
				  sys-chaos)
			  sys-chaos)
		      (ferror "No address specified for SYS HOST")))))
	       (print-sited-directory-item sys-directory nil)))))))))

(defcommand point-to-site-files "Point to Site Files"
	    "Set Sys Host (pointer to site files) and load SYS.TRANSLATIONS"
  (set-sys-host-smart *typeout-pane*))


;;; ;;; Configuration commands

(defcommand config-expert "Configure Window"
	    "Set preferred window configuration"
  (let ((choice (tv:menu-choose '(normal expert)
				"--Choose Configuration--"
				'(:mouse)
				'normal)))
    (when choice
      (let ((mode (configure-appropriately choice)))
	(send *site-editor-frame* :sort-menu-commands mode)
	(send *site-editor-frame* :set-configuration mode)))))

;;; The Site Editor window

(defun sited(&optional (select-p t))
  "Creates the menu-based Site Editor Frame, if one isn't already running.
With SELECT-P non-NIL (the default), selects the window.
Returns the window object corresponding to the Site Editor Frame."
  (prog1
    (if (or (null (boundp '*site-editor-frame*))
	    (null *site-editor-frame*)
	    (not (typep *site-editor-frame* 'site-editor-frame))
	    (member (send *site-editor-frame* :status) '(:deactivated)))
      (setq *site-editor-frame*
	    (make-instance 'site-editor-frame :activate-p t))
    *site-editor-frame*)
    (and select-p (send *site-editor-frame* :select))))
     
(tv:add-system-key #\ '(sited nil) "Site Editor" nil)

(add-initialization "How to bring up the Site Editor"
		    '(format t "~%Execute (SITED:SITED) to bring up the Site Editor.")
		    '(once now))
#||
Forms for patching:

(send *site-editor-frame* :kill)
(fmakunbound '*site-editor-frame*)
(sited nil)

||#