;;; -*- Mode:Common-Lisp; Package:PROFILE; Base:10; Fonts:(CPTFONT HL12B HL12I) -*- ;1;;;; SYSTEM ACCESS MENU* ;1;; This code adds the variable W::*SYSTEM-ACCESS-SPECS* to the IMPORTANT VARIABLES* ;1;; column of PROFILE. If selected, the System Access Menu is brought up. It provides a list* ;1;; of software systems and their current system-key assignments. From this menu, the user * ;1;; can find additional systems on SYS:SITE; or in his environment, and then edit the SYSTEM * ;1;; key assignments or System Menu column assignments for any of these systems. All of this* ;1;; can then be stored in the user's login.init file through Profile.* ;1; These three forms establish the W::*SYSTEM-ACCESS-SPECS* variable as a special CVV* ;1; type of its own and add the variable into PROFILE.* (DEFPROP :ACCESS-SPECS ((LAMBDA (OBJECT STREAM) (FORMAT STREAM "System Access Menu")) (CVV-CALL-SAM) NIL NIL NIL "Bring up a menu of systems and their System Menu and SYSTEM key assignments") W:CHOOSE-VARIABLE-VALUES-KEYWORD) (DEFUN CVV-CALL-SAM (&REST IGNORE) "2Calls the Systems Access Menu and returns the new value of W::*SYSTEMS-ACCESS-SPECS**" (SYSTEM-ACCESS-MENU)) (DEFINE-PROFILE-VARIABLE W::*SYSTEM-ACCESS-SPECS* (:IMPORTANT) :CVV-TYPE :ACCESS-SPECS :DOCUMENTATION "Bring up a menu of systems and their System Menu and SYSTEM key assignments" :SET-EFFECT (W:SET-SYSTEM-ACCESS-SPECS W::*SYSTEM-ACCESS-SPECS*) :FORM-FOR-INIT-FILE (LAMBDA (VAR) `(PROFILE-SETQ ,VAR ',(PRINT-ACCESSIBLE-SYSTEMS))) ) (DEFUN PRINT-ACCESSIBLE-SYSTEMS () "2Returns only the accessible systems in W::*SYSTEM-ACCESS-SPECS*.*" (REMOVE-IF #'(LAMBDA (S-A-SPEC) (AND (EQ :NONE (THIRD S-A-SPEC)) (NOT (FOURTH S-A-SPEC)))) W::*SYSTEM-ACCESS-SPECS*)) ;1;; System Access Menu* (DEFVAR *ACCESS-SPECS-BUF* NIL "2A globally accessible buffer which is used to hold a COPY of W::*SYSTEM- ACCESS-SPECS*, so that it can be edited freely and then, via W:SET- SYSTEM-ACCESS-SPECS, be set back into W::*SYSTEM-ACCESS-SPECS*.*") ;1;; This is a general-scroll window with mouse-sensitive items.* ;1;; It has a boxed title at the top, margin-choices at the bottom,* ;1;; scroll bars, and a shadowed border to set it apart from the* ;1;; window below it.* (DEFFLAVOR SAM-WINDOW-FLAVOR () (W:SCROLL-MOUSE-MIXIN W:SHADOW-BORDERS-MIXIN W:BORDERS-MIXIN W:TOP-BOX-LABEL-MIXIN W:MARGIN-CHOICE-MIXIN W:BASIC-SCROLL-WINDOW W:SCROLL-BAR-MIXIN W:WINDOW)) (COMPILE-FLAVOR-METHODS SAM-WINDOW-FLAVOR) (DEFVAR SAM-WINDOW NIL "2This global variable holds the window for the Systems Access Menu. In this way, the window must only be built once.*") (DEFUN MAKE-SAM-WINDOW () "2Makes the general-scroll window for the System Access Menu.*" (MAKE-INSTANCE 'SAM-WINDOW-FLAVOR :LABEL '(:CENTERED :STRING "SYSTEM ACCESS MENU") :LEFT 25 :TOP 25 :BORDERS 3 :CHARACTER-WIDTH 61 :CHARACTER-HEIGHT 30 :MARGIN-CHOICES '(("Abort" NIL (LAMBDA (&REST IGNORE) (SEND SELF :FORCE-KBD-INPUT #\ABORT)) NIL NIL :DOCUMENTATION (:MOUSE-ANY "Exit and abort all changes")) ("Do It" NIL (LAMBDA (&REST IGNORE) (SEND SELF :FORCE-KBD-INPUT #\END)) NIL NIL :DOCUMENTATION (:MOUSE-ANY "Exit and activate changes")) ("Update" NIL (LAMBDA (&REST IGNORE) (SEND SELF :FORCE-KBD-INPUT (IF (W:MOUSE-CONFIRM "Do you want to activate any previous changes?" (FORMAT NIL "Click mouse or press ” to `Do It'.~%~ Move off window or press to `Abort'.")) :DO-IT-UPDATE :ABORT-UPDATE))) NIL NIL :DOCUMENTATION (:MOUSE-ANY "Exit, look for other systems, update list of systems, and return"))) :DISPLAY-ITEM (MAKE-SAM-ROOT))) (DEFUN SYSTEM-ACCESS-MENU () "2Provides a menu of software systems and their accessibility. It allows the user to edit print-name, System Menu column, and SYSTEM key for each system.*" (SETQ *ACCESS-SPECS-BUF* (COPY-TREE W::*SYSTEM-ACCESS-SPECS*)) (CASE (SYSTEM-ACCESS-MENU-HANDLER) (:ABORT (SETQ *ACCESS-SPECS-BUF* NIL) W::*SYSTEM-ACCESS-SPECS*) (:DO-IT (PROG1 *ACCESS-SPECS-BUF* (SETQ *ACCESS-SPECS-BUF* NIL))) (:ABORT-UPDATE (W:UPDATE-SYSTEM-ACCESS-SPECS) (SYSTEM-ACCESS-MENU)) (:DO-IT-UPDATE (W:SET-SYSTEM-ACCESS-SPECS *ACCESS-SPECS-BUF*) (W:UPDATE-SYSTEM-ACCESS-SPECS) (SYSTEM-ACCESS-MENU)) )) (DEFUN SYSTEM-ACCESS-MENU-HANDLER () "2Handles the menu for the function PROFILE:SYSTEM-ACCESS-MENU.*" (LET ((W:KBD-INTERCEPTED-CHARACTERS (COPY-TREE W:KBD-INTERCEPTED-CHARACTERS))) (SETF (CADR (ASSOC #\BREAK W:KBD-INTERCEPTED-CHARACTERS)) #'(LAMBDA (CHAR) (VALUES CHAR NIL))) (SETF (CADR (ASSOC #\ABORT W:KBD-INTERCEPTED-CHARACTERS)) #'(LAMBDA (CHAR) (VALUES CHAR NIL))) (IF SAM-WINDOW (SEND SAM-WINDOW :SET-DISPLAY-ITEM (MAKE-SAM-ROOT)) (SETQ SAM-WINDOW (MAKE-SAM-WINDOW))) (UNWIND-PROTECT (W:WINDOW-CALL (SAM-WINDOW :DEACTIVATE) (DO* ((INPUT (W:READ-ANY-WHILE SAM-WINDOW :SELECTED :EXPOSED) (W:READ-ANY-WHILE SAM-WINDOW :SELECTED :EXPOSED))) ((MEMBER INPUT '(NIL #\ABORT #\END :ABORT-UPDATE :DO-IT-UPDATE)) (CASE INPUT ((NIL #\ABORT) :ABORT) (#\END :DO-IT) (:ABORT-UPDATE :ABORT-UPDATE) (:DO-IT-UPDATE :DO-IT-UPDATE))) (WHEN (CONSP INPUT) (CASE (CAR INPUT) (:EDIT-NAME (EDIT-NAME (THIRD (SECOND INPUT)) (THIRD INPUT) (FOURTH INPUT))) (:EDIT-COLUMN (EDIT-COLUMN (THIRD (SECOND INPUT)) (THIRD INPUT) (FOURTH INPUT))) (:EDIT-KEY (EDIT-KEY (THIRD (SECOND INPUT)) (THIRD INPUT) (FOURTH INPUT))) )))) (SEND SAM-WINDOW :SET-DISPLAY-ITEM NIL)) )) (DEFUN MAKE-SAM-ROOT () "2Builds the contents of the PROFILE::SAM-WINDOW for the System Access Menu, from the current value of PROFILE::*ACCESS-SPECS-BUF*.*" (APPEND (LIST NIL (W:SCROLL-PARSE-ITEM '(:STRING "" 61)) (W:SCROLL-PARSE-ITEM '(:STRING " " 1) '(:STRING "SYSTEM" 18) '(:STRING "PRINT NAME" 18) '(:STRING "MENU COLUMN" 13) '(:STRING "SYSTEM-KEY" 11)) (W:SCROLL-PARSE-ITEM '(:STRING " " 1) '(:STRING "----------------" 18) '(:STRING "----------------" 18) '(:STRING "-----------" 13) '(:STRING "----------" 11))) (MAPCAR #'S-A-SPEC->SCROLL-ITEM *ACCESS-SPECS-BUF*) (OBSOLETE-SYSTEM-KEYS-LIST-ITEM))) (DEFUN S-A-SPEC->SCROLL-ITEM (S-A-SPEC) "2Converts an item of PROFILE::*ACCESS-SPECS-BUF* (one access spec) to a general-scroll window item for the System Access Menu. Called by PROFILE::MAKE-SAM-ROOT.*" (W:SCROLL-PARSE-ITEM '(:STRING " " 1) `(:STRING ,(SYMBOL-NAME (FIRST S-A-SPEC)) 16) '(:STRING " " 2) `(:MOUSE (:EDIT-NAME :ARG ,S-A-SPEC :DOCUMENTATION (:MOUSE-L-1 "Edit the name" :MOUSE-R-1 "Assign the system's default print-name" :DOCUMENTATION "The name used in the System Menu and in SYSTEM-HELP")) :FUNCTION (LAMBDA (ARG-LIST) (IF (STRING= "" (SECOND ARG-LIST)) " " (SECOND ARG-LIST))) ,(LIST S-A-SPEC) 16) '(:STRING " " 2) `(:MOUSE (:EDIT-COLUMN :ARG ,S-A-SPEC :DOCUMENTATION (:MOUSE-L-1 "Choose a different column" :MOUSE-R-1 "Assign the system's default menu column" :DOCUMENTATION "The column in which this system will appear on the System Menu")) :FUNCTION THIRD ,(LIST S-A-SPEC) 11) '(:STRING " " 2) `(:MOUSE (:EDIT-KEY :ARG ,S-A-SPEC :DOCUMENTATION (:MOUSE-L-1 "Enter a new key" :MOUSE-R-1 "Assign the system's default SYSTEM key" :DOCUMENTATION "The SYSTEM key that will access the system")) :FUNCTION FOURTH ,(LIST S-A-SPEC) 10 ("~:[~:*~A~;~:*~C~]") ) )) (DEFUN OBSOLETE-SYSTEM-KEYS-LIST-ITEM () "2Places a note on bottom of System Access Menu, listing keys that have been assigned with the obsolete function W:ADD-SYSTEM-KEY.*" (WHEN W:*OBSOLETE-SYSTEM-KEYS* (LIST (W:SCROLL-PARSE-ITEM '(:STRING "" 62)) (APPLY #'W:SCROLL-PARSE-ITEM (CONS '(:STRING "Other assigned keys:" 22) (MAPCAR #'(LAMBDA (S-A-SPEC) (LIST :STRING (STRING (CAR S-A-SPEC)) 2)) W:*OBSOLETE-SYSTEM-KEYS*))) ))) (DEFUN VERIFY-THAT-SYSTEM-IS-LOADED (S-A-SPEC &AUX SYSTEM) "2If the system corresponding to S-A-SPEC is loaded (the Defsystem), then S-A-SPEC is returned. If not, it asks if the user if he would like to load it. If so, it tries to load the defsystem. If it fails, it will notify the user and return NIL; otherwise, it will check to see if the print- name of S-A-SPEC is '', in which case it sets the print-name to the system's default, and then returns the new S-A-SPEC.*" (IF (SETQ SYSTEM (SYS:FIND-SYSTEM-NAMED (CAR S-A-SPEC) T T)) S-A-SPEC (WHEN (W:MOUSE-CONFIRM "This system definition has not been loaded!" (FORMAT NIL "Click mouse or press ” to load defsystem.~%~ (This will NOT make the system.)~%~ Move mouse or press to abort.")) (IF (SETQ SYSTEM (SYS:FIND-SYSTEM-NAMED (CAR S-A-SPEC) T)) (PROGN (WHEN (STRING= "" (SECOND S-A-SPEC)) (SETF (SECOND S-A-SPEC) (SYS:SYSTEM-NAME SYSTEM))) S-A-SPEC) (PROGN (W:NOTIFY NIL "The system definition could not be loaded!") NIL))))) (DEFUN EDIT-NAME (S-A-SPEC WINDOW CLICK) "2Called when user of Systems Access Menu clicks on a print-name. If click is #\MOUSE-L-1 then this function puts up a window and allows the user to edit the name. If click is #MOUSE-R-1 then name is set to the default for the SYSTEM specified in S-A-SPEC. Note that the name can only be 16 characters long.*" (WHEN (MEMBER CLICK '(#\MOUSE-L-1 #\MOUSE-R-1)) (WHEN (SETQ S-A-SPEC (VERIFY-THAT-SYSTEM-IS-LOADED S-A-SPEC)) (SETF (SECOND S-A-SPEC) (CASE CLICK (#\MOUSE-L-1 (GET-NEW-NAME (SECOND S-A-SPEC))) (#\MOUSE-R-1 (SUBSEQ (GETF (SYS:GET-SYSTEM-ACCESS-LIST (CAR S-A-SPEC)) :NAME) 0 16)) ))) (SEND WINDOW :REDISPLAY NIL T))) (DEFUN GET-NEW-NAME (OLD-NAME) "2Called by PROFILE::EDIT-NAME to get a new name from the user via a pop-up window in which the user can edit the old name.*" (W:POP-UP-EDIT-STRING OLD-NAME :MAX-LENGTH 16 :LEFT-EDGE 180 :TOP-EDGE (MIN (- SYS:MOUSE-Y 30) 400))) (DEFUN EDIT-COLUMN (S-A-SPEC WINDOW CLICK) "2Called when user of Systems Access Menu clicks on a system menu column assignment. If CLICK is #\MOUSE-L-1, it brings up a menu of possible System Menu columns from which the user can accept a new column. If CLICK is #\MOUSE-R-1, column is set to the system's default menu column.*" (WHEN (MEMBER CLICK '(#\MOUSE-L-1 #\MOUSE-R-1)) (WHEN (SETQ S-A-SPEC (VERIFY-THAT-SYSTEM-IS-LOADED S-A-SPEC)) (SETF (THIRD S-A-SPEC) (CASE CLICK (#\MOUSE-L-1 (GET-NEW-COLUMN (THIRD S-A-SPEC))) (#\MOUSE-R-1 (GETF (SYS:GET-SYSTEM-ACCESS-LIST (CAR S-A-SPEC)) :DEFAULT-MENU-COLUMN))) )) (SEND WINDOW :REDISPLAY))) (DEFUN GET-NEW-COLUMN (OLD-COLUMN) "2Allows the user to choose from a menu of the possible System Menu columns.*" (LET ((ITEM-LIST '(("USER AIDS" . :USER-AIDS) ("PROGRAMS" . :PROGRAMS) ("DEBUG TOOLS" . :DEBUG) ("NONE" . :NONE)))) (OR (W:MENU-CHOOSE ITEM-LIST :LABEL "Choose a column:" :DEFAULT-ITEM (FIND OLD-COLUMN ITEM-LIST :TEST #'EQL :KEY #'CDR)) OLD-COLUMN))) (DEFUN EDIT-KEY (S-A-SPEC WINDOW CLICK) "2Called when user of System Access Menu clicks on a system-key assignment. If CLICK is #\MOUSE-L-1, it prompts the user for a new key assignment; if CLICK is #\MOUSE-R-1, it uses the default system key from the system's defsystem. In either case it does not allow duplicate assignments or CONTROL char's.*" (WHEN (MEMBER CLICK '(#\MOUSE-L-1 #\MOUSE-R-1)) (WHEN (SETQ S-A-SPEC (VERIFY-THAT-SYSTEM-IS-LOADED S-A-SPEC)) (LET* ((OLD-KEY (FOURTH S-A-SPEC)) (NEW-KEY (CASE CLICK (#\MOUSE-L-1 (GET-NEW-KEY OLD-KEY)) (#\MOUSE-R-1 (GETF (SYS:GET-SYSTEM-ACCESS-LIST (CAR S-A-SPEC)) :DEFAULT-SYSTEM-KEY)) ))) (WHEN (NOT (EQL OLD-KEY NEW-KEY)) (IF (NOT NEW-KEY) (SETF (FOURTH S-A-SPEC) NIL) (COND ((EQUAL NEW-KEY #\?) (W:MOUSE-CONFIRM "The '?' is used to get the System Help screen" "Click or move off box to remove.")) ((FIND NEW-KEY *ACCESS-SPECS-BUF* :TEST #'EQL :KEY #'FOURTH) (W:MOUSE-CONFIRM (FORMAT NIL "The key ~C is already used!" NEW-KEY) "Click or move off box to remove.")) ((ASSOC NEW-KEY W:*OBSOLETE-SYSTEM-KEYS*) (WHEN (W:MOUSE-CONFIRM "This key will override an assignment made with an obsolete function" (FORMAT NIL "Click mouse or press ” to override previous assignment.~%~ Move off window or press to abort assignment.") FONTS:HL12B FONTS:HL12 600) (SETF (FOURTH S-A-SPEC) NEW-KEY))) (T (SETF (FOURTH S-A-SPEC) NEW-KEY)) ))))) (SEND WINDOW :REDISPLAY) )) (DEFUN GET-NEW-KEY (OLD-KEY &AUX NEW-KEY) "2Pops up a window which prompts the user for a character to be used as a System key assignment. It does not allow CONTROL characters or already assigned characters.*" (SETQ NEW-KEY (W:POP-UP-PROMPT-AND-READ-CHAR "Press new System-Key (or for NIL): " OLD-KEY :LEFT-EDGE 200 :TOP-EDGE (MIN (- SYS:MOUSE-Y 10) 400) :ILLEGAL-MODIFIER-LIST '(:CONTROL) :ILLEGAL-CHAR-LIST (APPEND '(#\HELP #\?) (MAPCAR #'FOURTH *ACCESS-SPECS-BUF*)) :STANDARD-CHARS-ONLY-P T)) (IF NEW-KEY (IF (EQL NEW-KEY #\SPACE) NIL (CHAR-UPCASE NEW-KEY)) NEW-KEY))