[bpt/emacs.git] / lisp / tmm.el

;;; 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>
;; Maintainer: FSF

;; 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, 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)

;;; 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-table-undef)

;;;###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)

;;;###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)
  ;; Obey menu-bar-final-items; put those items last.
  (let ((menu-bar (tmm-get-keybind [menu-bar])))
    (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))))
    (tmm-prompt 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.  Type 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 history history-len 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
	 (progn
	   (if tmm-mid-prompt
	       (setq tmm-km-list (tmm-add-shortcuts tmm-km-list))
	     t)
	   (setq history (reverse (mapcar 'car tmm-km-list)))
	   (setq history-len (length history))
	   (setq history (append history history history history))
	   (setq tmm-c-prompt (nth (1- history-len) 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))))
	     (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))))
    (and (null bind)
	 (setq out (try-completion out tmm-km-list)
	       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-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) "\e\e" 'abort-recursive-edit)
  (define-key (current-local-map) "\C-n" 'next-history-element)
  (define-key (current-local-map) "\C-p" 'previous-history-element))

(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 (current-local-map))
    (use-local-map (append (make-sparse-keymap) tmm-old-mb-map))
    (tmm-define-keys)
    ;; Get window and hide it for electric mode to get correct size
    (save-window-excursion 
      (let ((completions
	     (mapcar 'car minibuffer-completion-table)))
	(with-output-to-temp-buffer "*Completions*"
	  (display-completion-list completions)))
      (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 (make-sparse-keymap) tmm-old-comp-map))
      (tmm-define-keys)
      (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 t)
  (if tmm-old-mb-map
      (use-local-map tmm-old-mb-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)
	(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, an `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)
  "Return the current binding of KEYSEQ, merging prefix definitions.
If KEYSEQ is a prefix key that has local and gloibal 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.
	  (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)))))
		  allbind)
	  ;; Return that keymap.
	  bind))))

(add-hook 'calendar-load-hook (lambda () (require 'cal-menu)))


(provide 'tmm)


;;; tmm.el ends here
Commit	Line	Data
be010748	1	;;; tmm.el --- text mode access to menu-bar
20062d6b RS	2
	3	;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.
	4
	5	;; Author: Ilya Zakharevich <ilya@math.mps.ohio-state.edu>
fc225f66	6	;; Maintainer: FSF
20062d6b	7
d440e474	8	;; This file is part of GNU Emacs.
20062d6b RS	9
	10	;; GNU Emacs is free software; you can redistribute it and/or modify
	11	;; it under the terms of the GNU General Public License as published by
	12	;; the Free Software Foundation; either version 2, or (at your option)
	13	;; any later version.
	14
	15	;; GNU Emacs is distributed in the hope that it will be useful,
	16	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;; GNU General Public License for more details.
	19
	20	;; You should have received a copy of the GNU General Public License
	21	;; along with GNU Emacs; see the file COPYING. If not, write to
	22	;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
	23
	24	;;; Commentary ============================================================
	25
	26	;;; To use this package add
	27
	28	;;; (autoload 'tmm-menubar 'tmm "Text mode substitute for menubar" t)
	29	;;; (global-set-key [f10] 'tmm-menubar)
	30
	31	;;; to your .emacs file. You can also add your own access to different
	32	;;; menus available in Window System Emacs modelling definition after
	33	;;; tmm-menubar.
	34
	35	(require 'electric)
20062d6b RS	36
	37	;;; The following will be localized, added only to pacify the compiler.
	38	(defvar tmm-short-cuts)
fc225f66	39	(defvar tmm-old-mb-map nil)
20062d6b RS	40	(defvar tmm-old-comp-map)
	41	(defvar tmm-c-prompt)
	42	(defvar tmm-km-list)
	43	(defvar tmm-table-undef)
	44
e6a5c7de	45	;;;###autoload (define-key global-map "\M-`" 'tmm-menubar)
b46324e6	46	;;;###autoload (define-key global-map [f10] 'tmm-menubar)
6d0150f9	47	;;;###autoload (define-key global-map [menu-bar mouse-1] 'tmm-menubar)
afb1835e	48
20062d6b RS	49	;;;###autoload
	50	(defun tmm-menubar ()
	51	"Text-mode emulation of looking and choosing from a menubar.
	52	See the documentation for `tmm-prompt'."
	53	(interactive)
	54	(run-hooks 'menu-bar-update-hook)
fc225f66 RS	55	;; Obey menu-bar-final-items; put those items last.
	56	(let ((menu-bar (tmm-get-keybind [menu-bar])))
	57	(let ((list menu-bar-final-items))
	58	(while list
	59	(let ((item (car list)))
	60	;; ITEM is the name of an item that we want to put last.
	61	;; Find it in MENU-BAR and move it to the end.
	62	(let ((this-one (assq item menu-bar)))
	63	(setq menu-bar (append (delq this-one menu-bar)
	64	(list this-one)))))
	65	(setq list (cdr list))))
	66	(tmm-prompt menu-bar)))
20062d6b RS	67
	68	(defvar tmm-mid-prompt "==>"
	69	"String to insert between shortcut and menu item or nil.")
	70
	71	(defvar tmm-mb-map nil
	72	"A place to store minibuffer map.")
	73
	74	(defvar tmm-completion-prompt
	75	"Press PageUp Key to reach this buffer from the minibuffer.
	76	Alternatively, you can use Up/Down keys (or your History keys) to change
	77	the item in the minibuffer, and press RET when you are done, or press the
afb1835e	78	marked letters to pick up your choice. Type ESC ESC to cancel.
20062d6b RS	79	"
	80	"What insert on top of completion buffer.")
	81
	82	;;;###autoload
	83	(defun tmm-prompt (bind &optional in-popup)
	84	"Text-mode emulation of calling the bindings in keymap.
	85	Creates a text-mode menu of possible choices. You can access the elements
	86	in the menu:
	87	*) Either via history mechanism from minibuffer;
	88	*) Or via completion-buffer that is automatically shown.
	89	The last alternative is currently a hack, you cannot use mouse reliably.
	90	If the optional argument IN-POPUP is set, is argument-compatible with
	91	`x-popup-menu', otherwise the argument BIND should be a cdr of sparse keymap."
	92	(if in-popup (if bind (setq bind in-popup) (x-popup-menu nil in-popup)))
fc225f66	93	(let (gl-str tmm-km-list out history history-len tmm-table-undef tmm-c-prompt
20062d6b RS	94	tmm-old-mb-map tmm-old-comp-map tmm-short-cuts)
	95	(run-hooks 'activate-menubar-hook)
	96	(mapcar (function (lambda (elt)
	97	(if (stringp elt)
	98	(setq gl-str elt)
fc225f66 RS	99	(and (listp elt) (tmm-get-keymap elt in-popup)))))
fc225f66 RS	100	bind)
20062d6b	101	(and tmm-km-list
fc225f66 RS	102	(progn
	103	(if tmm-mid-prompt
	104	(setq tmm-km-list (tmm-add-shortcuts tmm-km-list))
	105	t)
	106	(setq history (reverse (mapcar 'car tmm-km-list)))
	107	(setq history-len (length history))
	108	(setq history (append history history history history))
	109	(setq tmm-c-prompt (nth (1- history-len) history))
	110	(add-hook 'minibuffer-setup-hook 'tmm-add-prompt)
	111	(unwind-protect
	112	(setq out
	113	(completing-read
	114	(concat gl-str " (up/down to change, PgUp to menu): ")
	115	tmm-km-list nil t nil
	116	(cons 'history (* 2 history-len))))
	117	(save-excursion
	118	(set-buffer "Completions")
	119	(use-local-map tmm-old-comp-map)
	120	(bury-buffer (current-buffer)))
	121	)))
20062d6b RS	122	(setq bind (cdr (assoc out tmm-km-list)))
	123	(and (null bind)
	124	(> (length out) (length tmm-c-prompt))
	125	(string= (substring out 0 (length tmm-c-prompt)) tmm-c-prompt)
	126	(setq out (substring out (length tmm-c-prompt))
	127	bind (cdr (assoc out tmm-km-list))))
fc225f66 RS	128	(and (null bind)
	129	(setq out (try-completion out tmm-km-list)
	130	bind (cdr (assoc out tmm-km-list))))
20062d6b RS	131	(setq last-command-event (car bind))
	132	(setq bind (cdr bind))
	133	(if bind
	134	(if in-popup (tmm-prompt t bind)
	135	(if (keymapp bind)
	136	(if (listp bind)
	137	(progn
	138	(condition-case nil
	139	(require 'mouse)
	140	(error nil))
	141	(condition-case nil
	142	(x-popup-menu nil bind) ; Get the shortcuts
	143	(error nil))
	144	(tmm-prompt bind))
	145	(tmm-prompt (symbol-value bind))
	146	)
	147	(if last-command-event
	148	(call-interactively bind)
	149	bind)))
	150	gl-str)))
	151
20062d6b RS	152
	153	(defun tmm-add-shortcuts (list)
	154	"Adds shortcuts to cars of elements of the list.
	155	Takes a list of lists with a string as car, returns list with
fc225f66 RS	156	shortcuts added to these cars.
	157	Stores a list of all the shortcuts in the free variable `tmm-short-cuts'."
	158	(let ((next-shortcut-number 0))
	159	(mapcar (lambda (elt)
	160	(let ((str (car elt)) f b)
	161	(setq f (upcase (substring str 0 1)))
	162	;; If does not work, try beginning of the other word
	163	(if (and (member f tmm-short-cuts)
	164	(string-match " \\([^ ]\\)" str))
	165	(setq f (upcase (substring
	166	str
	167	(setq b (match-beginning 1)) (1+ b)))))
	168	;; If we don't have an unique letter shortcut,
	169	;; pick a digit as a shortcut instead.
	170	(if (member f tmm-short-cuts)
	171	(if (< next-shortcut-number 10)
	172	(setq f (format "%d" next-shortcut-number)
	173	next-shortcut-number (1+ next-shortcut-number))
	174	(setq f nil)))
	175	(if (null f)
	176	elt
	177	(setq tmm-short-cuts (cons f tmm-short-cuts))
	178	(cons (concat f tmm-mid-prompt str) (cdr elt)))))
	179	(reverse list))))
20062d6b	180
b46324e6 RS	181	(defun tmm-define-keys ()
	182	(mapcar (lambda (str)
	183	(define-key (current-local-map) str 'tmm-shortcut)
	184	(define-key (current-local-map) (downcase str) 'tmm-shortcut))
	185	tmm-short-cuts)
	186	(define-key (current-local-map) [pageup] 'tmm-goto-completions)
	187	(define-key (current-local-map) [prior] 'tmm-goto-completions)
	188	(define-key (current-local-map) "\ev" 'tmm-goto-completions)
	189	(define-key (current-local-map) "\e\e" 'abort-recursive-edit)
	190	(define-key (current-local-map) "\C-n" 'next-history-element)
	191	(define-key (current-local-map) "\C-p" 'previous-history-element))
	192
20062d6b RS	193	(defun tmm-add-prompt ()
20062d6b RS	194	(remove-hook 'minibuffer-setup-hook 'tmm-add-prompt)
afb1835e RS	195	(make-local-hook 'minibuffer-exit-hook)
afb1835e RS	196	(add-hook 'minibuffer-exit-hook 'tmm-delete-map nil t)
b46324e6	197	(let ((win (selected-window)))
20062d6b	198	(setq tmm-old-mb-map (current-local-map))
b46324e6 RS	199	(use-local-map (append (make-sparse-keymap) tmm-old-mb-map))
b46324e6 RS	200	(tmm-define-keys)
20062d6b RS	201	;; Get window and hide it for electric mode to get correct size
20062d6b RS	202	(save-window-excursion
fc225f66 RS	203	(let ((completions
	204	(mapcar 'car minibuffer-completion-table)))
	205	(with-output-to-temp-buffer "Completions"
	206	(display-completion-list completions)))
20062d6b RS	207	(set-buffer "Completions")
	208	(goto-char 1)
	209	(insert tmm-completion-prompt)
	210	)
	211	(save-excursion
	212	(other-window 1) ; Electric-pop-up-window does
	213	; not work in minibuffer
	214	(set-buffer (window-buffer (Electric-pop-up-window "Completions")))
	215	(setq tmm-old-comp-map (current-local-map))
b46324e6 RS	216	(use-local-map (append (make-sparse-keymap) tmm-old-comp-map))
b46324e6 RS	217	(tmm-define-keys)
20062d6b RS	218	(select-window win) ; Cannot use
	219	; save-window-excursion, since
	220	; it restores the size
	221	)
	222	(insert tmm-c-prompt)))
	223
	224	(defun tmm-delete-map ()
afb1835e	225	(remove-hook 'minibuffer-exit-hook 'tmm-delete-map t)
fc225f66 RS	226	(if tmm-old-mb-map
fc225f66 RS	227	(use-local-map tmm-old-mb-map)))
20062d6b RS	228
20062d6b RS	229	(defun tmm-shortcut ()
fc225f66	230	"Choose the shortcut that the user typed."
20062d6b RS	231	(interactive)
	232	(let ((c (upcase (char-to-string last-command-char))) s)
	233	(if (member c tmm-short-cuts)
fc225f66 RS	234	(if (equal (buffer-name) "Completions")
	235	(progn
	236	(beginning-of-buffer)
	237	(re-search-forward
	238	(concat "\\(^\\\|[ \t]\\)" c tmm-mid-prompt))
	239	(choose-completion))
	240	(erase-buffer) ; In minibuffer
	241	(mapcar (lambda (elt)
	242	(if (string=
	243	(substring (car elt) 0
	244	(min (1+ (length tmm-mid-prompt))
	245	(length (car elt))))
	246	(concat c tmm-mid-prompt))
	247	(setq s (car elt))))
	248	tmm-km-list)
	249	(insert s)
	250	(exit-minibuffer)))))
20062d6b RS	251
	252	(defun tmm-goto-completions ()
	253	(interactive)
	254	(setq tmm-c-prompt (buffer-string))
	255	(erase-buffer)
fc225f66	256	(switch-to-buffer-other-window "Completions")
20062d6b RS	257	(search-forward tmm-c-prompt)
	258	(search-backward tmm-c-prompt))
	259
	260
	261	(defun tmm-get-keymap (elt &optional in-x-menu)
	262	"Prepends (DOCSTRING EVENT BINDING) to free variable `tmm-km-list'.
	263	The values are deduced from the argument ELT, that should be an
fc225f66	264	element of keymap, an `x-popup-menu' argument, or an element of
20062d6b RS	265	`x-popup-menu' argument (when IN-X-MENU is not-nil).
	266	Does it only if it is not already there. Uses free variable
	267	`tmm-table-undef' to keep undefined keys."
	268	(let (km str cache (event (car elt)))
	269	(setq elt (cdr elt))
	270	(if (eq elt 'undefined)
	271	(setq tmm-table-undef (cons (cons event nil) tmm-table-undef))
	272	(or
	273	(assoc event tmm-table-undef)
	274	(and (if (listp elt)
	275	(keymapp elt)
	276	(fboundp elt))
	277	(setq km elt))
	278	(and (if (listp (cdr-safe elt))
	279	(keymapp (cdr-safe elt))
	280	(fboundp (cdr-safe elt)))
	281	(setq km (cdr elt))
	282	(and (stringp (car elt)) (setq str (car elt))))
	283	(and (if (listp (cdr-safe (cdr-safe elt)))
	284	(keymapp (cdr-safe (cdr-safe elt)))
	285	(fboundp (cdr-safe (cdr-safe elt))))
	286	(setq km (cdr (cdr elt)))
	287	(and (stringp (car elt)) (setq str (car elt)))
	288	(or (and str
	289	(stringp (cdr (car (cdr elt)))) ; keyseq cache
	290	(setq cache (cdr (car (cdr elt))))
	291	cache (setq str (concat str cache))) str))
	292	(and (if (listp (cdr-safe (cdr-safe (cdr-safe elt))))
	293	(keymapp (cdr-safe (cdr-safe (cdr-safe elt))))
	294	(fboundp (cdr-safe (cdr-safe (cdr-safe elt)))))
	295	; New style of easy-menu
	296	(setq km (cdr (cdr (cdr elt))))
	297	(and (stringp (car elt)) (setq str (car elt)))
	298	(or (and str
	299	(stringp (cdr (car (cdr (cdr elt))))) ; keyseq cache
	300	(setq cache (cdr (car (cdr (cdr elt)))))
	301	cache (setq str (concat str cache)))
	302	str))
	303	(and (stringp event) ; x-popup or x-popup element
	304	(if (or in-x-menu (stringp (car-safe elt)))
	305	(setq str event event nil km elt)
	306	(setq str event event nil km (cons 'keymap elt))
	307	)))
	308	(and km (stringp km) (setq str km))
	309	(and km str
	310	(or (assoc str tmm-km-list)
	311	(setq tmm-km-list
	312	(cons (cons str (cons event km)) tmm-km-list)))
	313	))))
	314
	315
	316	(defun tmm-get-keybind (keyseq)
fc225f66 RS	317	"Return the current binding of KEYSEQ, merging prefix definitions.
	318	If KEYSEQ is a prefix key that has local and gloibal bindings,
	319	we merge them into a single keymap which shows the proper order of the menu.
	320	However, for the menu bar itself, the value does not take account
	321	of `menu-bar-final-items'."
20062d6b	322	(let (allbind bind)
fc225f66 RS	323	(setq bind (key-binding keyseq))
	324	;; If KEYSEQ is a prefix key, then BIND is either nil
	325	;; or a symbol defined as a keymap (which satisfies keymapp).
	326	(if (keymapp bind)
	327	(setq bind nil))
	328	;; If we have a non-keymap definition, return that.
	329	(or bind
	330	(progn
	331	;; Otherwise, it is a prefix, so make a list of the subcommands.
	332	;; Make a list of all the bindings in all the keymaps.
	333	(setq allbind (mapcar 'cdr (minor-mode-key-binding keyseq)))
	334	(setq allbind (cons (local-key-binding keyseq) allbind))
	335	(setq allbind (cons (global-key-binding keyseq) allbind))
	336	;; Merge all the elements of ALLBIND into one keymap.
	337	(mapcar (lambda (in)
	338	(if (and (symbolp in) (keymapp in))
	339	(setq in (symbol-function in)))
	340	(and in (keymapp in)
	341	(if (keymapp bind)
	342	(setq bind (nconc bind (copy-sequence (cdr in))))
	343	(setq bind (copy-sequence in)))))
	344	allbind)
	345	;; Return that keymap.
	346	bind))))
20062d6b RS	347
	348	(add-hook 'calendar-load-hook (lambda () (require 'cal-menu)))
	349
	350
	351	(provide 'tmm)
	352
	353
	354	;;; tmm.el ends here