;;; vt-menu.el --- Video Terminal Menu with Mouse support ;; ;; Copyright (C) 2007 Free Software Foundation, Inc. ;; ;; Author: Daniel Dean Badger 2007 ;; Maintainers: ;; Created: 2007 ;; Version: 0.7 ;; Keywords: menu, mouse, terminal, terminals ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; 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, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;; Fodder: ;; ;; ;;; tmm.el --- Text Mode access to Menu-bar ;; ;; Author: Ilya Zakharevich 1994 ;; ;; ;;; vt-mouse.el --- Video Terminal Mouse support ;; ;; Author: Devon Sean McCullough 2001 ;; ;;; Commentary: ;; This `vt-menu' package provides `vt-mouse' access to the menu-bar. ;; ;; Essentially a re-write of `tmm.el', merged with methods for employing ;; `vt-mouse' functionality, plus additional propertizations using an ;; independent menu-completions buffer window placed under the menu-bar ;; rather than at the bottom, for better proximity context; ;; This module is currently a requirement of `vt-mouse.el', but is ;; capable of being used independently, as an enhancement to `tmm'. ;; .emacs file additions and usage: ;; ;; ;;; to acquire `vt-menu' definitions independent of vt-mouse: ;; ;; (require 'vt-menu) ; also starts (vt-menu-mode) setting key bindings ;; ;; ; (vt-menu-mode 0) ; use to restore old key bindings ;; ;;; for `vt-mouse' support, use instead since this module is required ;; ;; (require 'vt-mouse) ;; ;;; by vt-mouse. ;;; HISTORY ; 2007 Wed Mar 14 21:03 EDT badger initial section of vt-menu.el from vt-mouse.el ; 2007 Feb 18 Sun 17:00 EST badger add mouse menu interface to tmm for vt-mouse ;;; Code: ;; First acquire any needed bindings or dependencies. (require 'vt-aux) ; debug and compatability support (require 'electric) ; for display of menu completions ;; our group (defgroup vt-menu nil "VT mouse and text mode access to menu-bar." :tag "Video Terminal Menu" :prefix "vt-menu-" :group 'menu) ;;; The following will be localized, added only to pacify the compiler. (defvar vt-menu-short-cuts) (defvar vt-menu-old-mb-map nil) (defvar vt-menu-old-comp-map) (defvar vt-menu-c-prompt) (defvar vt-menu-km-list) (defvar vt-menu-next-shortcut-digit) (defvar vt-menu-table-undef) ;; Internal global menu state variables (defvar vt-menu-active nil "Non-nil whenever a text menu is active.") (defvar vt-menu-window nil "Selected window when menu first activated.") (defvar vt-menu-buffer nil "Current buffer when menu first activated.") (defvar vt-menu-vector nil "Command keys required to launch selection.") (defvar vt-menu-string nil "Current menu representation.") (defvar vt-menu-depth 0 "Depth of current menu") (defvar vt-menu-window-configuration nil "Window configuration upon root menubar action.") (defvar vt-menu-mark-active nil "Whether the original buffer had mark set.") (defvar vt-menu-mb-map nil "A place to store minibuffer map.") (defvar vt-menu-saved-keys nil "Where some original bindings are stored") ;; Customizables (defcustom vt-menu-completion-prompt "" "*Help text to insert on the top of the completion buffer. To save space, you can set this to empty string; in any case the standard completions help text is removed." :type '(choice string (const "")) :group 'vt-menu) (defcustom vt-menu-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 'vt-menu) (defcustom vt-menu-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 'vt-menu) (defcustom vt-menu-shortcut-words 2 "*How many successive words to try for shortcuts, nil means all. If you use only one of `downcase' or `upcase' for `vt-menu-shortcut-style', specify nil for this variable." :type '(choice integer (const nil)) :group 'vt-menu) ;; Shorthand for selecting first frame window. (defun select-first-window (&optional frame) "Selects the topmost, leftmost window of FRAME, or selected frame if omitted." (let ((which-frame (if (framep frame) frame (selected-frame)))) (select-window (if (fboundp 'frame-first-window) (frame-first-window frame) (window-at ; select window under menu-bar selection 0 (or (frame-parameter frame 'menu-bar-lines) 1)))))) ;; (keymap-prompt) missing from emacs-version < 21.5 ;; Provides given prompt for the supplied keymap or menu-item. (defun vt-keymap-prompt (keylist) "Return the first string or first token as string from keylist in menu or keymap form." (cond ((not keylist) nil) ((stringp keylist) keylist) ((symbolp keylist) (format "%S" keylist)) ((and (consp keylist) (symbolp (cdr keylist))) (format "%S" (car keylist))) ((listp keylist) (let ((prompt nil)) (dolist (key keylist) (when (stringp key) (unless (and (stringp prompt) (not (string= "--" key))) (setq prompt key)))) (unless prompt (dolist (key keylist) (unless (or prompt (member key '(keymap menu-item :visible :help :enable :toggle :button :filter :keys :key-sequence nil))) (setq prompt (format "%S" key))))) prompt)) (t nil))) ;; Attempt to return the first symbol intended as the keyname for the list. ;; (vt-menu-keyname '(major "major" . theory-scale-major)) ;; (vt-menu-keyname (vt-menu-get-keybind [menu-bar edit])) ;; Provides given keyname for the supplied keymap or menu-item. (defun vt-menu-keyname (keylist) "Return the first non-string token symbol from keylist in menu or keymap form." (cond ((and (consp keylist) (symbolp (cdr keylist))) (if (stringp (car keylist)) (cdr keylist) ; ("string" . SYMBOL) (and (symbolp (car keylist)) (car keylist)))) ; (SYMBOL . symbol) ((listp keylist) (do ((item-list keylist (cdr item-list))) ((or (not (consp item-list)) (and (symbolp (car item-list)) (not (member (car item-list) '(keymap menu-item :visible :help :enable :toggle :button :filter :keys :key-sequence nil))))) (car item-list)))) ; ( ... SYMBOL ...) ((symbolp keylist) keylist) ; SYMBOL (t nil))) ; (dolist (item (vt-menu-get-keybind [menu-bar])) (print (vt-menu-keyname item))) ;; Originally tmm-add-shortcuts, otherwise unchanged except for ;; converted global variable names. (defun vt-menu-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 `vt-menu-short-cuts'." (let ((vt-menu-next-shortcut-digit ?0)) (mapcar 'vt-menu-add-one-shortcut (reverse list)))) ;; Originally tmm-add-one-shortcut, otherwise unchanged except for ;; converted global variable names. (defsubst vt-menu-add-one-shortcut (elt) ;; uses the free vars vt-menu-next-shortcut-digit and vt-menu-short-cuts (let* ((str (car elt)) (paren (string-match "(" str)) (pos 0) (word 0) char) (catch 'done ; ??? is this slow? (while (and (or (not vt-menu-shortcut-words) ; no limit on words (< word vt-menu-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 vt-menu-shortcut-style) ; convert to list vt-menu-shortcut-style (list vt-menu-shortcut-style)))) (while shortcut-style ; try upcase and downcase variants (setq char (funcall (car shortcut-style) (aref str pos))) (if (not (memq char vt-menu-short-cuts)) (throw 'done char)) (setq shortcut-style (cdr shortcut-style))))) (setq word (1+ word)) (setq pos (match-end 0))) (while (<= vt-menu-next-shortcut-digit ?9) ; no letter shortcut, pick a digit (setq char vt-menu-next-shortcut-digit) (setq vt-menu-next-shortcut-digit (1+ vt-menu-next-shortcut-digit)) (if (not (memq char vt-menu-short-cuts)) (throw 'done char))) (setq char nil)) (if char (setq vt-menu-short-cuts (cons char vt-menu-short-cuts))) (cons (concat (if char (concat (char-to-string char) vt-menu-mid-prompt) ;; keep them lined up in columns (make-string (1+ (length vt-menu-mid-prompt)) ?\ )) str) (cdr elt)))) ;; This returns the old minibuffer map and sets up the menu-completions map. (defun vt-menu-define-keys (minibuffer) (let ((map (make-sparse-keymap))) (suppress-keymap map t) (mapc (lambda (c) (if (listp vt-menu-shortcut-style) (define-key map (char-to-string c) 'vt-menu-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)) 'vt-menu-shortcut) (define-key map (char-to-string (upcase c)) 'vt-menu-shortcut))) vt-menu-short-cuts) (if minibuffer (progn (define-key map [pageup] 'vt-menu-goto-completions) (define-key map [prior] 'vt-menu-goto-completions) (define-key map "\ev" 'vt-menu-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)))))) ;; Closes menu completions window and exits from minibuffer. (defun vt-menu-cancel () "Provides quick escape hatch from `vt-menubar' invocation." (interactive) (erase-active-minibuffer) (set-window-configuration vt-menu-window-configuration) (select-window vt-menu-window) (when vt-menu-mark-active (setq deactivate-mark nil)) (setq vt-menu-active nil vt-menu-string "" vt-menu-vector nil vt-menu-window-configuration nil vt-menu-window nil vt-menu-mark-active nil) (vt-debug-message "VT-menu cancelled.") (exit-minibuffer)) ;; Closes menu completions window and exits from minibuffer, ;; queuing command events which show selected parent menu. (defun vt-menu-reselect (&optional depth) "Selects menu-completions at provided depth." (interactive) (if (not depth) (setq depth (- (length vt-menu-vector) 1))) (let ((eject (- (length vt-menu-vector) depth 1))) (dotimes (n eject) (pop vt-menu-vector))) (while vt-menu-vector (let ((key (pop vt-menu-vector))) (if (eq key 'menu-bar) (setq key (list 'vt-menubar 'reselect))) (push key unread-command-events))) (vt-debug-message "unread-command-events %S " unread-command-events) (erase-active-minibuffer) (set-window-configuration vt-menu-window-configuration) (select-window vt-menu-window) (when vt-menu-mark-active (setq deactivate-mark nil)) (setq vt-menu-active nil vt-menu-string "" vt-menu-vector nil vt-menu-window-configuration nil vt-menu-window nil vt-menu-mark-active nil) (exit-minibuffer)) ;; Re-invokes the selected ancestor menu. (defun vt-menu-select-ancestor (click) "Switch menu-completions to that of selected parent menu." (interactive "e") (vt-debug-message "click = %S" click) (let* ((posn (event-start click)) (pos (posn-point posn)) (depth (get-text-property pos 'depth))) (vt-debug-message "vt-menu-depth %S depth %S vt-menu-vector %S " vt-menu-depth depth vt-menu-vector) (when (numberp depth) ;; purge anything in current event stream and menu settings (while (pop unread-command-events)) (while (input-pending-p) (read-event)) (select-window (active-minibuffer-window)) (cond ;; pressing Menu Bar link when in top level menu cancels ((and (zerop vt-menu-depth) (zerop depth)) (vt-menu-cancel)) ;; when requested depth < current depth rebuild at that level ((> (- (length vt-menu-vector) 1) depth) (vt-menu-reselect depth)) ;; someplace else gets a beep; probably should be intangible (t (ding 'keep-stream)))))) ;; This hook mangles the prompt automagically generated by ;; `display-completions-list' into condensed forms and sets ;; various additional text properties. (defun vt-menu-completion-replace-prompt () "Replaces automatically created prompt with propertized menu heiarchy." (set-buffer "*Menu Completions*") (let ((inhibit-read-only t) (from (point-min)) (to (or (search-forward "Possible completions are:" nil t) (point-min)))) (ignore-errors (delete-region from to)) (when vt-menu-completion-prompt (insert vt-menu-completion-prompt)) (insert vt-menu-string "> \n") (let ((pos (point)) (before 0) (map (make-sparse-keymap "Ancestor"))) (define-key map [mouse-1] 'vt-menu-select-ancestor) (goto-char (setq from (point-min))) (goto-char (search-forward "> \n")) (backward-char 1) (setq to (point)) (save-excursion (put-text-property from to 'keymap map) (goto-char pos) (when (and (functionp 'global-font-lock-mode) global-font-lock-mode) (while (setq pos (search-forward vt-menu-mid-prompt nil t)) (when (plusp before) (add-text-properties before (- (- pos (length vt-menu-mid-prompt)) 1) '(face font-lock-type-face))) (setq before pos) (add-text-properties (- (- pos (length vt-menu-mid-prompt)) 1) (- pos (length vt-menu-mid-prompt)) '(face bold)) (add-text-properties (- pos (length vt-menu-mid-prompt)) pos '(face font-lock-function-name-face))) (add-text-properties (progn (goto-char before) (point)) (progn (end-of-line) (point)) '(face font-lock-type-face))))))) ;; Earlier versions of Emacs are missing set-window-text-height (defun vt-menu-resize-completions () "Attempt better sizing of *Menu Completions* window" (if (functionp 'set-window-text-height) (set-window-text-height (selected-window) (count-lines (point-min) (point-max))) (let* ((line-count (count-lines (point-min) (point-max))) (difference (- line-count (window-height)))) (incf difference) (if (plusp difference) (enlarge-window difference) (shrink-window (abs difference)))))) ;; This hook is run when a new completion list is generated by `vt-menu-prompt'. (defun vt-menu-add-prompt () (remove-hook 'minibuffer-setup-hook 'vt-menu-add-prompt) (make-local-hook 'minibuffer-exit-hook) (add-hook 'minibuffer-exit-hook 'vt-menu-delete-map nil t) (setq vt-menu-old-mb-map (vt-menu-define-keys t)) ;; Get window and hide it for electric mode to get correct size (save-window-excursion (let ((completions (mapcar 'car minibuffer-completion-table))) (and vt-menu-completion-prompt (add-hook 'completion-setup-hook 'vt-menu-completion-replace-prompt 'append)) (with-output-to-temp-buffer "*Menu Completions*" (display-completion-list completions)) (remove-hook 'completion-setup-hook 'vt-menu-completion-replace-prompt))) (save-selected-window (other-window 1) ; Electric-pop-up-window fails when called from minibuffer (Electric-pop-up-window "*Menu Completions*") (local-set-key [mouse-1] 'vt-menu-selection) ;; set the window size again to correct some version skew mishaps (vt-menu-resize-completions)) (insert vt-menu-c-prompt)) ;; Fundamentally unchanged from its tmm-delete-map ancestor. (defun vt-menu-delete-map () (remove-hook 'minibuffer-exit-hook 'vt-menu-delete-map t) (if vt-menu-old-mb-map (use-local-map vt-menu-old-mb-map))) ;; Fundamentally unchanged from its tmm-shortcut ancestor. (defun vt-menu-shortcut () "Choose the shortcut that the user typed." (interactive) (let ((c last-command-char) s) (if (symbolp vt-menu-shortcut-style) (setq c (funcall vt-menu-shortcut-style c))) (if (memq c vt-menu-short-cuts) (if (equal (buffer-name) "*Menu Completions*") (progn (beginning-of-buffer) (re-search-forward (concat "\\(^\\|[ \t]\\)" (char-to-string c) vt-menu-mid-prompt)) (choose-completion)) ;; In minibuffer (clear-minibuffer-input) (mapc (lambda (elt) (if (string= (substring (car elt) 0 (min (1+ (length vt-menu-mid-prompt)) (length (car elt)))) (concat (char-to-string c) vt-menu-mid-prompt)) (setq s (car elt)))) vt-menu-km-list) (insert s) (exit-minibuffer))))) ;; This function ensures menu-completions window is available when ;; setting up prompts from within the minibuffer. It is fundamentally ;; unchanged from its tmm-goto-completions ancestor. (defun vt-menu-goto-completions () "Switch to menu-completions from minibuffer." (interactive) ;; (if (functionp 'minibuffer-prompt-end) ;; (let ((prompt-end (minibuffer-prompt-end))) ;; (setq vt-menu-c-prompt (buffer-substring prompt-end (point-max))) ;; (delete-region prompt-end (point-max))) ;; (erase-buffer)) (setq vt-menu-c-prompt (clear-minibuffer-input)) (switch-to-buffer-other-window "*Menu Completions*") (search-forward vt-menu-c-prompt) (search-backward vt-menu-c-prompt)) ;; This procedure selects the menu-completions window, creating if needed, ;; positioned under menu-bar, sized and sensitized appropriately. It is ;; vaguely analogous to `switch-to-completions'. (defun vt-menu-switch-to-completions () "Exhume or initialize the menu-completions window used by `vt-menubar'." (interactive) ;; save events for final selection of menu completions window (let ((queued-events (copy-tree (reverse unread-command-events)))) ;; purge current events (while (pop unread-command-events)) ;; check for an existing menu-completions window (unless (get-buffer-window "*Menu Completions*") ;; create window under menu-bar for menu-completions (select-first-window) (let (winbuf (current-buffer)) (switch-to-buffer "*Menu Completions*") (local-set-key [mouse-1] 'vt-menu-selection) (unless (eq winbuf (current-buffer)) (when (zerop (buffer-size)) (let ((buffer-read-only nil)) (erase-buffer) (insert "\n\n\n generating menu-completions... \n\n\n\n"))) ;; split off new menu-completions window (unless (< (window-height) 10) (split-window) (other-window 1) (switch-to-buffer winbuf) (other-window -1))))) ;; ensure menu-completions window is under menu-bar (select-first-window) (let ((first-window (selected-window)) (menu-window (get-buffer-window "*Menu Completions*"))) (unless (equalp first-window menu-window) (select-window menu-window) (bury-buffer) (select-window first-window) (switch-to-buffer "*Menu Completions*") ;; split off old menu-completions window (unless (< (window-height) 12) (split-window) (other-window 1) (bury-buffer) (other-window -1)))) ;; requeue events, reselect menu-completions window, and resize (dolist (event queued-events) (push event unread-command-events)) (let ((window (get-buffer-window "*Menu Completions*"))) (when window (select-window window) (local-set-key [mouse-1] 'vt-menu-selection) (vt-menu-resize-completions))))) ;;; CHOICE is now (STRING . MEANING). Separate as needed. ;; This function differs from its tmm-menu-prompt ancestor by having ;; an option to merely return the choice cons, rather than executing ;; the menu-item procedure chosen, also in that it provides more ;; highlight propertization, using its own completions buffer. (defun vt-menu-prompt (menu &optional in-popup default-item fetch) "VT-mouse text-mode emulation of calling the bindings in keymap. Creates a propertized text-mode menu-completion buffer and window with possible menu choices accessible either via history mechanism from the minibuffer, or via menu-completion buffer shown. MENU is like the MENU argument to `x-popup-menu': either a keymap or an alist of alists. DEFAULT-ITEM, if non-nil, specifies an initial default choice. Its value should be an event that has a binding in MENU. When FETCH is non-nil a cons of the form (String . Meaning) is returned rather than execution of selected option. This method of use is intended for calling from `vt-menubar'." ;; If the optional argument IN-POPUP is t, ;; then MENU is an alist of elements of the form (STRING . VALUE). ;; That is used for recursive calls only. (let ((gl-str "Menu bar") ;; The menu bar itself is not a menu keymap so it doesn't have a name. vt-menu-km-list out history history-len vt-menu-table-undef vt-menu-c-prompt vt-menu-old-mb-map vt-menu-old-comp-map vt-menu-short-cuts chosen-string choice (not-menu (not (keymapp menu)))) ;;; (run-hooks 'activate-menubar-hook) ;; Compute vt-menu-km-list from MENU. ;; vt-menu-km-list is an alist of (STRING . MEANING). ;; It has no other elements. ;; The order of elements in vt-menu-km-list is the order of the menu bar. (mapc (lambda (elt) (if (stringp elt) (setq gl-str elt) (and (listp elt) (vt-menu-get-keymap elt not-menu)))) menu) ;; Choose an element of vt-menu-km-list; put it in choice. (if (and not-menu (= 1 (length vt-menu-km-list))) ;; If this is the top-level of an x-popup-menu menu, ;; and there is just one pane, choose that one silently. ;; This way we only ask the user one question, ;; for which element of that pane. (setq choice (cdr (car vt-menu-km-list))) (unless vt-menu-km-list (error "Empty menu reached")) (and vt-menu-km-list (let ((index-of-default 0)) (if vt-menu-mid-prompt (setq vt-menu-km-list (vt-menu-add-shortcuts vt-menu-km-list)) t) ;; Find the default item's index within the menu bar. ;; We use this to decide the initial minibuffer contents ;; and initial history position. (if default-item (let ((tail menu)) (while (and tail (not (eq (car-safe (car tail)) default-item))) ;; Be careful to count only the elements of MENU ;; that actually constitute menu bar items. (if (and (consp (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))))) (let ((prompt (concat "^." (regexp-quote vt-menu-mid-prompt)))) (setq history (reverse (delq nil (mapcar (lambda (elt) (if (string-match prompt (car elt)) (car elt))) vt-menu-km-list))))) (setq history-len (length history)) (setq history (append history history history history)) (setq vt-menu-c-prompt (nth (- history-len 1 index-of-default) history)) (add-hook 'minibuffer-setup-hook 'vt-menu-add-prompt) (save-excursion (unwind-protect (let ((miniprompt " (up/down to change, PgUp to menu): ")) (setq out (completing-read (concat gl-str (if (and global-font-lock-mode (functionp 'propertize)) (propertize miniprompt 'face 'font-lock-type-face) miniprompt)) vt-menu-km-list nil t nil (cons 'history (- (* 2 history-len) index-of-default))))) (save-excursion (remove-hook 'minibuffer-setup-hook 'vt-menu-add-prompt) (if (get-buffer "*Menu Completions*") (progn (set-buffer "*Menu Completions*") (use-local-map vt-menu-old-comp-map) (bury-buffer (current-buffer))))) )))) (setq choice (cdr (assoc out vt-menu-km-list))) (and (null choice) (> (length out) (length vt-menu-c-prompt)) (string= (substring out 0 (length vt-menu-c-prompt)) vt-menu-c-prompt) (setq out (substring out (length vt-menu-c-prompt)) choice (cdr (assoc out vt-menu-km-list)))) (and (null choice) out (setq out (try-completion out vt-menu-km-list) choice (cdr (assoc out vt-menu-km-list))))) (if fetch ;; Just return choice cons as is when fetching. choice ;; CHOICE is now (STRING . MEANING). Separate the two parts. (setq chosen-string (car choice)) (setq choice (cdr choice)) (cond (in-popup ;; We just did the inner level of a -popup menu. choice) ;; We just did the outer level. Do the inner level now. (not-menu (vt-menu-prompt choice t)) ;; We just handled a menu keymap and found another keymap. ((keymapp choice) (if (symbolp choice) (setq choice (indirect-function choice))) (condition-case nil (require 'mouse) (error nil)) (condition-case nil (x-popup-menu nil choice) ; Get the shortcuts (error nil)) (vt-menu-prompt choice)) ;; We just handled a menu keymap and found a command. (choice (if chosen-string (progn (setq last-command-event chosen-string) (call-interactively choice)) choice)))))) ;; Key to stuff into input queue upon menu-item selection ;;;###autoload (global-set-key [vt-menubar-select] 'vt-menu-selection) ;; This is the menu-completions buffer selection handler, invoked ;; when menu-item is selected. ;;;###autoload (defun vt-menu-selection (event) "Handles menu-completions buffer item selection from mouse or keyboard." (interactive "e") (when vt-menu-active ; ...otherwise, how'd we get here? (let ((chosen nil) (click `(mouse-1 ,(event-end event) 1)) (drag (zerop (event-click-count event)))) (vt-menu-switch-to-completions) ;; Completion breaks selecting first item if `vt-menu-completion-prompt' is nil (ignore-errors (unwind-protect (progn ;; Initial attempt to read menu-item selection from event (mouse-choose-completion click) (setq chosen t)) (unless chosen ;; `mouse-choose-completion' failed so try `choose-completion' (vt-menu-switch-to-completions) (choose-completion)))) (when drag (select-window (active-minibuffer-window)) (minibuffer-complete-and-exit))))) ;;; For documentation and history, here are the original tmm- functions ;;; which were autoloaded previously: ;; ;;;###autoload (define-key global-map "\M-`" 'tmm-menubar) ;; ;;;###autoload (define-key global-map [f10] 'tmm-menubar) ;; ;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar-mouse) ;; ;;;###autoload ;; (defun tmm-menubar (&optional x-position) ;; "Text-mode emulation of looking and choosing from a menubar. ;; See the documentation for `tmm-prompt'. ;; X-POSITION, if non-nil, specifies a horizontal position within the menu bar; ;; we make that menu bar item (the one at that position) the default choice." ;; (interactive) ;; (run-hooks 'menu-bar-update-hook) ;; ;; Obey menu-bar-final-items; put those items last. ;; (let ((menu-bar (tmm-get-keybind [menu-bar])) ;; menu-bar-item) ;; (let ((list menu-bar-final-items)) ;; (while list ;; (let ((item (car list))) ;; ;; ITEM is the name of an item that we want to put last. ;; ;; Find it in MENU-BAR and move it to the end. ;; (let ((this-one (assq item menu-bar))) ;; (setq menu-bar (append (delq this-one menu-bar) ;; (list this-one))))) ;; (setq list (cdr list)))) ;; (if x-position ;; (let ((tail menu-bar) ;; this-one ;; (column 0)) ;; (while (and tail (< column x-position)) ;; (setq this-one (car tail)) ;; (if (and (consp (car tail)) ;; (consp (cdr (car tail))) ;; (stringp (nth 1 (car tail)))) ;; (setq column (+ column ;; (length (nth 1 (car tail))) ;; 1))) ;; (setq tail (cdr tail))) ;; (setq menu-bar-item (car this-one)))) ;; (tmm-prompt menu-bar nil menu-bar-item))) ;; ;;;###autoload ;; (defun tmm-menubar-mouse (event) ;; "Text-mode emulation of looking and choosing from a menubar. ;; This command is used when you click the mouse in the menubar ;; on a console which has no window system but does have a mouse. ;; See the documentation for `tmm-prompt'." ;; (interactive "e") ;; (tmm-menubar (car (posn-x-y (event-start event))))) ;;; This procedure combines these methods and allows menu creation from an ;;; argument sub-menu keymap, or from the main menu-bar by default. It is ;;; intended to function recursively as needed, returning either the choice ;;; selected from the final sub-menu, or nil if cancelled. ;;;###autoload (defun vt-menubar (&optional x-position sub-menu) "Vt-mouse enabled text-mode emulation of menu-bar and sub-menu selection. See the documentation for `vt-menu-prompt'. X-POSITION, if non-nil, specifies a horizontal position within menu bar; we make that menu bar item (the one at that position) the default choice. If SUB-MENU is provided then menu-completions are constructed from that keymap rather than from the main menu-bar keymap." (interactive) (when vt-menu-active ;; (run-hooks 'menu-bar-update-hook) (let ((menu-bar (if sub-menu sub-menu (vt-menu-get-keybind [menu-bar]))) (menu-bar-item nil) (winbuf nil) (vt-menu-item nil)) ;; if not a sub-menu then merge menu-bar-final-items into local menu-bar (unless sub-menu (let ((list menu-bar-final-items)) (while list (let ((item (car list))) ;; ITEM is the name of an item that we want to put last. ;; Find it in MENU-BAR and move it to the end. (let ((this-one (assq item menu-bar))) (when this-one (setq menu-bar (append (delq this-one menu-bar) (list this-one)))))) (setq list (cdr list))))) ;; check to see if specific item was already chosen and queued (if (and unread-command-events (symbolp (car unread-command-events))) (let ((token (pop unread-command-events)) (found nil)) (dolist (item menu-bar) (when (and (not found) (eq token (vt-menu-keyname item))) (setq found t) (setq menu-bar-item token) (setq vt-menu-item item) (vt-debug-message "token %S found" menu-bar-item))) (unless found (vt-debug-message "token %S not found" token) (while (input-pending-p) (read-event)) (while (pop unread-command-events))))) ;; check to see if a specific item was already chosen from menu-bar (if (and x-position (not vt-menu-item) (not sub-menu)) (let ((tail menu-bar) this-one (column 0)) (while (and tail (< column x-position)) (setq this-one (car tail)) (unless (and (consp this-one) (and (cdr this-one) (not (listp (cdr this-one))))) (if (and (consp (car tail)) (consp (cdr (car tail))) (stringp (vt-keymap-prompt (car tail))) ;; exceptions to bypass (LAME!!): (not (equalp 'completion (vt-menu-keyname (car tail))))) (setq column (+ column (length (vt-keymap-prompt (car tail))) 1)))) (setq tail (cdr tail))) (if (> column x-position) ;; found item at selected x-position on menu-bar (setq menu-bar-item (car this-one)) ;; no item where selected so clear x-position (setq x-position nil)))) ;; prepare initial menu selection event vector and string (unless sub-menu (setq vt-menu-depth 0) (setq vt-menu-string (concat vt-menu-string (propertize "Menu bar" 'depth vt-menu-depth 'face 'underline) " ")) (push 'menu-bar vt-menu-vector)) (when (and menu-bar-item (listp menu-bar-item)) (push (vt-menu-keyname menu-bar-item) vt-menu-vector) (setq vt-menu-depth (- (length vt-menu-vector) 1)) (setq vt-menu-string (concat vt-menu-string "> " (propertize (vt-keymap-prompt menu-bar-item) 'depth vt-menu-depth 'face 'underline) " "))) (vt-debug-message "%s" (reverse vt-menu-vector)) (vt-menu-switch-to-completions) ;; restore previous window buffer to next window and proceed with actions (other-window 1) (switch-to-buffer vt-menu-buffer) (when (and (not vt-menu-item) (or (and x-position (not sub-menu)) menu-bar-item)) (push ?\r unread-command-events)) (unless (and vt-menu-item menu-bar-item) (setq vt-menu-item (vt-menu-prompt menu-bar nil menu-bar-item t)) ;; CHOICE is now (STRING . MEANING) (let ((event (and x-position (not sub-menu) (input-pending-p) (read-event)))) (and event (not (eq ?\r event)) ; ignore CR (push event unread-command-events)))) (when vt-menu-item ;; update selected menu event string and vector (push (vt-menu-keyname vt-menu-item) vt-menu-vector) (setq vt-menu-depth (- (length vt-menu-vector) 1)) (setq vt-menu-string (concat vt-menu-string "> " (propertize (format "%s" (vt-keymap-prompt vt-menu-item)) 'depth vt-menu-depth 'face 'underline) " ")) (vt-menu-switch-to-completions) (vt-debug-message "%S" vt-menu-item) (sit-for 0) (if (or (keymapp vt-menu-item) (and vt-menu-item (listp vt-menu-item) (listp (cdr vt-menu-item)) (or (keymapp (cdr vt-menu-item)) (eq (cadr vt-menu-item) 'keymap) (eq (cadr vt-menu-item) 'menu-item) (eq (caddr vt-menu-item) 'keymap) (eq (caddr vt-menu-item) 'menu-item) (and (cadddr vt-menu-item) (or (eq (cadddr vt-menu-item) 'keymap) (eq (cadddr vt-menu-item) 'menu-item)))))) ;; activate completions on selected sub-menu (let ((keystring "")) (dolist (key (reverse vt-menu-vector)) (setq keystring (concat keystring (if (plusp (length keystring)) " " "") (format "%s" key)))) (let ((keybind (vt-menu-get-keybind (car (read-from-string (format "[%s]" keystring)))))) (if (not keybind) (setq keybind (cdr vt-menu-item))) (setq vt-menu-item (vt-menubar nil keybind)))))) ;; return what we just picked up vt-menu-item))) ;; meta-event to stuff into input queue upon menu-bar selection ;;;###autoload (global-set-key [vt-menubar] 'vt-menubar-handler) ;; This is the primary menu-bar selection handler, encapsulating ;; `vt-menubar' with initial state and subsequent clean-up. ;;;###autoload (defun vt-menubar-handler (&optional event fetch-only) "Encapsulate `vt-menubar' with save-window-excursion wrapper and some global state." (interactive "e") (if vt-menu-active (when (< vt-menu-depth 0) (if (= -999 vt-menu-depth) (vt-menu-cancel) (vt-menu-reselect (setq vt-menu-depth (- (- vt-menu-depth) 1))))) ;; (unless vt-menu-active ;; preset some global state (setq vt-menu-window-configuration (current-window-configuration) vt-menu-window (selected-window) vt-menu-mark-active mark-active) ;;; (force-mode-line-update 'all) (let ((vt-menu-buffer nil) (vt-menu-active t) (vt-menu-string "") (vt-menu-vector nil) (vt-menu-depth 0) (vt-menu-mid-prompt (let ((prompt (if (and vt-menu-mid-prompt (stringp vt-menu-mid-prompt) (plusp (length vt-menu-mid-prompt))) vt-menu-mid-prompt " -> "))) (if global-font-lock-mode (propertize prompt 'face 'font-lock-function-name-face) prompt))) (vt-menu-completion-prompt (if (stringp vt-menu-completion-prompt) vt-menu-completion-prompt "")) ; "Mouse-1 on Menu-Item; " (vt-menu-choice nil) (highlight-nonselected-windows vt-menu-mark-active) (deactivate-mark (not vt-menu-mark-active))) ;; extract embedded event if present (and event (listp event) (plusp (length event)) (or (eventp (cadr event)) (and (= (length event) 2) (symbolp (cadr event)))) (setq event (cadr event))) (save-window-excursion ;;; (run-hooks 'activate-menubar-hook) (select-first-window) (setq vt-menu-buffer (current-buffer)) (select-window vt-menu-window) (unwind-protect (setq vt-menu-choice (vt-menubar (if (and (eventp event) (listp event)) (car (posn-x-y (event-start event))) nil))) (ignore-errors (set-window-configuration vt-menu-window-configuration) (select-window vt-menu-window) (when vt-menu-mark-active (setq deactivate-mark nil))))) ;; reset some global state (setq vt-menu-window-configuration nil vt-menu-window nil vt-menu-mark-active nil) (unless fetch-only (when vt-menu-choice (let ((choice-event (car vt-menu-choice)) (choice-function (cdr vt-menu-choice)) (last-nonmenu-event nil)) (setq last-nonmenu-event 0) ; workaround misfeature in map-y-or-n-p (setq last-command-event choice-event) (call-interactively choice-function)))) vt-menu-choice))) ;; This is the function for binding to a command event key. ;;;###autoload (defun vt-menubar-command () "Interactively start `vt-menubar' menu selections." (interactive) (if vt-menu-active (if (= 0 vt-menu-depth) (vt-menu-cancel) (vt-menu-reselect (decf vt-menu-depth))) (unless vt-menu-mode (vt-menu-mode 1)) (vt-menubar-handler '(vt-menubar)))) ;; ;;;###autoload ;; (define-minor-mode vt-menu-mode ;; "Toggle Video Terminal Menu mode. ;; With prefix arg, turn vt-menu mode on iff arg is positive." ;; :global t ;; :group 'menu ;; ;; (vt-debug-message "%S" vt-menu-mode) ;; (if (or vt-menu-mode (ignore-errors vt-mouse-mode)) ;; (unless (plusp (length vt-menu-saved-keys)) ;; (setq vt-menu-saved-keys ;; `(progn ;; (define-key global-map [f10] ',(global-key-binding [f10])) ;; (define-key global-map [M-\`] ',(global-key-binding [M-\`])) ;; (define-key global-map [menu-bar mouse-1] ',(global-key-binding [menu-bar mouse-1])) ;; (setq vt-menu-saved-keys nil))) ;; (define-key global-map [f10] 'vt-menubar-command) ;; (define-key global-map "\M-`" 'vt-menubar-command) ;; (define-key global-map [vt-menubar] 'vt-menubar-handler) ;; (define-key global-map [menu-bar mouse-1] 'vt-menubar-handler) ;; (define-key global-map [vt-menubar-select] 'vt-menu-selection)) ;; (if (and (plusp (length vt-menu-saved-keys)) ;; (eq 'progn (car vt-menu-saved-keys))) ;; (eval vt-menu-saved-keys) ;; (setq vt-menu-saved-keys nil)))) ;; Emacs versions before 21 do not have define-minor-mode ;;;###autoload (let ((documentation "Toggle Video Terminal Menu mode. With prefix arg, turn vt-menu mode on iff arg is positive.") (procedure `(if (or vt-menu-mode (ignore-errors vt-mouse-mode)) (unless (plusp (length vt-menu-saved-keys)) (setq vt-menu-saved-keys `(progn (define-key global-map [f10] ',(global-key-binding [f10])) (define-key global-map [M-\`] ',(global-key-binding [M-\`])) (define-key global-map [menu-bar mouse-1] ',(global-key-binding [menu-bar mouse-1])) (setq vt-menu-saved-keys nil))) (define-key global-map [f10] 'vt-menubar-command) (define-key global-map "\M-`" 'vt-menubar-command) (define-key global-map [vt-menubar] 'vt-menubar-handler) (define-key global-map [menu-bar mouse-1] 'vt-menubar-handler) (define-key global-map [vt-menubar-select] 'vt-menu-selection)) (if (and (plusp (length vt-menu-saved-keys)) (eq 'progn (car vt-menu-saved-keys))) (eval vt-menu-saved-keys) (setq vt-menu-saved-keys nil))))) (if (functionp 'define-minor-mode) (eval `(define-minor-mode vt-menu-mode ,documentation :global t :group 'menu ,procedure)) (defvar vt-menu-mode nil "Vt-Menu status") (eval `(defun vt-menu-mode (&optional arg) ,documentation (interactive) (setq vt-menu-mode (if arg (> (prefix-numeric-value arg) 0) (not vt-menu-mode))) ,procedure (run-hooks 'vt-menu-mode-hook (if vt-menu-mode 'vt-menu-mode-on-hook 'vt-menu-mode-off-hook)) (if (interactive-p) (message "Vt-Menu mode %sabled" (if vt-menu-mode "en" "dis"))) (force-mode-line-update) vt-menu-mode)))) ;;;###autoload (defalias 'vt-menu 'vt-menubar-command) ;; Originally tmm-get-keymap, otherwise unchanged except for ;; converted global variable names. (defun vt-menu-get-keymap (elt &optional in-x-menu) "Prepends (DOCSTRING EVENT BINDING) to free variable `vt-menu-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 `vt-menu-table-undef' to keep undefined keys." (let (km str cache plist filter visible (event (car elt))) (setq elt (cdr elt)) (if (eq elt 'undefined) (setq vt-menu-table-undef (cons (cons event nil) vt-menu-table-undef)) (unless (assoc event vt-menu-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. (when (and km (symbolp km) (get km 'menu-enable)) (unless (eval (get km 'menu-enable)) (setq km nil))) (and km str (or (assoc str vt-menu-km-list) (push (cons str (cons event km)) vt-menu-km-list)))))) ;; Originally tmm-get-keybind, otherwise unchanged except for ;; converted global variable names. (defun vt-menu-get-keybind (keyseq) "Return the current binding of KEYSEQ, merging prefix definitions. If KEYSEQ is a prefix key that has local and global bindings, we merge them into a single keymap which shows the proper order of the menu. However, for the menu bar itself, the value does not take account of `menu-bar-final-items'." (let (allbind bind) (setq bind (key-binding keyseq)) ;; If KEYSEQ is a prefix key, then BIND is either nil ;; or a symbol defined as a keymap (which satisfies keymapp). (if (keymapp bind) (setq bind nil)) ;; If we have a non-keymap definition, return that. (or bind (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 (cons (local-key-binding keyseq) allbind)) (setq allbind (cons (global-key-binding keyseq) allbind)) ;; Merge all the elements of ALLBIND into one keymap. (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)))) ;; probably need more of these (add-hook 'calendar-load-hook (lambda () (require 'cal-menu))) ;; turn it on automatically when using vt-menu independently (unless (boundp 'vt-mouse-loading) (vt-menu-mode 1)) ;; what we do here (provide 'vt-menu) ;;; end of vt-menu.el