;;; -*- Mode:Common-Lisp; Base: 10.; Package: (DOX :size 100); Fonts: (MEDFNT TR12B TR12BI) -*- ;;;The data, information, methods, and concepts contained herein are ;;;a valuable trade secret of Texas Instruments. They are licensed ;;;in confidence by Texas Instruments and may only be used as ;;;permitted under the terms of the definitive license agreement ;;;under which such use is licensed. ;;; ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1987, Texas Instruments Incorporated. All rights reserved. ;;; Change History (started 10/8/87) ;;; -------------------------------- ;;; 04-20-89 DAB Fixed BOOT-VISIDOC-SERVER-NAMED to reload XLD file if necessary. ;;; 03-20-89 DAB Added (:method visidoc-server :before :flush) to notify user that the visidoc-server is going ;;; down and what to do if not disk saving. ;;; 03-20-89 DAB Fixed references to *defined-products* to find explorer os, not always first on LXes. ;;; 09-08-88 DAB Modified initialize-visidoc-server ADD-INITIALIZATION to place it on the WARM list. ;;; 09-01-88 DAB Fixed (Visidoc-server :Table-Of-Contents). It was calling entries-alist with a nil value. ;;; If the client OS version is not the same as the visidoc server, the code was trying to ;;; returning information from the wrong namespace. ;;; 11/10/87 slm Fix :READ-ITEM and GET-DOC-OBJECT-START-AND-END to make sure ;;; that an object is not recursively returned within its own list ;;; of inferiors (ie. TRACE is a TOPIC and a MACRO pointing to text ;;; in the same manual/chapter/section!!) ;;; ---Release 4.0 and beyond----- ;;; 1/19/88 slm Update all references to *VISIDOC-SERVER-NAMESPACE* to refer to ;;; the list *VISIDOC-SERVER-NAMESPACES*. Boot, initialization and ;;; save routines also updated to handle one host serving multiple ;;; versions of documentation. ;1;; Namespace Server code for Documentation Server* ;1;Server list for Rel4+... in case a host is serving multiple versions of documentation.* (DEFVAR *visidoc-server-namespaces* nil) (DEFVAR name:image nil "2This is needed for saving/loading with fasd-dump, etc.*") (DEFFLAVOR Visidoc-server (IMAGE) (name:basic-namespace) (:default-init-plist :new nil :namespace-file-pathname (make-pathname :host si:local-host :device (send si:local-host :default-device) :directory '("name-service") :name "visidoc-server" :type :xld) :domain-name "VISIDOC-SERVER" :usage :Visidoc-server) (:INIT-KEYWORDS :NEW :NAMESPACE-FILE-PATHNAME) :initable-instance-variables :gettable-instance-variables :settable-instance-variables ) (defmethod (Visidoc-server :namespace-file-pathname) (&optional name) (make-pathname :host si:local-host :device (send si:local-host :default-device) :directory '("name-service") :name (or name name:domain-name) :type :xld)) (DEFMETHOD (Visidoc-server :INIT) (PLIST) "2Set up the namespace instance*" (DECLARE (SPECIAL name:image)) (LET* ((PATHNAME (OR (GET PLIST :NAMESPACE-FILE-PATHNAME) (send self :namespace-file-pathname name:domain-name))) (USER-ID "VISIDOC-SERVER")) (IF (GET PLIST :NEW) (PROGN (FS:CREATE-DIRECTORY PATHNAME :RECURSIVE T) (SEND SELF :MAKE-NAMESPACE-HASH-TABLE) (SETF IMAGE (NAME:MAKE-SIMPLE :NAMESPACE name:NAMESPACE)) (SEND SELF :INTERNAL-ADD-OBJECT (name:BUILD-OBJECT name:DOMAIN-NAME :NAMESPACE (LIST :TYPE :public :USAGE :VISIDOC-SERVER :NAMESPACE-FILE-PATHNAME PATHNAME )))) (PROGN (PROCESS-RUN-FUNCTION "Loading Document Server" #'FUNCALL SELF :LOAD PATHNAME))) )) (DEFMETHOD (VISIDOC-SERVER :LOAD) (&optional (PATHNAME nil) (net-initialize t)) 2 *"2Loads an entire namespace from a file. When NET-INITIALIZE is true (*the default)2, register the namespace as a handler.*" (DECLARE (SPECIAL name:image)) (LET ((USER-ID "NAMESPACE") (DEFAULT-CONS-AREA name:*NAMESPACE-OBJECT-AREA*)) (SETF PATHNAME (OR pathname (name:lookup-attribute-value name:domain-name :namespace :NAMESPACE-FILE-PATHNAME :namespace self :local t))) (WHEN (AND (LOAD PATHNAME :VERBOSE NIL :IF-DOES-NOT-EXIST NIL) name:IMAGE) ;1the dump file actually had something in it.* (SETF image name:image) (SETF NAME:NAMESPACE (NAME:SIMPLE-NAMESPACE IMAGE)) (SETF NAME:CLASS-LIST (NAME:SIMPLE-CLASS-LIST IMAGE)) (WHEN net-initialize (name:register-namespace self nil) (NAME:REGISTER-HANDLER name:domain-name self))))) (DEFMETHOD (VISIDOC-SERVER :DUMP) (&OPTIONAL PATHNAME) 2 "Dumps the entire namespace to the specified pathname as an XLD. No meaningful return1."** (DECLARE (SPECIAL name:image)) (LET ((USER-ID "NAMESPACE")) (UNLESS PATHNAME (SETF PATHNAME (NAME:INTERNAL-AVAL :NAMESPACE-FILE-PATHNAME))) (WHEN PATHNAME (clean-up-namespace name:namespace) (SETF NAME:CLASS-LIST (SEND SELF :CLEAR-HIDDEN-PLISTS)) (SETF (NAME:SIMPLE-CLASS-LIST IMAGE) NAME:CLASS-LIST) (SETF name:image image) (COMPILER:FASD-SYMBOL-VALUE PATHNAME 'name:IMAGE) (LET ((FP (FS:FILE-PROPERTIES PATHNAME))) (UNLESS (EQL (GET (LOCF FP) :VERSION-LIMIT) NAME:*DEFAULT-SIMPLE-VERSION-LIMIT*) (FS:CHANGE-FILE-PROPERTIES PATHNAME NIL :VERSION-LIMIT name:*DEFAULT-SIMPLE-VERSION-LIMIT*))) (UNLESS (tv:mac-system-p) ;Hack to get around NFS error on expunge (FS:EXPUNGE-DIRECTORY (SEND (PATHNAME PATHNAME) :NEW-VERSION :WILD)))))) (DEFMETHOD (VISIDOC-SERVER :before :flush) (&rest ignore) ; DAB 03-20-89 (tv:notify () "The visidoc server has been cleared: do (DOX:boot-visidoc-server-named ~s ~s) after rebooting the local file system and initializing the namespace if not disk-saving." (send self :domain-name) (name:lookup-attribute-value "VISIDOC-SERVER" :namespace :version :namespace self :Local t) ) ) (DEFMETHOD (VISIDOC-SERVER :after :flush) (&rest ignore) (SETQ *visidoc-server-namespaces* (DELETE self *visidoc-server-namespaces*))) (DEFMACRO data-from-list (keyword data-list attribute-list) "2Finds the keyword's position in DATA-LIST, for example :CHAPTER in '(:CHAPTER :START :END), and returns the item in that list position of attribute-list*" `(NTH (POSITION ,keyword ,data-list) ,attribute-list)) (DEFMACRO get-general-info (info class) `(name:lookup-attribute-value ,class :NAMESPACE ,info :namespace self)) (DEFMETHOD (visidoc-server :chapter-length) (chapter manual) "2Returns the length in bytes of the chapter specified by CHAPTER. CHAPTER can be a number or a symbol, such as 'APPA for appendix A if that is how it was originally stored.*" (LET* ((chapter-list (get-general-info :CHAPTER-FILES manual)) (this-chapter (ASSOC chapter chapter-list))) (WHEN this-chapter (THIRD this-chapter)))) (DEFMETHOD (Visidoc-server :List-Of-Manuals) () (REMOVE :Namespace (name:namespace-classes self))) (DEFMETHOD (Visidoc-server :Table-Of-Contents) (manual) (LET* ((man-obj (name:lookup-object manual :NAMESPACE :namespace self :read-only t :local t)) (chapter-list (get-general-info :CHAPTER-FILES man-obj)) (data-list (get-general-info :LIST-ORDER manual)) (ret-list nil)) (DO* ((ch-list chapter-list (CDR ch-list)) (chapter-id (FIRST ch-list) (FIRST ch-list)) (chapter-name (FOURTH chapter-id) (FOURTH chapter-id)) (ch-object (name:lookup-object chapter-name manual :NAMESPACE SELF :LOCAL T :READ-ONLY T) (name:lookup-object chapter-name manual :NAMESPACE SELF :LOCAL T :READ-ONLY T)) (ch-entries (zwei:entries-alist ch-object manual) (when ch-object ;09-01-88 DAB Need to check for NIl, otherwise the last iteration ;will access the namespace of the OS you are running. (zwei:entries-alist ch-object manual)))) ((NULL ch-list)) (DOLIST (ch ch-entries) (WHEN (AND (EQ (FIRST ch) :TOPIC) (NULL (data-from-list :SUPERIOR data-list (SECOND ch))) (EQL (FIRST chapter-id) (data-from-list :CHAPTER data-list (SECOND ch)))) (PUSH (LIST ch-object (THIRD ch)) ret-list) (RETURN)))) (NREVERSE ret-list))) (DEFMETHOD (Visidoc-server :LIST-OF-TYPES) () "2Returns a list of types in the manual. Types are equivalent to attributes, such as :METHOD, :FUNCTION, etc.*" ;1;Because of the way we've been shipping index XLD files, the domain-name* ;1;object in the loadable file no longer matches the logical contact name of the* ;1;server object. The following OR statement guarantees compatibility. -slm* (OR (name:lookup-attribute-value name:domain-name :NAMESPACE :LIST-OF-TYPES :namespace self :Local t) (name:lookup-attribute-value "VISIDOC-SERVER" :namespace :list-of-types :namespace self :Local t))) (DEFMETHOD (Visidoc-server :Read-Item) (name &optional manual-name (Nth-item nil)) "2Returns information regarding the requested NAME (*a string)2. MANUAL-NAME is a keyword representing one of the manuals, such as :WINDOWS or :IO. Nth-item is a positional argument into the entries-alist of an object with multiple attributes. Returns one of: NIL if no NAME was found; (*:ITEM object Nth list-of-strings-and-inferior-lists) 2 when only one item matches the name, manual name, and Nth-item passed in; (*:MULTIPLE-ATTRIBUTES object) 2 when only one object exists (*that is, it is only in one manual)2 but multiple definitions exist within the object that were not explicitly identified by Nth-item; (*:MULTIPLE-OBJECTS object-list) 2 when the manual name was not specified, and the same name is defined in multiple manuals.*" (LET* (object data-list files-info chapters more-exist-p uncoded-attributes attributes file chapter ret-list) (MULTIPLE-VALUE-SETQ (object manual-name more-exist-p) (name:find-object name self manual-name)) (COND (more-exist-p ;1Test to see if name exists in MULTIPLE MANUALS* (LIST :MULTIPLE-OBJECTS ;1If so, return :MULTIPLE-OBJECTS and list them.* (name:find-all-objects name self))) (object (SETQ data-list (get-general-info :LIST-ORDER manual-name) files-info (get-general-info :FILES-INFO manual-name) chapters (get-general-info :CHAPTER-FILES manual-name) uncoded-attributes (name:get-attribute-list object) attributes (zwei:entries-alist-internal uncoded-attributes) ret-list nil) ;1; First make sure there is only one entry for this name.* ;1; Could be either two attributes, such as :FLAVOR and :FUNCTION,* ;1; or two entries for this attribute, such as :FUNCTION '((3 .. .. .. .. ) (5 .. .. .. ..))* ;1; We deal with this by using the entries-alist length.* (CATCH 'MULTIPLE (WHEN (> (LENGTH attributes) 1) (IF (AND Nth-Item (< Nth-Item (LENGTH attributes))) (SETQ attributes (LIST (NTH Nth-item attributes))) ;1return '(Object :MULTIPLE-ATTRIBUTES entries-alist)* (THROW 'MULTIPLE (LIST :MULTIPLE-ATTRIBUTES object)))) ;1; Okay, just one. Now we can read the filename, start and end and return the string.* (WHEN attributes (SETQ attributes (SECOND (FIRST attributes))) ;1Get the (3 .. .. .. ..) in ((:TYPE (3 .. .. .. ..)))* (SETQ chapter (data-from-list :CHAPTER data-list attributes)) (SETQ file (MAKE-PATHNAME :host (SECOND (ASSOC :HOST files-info)) :device (SECOND (ASSOC :DEVICE files-info)) :directory (SECOND (ASSOC :DIRECTORY files-info)) :name (SECOND (ASSOC (NTH (POSITION :CHAPTER data-list) attributes) chapters)) :type (SECOND (ASSOC :EXTENSION files-info)))) (LET ((user-id "visidoc-namespace")) (WITH-OPEN-FILE (f file) (LOOP with start = (data-from-list :START data-list attributes) with end = (data-from-list :END data-list attributes) with next-start = start with this-end and this-obj and nth with inferiors = (data-from-list :INFERIORS data-list attributes) for this-inferior in inferiors do ;1; We will write out the string from start to this-end, then next-start to the new this-end, etc* (PROGN ;1; This multiple-value-bind is necessary in case we receive NIL back (no object)* (MULTIPLE-VALUE-BIND (temp-end temp-start temp-obj temp-nth) (get-doc-object-start-and-end this-inferior manual-name chapter next-start end name (OR nth-item 0)) (WHEN temp-end ;1Test to see if we have an object* (SETQ this-end temp-end next-start temp-start this-obj temp-obj nth temp-nth) (WHEN (< start this-end) (PUSH (string-from-file f start this-end) ret-list)) (PUSH (LIST this-obj nth) ret-list) (SETQ start next-start)))) finally (PROGN (WHEN (< start end) (PUSH (string-from-file f start end) ret-list)) )))) (LIST :ITEM object (OR Nth-Item 0) (NREVERSE ret-list)))))))) (DEFUN string-from-file (file start end) (LET* ((len (1+ (- end start))) (str (MAKE-ARRAY len :element-type 'STRING-CHAR))) (FILE-POSITION file start) (SEND file :string-in nil str 0 len) str)) (DEFUN get-doc-object-start-and-end (obj-name manual chapter min-start max-end sup-name superior-nth) "2Returns as multiple values the start and end file position, an object and Nth definition. Watches for multiple definitions, and tests that the definition returned is within the chapter, min-start, and max-end requirements.*" 1;;Need SUP-NAME and SUPERIOR-NTH to make sure that if an inferior has the same name as its ;;superior, we don't want to return the wrong set of information!!* 111/10/87* (DECLARE (:self-flavor visidoc-server) (VALUES start end object nth)) (CATCH 'Found (LET* ((data-list (name:lookup-attribute-value manual :NAMESPACE :LIST-ORDER :namespace self)) (object (name:find-object obj-name self manual)) (attributes (zwei:entries-alist-internal (name:get-attribute-list object)))) (COND ((NULL attributes) (THROW 'Found (VALUES nil nil nil))) ;1; Check for multiple types* ((> (LENGTH attributes) 1) (DO* ((lst attributes (CDR lst)) (att-list (FIRST lst) (FIRST lst)) (type (FIRST att-list) (FIRST att-list)) (atts (SECOND att-list) (SECOND att-list)) (NTH (THIRD att-list) (THIRD att-list))) ((NULL att-list)) (IF (AND (NOT (AND (STRING-EQUAL sup-name obj-name) (EQL superior-nth nth))) ;;we don't want the superior's entry (EQL chapter (data-from-list :CHAPTER data-list atts)) (<= min-start (data-from-list :START data-list atts)) (>= max-end (data-from-list :END data-list atts))) (THROW 'Found (VALUES (data-from-list :START data-list atts) (data-from-list :END data-list atts) object nth))))) (t (SETQ attributes (SECOND (FIRST attributes))) (THROW 'Found (VALUES (data-from-list :START data-list attributes) (data-from-list :END data-list attributes) object 0))))))) (DEFMETHOD (visidoc-server :apropos) (target-string &key manual type (match-method :any)) "2Returns a list of strings that are namespace names that match TARGET-STRING according to restrictions specified in :MANUAL (manual name or list of manuals), :TYPE (type specifier [eg, :FUNCTION, etc] or list of them), and :MATCH-METHOD which can be: :ANY (the default) = Find the target string in any name in the namespace; :START = the target string must match the start of the namespace name; :END = the target string must match the end of the namespace name; :WORDS = TARGET-STRING is a list of words [eg, '(\"*word12\"* 2\"*word22\")] to try to match, take any of them :AND-WORDS = same as :WORDS, but a namespace name must have ALL the words in TARGET-STRING.*" (LET ((ret-list nil) (this-list nil)) (CASE match-method ((:any :start :end) (SETQ target-string (CONCATENATE 'STRING (IF (EQ match-method :END) "" "*") target-string (IF (EQ match-method :START) "" "*"))) (DOLIST (man (IF (ATOM manual) (LIST manual) manual)) (DOLIST (this-type (IF (ATOM type) (LIST type) type)) (SETQ ret-list (NCONC ret-list (MAPCAR #'CAR (name:list-objects-from-properties :namespace self :name-pattern target-string :class man :attribute-list (IF this-type `(,this-type :*) nil) :local t :brief t))))))) ((:WORDS :AND-WORDS) (LET* ((word-list nil) (word (CONCATENATE 'STRING "*" (FIRST target-string) "*")) (others (REMOVE word target-string :test #'STRING=))) (DOLIST (man (IF (ATOM manual) (LIST manual) manual) word-list) (DOLIST (this-type (IF (ATOM type) (LIST type) type)) (WHEN (SETQ this-list (name:lookup-objects-from-properties :namespace self :name-pattern word :class man :attribute-list (IF this-type `(,this-type :*) nil) :local t :read-only t)) (SETQ this-list (MAPCAR #'name:object-name this-list)) (IF (EQ match-method :AND-WORDS) (DOLIST (phrase this-list) (WHEN (DOLIST (wd others t) (IF (SEARCH wd phrase :test #'STRING-EQUAL) t (RETURN nil))) (PUSH phrase word-list))) (SETQ word-list (NCONC word-list this-list)))))) (DOLIST (i word-list) (SETQ ret-list (ADJOIN i ret-list :test #'STRING=))))) (otherwise (SETQ ret-list "NOT IMPLEMENTED YET"))) ret-list)) (DEFUN BOOT-VISIDOC-SERVER-NAMED (contact-name version &aux namespace) "2Boots up the VISIDOC server system if necessary.*" (WHEN (AND (MEMBER net:local-host-name (CADR (ASSOC version (GET-SITE-OPTION :VISIDOC-SERVERS nil))) :test #'STRING-EQUAL) (NOT (name:find-known-namespace contact-name))) ;1; Must determine whether to create and load the namespace or just register it.* (IF (SETQ namespace (CAR (MEMBER contact-name dox:*visidoc-server-namespaces* :key #'(lambda (x) (SEND x :domain-name)) :test #'string-equal))) (PROGN ;; ; DAB 04-20-89 Just register does not automatically load the XLD. We need to reload. (PROCESS-RUN-FUNCTION "Loading Document Server" ; DAB 04-20-89 Need to reload. #'FUNCALL NAMESPACE :LOAD (send NAMESPACE :namespace-file-pathname)) ) ;1;Making a new instance by default loads and registers the namespace* (PUSHNEW (MAKE-INSTANCE 'dox:visidoc-server :domain-name contact-name :namespace-file-pathname (fs:make-pathname :host si:local-host :device (send si:local-host :default-device) :directory '("name-service") :name contact-name :type :xld)) dox:*visidoc-server-namespaces*)))) (DEFUN clean-up-namespace (ns) "2Do any cleanup needed before saving the namespace*" (MAPHASH #'(lambda (ignore value) (SETF (name:object-plist value) nil)) ns)) (COMPILE-FLAVOR-METHODS visidoc-server) ;;================================================================================================= (defun initialize-visidoc-server (&optional version &aux contact-name namespace pathname) "2Initialize the server code for the Visidoc server namespace of documentation for release version VERSION. VERSION should be a keyword or string of the form REL-- (eg. :REL-4-0 or *\2"REL-4-0*\2") VERSION defaults to the that of the current load band.*" (COND ((NULL version) (LET ((product (dolist (item sys:*DEFINED-PRODUCTS*) ;DAB 03-20-89 The car is not the Explorer Release on LX. (when (or (string-equal (send item :name) "Explorer System Release") (string-equal (send item :name) "microExplorer System Release")) ; DAB 03-22-89 (return item))))) (SETQ version (FORMAT nil "REL-~s-~s~:[~;-~:*~s~]" (SEND product :major-version) (SEND product :minor-version))))) ((AND (KEYWORDP version)) (SETQ version (FORMAT nil "~a" version))) ((STRINGP version) version) (t (FERROR nil "~a is not a recognized release version spec." version))) ;1;Make sure version is in the right format* (UNLESS (STRING-EQUAL "REL-" version :end2 4) (FERROR nil "~a is not a recognized release version spec." version)) (UNLESS (AND (NUMBERP (READ-FROM-STRING (SUBSEQ version 4 5))) (NUMBERP (READ-FROM-STRING (SUBSEQ version 6 7)))) (FERROR nil "~a is not a recognized release version spec." version)) ;1;Finish setup info.* (SETQ contact-name (FORMAT nil "visidoc-server~@[-~a~]" (IF (STRING-EQUAL "rel-3-2" version) nil version))) (SETQ version (INTERN (READ-FROM-STRING version) 'keyword)) ;1;If there is already a server on this machine for this release version...* (IF (AND (VARIABLE-BOUNDP dox:*visidoc-server-namespaces*) (MEMBER contact-name dox:*visidoc-server-namespaces* :key #'(lambda (x) (SEND x :domain-name)) :test #'string-equal)) ;1;..return from this function; otherwise, if there is no server...* (RETURN-FROM initialize-visidoc-server (FORMAT nil "There is already a Visidoc server for ~a on this machine" version)) ;1;..and unless there is no data file to load...* (UNLESS (PROBE-FILE (setf pathname ;08-22-88 DAB (fs:make-pathname :host si:local-host :device (send si:local-host :default-device) :directory '("name-service") :name contact-name :type :xld))) (tv:notify nil "There is no file for \"~A\". Get one from your VISIDOC server installation tape, or copy it from another VISIDOC server host." pathname) (RETURN-FROM initialize-visidoc-server)) ;1;...make a new server instance and do all initializations for it!* (PUSHNEW (SETQ namespace (MAKE-INSTANCE 'dox:visidoc-server :domain-name contact-name :namespace-file-pathname pathname)) dox:*visidoc-server-namespaces*) (loop until (not (find-process "Loading Document Server")) do (process-sleep 500)) (send namespace :initial-server-setup version) (ADD-INITIALIZATION (STRING-APPEND "2Boot VISIDOC server* for " contact-name) `(BOOT-VISIDOC-SERVER-NAMED ,contact-name ,version) '(:SITE-OPTION :WARM)) ;09-08-88 DAB Added :warm (boot-visidoc-server-named contact-name version))) (DEFUN save-visidoc-server (&optional namespace pathname) "2Save the Visidoc server NAMESPACE in the file shown by pathname. If NAMESPACE is nil, a menu of known servers will be displayed, unless there is only one. If PATHNAME is nil, then the default pathname in the :namespace-file-pathname slot is used.*" (COND ((AND namespace (TYPEP namespace 'dox:visidoc-server)) namespace) ((AND (BOUNDP 'dox:*visidoc-server-namespaces*) (EQ 1 (LENGTH dox:*visidoc-server-namespaces*))) (SETQ namespace (CAR dox:*visidoc-server-namespaces*))) ((BOUNDP 'dox:*visidoc-server-namespaces*) (SETQ namespace (w:menu-choose (LOOP for server in dox:*visidoc-server-namespaces* collect (LIST (SEND server :domain-name) :value server)))) (UNLESS namespace (RETURN-FROM save-visidoc-server "No Visidoc server was chosen, so no server will be saved."))) (t (RETURN-FROM save-visidoc-server "There are no known Visidoc servers to be saved."))) ;1;We have a valid Visidoc server namespace... SAVE IT!!* (SEND namespace :dump (OR pathname (SEND namespace :namespace-file-pathname)))) (DEFMETHOD (visidoc-server :initial-server-setup) (&optional version) "2Initializes the host and directories for the manual data files of a VISIDOC server. VERSION is a keyword of the form :REL--. If VERSION is nil, then the :VERSION info is looked for as an attribute of the :DOMAIN-NAME object in the :NAMESPACE class. If nothing is found there, the default is the same as the current load band.*" (LET* ((servers (net:get-site-option :visidoc-servers nil)) (release (OR version (name:lookup-attribute-value name:domain-name :namespace :version :namespace self :local t))) (product (dolist (item sys:*DEFINED-PRODUCTS*) ; DAB 03-20-89 The car is not the Explorer Release on LX. (when (or (string-equal (send item :name) "Explorer System Release") (string-equal (send item :name) "microExplorer System Release")) ; DAB 03-22-89 (return item)))) (manuals nil) info flag sym save) ;1;If no release number was found, then we have to create it and add the info to the namespace.* (UNLESS release (SETQ release (READ-FROM-STRING (FORMAT nil ":REL-~s-~s" (SEND product :major-version) (SEND product :minor-version)))) (SETF name:domain-name (FORMAT nil "visidoc-server~@[-~a~]" release)) (name:add-attribute name:domain-name :namespace :version release :namespace self :local t)) ;1;Add namespace to list of known servers on the :SITE info* (IF servers (name:add-attribute site-name :site :VISIDOC-SERVERS (LET ((rel-servers (ASSOC release servers))) (IF rel-servers (PROGN (PUSHNEW si:local-host-name (CADR rel-servers) :test #'string-equal) servers) (PUSH-END (LIST release (LIST si:local-host-name)) servers)))) (name:add-attribute site-name :site :VISIDOC-SERVERS (LIST (LIST release (LIST si:local-host-name))))) ;1;ok.. SITE info updated. Now update manuals info for this server instance if needed.* ;1;To do this, first make a menu-item list out of the default pathnames. Then use a CVV menu* ;1;to update the pathnames.* (DOLIST (man (SEND self :list-of-manuals)) (PUSH-END (LIST (SETQ sym (INTERN (CONCATENATE 'STRING (STRING man) "-manual"))) man (SETF (SYMBOL-VALUE sym) (MAKE-PATHNAME :host (SECOND (ASSOC :host (SETQ info (get-general-info :FILES-INFO man)))) :device (SECOND (ASSOC :device info)) :directory (SECOND (ASSOC :directory info)) :name :wild :type (SECOND (ASSOC :extension info)))) info) manuals)) ;1;make symbols SPECIAL so CVV will work.* (PROCLAIM `(SPECIAL ,@(MAPCAR #'CAR manuals))) (CONDITION-CASE () (w:choose-variable-values (LOOP for alist in manuals collect (LIST (CAR alist) :pathname (SYMBOL-VALUE (CAR alist)))) :label (FORMAT nil "~:@(~a~) pathnames for manual files:" name:domain-name) :margin-choices '(("Abort" (SIGNAL-CONDITION eh:*abort-object*)))) (sys:abort (FORMAT t "~&Location of manuals has been set to the defaults")) (:no-error (DOLIST (man manuals) (SETQ flag nil) (LET* ((sym (FIRST man)) (symval (MAKE-PATHNAME :defaults (SYMBOL-VALUE sym))) (host (HOST-NAMESTRING symval)) (device (pathname-device symval)) (dir (DIRECTORY-NAMESTRING symval))) ;1;check hosts* (WHEN (NOT (STRING-EQUAL (HOST-NAMESTRING (THIRD man)) host)) (RPLACD (ASSOC :host (FOURTH man)) (LIST (SUBSEQ host 0 (1- (length host))))) (SETQ flag t)) ;1; check device* (WHEN (NOT (STRING-EQUAL (PATHNAME-DEVICE (THIRD man)) device)) (IF (ASSOC :device (FOURTH man)) (RPLACD (ASSOC :device (FOURTH man)) (LIST device)) (SETF (FOURTH man) (CONS (LIST :device device) (FOURTH man)))) (SETQ flag t)) ;1;check directories* (WHEN (NOT (STRING-EQUAL (DIRECTORY-NAMESTRING (THIRD man)) dir)) (RPLACD (ASSOC :directory (FOURTH man)) (LIST (SEND symval :directory))) (SETQ flag t)) ;1;When FLAG is set, we changed at least one part of the pathname.* (WHEN flag (SETQ save t) (name:add-attribute (SECOND man) :namespace :FILES-INFO (FOURTH man) :namespace self :local t)) )) ;1;Iff we actually made any changes, save the namespace.* ; (WHEN save (PROCESS-RUN-FUNCTION ; (FORMAT nil "Save ~:@(~a~)" name:domain-name) ; #'save-visidoc-server self)) )) manuals)) (EXPORT '(initialize-visidoc-server save-visidoc-server boot-visidoc-server-named) 'dox)