X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/2a9f2437c401f997ebdd4f5194d09bd868633e22..937640a621a4ce2e5e56eaecca37a2a28a584318:/lisp/tmm.el

diff --git a/lisp/tmm.el b/lisp/tmm.el
index 35630aa6d5..9993186779 100644
--- a/lisp/tmm.el
+++ b/lisp/tmm.el
@@ -1,9 +1,11 @@
 ;;; tmm.el --- text mode access to menu-bar
 
-;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1996, 2000, 2001, 2002
+;;   Free Software Foundation, Inc.
 
 ;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu>
 ;; Maintainer: FSF
+;; Keywords: convenience
 
 ;; This file is part of GNU Emacs.
 
@@ -24,18 +26,17 @@
 
 ;;; Commentary:
 
-;; To use this package add 
-
-;; (autoload 'tmm-menubar 'tmm "Text mode substitute for menubar" t) 
-;; (global-set-key [f10] 'tmm-menubar)
-;; to your .emacs file. You can also add your own access to different
-;; menus available in Window System Emacs modeling definition after
-;; tmm-menubar.
+;; This package provides text mode access to the menu bar.
 
 ;;; Code:
 
 (require 'electric)
 
+(defgroup tmm nil
+  "Text mode access to menu-bar."
+  :prefix "tmm-"
+  :group 'menu)
+
 ;;; The following will be localized, added only to pacify the compiler.
 (defvar tmm-short-cuts)
 (defvar tmm-old-mb-map nil)
@@ -94,33 +95,43 @@ See the documentation for `tmm-prompt'."
   (interactive "e")
   (tmm-menubar (car (posn-x-y (event-start event)))))
 
-(defvar tmm-mid-prompt "==>"
-  "*String to insert between shortcut and menu item. 
+(defcustom tmm-mid-prompt "==>"
+  "*String to insert between shortcut and menu item.
 If nil, there will be no shortcuts. It should not consist only of spaces,
-or else the correct item might not be found in the `*Completions*' buffer.")
+or else the correct item might not be found in the `*Completions*' buffer."
+  :type 'string
+  :group 'tmm)
 
 (defvar tmm-mb-map nil
   "A place to store minibuffer map.")
 
-(defvar tmm-completion-prompt 
-  "Press PageUp Key to reach this buffer from the minibuffer.
+(defcustom tmm-completion-prompt
+  "Press PageUp key to reach this buffer from the minibuffer.
 Alternatively, you can use Up/Down keys (or your History keys) to change
-the item in the minibuffer, and press RET when you are done, or press the 
+the item in the minibuffer, and press RET when you are done, or press the
 marked letters to pick up your choice.  Type C-g or ESC ESC ESC to cancel.
 "
   "*Help text to insert on the top of the completion buffer.
 To save space, you can set this to nil,
-in which case the standard introduction text is deleted too.")
-
-(defvar tmm-shortcut-style '(downcase upcase)
-  "*What letters to use as menu shortcuts. 
-Must be either one of the symbols `downcase' or `upcase', 
-or else a list of the two in the order you prefer.")
-
-(defvar tmm-shortcut-words 2
+in which case the standard introduction text is deleted too."
+  :type '(choice string (const nil))
+  :group 'tmm)
+
+(defcustom tmm-shortcut-style '(downcase upcase)
+  "*What letters to use as menu shortcuts.
+Must be either one of the symbols `downcase' or `upcase',
+or else a list of the two in the order you prefer."
+  :type '(choice (const downcase)
+		 (const upcase)
+		 (repeat (choice (const downcase) (const upcase))))
+  :group 'tmm)
+
+(defcustom tmm-shortcut-words 2
   "*How many successive words to try for shortcuts, nil means all.
-If you use only one of `downcase' or `upcase' for `tmm-shortcut-style', 
-specify nil for this variable.")
+If you use only one of `downcase' or `upcase' for `tmm-shortcut-style',
+specify nil for this variable."
+  :type '(choice integer (const nil))
+  :group 'tmm)
 
 ;;;###autoload
 (defun tmm-prompt (menu &optional in-popup default-item)
@@ -149,10 +160,10 @@ Its value should be an event that has a binding in MENU."
     ;; tmm-km-list is an alist of (STRING . MEANING).
     ;; It has no other elements.
     ;; The order of elements in tmm-km-list is the order of the menu bar.
-    (mapcar (function (lambda (elt)
-			(if (stringp elt)
-			    (setq gl-str elt)
-			  (and (listp elt) (tmm-get-keymap elt not-menu)))))
+    (mapc (lambda (elt)
+	    (if (stringp elt)
+		(setq gl-str elt)
+	      (and (listp elt) (tmm-get-keymap elt not-menu))))
 	    menu)
     ;; Choose an element of tmm-km-list; put it in choice.
     (if (and not-menu (= 1 (length tmm-km-list)))
@@ -161,6 +172,8 @@ Its value should be an event that has a binding in MENU."
 	;; This way we only ask the user one question,
 	;; for which element of that pane.
 	(setq choice (cdr (car tmm-km-list)))
+      (unless tmm-km-list
+	(error "Empty menu reached"))
       (and tmm-km-list
 	   (let ((index-of-default 0))
 	     (if tmm-mid-prompt
@@ -176,7 +189,8 @@ Its value should be an event that has a binding in MENU."
 		     ;; Be careful to count only the elements of MENU
 		     ;; that actually constitute menu bar items.
 		     (if (and (consp (car tail))
-			      (stringp (car-safe (cdr (car tail)))))
+			      (or (stringp (car-safe (cdr (car tail))))
+				  (eq (car-safe (cdr (car tail))) 'menu-item)))
 			 (setq index-of-default (1+ index-of-default)))
 		     (setq tail (cdr tail)))))
 	     (setq history (reverse (mapcar 'car tmm-km-list)))
@@ -205,7 +219,7 @@ Its value should be an event that has a binding in MENU."
 	   (string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt)
 	   (setq out (substring out (length tmm-c-prompt))
 		 choice (cdr (assoc out tmm-km-list))))
-      (and (null choice)
+      (and (null choice) out
 	   (setq out (try-completion out tmm-km-list)
 		 choice (cdr (assoc  out tmm-km-list)))))
     ;; CHOICE is now (STRING . MEANING).  Separate the two parts.
@@ -215,7 +229,7 @@ Its value should be an event that has a binding in MENU."
 	   ;; We just did the inner level of a -popup menu.
 	   choice)
 	  ;; We just did the outer level.  Do the inner level now.
-	  (not-menu (tmm-prompt choice t)) 
+	  (not-menu (tmm-prompt choice t))
 	  ;; We just handled a menu keymap and found another keymap.
 	  ((keymapp choice)
 	   (if (symbolp choice)
@@ -246,7 +260,7 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
 (defsubst tmm-add-one-shortcut (elt)
 ;; uses the free vars tmm-next-shortcut-digit and tmm-short-cuts
   (let* ((str (car elt))
-        (paren (string-match "(" str))  
+        (paren (string-match "(" str))
         (pos 0) (word 0) char)
     (catch 'done                        ; ??? is this slow?
       (while (and (or (not tmm-shortcut-words) ; no limit on words
@@ -255,7 +269,7 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
                   (not (and paren (> pos paren)))) ; don't go past "(binding.."
         (if (or (= pos 0)
                 (/= (aref str (1- pos)) ?.)) ; avoid file extensions
-            (let ((shortcut-style                 
+            (let ((shortcut-style
                    (if (listp tmm-shortcut-style) ; convert to list
                        tmm-shortcut-style
                      (list tmm-shortcut-style))))
@@ -281,15 +295,14 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
 (defun tmm-define-keys (minibuffer)
   (let ((map (make-sparse-keymap)))
     (suppress-keymap map t)
-    (mapcar
-     (function
-      (lambda (c)
-        (if (listp tmm-shortcut-style)
-            (define-key map (char-to-string c) 'tmm-shortcut)
-          ;; only one kind of letters are shortcuts, so map both upcase and
-          ;; downcase input to the same
-          (define-key map (char-to-string (downcase c)) 'tmm-shortcut)
-          (define-key map (char-to-string (upcase c)) 'tmm-shortcut))))
+    (mapc
+     (lambda (c)
+       (if (listp tmm-shortcut-style)
+	   (define-key map (char-to-string c) 'tmm-shortcut)
+	 ;; only one kind of letters are shortcuts, so map both upcase and
+	 ;; downcase input to the same
+	 (define-key map (char-to-string (downcase c)) 'tmm-shortcut)
+	 (define-key map (char-to-string (upcase c)) 'tmm-shortcut)))
      tmm-short-cuts)
     (if minibuffer
 	(progn
@@ -308,12 +321,11 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
 
 (defun tmm-add-prompt ()
   (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt)
-  (make-local-hook 'minibuffer-exit-hook)
   (add-hook 'minibuffer-exit-hook 'tmm-delete-map nil t)
   (let ((win (selected-window)))
     (setq tmm-old-mb-map (tmm-define-keys t))
     ;; Get window and hide it for electric mode to get correct size
-    (save-window-excursion 
+    (save-window-excursion
       (let ((completions
 	     (mapcar 'car minibuffer-completion-table)))
         (or tmm-completion-prompt
@@ -322,12 +334,11 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
 	(with-output-to-temp-buffer "*Completions*"
 	  (display-completion-list completions))
         (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt))
-      (if tmm-completion-prompt
-          (progn
-	    (set-buffer "*Completions*")
-	    (goto-char 1)
-            (insert tmm-completion-prompt)))
-      )
+      (when tmm-completion-prompt
+	(set-buffer "*Completions*")
+	(let ((buffer-read-only nil))
+	  (goto-char (point-min))
+	  (insert tmm-completion-prompt))))
     (save-selected-window
       (other-window 1)			; Electric-pop-up-window does
 					; not work in minibuffer
@@ -355,76 +366,100 @@ Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
 	      (re-search-forward
 	       (concat "\\(^\\|[ \t]\\)" (char-to-string c) tmm-mid-prompt))
 	      (choose-completion))
-	  (erase-buffer)		; In minibuffer
-	  (mapcar (lambda (elt)
-		    (if (string=
-			 (substring (car elt) 0 
-				    (min (1+ (length tmm-mid-prompt))
-					 (length (car elt))))
-			 (concat (char-to-string c) tmm-mid-prompt))
-			(setq s (car elt))))
+	  ;; In minibuffer
+	  (delete-region (minibuffer-prompt-end) (point-max))
+	  (mapc (lambda (elt)
+		  (if (string=
+		       (substring (car elt) 0
+				  (min (1+ (length tmm-mid-prompt))
+				       (length (car elt))))
+		       (concat (char-to-string c) tmm-mid-prompt))
+		      (setq s (car elt))))
 		  tmm-km-list)
 	  (insert s)
 	  (exit-minibuffer)))))
 
 (defun tmm-goto-completions ()
   (interactive)
-  (setq tmm-c-prompt (buffer-string))
-  (erase-buffer)
+  (let ((prompt-end (minibuffer-prompt-end)))
+    (setq tmm-c-prompt (buffer-substring prompt-end (point-max)))
+    (delete-region prompt-end (point-max)))
   (switch-to-buffer-other-window "*Completions*")
   (search-forward tmm-c-prompt)
   (search-backward tmm-c-prompt))
 
-(defun tmm-get-keymap (elt &optional in-x-menu) 
+(defun tmm-get-keymap (elt &optional in-x-menu)
   "Prepends (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'.
 The values are deduced from the argument ELT, that should be an
 element of keymap, an `x-popup-menu' argument, or an element of
 `x-popup-menu' argument (when IN-X-MENU is not-nil).
 This function adds the element only if it is not already present.
 It uses the free variable `tmm-table-undef' to keep undefined keys."
-  (let (km str cache (event (car elt)))
+  (let (km str cache plist filter visible (event (car elt)))
     (setq elt (cdr elt))
     (if (eq elt 'undefined)
 	(setq tmm-table-undef (cons (cons event nil) tmm-table-undef))
-      (or
-       (assoc event tmm-table-undef)
-       (and (if (listp elt)
-		(or (keymapp elt) (eq (car elt) 'lambda))
-	      (fboundp elt))
-	    (setq km elt))
-       (and (if (listp (cdr-safe elt))
-		(or (keymapp (cdr-safe elt))
-		    (eq (car (cdr-safe elt)) 'lambda))
-	      (fboundp (cdr-safe elt)))
-	    (setq km (cdr elt))
-	    (and (stringp (car elt)) (setq str (car elt))))
-       (and (if (listp (cdr-safe (cdr-safe elt)))
-		(or (keymapp (cdr-safe (cdr-safe elt)))
-		    (eq (car (cdr-safe (cdr-safe elt))) 'lambda))
-	      (fboundp (cdr-safe (cdr-safe elt))))
-	    (setq km (cdr (cdr elt)))
-	    (and (stringp (car elt)) (setq str (car elt)))
-	    (or (and str
-		     (stringp (cdr (car (cdr elt)))) ; keyseq cache
-		     (setq cache (cdr (car (cdr elt))))
-		     cache (setq str (concat str cache))) str))
-       (and (if (listp (cdr-safe (cdr-safe (cdr-safe elt))))
-		(or (keymapp (cdr-safe (cdr-safe (cdr-safe elt))))
-		    (eq (car (cdr-safe (cdr-safe (cdr-safe elt)))) 'lambda))
-	      (fboundp (cdr-safe (cdr-safe (cdr-safe elt)))))
-					; New style of easy-menu
-	    (setq km (cdr (cdr (cdr elt))))
-	    (and (stringp (car elt)) (setq str (car elt)))
-	    (or (and str
-		     (stringp (cdr (car (cdr (cdr elt))))) ; keyseq cache
-		     (setq cache (cdr (car (cdr (cdr elt)))))
-		     cache (setq str (concat str cache)))
-		str))
-	    (and (stringp event)	; x-popup or x-popup element
-		 (if (or in-x-menu (stringp (car-safe elt)))
-		     (setq str event event nil km elt)
-		   (setq str event event nil km (cons 'keymap elt))
-		   )))
+      (unless (assoc event tmm-table-undef)
+	(cond ((if (listp elt)
+		   (or (keymapp elt) (eq (car elt) 'lambda))
+		 (fboundp elt))
+	       (setq km elt))
+
+	      ((if (listp (cdr-safe elt))
+		   (or (keymapp (cdr-safe elt))
+		       (eq (car (cdr-safe elt)) 'lambda))
+		 (fboundp (cdr-safe elt)))
+	       (setq km (cdr elt))
+	       (and (stringp (car elt)) (setq str (car elt))))
+
+	      ((if (listp (cdr-safe (cdr-safe elt)))
+		   (or (keymapp (cdr-safe (cdr-safe elt)))
+		       (eq (car (cdr-safe (cdr-safe elt))) 'lambda))
+		 (fboundp (cdr-safe (cdr-safe elt))))
+	       (setq km (cdr (cdr elt)))
+	       (and (stringp (car elt)) (setq str (car elt)))
+	       (and str
+		    (stringp (cdr (car (cdr elt)))) ; keyseq cache
+		    (setq cache (cdr (car (cdr elt))))
+		    cache (setq str (concat str cache))))
+
+	      ((eq (car-safe elt) 'menu-item)
+	       ;; (menu-item TITLE COMMAND KEY ...)
+	       (setq plist (cdr-safe (cdr-safe (cdr-safe elt))))
+	       (when (consp (car-safe plist))
+		 (setq plist (cdr-safe plist)))
+	       (setq km (nth 2 elt))
+	       (setq str (eval (nth 1 elt)))
+	       (setq filter (plist-get plist :filter))
+	       (if filter
+		   (setq km (funcall filter km)))
+	       (setq visible (plist-get plist :visible))
+	       (if visible
+		   (setq km (and (eval visible) km)))
+	       (and str
+		    (consp (nth 3 elt))
+		    (stringp (cdr (nth 3 elt))) ; keyseq cache
+		    (setq cache (cdr (nth 3 elt)))
+		    cache
+		    (setq str (concat str cache))))
+
+	      ((if (listp (cdr-safe (cdr-safe (cdr-safe elt))))
+		   (or (keymapp (cdr-safe (cdr-safe (cdr-safe elt))))
+		       (eq (car (cdr-safe (cdr-safe (cdr-safe elt)))) 'lambda))
+		 (fboundp (cdr-safe (cdr-safe (cdr-safe elt)))))
+					 ; New style of easy-menu
+	       (setq km (cdr (cdr (cdr elt))))
+	       (and (stringp (car elt)) (setq str (car elt)))
+	       (and str
+		    (stringp (cdr (car (cdr (cdr elt))))) ; keyseq cache
+		    (setq cache (cdr (car (cdr (cdr elt)))))
+		    cache (setq str (concat str cache))))
+
+	      ((stringp event)		; x-popup or x-popup element
+	       (if (or in-x-menu (stringp (car-safe elt)))
+		   (setq str event event nil km elt)
+		 (setq str event event nil km (cons 'keymap elt))
+		 ))))
       (and km (stringp km) (setq str km))
       ;; Verify that the command is enabled;
       ;; if not, don't mention it.
@@ -433,9 +468,7 @@ It uses the free variable `tmm-table-undef' to keep undefined keys."
 	  (setq km nil)))
       (and km str
 	   (or (assoc str tmm-km-list)
-	       (setq tmm-km-list 
-		     (cons (cons str (cons event km)) tmm-km-list)))
-	   ))))
+	       (push (cons str (cons event km)) tmm-km-list))))))
 
 (defun tmm-get-keybind (keyseq)
   "Return the current binding of KEYSEQ, merging prefix definitions.
@@ -454,17 +487,17 @@ of `menu-bar-final-items'."
 	(progn
 	  ;; Otherwise, it is a prefix, so make a list of the subcommands.
 	  ;; Make a list of all the bindings in all the keymaps.
-	  (setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq))) 
+	  (setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq)))
 	  (setq allbind (cons (local-key-binding keyseq) allbind))
 	  (setq allbind (cons (global-key-binding keyseq) allbind))
 	  ;; Merge all the elements of ALLBIND into one keymap.
-	  (mapcar (lambda (in)
-		    (if (and (symbolp in) (keymapp in))
-			(setq in (symbol-function in)))
-		    (and in (keymapp in)
-			 (if (keymapp bind)
-			     (setq bind (nconc bind (copy-sequence (cdr in))))
-			   (setq bind (copy-sequence in)))))
+	  (mapc (lambda (in)
+		  (if (and (symbolp in) (keymapp in))
+		      (setq in (symbol-function in)))
+		  (and in (keymapp in)
+		       (if (keymapp bind)
+			   (setq bind (nconc bind (copy-sequence (cdr in))))
+			 (setq bind (copy-sequence in)))))
 		  allbind)
 	  ;; Return that keymap.
 	  bind))))
@@ -473,4 +506,5 @@ of `menu-bar-final-items'."
 
 (provide 'tmm)
 
+;;; arch-tag: e7ddbdb6-4b95-4da3-afbe-ad6063d112f4
 ;;; tmm.el ends here