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                        ;; We have to use last-nonminibuf-frame here
 334                        ;; and not selected-frame because if a
 335                        ;; minibuffer-only frame is being used it will
 336                        ;; be the selected-frame at the point this is
 337                        ;; run.  We keep the selected-frame call around
 338                        ;; just in case.
 339                (window-width (get-lru-window (last-nonminibuf-frame)))
 340                      80))))
 341           (let ((count 0)
 342                 (max-width 0)
 343                 old-max-width)
 344             ;; Find longest completion
 345             (let ((tail completions))
 346               (while tail
 347                 (let* ((elt (car tail))
 348                        (len (cond ((stringp elt)
 349                                    (length elt))
 350                                   ((and (consp elt)
 351                                         (stringp (car elt))
 352                                         (stringp (car (cdr elt))))
 353                                    (+ (length (car elt))
 354                                       (length (car (cdr elt)))))
 355                                   (t
 356                                    (signal 'wrong-type-argument
 357                                            (list 'stringp elt))))))
 358                   (if (> len max-width)
 359                       (setq max-width len))
 360                   (setq count (1+ count)
 361                         tail (cdr tail)))))
 362
 363             (setq max-width (+ 2 max-width)) ; at least two chars between cols
 364             (setq old-max-width max-width)
 365             (let ((rows (let ((cols (min (/ win-width max-width) count)))
 366                           (if (<= cols 1)
 367                               count
 368                             (progn
 369                               ;; re-space the columns
 370                               (setq max-width (/ win-width cols))
 371                               (if (/= (% count cols) 0) ; want ceiling...
 372                                   (1+ (/ count cols))
 373                                 (/ count cols)))))))
 374               (when
 375                   (and cl-window-height
 376                        (> rows cl-window-height))
 377                 (setq max-width old-max-width)
 378                 (setq rows cl-window-height))
 379               (when (and (stringp cl-completion-string)
 380                          (> (length cl-completion-string) 0))
 381                 (princ (gettext cl-completion-string))
 382                 (terpri))
 383               (let ((tail completions)
 384                     (r 0)
 385                     (regexp-string
 386                      (if (eq t
 387                              completion-highlight-first-word-only)
 388                          "[ \t]"
 389                        completion-highlight-first-word-only)))
 390                 (while (< r rows)
 391                   (and (> r 0) (terpri))
 392                   (let ((indent 0)
 393                         (column 0)
 394                         (tail2 tail))
 395                     (while tail2
 396                       (let ((elt (car tail2)))
 397                         (if (/= indent 0)
 398                             (if bufferp
 399                                 (indent-to indent 2)
 400                               (while (progn (write-char ?\ )
 401                                             (setq column (1+ column))
 402                                             (< column indent)))))
 403                         (setq indent (+ indent max-width))
 404                         (let ((start (point))
 405                               end)
 406                           ;; Frob some mousable extents in there too!
 407                           (if (consp elt)
 408                               (progn
 409                                 (princ (car elt))
 410                                 (princ (car (cdr elt)))
 411                                 (or bufferp
 412                                     (setq column
 413                                           (+ column
 414                                              (length (car elt))
 415                                              (length (car (cdr elt)))))))
 416                             (progn
 417                               (princ elt)
 418                               (or bufferp
 419                                   (setq column (+ column (length
 420                                                           elt))))))
 421                           (add-list-mode-item
 422                            start
 423                            (progn
 424                              (setq end (point))
 425                              (or
 426                               (and completion-highlight-first-word-only
 427                                    (goto-char start)
 428                                    (re-search-forward regexp-string end t)
 429                                    (match-beginning 0))
 430                               end))
 431                            nil cl-activate-callback cl-user-data)
 432                           (goto-char end)))
 433                       (setq tail2 (nthcdr rows tail2)))
 434                     (setq tail (cdr tail)
 435                           r (1+ r)))))))))
 436       (if bufferp
 437           (set-buffer old-buffer)))
 438     (save-excursion
 439       (let ((mainbuf (or cl-reference-buffer (current-buffer))))
 440         (set-buffer standard-output)
 441         (completion-list-mode)
 442         (make-local-variable 'completion-reference-buffer)
 443         (setq completion-reference-buffer mainbuf)
 444 ;;; The value 0 is right in most cases, but not for file name completion.
 445 ;;; so this has to be turned off.
 446 ;;;      (setq completion-base-size 0)
 447         (goto-char (point-min))
 448         (let ((buffer-read-only nil))
 449           (insert (eval cl-help-string)))
 450           ;; unnecessary FSFmacs crock
 451           ;;(forward-line 1)
 452           ;;(while (re-search-forward "[^ \t\n]+\\( [^ \t\n]+\\)*" nil t)
 453           ;;      (let ((beg (match-beginning 0))
 454           ;;            (end (point)))
 455           ;;        (if completion-fixup-function
 456           ;;            (funcall completion-fixup-function))
 457           ;;        (put-text-property beg (point) 'mouse-face 'highlight)
 458           ;;        (put-text-property beg (point) 'list-mode-item t)
 459           ;;        (goto-char end)))))
 460         ))
 461     (save-excursion
 462       (set-buffer standard-output)
 463       (run-hooks 'completion-setup-hook))))
 464
 465 (defvar completion-display-completion-list-function 'display-completion-list
 466   "Function to set up the list of completions in the completion buffer.
 467 The function is called with one argument, the sorted list of completions.
 468 Particular minibuffer interface functions (e.g. `read-file-name') may
 469 want to change this.  To do that, set a local value for this variable
 470 in the minibuffer; that ensures that other minibuffer invocations will
 471 not be affected.")
 472
 473 (defun minibuffer-completion-help ()
 474   "Display a list of possible completions of the current minibuffer contents.
 475 The list of completions is determined by calling `all-completions',
 476 passing it the current minibuffer contents, the value of
 477 `minibuffer-completion-table', and the value of
 478 `minibuffer-completion-predicate'.  The list is displayed by calling
 479 the value of `completion-display-completion-list-function' on the sorted
 480 list of completions, with the standard output set to the completion
 481 buffer."
 482   (interactive)
 483   (message "Making completion list...")
 484   (let ((completions (all-completions (buffer-string)
 485                                       minibuffer-completion-table
 486                                       minibuffer-completion-predicate)))
 487     (message nil)
 488     (if (null completions)
 489         (progn
 490           (ding nil 'no-completion)
 491           (temp-minibuffer-message " [No completions]"))
 492         (with-output-to-temp-buffer "*Completions*"
 493           (funcall completion-display-completion-list-function
 494                    (sort completions #'string-lessp))))))
 495
 496 (define-derived-mode completion-list-mode list-mode
 497   "Completion List"
 498   "Major mode for buffers showing lists of possible completions.
 499 \\{completion-list-mode-map}"
 500   (make-local-variable 'completion-base-size)
 501   (setq completion-base-size nil))
 502
 503 (let ((map completion-list-mode-map))
 504   (define-key map 'button2up 'mouse-choose-completion)
 505   (define-key map 'button2 'undefined)
 506   (define-key map "\C-m" 'choose-completion)
 507   (define-key map "\e\e\e" 'delete-completion-window)
 508   (define-key map "\C-g" 'minibuffer-keyboard-quit)
 509   (define-key map "q" 'completion-list-mode-quit)
 510   (define-key map " " 'completion-switch-to-minibuffer)
 511   ;; [Tab] used to switch to the minibuffer but since [space] does that and
 512   ;; since most applications in the world use [Tab] to select the next item
 513   ;; in a list, do that in the *Completions* buffer too.  -- Bob Weiner,
 514   ;; BeOpen.com, 06/23/1999.
 515   (define-key map "\t" 'next-list-mode-item))
 516
 517 (defvar completion-reference-buffer nil
 518   "Record the buffer that was current when the completion list was requested.
 519 This is a local variable in the completion list buffer.
 520 Initial value is nil to avoid some compiler warnings.")
 521
 522 (defvar completion-base-size nil
 523   "Number of chars at beginning of minibuffer not involved in completion.
 524 This is a local variable in the completion list buffer
 525 but it talks about the buffer in `completion-reference-buffer'.
 526 If this is nil, it means to compare text to determine which part
 527 of the tail end of the buffer's text is involved in completion.")
 528
 529 ;; These names are referenced in the doc string for `completion-list-mode'.
 530 (defalias 'choose-completion 'list-mode-item-keyboard-selected)
 531 (defalias 'mouse-choose-completion 'list-mode-item-mouse-selected)
 532
 533 (defun delete-completion-window ()
 534   "Delete the completion list window.
 535 Go to the window from which completion was requested."
 536   (interactive)
 537   (let ((buf completion-reference-buffer))
 538     (delete-window (selected-window))
 539     (if (get-buffer-window buf)
 540          (select-window (get-buffer-window buf)))))
 541
 542 (defun completion-switch-to-minibuffer ()
 543   "Move from a completions buffer to the active minibuffer window."
 544   (interactive)
 545   (select-window (minibuffer-window)))
 546
 547 (defun completion-list-mode-quit ()
 548   "Abort any recursive edit and bury the completions buffer."
 549   (interactive)
 550   (condition-case ()
 551       (abort-recursive-edit)
 552     (error nil))
 553   ;; If there was no recursive edit to abort, simply bury the completions
 554   ;; list buffer.
 555   (if (eq major-mode 'completion-list-mode) (bury-buffer)))
 556
 557 (defun completion-do-in-minibuffer ()
 558   (interactive "_")
 559   (save-excursion
 560     (set-buffer (window-buffer (minibuffer-window)))
 561     (call-interactively (key-binding (this-command-keys)))))
 562
 563 (defun default-choose-completion (event extent buffer)
 564   "Click on an alternative in the `*Completions*' buffer to choose it."
 565   (and (button-event-p event)
 566        ;; Give temporary modes such as isearch a chance to turn off.
 567        (run-hooks 'mouse-leave-buffer-hook))
 568   (let ((list-buffer (or (and (button-event-p event)
 569                               (event-buffer event))
 570                          (current-buffer))))
 571     (or buffer (setq buffer (symbol-value-in-buffer
 572                              'completion-reference-buffer
 573                              list-buffer)))
 574     (save-selected-window
 575       (and (button-event-p event)
 576            (select-window (event-window event)))
 577       (if (and (one-window-p t 'selected-frame)
 578                (window-dedicated-p (selected-window)))
 579           ;; This is a special buffer's frame
 580           (iconify-frame (selected-frame))
 581         (or (window-dedicated-p (selected-window))
 582             (bury-buffer))))
 583     (choose-completion-string (extent-string extent)
 584                               buffer
 585                               (symbol-value-in-buffer 'completion-base-size
 586                                                       list-buffer))))
 587
 588 ;; Delete the longest partial match for STRING
 589 ;; that can be found before POINT.
 590 (defun choose-completion-delete-max-match (string)
 591   (let ((len (min (length string)
 592                   (- (point) (point-min)))))
 593     (goto-char (- (point) (length string)))
 594     (if completion-ignore-case
 595          (setq string (downcase string)))
 596     (while (and (> len 0)
 597                  (let ((tail (buffer-substring (point)
 598                                                (+ (point) len))))
 599                    (if completion-ignore-case
 600                        (setq tail (downcase tail)))
 601                    (not (string= tail (substring string 0 len)))))
 602       (setq len (1- len))
 603       (forward-char 1))
 604     (delete-char len)))
 605
 606 ;; Switch to BUFFER and insert the completion choice CHOICE.
 607 ;; BASE-SIZE, if non-nil, says how many characters of BUFFER's text
 608 ;; to keep.  If it is nil, use choose-completion-delete-max-match instead.
 609 (defun choose-completion-string (choice &optional buffer base-size)
 610   (let ((buffer (or buffer completion-reference-buffer)))
 611     ;; If BUFFER is a minibuffer, barf unless it's the currently
 612     ;; active minibuffer.
 613     (if (and (string-match "\\` \\*Minibuf-[0-9]+\\*\\'" (buffer-name buffer))
 614               (or (not (active-minibuffer-window))
 615                   (not (equal buffer
 616                               (window-buffer (active-minibuffer-window))))))
 617          (error "Minibuffer is not active for completion")
 618       ;; Insert the completion into the buffer where completion was requested.
 619       (set-buffer buffer)
 620       (if base-size
 621            (delete-region (+ base-size (point-min)) (point))
 622          (choose-completion-delete-max-match choice))
 623       (insert choice)
 624       (remove-text-properties (- (point) (length choice)) (point)
 625                                '(highlight nil))
 626       ;; Update point in the window that BUFFER is showing in.
 627       (let ((window (get-buffer-window buffer t)))
 628          (set-window-point window (point)))
 629       ;; If completing for the minibuffer, exit it with this choice.
 630       (and (equal buffer (window-buffer (minibuffer-window)))
 631             minibuffer-completion-table
 632             (exit-minibuffer)))))
 633
 634 (define-key minibuffer-local-completion-map [prior]
 635   'switch-to-completions)
 636 (define-key minibuffer-local-must-match-map [prior]
 637   'switch-to-completions)
 638 (define-key minibuffer-local-completion-map "\M-v"
 639   'advertised-switch-to-completions)
 640 (define-key minibuffer-local-must-match-map "\M-v"
 641   'advertised-switch-to-completions)
 642
 643 (defalias 'advertised-switch-to-completions 'switch-to-completions)
 644 (defun switch-to-completions ()
 645   "Select the completion list window."
 646   (interactive)
 647   ;; Make sure we have a completions window.
 648   (or (get-buffer-window "*Completions*")
 649       (minibuffer-completion-help))
 650   (if (not (get-buffer-window "*Completions*"))
 651       nil
 652     (select-window (get-buffer-window "*Completions*"))
 653     (goto-char (next-single-property-change (point-min) 'list-mode-item nil
 654                                             (point-max)))))
 655
 656 ;;; list-mode.el ends here