git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/list-mode.el

   1 ;;; list-mode.el --- Major mode for buffers containing lists of items
   2
   3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1996, 2000 Ben Wing.
   5
   6 ;; Maintainer: XEmacs Development Team
   7 ;; Keywords: extensions, dumped
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Synched up with: Not synched
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with XEmacs.
  31
  32 ;; Cleanup, merging with FSF by Ben Wing, January 1996
  33
  34 ;;; Code:
  35
  36 (defvar list-mode-extent nil)
  37 (make-variable-buffer-local 'list-mode-extent)
  38
  39 (defvar list-mode-map nil
  40   "Local map for buffers containing lists of items.")
  41 (or list-mode-map
  42     (let ((map (setq list-mode-map (make-sparse-keymap 'list-mode-map))))
  43       (suppress-keymap map)
  44       (define-key map 'button2up 'list-mode-item-mouse-selected)
  45       (define-key map 'button2 'undefined)
  46       (define-key map "\C-m" 'list-mode-item-keyboard-selected)
  47 ;;
  48 ;; The following calls to `substitute-key-definition' losed because
  49 ;; they were based on an incorrect assumption that `forward-char' and
  50 ;; `backward-char' are bound to keys in the global map. This might not
  51 ;; be the case if a user binds motion keys to different functions,
  52 ;; and was not actually the case since 20.5 beta 28 or around.
  53 ;;
  54 ;;    (substitute-key-definition 'forward-char 'next-list-mode-item map
  55 ;;                               global-map)
  56 ;;    (substitute-key-definition 'backward-char 'previous-list-mode-item map
  57 ;;                               global-map)
  58 ;;
  59 ;; We bind standard keys to motion commands instead.
  60 ;;
  61       (dolist (key '(kp-right right (control ?f)))
  62         (define-key map key 'next-list-mode-item))
  63       (dolist (key '(kp-left left (control ?b)))
  64         (define-key map key 'previous-list-mode-item))))
  65
  66 ;; #### We make list-mode-hook, as well as completion-setup-hook and
  67 ;; minibuffer-setup-hook, permanent-local so that it's possible to create
  68 ;; buffers in these modes and then set up some buffer-specific
  69 ;; customizations without resorting to awful kludges.  (The problem here
  70 ;; is that when you switch a buffer into a mode, reset-buffer is usually
  71 ;; called, which destroys all buffer-local settings that you carefully
  72 ;; tried to set up when you created the buffer.  Therefore, the only way
  73 ;; to set these variables is to use the setup hooks -- but if they are
  74 ;; not declared permanent local, then any local hook functions that you
  75 ;; put on them (which is exactly what you want to do) also get removed,
  76 ;; so you would have to resort to putting a global hook function on the
  77 ;; setup hook, and then making sure it gets removed later.  I actually
  78 ;; added some support for doing this with one-shot hooks, but this is
  79 ;; clearly not the correct way to do things, and it fails in some cases,
  80 ;; particularly when the buffer gets put into the mode more than once,
  81 ;; which typically happens with completion buffers, for example.)  In
  82 ;; fact, all setup hooks should be made permanent local, but I didn't
  83 ;; feel like making a global change like this quite yet.  The proper way
  84 ;; to do it would be to declare new def-style forms, such as defhook and
  85 ;; define-local-setup-hook, which are used to initialize hooks in place
  86 ;; of the current generic defvars. --ben
  87
  88 (put 'list-mode-hook 'permanent-local t)
  89 (defvar list-mode-hook nil
  90   "Normal hook run when entering List mode.")
  91
  92 (defun list-mode ()
  93   "Major mode for buffer containing lists of items."
  94   (interactive)
  95   (kill-all-local-variables)
  96   (use-local-map list-mode-map)
  97   (setq mode-name "List")
  98   (setq major-mode 'list-mode)
  99   (add-local-hook 'post-command-hook 'set-list-mode-extent)
 100   (add-local-hook 'pre-command-hook 'list-mode-extent-pre-hook)
 101   (set (make-local-variable 'next-line-add-newlines) nil)
 102   (setq list-mode-extent nil)
 103 ;; It is visually disconcerting to have the text cursor disappear within list
 104 ;; buffers, especially when moving from window to window, so leave it
 105 ;; visible.  -- Bob Weiner, 06/20/1999
 106 ; (set-specifier text-cursor-visible-p nil (current-buffer))
 107   (setq buffer-read-only t)
 108   (goto-char (point-min))
 109   (run-hooks 'list-mode-hook))
 110
 111 ;; List mode is suitable only for specially formatted data.
 112 (put 'list-mode 'mode-class 'special)
 113
 114 (defvar list-mode-extent-old-point nil
 115   "The value of point when pre-command-hook is called.
 116 Used to determine the direction of motion.")
 117 (make-variable-buffer-local 'list-mode-extent-old-point)
 118
 119 (defun list-mode-extent-pre-hook ()
 120   (setq list-mode-extent-old-point (point))
 121   ;(setq atomic-extent-goto-char-p nil)
 122 )
 123
 124 (defun set-list-mode-extent ()
 125   "Move to the closest list item and set up the extent for it.
 126 This is called from `post-command-hook'."
 127   (cond ((get-char-property (point) 'list-mode-item))
 128         ((and (> (point) (point-min))
 129               (get-char-property (1- (point)) 'list-mode-item))
 130          (goto-char (1- (point))))
 131         (t
 132          (let ((pos (point))
 133                dirflag)
 134            ;this fucks things up more than it helps.
 135            ;atomic-extent-goto-char-p as currently defined is all broken,
 136            ;since it will be triggered if the command *ever* runs goto-char!
 137            ;(if atomic-extent-goto-char-p
 138            ;    (setq dirflag 1)
 139            (if (and list-mode-extent-old-point
 140                     (> pos list-mode-extent-old-point))
 141                (setq dirflag 1)
 142              (setq dirflag -1))
 143            (next-list-mode-item dirflag)
 144            (or (get-char-property (point) 'list-mode-item)
 145                (next-list-mode-item (- dirflag))))))
 146   (or (and list-mode-extent
 147            (eq (current-buffer) (extent-object list-mode-extent)))
 148       (progn
 149         (setq list-mode-extent (make-extent nil nil (current-buffer)))
 150         (set-extent-face list-mode-extent 'list-mode-item-selected)))
 151   (let ((ex (extent-at (point) nil 'list-mode-item nil 'at)))
 152     (if ex
 153         (progn
 154           (set-extent-endpoints list-mode-extent
 155                                 (extent-start-position ex)
 156                                 (extent-end-position ex))
 157           (auto-show-make-region-visible (extent-start-position ex)
 158                                          (extent-end-position ex)))
 159       (detach-extent list-mode-extent))))
 160
 161 (defun previous-list-mode-item (n)
 162   "Move to the previous item in list-mode."
 163   (interactive "p")
 164   (next-list-mode-item (- n)))
 165
 166 (defun next-list-mode-item (n)
 167   "Move to the next item in list-mode.
 168 With prefix argument N, move N items (negative N means move backward)."
 169   (interactive "p")
 170   (while (and (> n 0) (not (eobp)))
 171     (let ((extent (extent-at (point) (current-buffer) 'list-mode-item))
 172           (end (point-max)))
 173       ;; If in a completion, move to the end of it.
 174       (if extent (goto-char (extent-end-position extent)))
 175       ;; Move to start of next one.
 176       (or (extent-at (point) (current-buffer) 'list-mode-item)
 177           (goto-char (next-single-property-change (point) 'list-mode-item
 178                                                   nil end))))
 179     (setq n (1- n)))
 180   (while (and (< n 0) (not (bobp)))
 181     (let ((extent (extent-at (point) (current-buffer) 'list-mode-item))
 182           (end (point-min)))
 183       ;; If in a completion, move to the start of it.
 184       (if extent (goto-char (extent-start-position extent)))
 185       ;; Move to the start of that one.
 186       (if (setq extent (extent-at (point) (current-buffer) 'list-mode-item
 187                                   nil 'before))
 188           (goto-char (extent-start-position extent))
 189         (goto-char (previous-single-property-change
 190                     (point) 'list-mode-item nil end))
 191         (if (setq extent (extent-at (point) (current-buffer) 'list-mode-item
 192                                     nil 'before))
 193             (goto-char (extent-start-position extent)))))
 194     (setq n (1+ n))))
 195
 196 (defun list-mode-item-selected-1 (extent event)
 197   (let ((func (extent-property extent 'list-mode-item-activate-callback))
 198         (user-data (extent-property extent 'list-mode-item-user-data)))
 199     (if func
 200         (funcall func event extent user-data))))
 201
 202 ;; we could make these two be just one function, but we want to be
 203 ;; able to refer to them in DOC strings.
 204
 205 (defun list-mode-item-keyboard-selected ()
 206   (interactive)
 207   (list-mode-item-selected-1 (extent-at (point) (current-buffer)
 208                                         'list-mode-item nil 'at)
 209                              nil))
 210
 211 (defun list-mode-item-mouse-selected (event)
 212   (interactive "e")
 213   ;; Sometimes event-closest-point returns nil.
 214   ;; So beep instead of bombing.
 215   (let ((point (event-closest-point event)))
 216     (if point
 217         (list-mode-item-selected-1 (extent-at point
 218                                               (event-buffer event)
 219                                               'list-mode-item nil 'at)
 220                                    event)
 221       (ding))))
 222
 223 (defun add-list-mode-item (start end &optional buffer activate-callback
 224                                  user-data)
 225   "Add a new list item in list-mode, from START to END in BUFFER.
 226 BUFFER defaults to the current buffer.
 227 This works by creating an extent for the span of text in question.
 228 If ACTIVATE-CALLBACK is non-nil, it should be a function of three
 229   arguments (EVENT EXTENT USER-DATA) that will be called when button2
 230   is pressed on the extent.  USER-DATA comes from the optional
 231   USER-DATA argument."
 232   (let ((extent (make-extent start end buffer)))
 233     (set-extent-property extent 'list-mode-item t)
 234     (set-extent-property extent 'start-open t)
 235     (if activate-callback
 236         (progn
 237           (set-extent-property extent 'mouse-face 'highlight)
 238           (set-extent-property extent 'list-mode-item-activate-callback
 239                                activate-callback)
 240           (set-extent-property extent 'list-mode-item-user-data user-data)))
 241     extent))
 242
 243 \f
 244 ;; Define the major mode for lists of completions.
 245
 246
 247 (defvar completion-highlight-first-word-only nil
 248   "*Completion will only highlight the first blank delimited word if t.
 249 If the variable in not t or nil, the string is taken as a regexp to match for end
 250 of highlight")
 251
 252 ;; see comment at list-mode-hook.
 253 (put 'completion-setup-hook 'permanent-local t)
 254 (defvar completion-setup-hook nil
 255   "Normal hook run at the end of setting up the text of a completion buffer.
 256 When run, the completion buffer is the current buffer.")
 257
 258 ; Unnecessary FSFmacs crock.  We frob the extents directly in
 259 ; display-completion-list, so no "heuristics" like this are necessary.
 260 ;(defvar completion-fixup-function nil
 261 ;  "A function to customize how completions are identified in completion lists.
 262 ;`completion-setup-function' calls this function with no arguments
 263 ;each time it has found what it thinks is one completion.
 264 ;Point is at the end of the completion in the completion list buffer.
 265 ;If this function moves point, it can alter the end of that completion.")
 266
 267 (defvar completion-default-help-string
 268   '(concat
 269     (if (device-on-window-system-p)
 270         (substitute-command-keys
 271          "Click \\<list-mode-map>\\[list-mode-item-mouse-selected] on a completion to select it.\n") "")
 272     (substitute-command-keys
 273      "Type \\<minibuffer-local-completion-map>\\[advertised-switch-to-completions] or \\[switch-to-completions] to move to this buffer, for keyboard selection.\n\n"))
 274   "Form the evaluate to get a help string for completion lists.
 275 This string is inserted at the beginning of the buffer.
 276 See `display-completion-list'.")
 277
 278 (defun display-completion-list (completions &rest cl-keys)
 279   "Display the list of completions, COMPLETIONS, using `standard-output'.
 280 Each element may be just a symbol or string or may be a list of two
 281  strings to be printed as if concatenated.
 282 Frob a mousable extent onto each completion.  This extent has properties
 283  'mouse-face (so it highlights when the mouse passes over it) and
 284  'list-mode-item (so it can be located).
 285
 286 Keywords:
 287   :activate-callback (default is `default-choose-completion')
 288     See `add-list-mode-item'.
 289   :user-data
 290     Value passed to activation callback.
 291   :window-width
 292     If non-nil, width to use in displaying the list, instead of the
 293     actual window's width.
 294   :window-height
 295     If non-nil, use no more than this many lines, and extend line width as
 296     necessary.
 297   :help-string (default is the value of `completion-default-help-string')
 298     Form to evaluate to get a string to insert at the beginning of
 299     the completion list buffer.  This is evaluated when that buffer
 300     is the current buffer and after it has been put into
 301     completion-list-mode.
 302   :reference-buffer (default is the current buffer)
 303     This specifies the value of `completion-reference-buffer' in
 304     the completion buffer.  This specifies the buffer (normally a
 305     minibuffer) that `default-choose-completion' will insert the
 306     completion into.
 307
 308 At the end, run the normal hook `completion-setup-hook'.
 309 It can find the completion buffer in `standard-output'.
 310 If `completion-highlight-first-word-only' is non-nil, then only the start
 311  of the string is highlighted."
 312    ;; #### I18N3 should set standard-output to be (temporarily)
 313    ;; output-translating.
 314   (cl-parsing-keywords
 315       ((:activate-callback 'default-choose-completion)
 316        :user-data
 317        :reference-buffer
 318        (:help-string completion-default-help-string)
 319        (:completion-string "Possible completions are:")
 320        :window-width
 321        :window-height)
 322       ()
 323     (let ((old-buffer (current-buffer))
 324           (bufferp (bufferp standard-output)))
 325       (if bufferp
 326           (set-buffer standard-output))
 327       (if (null completions)
 328           (princ (gettext
 329                   "There are no possible completions of what you have typed."))
 330         (let ((win-width
 331                (or cl-window-width
 332                    (if bufferp
 333                        ;; This needs fixing for the case of windows
 334                        ;; that aren't the same width's the frame.
 335                        ;; Sadly, the window it will appear in is not known
 336                        ;; until after the text has been made.
 337
 338                        ;; We have to use last-nonminibuf-frame here
 339                        ;; and not selected-frame because if a
 340                        ;; minibuffer-only frame is being used it will
 341                        ;; be the selected-frame at the point this is
 342                        ;; run.  We keep the selected-frame call around
 343                        ;; just in case.
 344                        (frame-width (or (last-nonminibuf-frame)
 345                                         (selected-frame)))
 346                      80))))
 347           (let ((count 0)
 348                 (max-width 0)
 349                 old-max-width)
 350             ;; Find longest completion
 351             (let ((tail completions))
 352               (while tail
 353                 (let* ((elt (car tail))
 354                        (len (cond ((stringp elt)
 355                                    (length elt))
 356                                   ((and (consp elt)
 357                                         (stringp (car elt))
 358                                         (stringp (car (cdr elt))))
 359                                    (+ (length (car elt))
 360                                       (length (car (cdr elt)))))
 361                                   (t
 362                                    (signal 'wrong-type-argument
 363                                            (list 'stringp elt))))))
 364                   (if (> len max-width)
 365                       (setq max-width len))
 366                   (setq count (1+ count)
 367                         tail (cdr tail)))))
 368
 369             (setq max-width (+ 2 max-width)) ; at least two chars between cols
 370             (setq old-max-width max-width)
 371             (let ((rows (let ((cols (min (/ win-width max-width) count)))
 372                           (if (<= cols 1)
 373                               count
 374                             (progn
 375                               ;; re-space the columns
 376                               (setq max-width (/ win-width cols))
 377                               (if (/= (% count cols) 0) ; want ceiling...
 378                                   (1+ (/ count cols))
 379                                 (/ count cols)))))))
 380               (when
 381                   (and cl-window-height
 382                        (> rows cl-window-height))
 383                 (setq max-width old-max-width)
 384                 (setq rows cl-window-height))
 385               (when (and (stringp cl-completion-string)
 386                          (> (length cl-completion-string) 0))
 387                 (princ (gettext cl-completion-string))
 388                 (terpri))
 389               (let ((tail completions)
 390                     (r 0)
 391                     (regexp-string
 392                      (if (eq t
 393                              completion-highlight-first-word-only)
 394                          "[ \t]"
 395                        completion-highlight-first-word-only)))
 396                 (while (< r rows)
 397                   (and (> r 0) (terpri))
 398                   (let ((indent 0)
 399                         (column 0)
 400                         (tail2 tail))
 401                     (while tail2
 402                       (let ((elt (car tail2)))
 403                         (if (/= indent 0)
 404                             (if bufferp
 405                                 (indent-to indent 2)
 406                               (while (progn (write-char ?\ )
 407                                             (setq column (1+ column))
 408                                             (< column indent)))))
 409                         (setq indent (+ indent max-width))
 410                         (let ((start (point))
 411                               end)
 412                           ;; Frob some mousable extents in there too!
 413                           (if (consp elt)
 414                               (progn
 415                                 (princ (car elt))
 416                                 (princ (car (cdr elt)))
 417                                 (or bufferp
 418                                     (setq column
 419                                           (+ column
 420                                              (length (car elt))
 421                                              (length (car (cdr elt)))))))
 422                             (progn
 423                               (princ elt)
 424                               (or bufferp
 425                                   (setq column (+ column (length
 426                                                           elt))))))
 427                           (add-list-mode-item
 428                            start
 429                            (progn
 430                              (setq end (point))
 431                              (or
 432                               (and completion-highlight-first-word-only
 433                                    (goto-char start)
 434                                    (re-search-forward regexp-string end t)
 435                                    (match-beginning 0))
 436                               end))
 437                            nil cl-activate-callback cl-user-data)
 438                           (goto-char end)))
 439                       (setq tail2 (nthcdr rows tail2)))
 440                     (setq tail (cdr tail)
 441                           r (1+ r)))))))))
 442       (if bufferp
 443           (set-buffer old-buffer)))
 444     (save-excursion
 445       (let ((mainbuf (or cl-reference-buffer (current-buffer))))
 446         (set-buffer standard-output)
 447         (completion-list-mode)
 448         (make-local-variable 'completion-reference-buffer)
 449         (setq completion-reference-buffer mainbuf)
 450 ;;; The value 0 is right in most cases, but not for file name completion.
 451 ;;; so this has to be turned off.
 452 ;;;      (setq completion-base-size 0)
 453         (goto-char (point-min))
 454         (let ((buffer-read-only nil))
 455           (insert (eval cl-help-string)))
 456           ;; unnecessary FSFmacs crock
 457           ;;(forward-line 1)
 458           ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t)
 459           ;;      (let ((beg (match-beginning 0))
 460           ;;            (end (point)))
 461           ;;        (if completion-fixup-function
 462           ;;            (funcall completion-fixup-function))
 463           ;;        (put-text-property beg (point) 'mouse-face 'highlight)
 464           ;;        (put-text-property beg (point) 'list-mode-item t)
 465           ;;        (goto-char end)))))
 466         ))
 467     (save-excursion
 468       (set-buffer standard-output)
 469       (run-hooks 'completion-setup-hook))))
 470
 471 (defvar completion-display-completion-list-function 'display-completion-list
 472   "Function to set up the list of completions in the completion buffer.
 473 The function is called with one argument, the sorted list of completions.
 474 Particular minibuffer interface functions (e.g. `read-file-name') may
 475 want to change this.  To do that, set a local value for this variable
 476 in the minibuffer; that ensures that other minibuffer invocations will
 477 not be affected.")
 478
 479 (defun minibuffer-completion-help ()
 480   "Display a list of possible completions of the current minibuffer contents.
 481 The list of completions is determined by calling `all-completions',
 482 passing it the current minibuffer contents, the value of
 483 `minibuffer-completion-table', and the value of
 484 `minibuffer-completion-predicate'.  The list is displayed by calling
 485 the value of `completion-display-completion-list-function' on the sorted
 486 list of completions, with the standard output set to the completion
 487 buffer."
 488   (interactive)
 489   (message "Making completion list...")
 490   (let ((completions (all-completions (buffer-string)
 491                                       minibuffer-completion-table
 492                                       minibuffer-completion-predicate)))
 493     (message nil)
 494     (if (null completions)
 495         (progn
 496           (ding nil 'no-completion)
 497           (temp-minibuffer-message " [No completions]"))
 498         (with-output-to-temp-buffer "*Completions*"
 499           (funcall completion-display-completion-list-function
 500                    (sort completions #'string-lessp))))))
 501
 502 (define-derived-mode completion-list-mode list-mode
 503   "Completion List"
 504   "Major mode for buffers showing lists of possible completions.
 505 \\{completion-list-mode-map}"
 506   (make-local-variable 'completion-base-size)
 507   (setq completion-base-size nil))
 508
 509 (let ((map completion-list-mode-map))
 510   (define-key map 'button2up 'mouse-choose-completion)
 511   (define-key map 'button2 'undefined)
 512   (define-key map "\C-m" 'choose-completion)
 513   (define-key map "\e\e\e" 'delete-completion-window)
 514   (define-key map "\C-g" 'minibuffer-keyboard-quit)
 515   (define-key map "q" 'completion-list-mode-quit)
 516   (define-key map " " 'completion-switch-to-minibuffer)
 517   ;; [Tab] used to switch to the minibuffer but since [space] does that and
 518   ;; since most applications in the world use [Tab] to select the next item
 519   ;; in a list, do that in the *Completions* buffer too.  -- Bob Weiner,
 520   ;; BeOpen.com, 06/23/1999.
 521   (define-key map "\t" 'next-list-mode-item))
 522
 523 (defvar completion-reference-buffer nil
 524   "Record the buffer that was current when the completion list was requested.
 525 This is a local variable in the completion list buffer.
 526 Initial value is nil to avoid some compiler warnings.")
 527
 528 (defvar completion-base-size nil
 529   "Number of chars at beginning of minibuffer not involved in completion.
 530 This is a local variable in the completion list buffer
 531 but it talks about the buffer in `completion-reference-buffer'.
 532 If this is nil, it means to compare text to determine which part
 533 of the tail end of the buffer's text is involved in completion.")
 534
 535 ;; These names are referenced in the doc string for `completion-list-mode'.
 536 (defalias 'choose-completion 'list-mode-item-keyboard-selected)
 537 (defalias 'mouse-choose-completion 'list-mode-item-mouse-selected)
 538
 539 (defun delete-completion-window ()
 540   "Delete the completion list window.
 541 Go to the window from which completion was requested."
 542   (interactive)
 543   (let ((buf completion-reference-buffer))
 544     (delete-window (selected-window))
 545     (if (get-buffer-window buf)
 546          (select-window (get-buffer-window buf)))))
 547
 548 (defun completion-switch-to-minibuffer ()
 549   "Move from a completions buffer to the active minibuffer window."
 550   (interactive)
 551   (select-window (minibuffer-window)))
 552
 553 (defun completion-list-mode-quit ()
 554   "Abort any recursive edit and bury the completions buffer."
 555   (interactive)
 556   (condition-case ()
 557       (abort-recursive-edit)
 558     (error nil))
 559   ;; If there was no recursive edit to abort, simply bury the completions
 560   ;; list buffer.
 561   (if (eq major-mode 'completion-list-mode) (bury-buffer)))
 562
 563 (defun completion-do-in-minibuffer ()
 564   (interactive "_")
 565   (save-excursion
 566     (set-buffer (window-buffer (minibuffer-window)))
 567     (call-interactively (key-binding (this-command-keys)))))
 568
 569 (defun default-choose-completion (event extent buffer)
 570   "Click on an alternative in the `*Completions*' buffer to choose it."
 571   (and (button-event-p event)
 572        ;; Give temporary modes such as isearch a chance to turn off.
 573        (run-hooks 'mouse-leave-buffer-hook))
 574   (or buffer (setq buffer (symbol-value-in-buffer
 575                            'completion-reference-buffer
 576                            (or (and (button-event-p event)
 577                                     (event-buffer event))
 578                                (current-buffer)))))
 579   (save-selected-window
 580    (and (button-event-p event)
 581         (select-window (event-window event)))
 582    (if (and (one-window-p t 'selected-frame)
 583             (window-dedicated-p (selected-window)))
 584        ;; This is a special buffer's frame
 585        (iconify-frame (selected-frame))
 586      (or (window-dedicated-p (selected-window))
 587          (bury-buffer))))
 588   (choose-completion-string (extent-string extent)
 589                             buffer
 590                             completion-base-size))
 591
 592 ;; Delete the longest partial match for STRING
 593 ;; that can be found before POINT.
 594 (defun choose-completion-delete-max-match (string)
 595   (let ((len (min (length string)
 596                   (- (point) (point-min)))))
 597     (goto-char (- (point) (length string)))
 598     (if completion-ignore-case
 599          (setq string (downcase string)))
 600     (while (and (> len 0)
 601                  (let ((tail (buffer-substring (point)
 602                                                (+ (point) len))))
 603                    (if completion-ignore-case
 604                        (setq tail (downcase tail)))
 605                    (not (string= tail (substring string 0 len)))))
 606       (setq len (1- len))
 607       (forward-char 1))
 608     (delete-char len)))
 609
 610 ;; Switch to BUFFER and insert the completion choice CHOICE.
 611 ;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text
 612 ;; to keep.  If it is nil, use choose-completion-delete-max-match instead.
 613 (defun choose-completion-string (choice &optional buffer base-size)
 614   (let ((buffer (or buffer completion-reference-buffer)))
 615     ;; If BUFFER is a minibuffer, barf unless it's the currently
 616     ;; active minibuffer.
 617     (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))
 618               (or (not (active-minibuffer-window))
 619                   (not (equal buffer
 620                               (window-buffer (active-minibuffer-window))))))
 621          (error "Minibuffer is not active for completion")
 622       ;; Insert the completion into the buffer where completion was requested.
 623       (set-buffer buffer)
 624       (if base-size
 625            (delete-region (+ base-size (point-min)) (point))
 626          (choose-completion-delete-max-match choice))
 627       (insert choice)
 628       (remove-text-properties (- (point) (length choice)) (point)
 629                                '(highlight nil))
 630       ;; Update point in the window that BUFFER is showing in.
 631       (let ((window (get-buffer-window buffer t)))
 632          (set-window-point window (point)))
 633       ;; If completing for the minibuffer, exit it with this choice.
 634       (and (equal buffer (window-buffer (minibuffer-window)))
 635             minibuffer-completion-table
 636             (exit-minibuffer)))))
 637
 638 (define-key minibuffer-local-completion-map [prior]
 639   'switch-to-completions)
 640 (define-key minibuffer-local-must-match-map [prior]
 641   'switch-to-completions)
 642 (define-key minibuffer-local-completion-map "\M-v"
 643   'advertised-switch-to-completions)
 644 (define-key minibuffer-local-must-match-map "\M-v"
 645   'advertised-switch-to-completions)
 646
 647 (defalias 'advertised-switch-to-completions 'switch-to-completions)
 648 (defun switch-to-completions ()
 649   "Select the completion list window."
 650   (interactive)
 651   ;; Make sure we have a completions window.
 652   (or (get-buffer-window "*Completions*")
 653       (minibuffer-completion-help))
 654   (if (not (get-buffer-window "*Completions*"))
 655       nil
 656     (select-window (get-buffer-window "*Completions*"))
 657     (goto-char (next-single-property-change (point-min) 'list-mode-item nil
 658                                             (point-max)))))
 659
 660 ;;; list-mode.el ends here