;;; tmm.el --- text mode access to menu-bar
-;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1996, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006 Free Software Foundation, Inc.
;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu>
;; Maintainer: FSF
+;; Keywords: convenience
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
-;;; Commentary ============================================================
+;;; Commentary:
-;;; To use this package add
+;; This package provides text mode access to the menu bar.
-;;; (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.
+;;; 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)
(defvar tmm-old-comp-map)
(defvar tmm-c-prompt)
(defvar tmm-km-list)
+(defvar tmm-next-shortcut-digit)
(defvar tmm-table-undef)
;;;###autoload (define-key global-map "\M-`" 'tmm-menubar)
(interactive "e")
(tmm-menubar (car (posn-x-y (event-start event)))))
-(defvar tmm-mid-prompt "==>"
- "String to insert between shortcut and menu item or nil.")
+(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."
+ :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.
"
- "What insert on top of completion buffer.")
+ "*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."
+ :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."
+ :type '(choice integer (const nil))
+ :group 'tmm)
+
+(defface tmm-inactive
+ '((t :inherit shadow))
+ "Face used for inactive menu items."
+ :group 'tmm)
;;;###autoload
(defun tmm-prompt (menu &optional in-popup default-item)
;; 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)))
;; 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
;; 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)))
+ (let ((prompt (concat "^." (regexp-quote tmm-mid-prompt))))
+ (setq history
+ (reverse (delq nil
+ (mapcar
+ (lambda (elt)
+ (if (string-match prompt (car elt))
+ (car elt)))
+ tmm-km-list)))))
(setq history-len (length history))
(setq history (append history history history history))
(setq tmm-c-prompt (nth (- history-len 1 index-of-default) history))
(add-hook 'minibuffer-setup-hook 'tmm-add-prompt)
- (unwind-protect
- (setq out
- (completing-read
- (concat gl-str " (up/down to change, PgUp to menu): ")
- tmm-km-list nil t nil
- (cons 'history (- (* 2 history-len) index-of-default))))
- (save-excursion
- (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt)
- (if (get-buffer "*Completions*")
- (progn
- (set-buffer "*Completions*")
- (use-local-map tmm-old-comp-map)
- (bury-buffer (current-buffer)))))
- )))
+ (save-excursion
+ (unwind-protect
+ (setq out
+ (completing-read
+ (concat gl-str " (up/down to change, PgUp to menu): ")
+ tmm-km-list nil t nil
+ (cons 'history (- (* 2 history-len) index-of-default))))
+ (save-excursion
+ (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt)
+ (if (get-buffer "*Completions*")
+ (progn
+ (set-buffer "*Completions*")
+ (use-local-map tmm-old-comp-map)
+ (bury-buffer (current-buffer)))))
+ ))))
(setq choice (cdr (assoc out tmm-km-list)))
(and (null choice)
(> (length out) (length tmm-c-prompt))
(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.
;; 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)
;; We just handled a menu keymap and found a command.
(choice
(if chosen-string
- (call-interactively choice)
+ (progn
+ (setq last-command-event chosen-string)
+ (call-interactively choice))
choice)))))
-
(defun tmm-add-shortcuts (list)
"Adds shortcuts to cars of elements of the list.
Takes a list of lists with a string as car, returns list with
shortcuts added to these cars.
Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
- (let ((next-shortcut-number 0))
- (mapcar (lambda (elt)
- (let ((str (car elt)) f b)
- (setq f (upcase (substring str 0 1)))
- ;; If does not work, try beginning of the other word
- (if (and (member f tmm-short-cuts)
- (string-match " \\([^ ]\\)" str))
- (setq f (upcase (substring
- str
- (setq b (match-beginning 1)) (1+ b)))))
- ;; If we don't have an unique letter shortcut,
- ;; pick a digit as a shortcut instead.
- (if (member f tmm-short-cuts)
- (if (< next-shortcut-number 10)
- (setq f (format "%d" next-shortcut-number)
- next-shortcut-number (1+ next-shortcut-number))
- (setq f nil)))
- (if (null f)
- elt
- (setq tmm-short-cuts (cons f tmm-short-cuts))
- (cons (concat f tmm-mid-prompt str) (cdr elt)))))
- (reverse list))))
-
-(defun tmm-define-keys ()
- (mapcar (lambda (str)
- (define-key (current-local-map) str 'tmm-shortcut)
- (define-key (current-local-map) (downcase str) 'tmm-shortcut))
- tmm-short-cuts)
- (define-key (current-local-map) [pageup] 'tmm-goto-completions)
- (define-key (current-local-map) [prior] 'tmm-goto-completions)
- (define-key (current-local-map) "\ev" 'tmm-goto-completions)
- (define-key (current-local-map) "\C-n" 'next-history-element)
- (define-key (current-local-map) "\C-p" 'previous-history-element))
+ (let ((tmm-next-shortcut-digit ?0))
+ (mapcar 'tmm-add-one-shortcut (reverse list))))
+
+(defsubst tmm-add-one-shortcut (elt)
+;; uses the free vars tmm-next-shortcut-digit and tmm-short-cuts
+ (cond
+ ((eq (cddr elt) 'ignore)
+ (cons (concat " " (make-string (length tmm-mid-prompt) ?\-)
+ (car elt))
+ (cdr elt)))
+ (t
+ (let* ((str (car elt))
+ (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
+ (< word tmm-shortcut-words)) ; try n words
+ (setq pos (string-match "\\w+" str pos)) ; get next word
+ (not (and paren (> pos paren)))) ; don't go past "(binding.."
+ (if (or (= pos 0)
+ (/= (aref str (1- pos)) ?.)) ; avoid file extensions
+ (let ((shortcut-style
+ (if (listp tmm-shortcut-style) ; convert to list
+ tmm-shortcut-style
+ (list tmm-shortcut-style))))
+ (while shortcut-style ; try upcase and downcase variants
+ (setq char (funcall (car shortcut-style) (aref str pos)))
+ (if (not (memq char tmm-short-cuts)) (throw 'done char))
+ (setq shortcut-style (cdr shortcut-style)))))
+ (setq word (1+ word))
+ (setq pos (match-end 0)))
+ (while (<= tmm-next-shortcut-digit ?9) ; no letter shortcut, pick a digit
+ (setq char tmm-next-shortcut-digit)
+ (setq tmm-next-shortcut-digit (1+ tmm-next-shortcut-digit))
+ (if (not (memq char tmm-short-cuts)) (throw 'done char)))
+ (setq char nil))
+ (if char (setq tmm-short-cuts (cons char tmm-short-cuts)))
+ (cons (concat (if char (concat (char-to-string char) tmm-mid-prompt)
+ ;; keep them lined up in columns
+ (make-string (1+ (length tmm-mid-prompt)) ?\ ))
+ str)
+ (cdr elt))))))
+
+;; This returns the old map.
+(defun tmm-define-keys (minibuffer)
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map t)
+ (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
+ (define-key map [pageup] 'tmm-goto-completions)
+ (define-key map [prior] 'tmm-goto-completions)
+ (define-key map "\ev" 'tmm-goto-completions)
+ (define-key map "\C-n" 'next-history-element)
+ (define-key map "\C-p" 'previous-history-element)))
+ (prog1 (current-local-map)
+ (use-local-map (append map (current-local-map))))))
+
+(defun tmm-completion-delete-prompt ()
+ (set-buffer standard-output)
+ (goto-char 1)
+ (delete-region 1 (search-forward "Possible completions are:\n")))
+
+(defun tmm-remove-inactive-mouse-face ()
+ "Remove the mouse-face property from inactive menu items."
+ (let ((inhibit-read-only t)
+ (inactive-string
+ (concat " " (make-string (length tmm-mid-prompt) ?\-)))
+ next)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq next (next-single-char-property-change (point) 'mouse-face))
+ (when (looking-at inactive-string)
+ (remove-text-properties (point) next '(mouse-face))
+ (add-text-properties (point) next '(face tmm-inactive)))
+ (goto-char next)))
+ (set-buffer-modified-p nil)))
(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)
+ (unless tmm-c-prompt
+ (error "No active menu entries"))
(let ((win (selected-window)))
- (setq tmm-old-mb-map (current-local-map))
- (use-local-map (append (make-sparse-keymap) tmm-old-mb-map))
- (tmm-define-keys)
+ (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
+ (add-hook 'completion-setup-hook
+ 'tmm-completion-delete-prompt 'append))
(with-output-to-temp-buffer "*Completions*"
- (display-completion-list completions)))
+ (display-completion-list completions))
+ (remove-hook 'completion-setup-hook 'tmm-completion-delete-prompt))
(set-buffer "*Completions*")
- (goto-char 1)
- (insert tmm-completion-prompt)
- )
- (save-excursion
+ (tmm-remove-inactive-mouse-face)
+ (when tmm-completion-prompt
+ (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
- (set-buffer (window-buffer (Electric-pop-up-window "*Completions*")))
- (setq tmm-old-comp-map (current-local-map))
- (use-local-map (append (make-sparse-keymap) tmm-old-comp-map))
- (tmm-define-keys)
- (select-window win) ; Cannot use
- ; save-window-excursion, since
- ; it restores the size
- )
+ (Electric-pop-up-window "*Completions*")
+ (with-current-buffer "*Completions*"
+ (setq tmm-old-comp-map (tmm-define-keys nil))))
(insert tmm-c-prompt)))
(defun tmm-delete-map ()
(defun tmm-shortcut ()
"Choose the shortcut that the user typed."
(interactive)
- (let ((c (upcase (char-to-string last-command-char))) s)
- (if (member c tmm-short-cuts)
+ (let ((c last-command-char) s)
+ (if (symbolp tmm-shortcut-style)
+ (setq c (funcall tmm-shortcut-style c)))
+ (if (memq c tmm-short-cuts)
(if (equal (buffer-name) "*Completions*")
(progn
- (beginning-of-buffer)
+ (goto-char (point-min))
(re-search-forward
- (concat "\\(^\\|[ \t]\\)" c tmm-mid-prompt))
+ (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 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 enable (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)
- (keymapp elt)
- (fboundp elt))
- (setq km elt))
- (and (if (listp (cdr-safe elt))
- (keymapp (cdr-safe elt))
- (fboundp (cdr-safe elt)))
- (setq km (cdr elt))
- (and (stringp (car elt)) (setq str (car elt))))
- (and (if (listp (cdr-safe (cdr-safe elt)))
- (keymapp (cdr-safe (cdr-safe elt)))
- (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))))
- (keymapp (cdr-safe (cdr-safe (cdr-safe elt))))
- (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)))
+ (setq enable (plist-get plist :enable))
+ (if enable
+ (setq km (if (eval enable) km 'ignore)))
+ (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.
+ (when (and km (symbolp km) (get km 'menu-enable))
+ (setq km (if (eval (get km 'menu-enable)) km 'ignore)))
(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.
(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))))
(add-hook 'calendar-load-hook (lambda () (require 'cal-menu)))
-
(provide 'tmm)
-
+;;; arch-tag: e7ddbdb6-4b95-4da3-afbe-ad6063d112f4
;;; tmm.el ends here