emacs_el/tiny-tools/other/complete-menu.el

   1 ;;; complete-menu.el --- show completions in X-popup menu
   2
   3 ;;{{{ Id
   4
   5 ;; This file is not part of Emacs
   6
   7 ;; Copyright (C) 1993 Alon Albert
   8 ;; Author:       Alon Albert <alon@milcse.rtsg.mot.com>
   9 ;; Maintainer:   Jari Aalto
  10 ;; Created:      1993-12-07
  11
  12 ;; COPYRIGHT NOTICE
  13 ;;
  14 ;; This program is free software; you can redistribute it and/or modify it
  15 ;; under the terms of the GNU General Public License as published by the Free
  16 ;; Software Foundation; either version 2 of the License, or (at your option)
  17 ;; any later version.
  18 ;;
  19 ;; This program is distributed in the hope that it will be useful, but
  20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  21 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  22 ;; for more details.
  23 ;;
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with program; see the file COPYING. If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28 ;;
  29 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  30
  31 ;;}}}
  32 ;;{{{ Install
  33 ;;; install:
  34
  35 ;;   Put this file in your load-path and insert the following in .emacs
  36 ;;
  37 ;;      (require 'cl)
  38 ;;      (when window-system
  39 ;;        (require 'complete-menu))
  40 ;;
  41 ;;   Or use autoload, your emacs starts up faster (then maybe not, because
  42 ;;   there is so much code)
  43 ;;
  44 ;;   (when window-system
  45 ;;     (setq cm-load-hook 'cm-install-default)  ;; Need advices too
  46 ;;     (autoload 'cm-minibuffer-completion-help "complete-menu")
  47 ;;     (define-key minibuffer-local-completion-map [C-tab]
  48 ;;       'cm-minibuffer-completion-help)
  49 ;;     (define-key minibuffer-local-must-match-map [C-tab]
  50 ;;       'cm-minibuffer-completion-help)
  51 ;;     (substitute-key-definition 'minibuffer-completion-help
  52 ;;                             'cm-minibuffer-completion-help
  53 ;;                             minibuffer-local-completion-map)
  54 ;;     (substitute-key-definition 'minibuffer-completion-help
  55 ;;                             'cm-minibuffer-completion-help
  56 ;;                             minibuffer-local-must-match-map)
  57 ;;     (substitute-key-definition 'PC-completion-help
  58 ;;                             'cm-minibuffer-completion-help
  59 ;;                             minibuffer-local-completion-map)
  60 ;;     (substitute-key-definition 'PC-completion-help
  61 ;;                             'cm-minibuffer-completion-help
  62 ;;                             minibuffer-local-must-match-map))
  63 ;;
  64 ;;
  65 ;;   The X-popup appears if "?" is pressed in minibuffer.
  66
  67 ;;}}}
  68 ;;{{{ Documentation
  69 ;;; Commentary:
  70
  71 ;;  Press "?" while in minibuffer to get the X-popup
  72 ;;  Also supports unix like wildcards so:
  73 ;;
  74 ;;        find file: comp*.el* <?>
  75 ;;
  76 ;;  This utility may be useful for `describe-function' and `describe-variable'.
  77 ;;  typing C-h v *word* pops a menu with all variables with the word "word"
  78 ;;  in them. (something like apropos)
  79
  80 ;;}}}
  81 ;;{{{ History
  82
  83 ;;; History:
  84
  85 ;; v1.10  2001-03-05 [jari]                             Released
  86 ;;       - Added Autoload statements.
  87 ;;
  88 ;; v1.8-1.9 May  24 1997 [jari]                         Released
  89 ;;      - Added byte compilation stop for XEmacs, thank to note from
  90 ;;        Rick Flower <flower@ms31.sp.trw.com>
  91 ;;      - Added defcustom support. Checkdoc 1.29 clear.
  92 ;;
  93 ;; v1.7 Dec  5  1996 [jari]                             Released
  94 ;;      - I was reordering my emacs startup files to make
  95 ;;        maximum use of autoloads and delete all unnecessary
  96 ;;        require commands, then I noticed that this file didn't have
  97 ;;        autoload choice.
  98 ;;      - updated the installation instructions, so that you this
  99 ;;        package is loaded only in demand.
 100 ;;
 101 ;; v1.6 Jun  3  1996 [jari]                             Released
 102 ;;      - Noticed bug. I I pressed "*" and tried to find all temporary
 103 ;;        buffers, it showed me all. Too bad...
 104 ;;      - Now I can hit "*m" to show me all "*mail* foo" "*mail* quux"
 105 ;;        and other pending mail buffers.
 106 ;;      - Advertise: If you want to have user name attached to mail
 107 ;;        buffer, like above, get my lisp libs and do this:
 108 ;;
 109 ;;           (require 'tinylibmail)
 110 ;;           (add-hook 'mail-setup-hook 'ti::mail-rename-buffer)
 111 ;;
 112 ;; v1.5 Jun  3  1996 [jari]                             Released
 113 ;;      - Error in installation, now there is cm-install-2
 114 ;;
 115 ;; v1.4 Jun  3  1996 [jari]                             NotReleased
 116 ;;      - Small corrections
 117 ;;
 118 ;; v1.3 Sep  21 1995 [jari]                             NotReleased
 119 ;;      - Bryan M Kramer <kramer@cs.toronto.edu> popped up in g.e.help
 120 ;;        asking why this package didn't work in XEmacs any more.
 121 ;;        It turned out that this package wasn't archived anywhere, nor
 122 ;;        in the OHIO nor did any archie could find it. So I received
 123 ;;        copy of this code and packaged whole file in suitable form.
 124 ;;      - added separate installation, added final load hook, replaced
 125 ;;        right copyright info. added advice, lots of small stuff..
 126 ;;      - Corrected bug in cm-minibuffer-completion-help: if user didn't
 127 ;;        choose anything, it cleared the minibuffer entry. Now the original
 128 ;;        entry is preserved.
 129 ;;
 130 ;; v1.2 Aug  22 1993 [Alon]
 131 ;;      - a few minor fixes
 132 ;;      - a new chooser from *completions* buffer that allows completion to
 133 ;;        be yanked into any buffer (not just the minibuffer)
 134 ;;
 135 ;; v1.1 July 18 1993 [Alon]
 136 ;;      - Cleaner faster version.
 137 ;;      - Special thanks to Kevin Rodgers <kevin@traffic.den.mmc.com>
 138 ;;        for an intriguing discussion about list manipulation in emacs lisp
 139 ;;
 140 ;; v1.0 July 7 1993: [Alon]
 141 ;;      - First release.
 142
 143 ;;}}}
 144
 145 ;;; Code:
 146
 147 ;;; ......................................................... &require ...
 148
 149 (require 'advice)
 150
 151 (eval-and-compile
 152   (when (boundp 'xemacs-logo)
 153     (message "\n\
 154   ** complete-menu.el: This package works only in Emacs, because the popup\n\
 155                        function is not compatible between Emacs versions.\n\
 156                        Ignore `Aborted' error command if you're\n\
 157                        byte compiling this file in XEmacs.")
 158     (error "Aborted.")))
 159
 160 (defgroup complete-menu nil
 161   "Provides X-popup list where you can select completions items. See ? key."
 162   :prefix "complete-menu-"
 163   :group  'extensions)
 164
 165 ;;{{{ setup: variables
 166
 167 ;;; ....................................................... &variables ...
 168
 169 ;;; or if you dont't want to substitute the originals, use
 170 ;;; 'cm-install-2
 171 ;;;
 172 ;;;###autoload
 173 (defcustom cm-load-hook '(cm-install-default)
 174   "*Hook run when file has been loaded."
 175   :type  'hook
 176   :group 'complete-menu)
 177
 178 ;;  handy if you want to call from non-mouse, eg. pressing key.
 179 ;;
 180 (defcustom cm-x-coord 170
 181   "*Default X menu coordinate."
 182   :type  'integer
 183   :group 'complete-menu)
 184
 185 (defcustom cm-y-coord 170
 186   "*Default Y menu coordinate."
 187   :type  'integer
 188   :group 'complete-menu)
 189
 190 (defcustom cm-max-entries-in-menu 45
 191   "*Maximum lines to display in a single menu pane"
 192   :type  'integer
 193   :group 'complete-menu)
 194
 195 (defcustom cm-store-cut-buffer t
 196   "If not nill then store selection in mouse cut buffer"
 197   :type 'boolean
 198   :group 'complete-menu)
 199
 200 (defcustom cm-execute-on-completion t
 201   "If not nil then exucute command after completion"
 202   :type  'boolean
 203   :group 'complete-menu)
 204
 205 (defvar cm-wildcard-to-regexp
 206   '((?* . ".*")
 207     (?. . "\\.")
 208     (?? . "."))
 209   "Translation table from wildcard format to regexp format")
 210
 211 ;;}}}
 212 ;;{{{ code: funcs
 213
 214 ;;; ....................................................... &Functions ...
 215
 216 ;;; ----------------------------------------------------------------------
 217 ;;;
 218 (defun cm-make-regexp (wildcard)
 219   "Make a regexp out of unix like WILDCARD."
 220   (let* ((char-list (append wildcard)))
 221     (mapconcat (function
 222                 (lambda (elt)
 223                   (let ((regexp (cdr (assoc elt cm-wildcard-to-regexp))))
 224                     (if regexp
 225                         regexp
 226                       (char-to-string elt)))))
 227                char-list "")))
 228
 229 ;;; ----------------------------------------------------------------------
 230 ;;;
 231 (defun cm-old-zap-to-char (arg char)
 232   "Kill up to (but not including) ARG'th occurrence of CHAR.
 233 Goes backward if ARG is negative; goes to end of buffer if CHAR not found."
 234 ;;;  (interactive "*p\ncZap to char: ")
 235   (kill-region (point) (if (search-forward (char-to-string char) nil t arg)
 236                            (progn (goto-char
 237                                    (if (> arg 0) (1- (point)) (1+ (point))))
 238                                   (point))
 239                          (if (> arg 0) (point-max) (point-min)))))
 240
 241 ;;; ----------------------------------------------------------------------
 242 ;;;
 243 ;;;###autoload
 244 (defun cm-minibuffer-completion-help ()
 245   "List completions in a menu and copy selction into minibuffer"
 246   (interactive)
 247   (message "Making completion list...")
 248   (let* ((complete (buffer-string))
 249          (mouse-pos (mouse-position))
 250          (mouse-pos (if (nth 1 mouse-pos)
 251                         mouse-pos
 252                       (set-mouse-position (car mouse-pos)
 253                                           (/ (frame-width) 2) 2)
 254                       (unfocus-frame)
 255                       (mouse-position)))
 256          (pos (list (list (car (cdr mouse-pos))
 257                           (1+ (cdr (cdr mouse-pos))))
 258                     (car mouse-pos)))
 259          (match nil)
 260          (panes nil)
 261          (pane nil)
 262          (i 0)
 263
 264          completion-list
 265          name
 266          menu
 267          elt)
 268
 269     (if (string-match "?" complete)
 270         (setq match (format "^%s$" (cm-make-regexp
 271                                     (file-name-nondirectory complete)))
 272               complete (substring complete 0 (match-beginning 0))))
 273
 274     (setq completion-list
 275           (sort (all-completions
 276                  complete
 277                  minibuffer-completion-table
 278                  minibuffer-completion-predicate)
 279                 'string<))
 280
 281     (message "Making completion list... Done")
 282     (message "Creating menu...")
 283
 284     (while (setq elt (car completion-list))
 285       (if (or (null match)
 286               (string-match match elt))
 287           (setq pane (cons elt pane)
 288                 i (1+ i)))
 289       (setq completion-list (cdr completion-list))
 290       (if (= i cm-max-entries-in-menu)
 291           (setq panes (cons pane (nreverse panes))
 292                 pane nil
 293                 i 0)))
 294
 295     (if pane (setq panes  (cons pane (nreverse panes))))
 296
 297     (setq menu (cons "Completions"
 298                      (mapcar (function
 299                               (lambda (elt)
 300                                 (cons (car elt)
 301                                       (mapcar (function
 302                                                (lambda (elt)
 303                                                  (cons elt elt)))
 304                                               elt))))
 305                              panes)))
 306
 307     (message "Creating menu... Done")
 308     (if (not (car (cdr menu)))
 309         (beep)
 310       (setq name (x-popup-menu pos menu))
 311       (cm-old-zap-to-char -1 ?/)
 312       (if (null name)
 313           ;;  User didn't select anything
 314           (insert complete)             ;put previous back.
 315         (insert name)
 316         (if cm-store-cut-buffer
 317             (kill-new name))
 318         (if cm-execute-on-completion
 319             (exit-minibuffer))))))
 320
 321 ;;; ----------------------------------------------------------------------
 322 ;;;
 323 (defun cm-delete-max-match (string)
 324   "Return maximum match for STRING."
 325   (let* ((len (min (length string) (1- (point))))
 326          (string (substring string 0 len)))
 327     (goto-char (- (point) len))
 328     (while (and (> len 0) (null (looking-at string)))
 329       (setq string (substring string 0 -1)
 330             len (1- len))
 331       (forward-char 1))
 332     (delete-char len)))
 333
 334 ;;; ----------------------------------------------------------------------
 335 ;;;
 336 (defun cm-choose-completion (event)
 337   "Display completion menu. EVENT is x popup event."
 338   (interactive "e")
 339   (let ((buffer (window-buffer))
 340         choice)
 341     (save-excursion
 342       (set-buffer (window-buffer (posn-window (event-start event))))
 343       (save-excursion
 344         (goto-char (posn-point (event-start event)))
 345         (skip-chars-backward "^ \t\n")
 346         (let ((beg (point)))
 347           (skip-chars-forward "^ \t\n")
 348           (setq choice (buffer-substring beg (point))))))
 349     (set-buffer buffer)
 350     (cm-delete-max-match choice)
 351     (insert choice)
 352     (and (equal buffer (window-buffer (minibuffer-window)))
 353          cm-execute-on-completion (exit-minibuffer))))
 354
 355 ;;; ----------------------------------------------------------------------
 356 ;;;  Not activated until user wants it, this overrides ? keys
 357 ;;;
 358 (defadvice minibuffer-completion-help (around cm-x-complete dis)
 359   "Replaces function and calls cm-minibuffer-completion-help.
 360 Displays completions in X-menu instead of separate buffer."
 361   (cm-minibuffer-completion-help))
 362
 363 ;;; ----------------------------------------------------------------------
 364 ;;;
 365 (defadvice PC-completion-help (around cm-x-complete dis)
 366   "Replaces function and calls cm-minibuffer-completion-help.
 367 Displays completions in X-menu instead of separate buffer."
 368   (cm-minibuffer-completion-help))
 369
 370 ;;; ----------------------------------------------------------------------
 371 ;;;  You may also want to bind it to "more closer key", [left hand
 372 ;;;  pops the X, and right controls the mouse]:
 373 ;;;
 374 (defun cm-install-2 ()
 375   "Install the X-menuing feature to separate C-tab key."
 376   (define-key minibuffer-local-completion-map [C-tab]
 377     'cm-minibuffer-completion-help)
 378   (define-key minibuffer-local-must-match-map [C-tab]
 379     'cm-minibuffer-completion-help))
 380
 381 ;;; ----------------------------------------------------------------------
 382 ;;;
 383 ;;;###autoload
 384 (defun cm-install-default (&optional arg verb)
 385   "Install the X-menuing feature. With ARG, remove X-menuing. VERB.
 386 Note: installation is only possible in X envinronment."
 387   (interactive "P")
 388   (let* ((map1  'minibuffer-local-completion-map)
 389          (map2  'minibuffer-local-must-match-map)
 390          (ofun1 'minibuffer-completion-help)
 391          (ofun2 'PC-completion-help)
 392          (nfun  'cm-minibuffer-completion-help))
 393
 394     (or verb
 395         (setq verb (interactive-p)))
 396
 397     (if (null window-system)
 398         (if verb
 399             (message "No window system detected. Cannot do nothing."))
 400       (cond
 401        (arg
 402         (substitute-key-definition nfun ofun1 (eval map1))
 403         (substitute-key-definition nfun ofun1 (eval map2))
 404
 405         (substitute-key-definition nfun ofun2 (eval map1))
 406         (substitute-key-definition nfun ofun2 (eval map2))
 407
 408         (ad-disable-advice ofun1 'around 'cm-x-complete)
 409         (ad-disable-advice ofun2 'around 'cm-x-complete)
 410         (if verb
 411             (message "X-menu completion off")))
 412        (t
 413         (substitute-key-definition ofun1 nfun (eval map1))
 414         (substitute-key-definition ofun1 nfun (eval map2))
 415
 416         (substitute-key-definition ofun2 nfun (eval map1))
 417         (substitute-key-definition ofun2 nfun (eval map2))
 418
 419         (ad-enable-advice ofun1 'around 'cm-x-complete)
 420         (ad-enable-advice ofun2 'around 'cm-x-complete)
 421         (if verb
 422             (message "X-menu completion on"))))
 423       (ad-activate ofun1)
 424       (ad-activate ofun2))))
 425
 426 ;;}}}
 427
 428 (provide   'complete-menu)
 429 (run-hooks 'cm-load-hook)
 430
 431 ;;; complete-menu.el ends here