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