;;; -*- Mode:Common-Lisp; Package:W; Base:10; Fonts:(CPTFONT HL12B HL12I) -*- ;1;;;;; SYSTEM ACCESS SOFTWARE* ;1;; Definitions:* ;1;; system access -- the interface between the user and the systems available from* ;1;; his computer (i.e. the System Menu and the SYSTEM keys).* ;1;; system access list -- the system-specific information concerning how to access* ;1;; the system. This information is kept on the system's* ;1;; Defsystem. It is a property list containing the following:* ;1;; :name, :documentation, :default-system-key, :default-menu-* ;1;; column, :instance-type, :instance-finder, and :instance-creator.* ;1;; The software for this is in the DEFSYSTEM software. See* ;1;; GET- and SET-SYSTEM-ACCESS-LIST and DEFSYSTEM.* ;1;; system access spec -- the user-specific information concerning the user interface* ;1;; to the system. This information is kept in *SYSTEM-ACCESS-* ;1;; SPECS* (see below). * ;1;;* (DEFVAR *SYSTEM-ACCESS-SPECS* NIL "2A list of systems and how they can be accessed by the user.. Each item is the access specification for a system, having the following format: (system-name print-name column key) system-name is the symbolic name of the system print-name is the string printed on the System Menu and in . column is the column of the System Menu in which this system will appear key is the System key that accesses this system (NIL = none) DO NOT set this variable on your own. Use W:SET-SYSTEM-ACCESS-SPECS to reset the variable completely or W:MODIFY-SYSTEM-ACCESS-SPEC to modify a single specification in the list.*") (DEFUN SET-SYSTEM-ACCESS-SPECS (NEW-VAL &AUX SYSTEM) "2This function sets W::*SYSTEM-ACCESS-SPECS* and does the related chores of maintaining the System Menu and System-keys lists. BEWARE: this function assumes that every item in NEW-VAL is a legal access specification!*" (SETQ *SYSTEM-ACCESS-SPECS* NIL) (SETQ *SYSTEM-KEYS* NIL) (SETQ *SYSTEM-MENU-USER-AIDS-COLUMN* NIL) (SETQ *SYSTEM-MENU-PROGRAMS-COLUMN* NIL) (SETQ *SYSTEM-MENU-DEBUG-TOOLS-COLUMN* NIL) (DOLIST (S-A-SPEC NEW-VAL) (WHEN (SETQ SYSTEM (SYS:FIND-SYSTEM-NAMED (CAR S-A-SPEC) T (AND (NULL (FOURTH S-A-SPEC)) (EQ :NONE (THIRD S-A-SPEC))))) (SETF (CAR S-A-SPEC) (SYS:SYSTEM-SYMBOLIC-NAME SYSTEM))) (APPLY #'ADD-SYSTEM-ACCESS-SPEC S-A-SPEC)) (ADD-OBSOLETE-SYSTEM-MENU-ENTRIES)) (DEFUN ADD-SYSTEM-ACCESS-SPEC (SYSTEM-NAME PRINT-NAME COLUMN KEY) "2Use W:MODIFY-SYSTEM-ACCESS-SPEC unless you are sure of what you're doing! Adds the system access spec (system-name print-name column key) to the variable W::*SYSTEM-ACCESS-SPECS*. This will make the system named SYSTEM-NAME accessible from COLUMN of the System Menu and from KEY.*" (WHEN KEY (ADD-TO-SYSTEM-KEYS KEY SYSTEM-NAME PRINT-NAME)) (WHEN COLUMN (UNLESS (EQL COLUMN :NONE) (ADD-TO-SYSTEM-MENU COLUMN SYSTEM-NAME PRINT-NAME (GETF (SYS:GET-SYSTEM-ACCESS-LIST SYSTEM-NAME) :DOCUMENTATION)))) (SETQ *SYSTEM-ACCESS-SPECS* (SORTCAR (PUSH (LIST SYSTEM-NAME PRINT-NAME COLUMN KEY) *SYSTEM-ACCESS-SPECS*) #'STRING-LESSP))) (DEFUN REMOVE-SYSTEM-ACCESS-SPEC (SYSTEM-NAME &AUX S-A-SPEC KEY COLUMN) "2Use W:MODIFY-SYSTEM-ACCESS-SPEC unless you are sure of what you're doing! If there, remove the spec for SYSTEM-NAME from W::*SYSTEM-ACCESS-SPECS* and remove it from the System Menu and System keys. Then return the spec removed.*" (WHEN (SETQ S-A-SPEC (ASSOC SYSTEM-NAME *SYSTEM-ACCESS-SPECS*)) (WHEN (SETQ KEY (FOURTH S-A-SPEC)) (REMOVE-FROM-SYSTEM-KEYS KEY SYSTEM-NAME)) (WHEN (SETQ COLUMN (THIRD S-A-SPEC)) (UNLESS (EQL :NONE COLUMN) (REMOVE-FROM-SYSTEM-MENU COLUMN (SECOND S-A-SPEC)))) (SETQ *SYSTEM-ACCESS-SPECS* (REMOVE-IF #'(LAMBDA (SPEC) (EQ SPEC S-A-SPEC)) *SYSTEM-ACCESS-SPECS*))) S-A-SPEC) (DEFUN MODIFY-SYSTEM-ACCESS-SPEC (SYSTEM-NAME &REST OPTIONS &AUX SYSTEM S-A-SPEC) "2This is the programatic interface to the system access facility. If you want to add, change, or remove a system's access specification, use this function. If you want to totally reset W::*SYSTEM-ACCESS-SPECS* use W:SET-SYSTEM-ACCESS-SPECS. SYSTEM-NAME specifies the system whose access spec is being modified. What is done to it is specified by the options: :REMOVE -- take the system off the System Menu, off the system keys, and out of *SYSTEM-ACCESS-SPECS*. This option will override all others. (:ASSIGN-NAME name) -- change the system's print-name to name. (:ASSIGN-COLUMN column) -- change the System Menu column in which the system appears to column, one of :USER-AIDS, :PROGRAMS, :DEBUG-TOOLS, or :NONE. (:ASSIGN-KEY key) -- change the system's System-key to key. :ASSIGN-DEFAULTS -- Assign the system's default print-name, the system's default system menu column, and its default system key, if the key is not already taken. :DO-NOT-LOAD -- Do not load the system's DEFSYSTEM. If this option is used with the :ASSIGN-DEFAULTS option, then the defaults will only be assigned if the system's DEFSYSTEM has already been loaded. If no options are specified, this function simply makes sure that an access spec exists for SYSTEM-NAME.*" (WHEN (SETQ SYSTEM (SYS::FIND-SYSTEM-NAMED (SETQ SYSTEM-NAME (INTERN SYSTEM-NAME 'KEYWORD)) T T)) (SETQ SYSTEM-NAME (SYS:SYSTEM-SYMBOLIC-NAME SYSTEM))) (UNLESS (SETQ S-A-SPEC (REMOVE-SYSTEM-ACCESS-SPEC SYSTEM-NAME)) (SETQ S-A-SPEC (LIST SYSTEM-NAME "" :NONE NIL))) (UNLESS (MEMBER :REMOVE OPTIONS) (UNLESS (OR SYSTEM (MEMBER :DO-NOT-LOAD OPTIONS)) (SETQ SYSTEM (SYS:FIND-SYSTEM-NAMED SYSTEM-NAME T))) (IF (NOT SYSTEM) ;1; system doesn't exist or :DO-NOT-LOAD* (IF (MEMBER :DO-NOT-LOAD OPTIONS) (APPLY #'ADD-SYSTEM-ACCESS-SPEC S-A-SPEC) (WARN "There is no such system!")) ;1; process :ASSIGN-DEFAULTS* (IF (MEMBER :ASSIGN-DEFAULTS OPTIONS) (SETQ OPTIONS (ACONS :ASSIGN-NAME (LIST (SYS:SYSTEM-NAME SYSTEM)) (ACONS :ASSIGN-COLUMN (LIST (GETF (SYS:SYSTEM-PLIST SYSTEM) :DEFAULT-MENU-COLUMN)) (ACONS :ASSIGN-KEY (LIST (GETF (SYS:SYSTEM-PLIST SYSTEM) :DEFAULT-SYSTEM-KEY)) OPTIONS)))) (WHEN (STRING= "" (SECOND S-A-SPEC)) (SETQ OPTIONS (ACONS :ASSIGN-NAME (LIST (SYS:SYSTEM-NAME SYSTEM)) OPTIONS)))) ;1;; process assignment options* (DOLIST (OPTION OPTIONS) (WHEN (CONSP OPTION) (CASE (CAR OPTION) (:ASSIGN-NAME (SETF (SECOND S-A-SPEC) (SECOND OPTION))) (:ASSIGN-COLUMN (SETF (THIRD S-A-SPEC) (SECOND OPTION))) (:ASSIGN-KEY (SETF (FOURTH S-A-SPEC) (SECOND OPTION))) ))) ;1;; add new system-access-item* (APPLY #'ADD-SYSTEM-ACCESS-SPEC S-A-SPEC) ))) (DEFUN UPDATE-SYSTEM-ACCESS-SPECS () "2Update W::*SYSTEM-ACCESS-SPECS*. It finds all potentially accessible systems in the environment and in SYS:SITE (by looking in the contents file) and adds them to W::*SYSTEM-ACCESS-SPECS*.*" (DOLIST (SYSTEM SYS::*SYSTEMS-LIST*) (WHEN (TYPEP SYSTEM 'SYS::SYSTEM) (WHEN (GETF (SYS::SYSTEM-PLIST SYSTEM) :INSTANCE-TYPE) (MODIFY-SYSTEM-ACCESS-SPEC (SYS::SYSTEM-SYMBOLIC-NAME SYSTEM)) ))) (DOLIST (SYSTEM-NAME (READ-SITE-CONTENTS)) (MODIFY-SYSTEM-ACCESS-SPEC SYSTEM-NAME :DO-NOT-LOAD))) (DEFUN PURGE-SYSTEM-ACCESS-SPECS (&OPTIONAL (PURGE-WHEN :NOT-ACCESSIBLE)) "2Used to clean-up the W::*SYSTEM-ACCESS-SPECS* variable. This function will remove all access specifications that satisfy PURGE-WHEN: :NOT-ACCESSIBLE the system is not assigned to the System Menu or a SYSTEM key. :NOT-MADE the system has not been made. :NOT-LOADED the system's definition has not been loaded. :T all systems.*" (DOLIST (S-A-SPEC (COPY-LIST *SYSTEM-ACCESS-SPECS*)) (WHEN (CASE PURGE-WHEN (:NOT-ACCESSIBLE (AND (EQ :NONE (THIRD S-A-SPEC)) (NULL (FOURTH S-A-SPEC))) ) (:NOT-MADE (NOT (SYS:SYSTEM-MADE-P (CAR S-A-SPEC)))) (:NOT-LOADED (NOT (SYS:FIND-SYSTEM-NAMED (CAR S-A-SPEC) T T))) (:T T)) (REMOVE-SYSTEM-ACCESS-SPEC (CAR S-A-SPEC)) ))) ;1;; SITE-CONTENTS FILE MAINTENANCE* (DEFVAR *SITE-CONTENTS-PATHNAME* (PATHNAME "SYS:SITE;CONTENTS.SITE#>") "2The pathname of the file containing the systems available on SYS:SITE;.*") (DEFUN READ-SITE-CONTENTS () "2Read contents file on SYS:SITE;.*" (WITH-OPEN-FILE (CONTENTS-FILE *SITE-CONTENTS-PATHNAME* :DIRECTION :INPUT :IF-DOES-NOT-EXIST NIL) (WHEN CONTENTS-FILE (READ CONTENTS-FILE)))) (DEFUN ADD-TO-SITE-CONTENTS (SYSTEM-NAME) "2Add a system to contents file on SYS:SITE;.*" (SETQ SYSTEM-NAME (INTERN SYSTEM-NAME 'KEYWORD)) (LET ((SITE-CONTENTS (READ-SITE-CONTENTS))) (WHEN (NOT (MEMBER SYSTEM-NAME SITE-CONTENTS)) (PUSH SYSTEM-NAME SITE-CONTENTS) (WITH-OPEN-FILE (CONTENTS-FILE *SITE-CONTENTS-PATHNAME* :DIRECTION :OUTPUT :IF-EXISTS :OVERWRITE :IF-DOES-NOT-EXIST :CREATE) (PRIN1 SITE-CONTENTS CONTENTS-FILE))))) (DEFUN REMOVE-FROM-SITE-CONTENTS (SYSTEM-NAME) "2Remove a system from contents file on SYS:SITE;.*" (SETQ SYSTEM-NAME (INTERN SYSTEM-NAME 'KEYWORD)) (LET ((SITE-CONTENTS (READ-SITE-CONTENTS))) (WHEN (MEMBER SYSTEM-NAME SITE-CONTENTS) (REMOVE SYSTEM-NAME SITE-CONTENTS) (WITH-OPEN-FILE (CONTENTS-FILE *SITE-CONTENTS-PATHNAME* :DIRECTION :OUTPUT :IF-EXISTS :OVERWRITE :IF-DOES-NOT-EXIST :CREATE) (PRIN1 SITE-CONTENTS CONTENTS-FILE))))) (DEFUN MAKE-NEW-SITE-CONTENTS () "2Clear contents file on SYS:SITE;.*" (WITH-OPEN-FILE (CONTENTS-FILE *SITE-CONTENTS-PATHNAME* :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE) (PRIN1 NIL CONTENTS-FILE))) (DEFUN MAKE-SITE-CONTENTS () "2If no contents file on SYS:SITE; exists, create one*" (WITH-OPEN-FILE (CONTENTS-FILE *SITE-CONTENTS-PATHNAME* :DIRECTION :OUTPUT :IF-EXISTS NIL :IF-DOES-NOT-EXIST :CREATE) (WHEN CONTENTS-FILE (PRIN1 NIL CONTENTS-FILE))))