diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/tmm.el | 320 |
1 files changed, 320 insertions, 0 deletions
diff --git a/lisp/tmm.el b/lisp/tmm.el new file mode 100644 index 00000000000..6612f70273d --- /dev/null +++ b/lisp/tmm.el @@ -0,0 +1,320 @@ +;;; tmm.el - text mode access to menu-bar + +;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. + +;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu> + +;; This file will soon be a part of GNU Emacs, and is made available under +;; the same conditions. + +;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; 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 modelling definition after +;;; tmm-menubar. + +(require 'electric) +(define-key completion-list-mode-map "\e\e" 'abort-recursive-edit) +(define-key completion-list-mode-map [left] 'backward-word) +(define-key completion-list-mode-map [right] 'forward-word) +;(define-key minibuffer-local-must-match-map [pageup] 'tmm-goto-completions) +;(define-key minibuffer-local-must-match-map [prior] 'tmm-goto-completions) +;(define-key minibuffer-local-must-match-map "\ev" 'tmm-goto-completions) +(define-key minibuffer-local-must-match-map [up] 'previous-history-element) +(define-key minibuffer-local-must-match-map [down] 'next-history-element) + +;;; The following will be localized, added only to pacify the compiler. +(defvar tmm-short-cuts) +(defvar tmm-old-mb-map) +(defvar tmm-old-comp-map) +(defvar tmm-c-prompt) +(defvar tmm-km-list) +(defvar tmm-table-undef) + +;;;###autoload +(defun tmm-menubar () + "Text-mode emulation of looking and choosing from a menubar. +See the documentation for `tmm-prompt'." + (interactive) + (run-hooks 'menu-bar-update-hook) + (tmm-prompt (tmm-get-keybind [menu-bar]))) + +(defvar tmm-mid-prompt "==>" + "String to insert between shortcut and menu item or nil.") + +(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. +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 +marked letters to pick up your choice. ESC ESC to cancel. +" + "What insert on top of completion buffer.") + +;;;###autoload +(defun tmm-prompt (bind &optional in-popup) + "Text-mode emulation of calling the bindings in keymap. +Creates a text-mode menu of possible choices. You can access the elements +in the menu: + *) Either via history mechanism from minibuffer; + *) Or via completion-buffer that is automatically shown. +The last alternative is currently a hack, you cannot use mouse reliably. +If the optional argument IN-POPUP is set, is argument-compatible with +`x-popup-menu', otherwise the argument BIND should be a cdr of sparse keymap." + (if in-popup (if bind (setq bind in-popup) (x-popup-menu nil in-popup))) + (let (gl-str tmm-km-list out compl-list compl-list-l tmm-table-undef tmm-c-prompt + tmm-old-mb-map tmm-old-comp-map tmm-short-cuts) + (run-hooks 'activate-menubar-hook) + (mapcar (function (lambda (elt) + (if (stringp elt) + (setq gl-str elt) + (and (listp elt) (tmm-get-keymap elt in-popup))) + )) bind) + (and tmm-km-list + (if tmm-mid-prompt + (setq tmm-km-list (reverse (tmm-add-shortcuts tmm-km-list))) + t) + (setq compl-list (mapcar 'car tmm-km-list)) + (setq compl-list-l (length compl-list)) + (setq compl-list (append compl-list compl-list compl-list compl-list)) + (setq tmm-c-prompt (nth (1- compl-list-l) compl-list)) + (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 'compl-list (* 2 compl-list-l)))) + ;;(add-hook 'minibuffer-setup-hook 'tmm-remove-shortcuts) + ;;(save-excursion + ;; (set-buffer "*Completions*") + ;; (use-local-map tmm-old-mb-map)) + (save-excursion + (set-buffer "*Completions*") + (use-local-map tmm-old-comp-map) + (bury-buffer (current-buffer))) + )) + (setq bind (cdr (assoc out tmm-km-list))) + (and (null bind) + (> (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)) + bind (cdr (assoc out tmm-km-list)))) + (setq last-command-event (car bind)) + (setq bind (cdr bind)) + (if bind + (if in-popup (tmm-prompt t bind) + (if (keymapp bind) + (if (listp bind) + (progn + (condition-case nil + (require 'mouse) + (error nil)) + (condition-case nil + (x-popup-menu nil bind) ; Get the shortcuts + (error nil)) + (tmm-prompt bind)) + (tmm-prompt (symbol-value bind)) + ) + (if last-command-event + (call-interactively bind) + bind))) + gl-str))) + +(defun tmm-remove-shortcuts () + (use-local-map tmm-mb-map)) + +(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. Adds the shortcuts to a free variable +`tmm-short-cuts'." + (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 (member f tmm-short-cuts) + elt + (setq tmm-short-cuts (cons f tmm-short-cuts)) + (cons (concat f tmm-mid-prompt str) (cdr elt))))) + (reverse list))) + +(defun tmm-add-prompt () + (remove-hook 'minibuffer-setup-hook 'tmm-add-prompt) + (add-hook 'minibuffer-exit-hook 'tmm-delete-map) + (let ((map (make-sparse-keymap)) (win (selected-window))) + (mapcar (lambda (str) + (define-key map str 'tmm-shortcut) + (define-key map (downcase str) 'tmm-shortcut)) + tmm-short-cuts) + (define-key map [pageup] 'tmm-goto-completions) + (define-key map [prior] 'tmm-goto-completions) + (define-key map "\ev" 'tmm-goto-completions) + (define-key map "\e\e" 'abort-recursive-edit) + (setq tmm-old-mb-map (current-local-map)) + (use-local-map (append map (cdr tmm-old-mb-map))) + ;; Get window and hide it for electric mode to get correct size + (save-window-excursion + (minibuffer-completion-help) + (set-buffer "*Completions*") + (goto-char 1) + (insert tmm-completion-prompt) + ) + (save-excursion + (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 map (cdr tmm-old-comp-map))) + (select-window win) ; Cannot use + ; save-window-excursion, since + ; it restores the size + ) + (insert tmm-c-prompt))) + +(defun tmm-delete-map () + (remove-hook 'minibuffer-exit-hook 'tmm-delete-map) + (use-local-map tmm-old-mb-map)) + +(defun tmm-shortcut () + (interactive) + (let ((c (upcase (char-to-string last-command-char))) s) + (if (member c tmm-short-cuts) + (if (equal (buffer-name) "*Completions*") + (progn + (beginning-of-buffer) + (re-search-forward + (concat "\\(^\\|[ \t]\\)" 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)))) + tmm-km-list) + (insert s) + (exit-minibuffer))))) + +(defun tmm-goto-completions () + (interactive) + (setq tmm-c-prompt (buffer-string)) + (erase-buffer) + (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) + "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, on `x-popup-menu' argument, or an element of +`x-popup-menu' argument (when IN-X-MENU is not-nil). +Does it only if it is not already there. Uses free variable +`tmm-table-undef' to keep undefined keys." + (let (km str cache (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)) + ))) + (and km (stringp km) (setq str km)) + (and km str + (or (assoc str tmm-km-list) + (setq tmm-km-list + (cons (cons str (cons event km)) tmm-km-list))) + )))) + + +(defun tmm-get-keybind (keyseq) + "Gets binding from all the tables, can have some junk inside." + (let (allbind bind) + (setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq))) + (setq allbind (append allbind (list (local-key-binding keyseq)))) + (setq allbind (append allbind (list (global-key-binding keyseq)))) + ; list of bindings + (mapcar (lambda (in) + (if (and (symbolp in) (keymapp in)) + (setq in (symbol-value in))) + (and in + (or (eq bind 'undefined) (not bind) + (and (keymapp bind) (keymapp in))) + (if (keymapp bind) + (setq bind (append bind (cdr in))) + (setq bind in) + ) + ) + ) + allbind) + bind)) + +(add-hook 'calendar-load-hook (lambda () (require 'cal-menu))) + + +(provide 'tmm) + + +;;; tmm.el ends here |