cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/completer.el

   1 ;;; -*- Mode: Emacs-Lisp -*-
   2 ;;;%Header
   3 ;;;
   4 ;;; Rcs_Info: completer.el,v 3.23 1993/09/03 02:05:07 ivan Rel $
   5 ;;;
   6 ;;; Partial completion mechanism for GNU Emacs and XEmacs.  Version 3.05
   7 ;;; Copyright (C) 1990, 1991, 1992 Chris McConnell, ccm@cs.cmu.edu.
   8 ;;; Copyright (C) 2000 Ben Wing.
   9 ;;; Copyright (C) 2002 Marco Antoniotti and the ILISP Maintainers
  10 ;;;
  11 ;;; Author: Chris Mcconnell <chrimc@microsoft.com>
  12 ;;; Latest XEmacs Author: Ben Wing
  13 ;;; Maintainer: The ILISP Maintainers
  14 ;;; Keywords: minibuffer, completion
  15
  16 ;;; Thanks to Bjorn Victor for suggestions, testing, and patches for
  17 ;;; file completion.
  18
  19 ;;; This file should be part of GNU Emacs and XEmacs.
  20
  21 ;;; GNU Emacs and XEmacs are distributed in the hope that they will be useful,
  22 ;;; but WITHOUT ANY WARRANTY.  No author or distributor
  23 ;;; accepts responsibility to anyone for the consequences of using it
  24 ;;; or for whether it serves any particular purpose or works at all,
  25 ;;; unless he says so in writing.  Refer to the GNU Emacs General Public
  26 ;;; License for full details.
  27 ;;; Everyone is granted permission to copy, modify and redistribute
  28 ;;; GNU Emacs and XEmacs, but only under the conditions described in the
  29 ;;; GNU Emacs and XEmacs General Public License.   A copy of this license is
  30 ;;; supposed to have been given to you along with GNU Emacs or XEmacs so you
  31 ;;; can know your rights and responsibilities.  It should be in a
  32 ;;; file named COPYING.  Among other things, the copyright notice
  33 ;;; and this notice must be preserved on all copies.
  34
  35 ;;; When loaded, this file extends the standard completion mechanisms
  36 ;;; so that they perform pattern matching completions.  There is also
  37 ;;; an interface that allows it to be used by other programs.  The
  38 ;;; completion rules are:
  39 ;;;
  40 ;;; 1) If what has been typed matches any possibility, do normal
  41 ;;; completion.
  42 ;;;
  43 ;;; 2) Otherwise, generate a regular expression such that
  44 ;;; completer-words delimit words and generate all possible matches.
  45 ;;; The variable completer-any-delimiter can be set to a character
  46 ;;; that matches any delimiter.  If it were " ", then "by  d" would be
  47 ;;; byte-recompile-directory.  If completer-use-words is T, a match is
  48 ;;; unique if it is the only one with the same number of words.  If
  49 ;;; completer-use-words is NIL, a match is unique if it is the only
  50 ;;; possibility.  If you ask the completer to use its best guess, it
  51 ;;; will be the shortest match of the possibilities unless
  52 ;;; completer-exact is T.
  53 ;;;
  54 ;;; 3) For filenames, if completer-complete-filenames is T, each
  55 ;;; pathname component will be individually completed, otherwise only
  56 ;;; the final component will be completed.  If you are using a
  57 ;;; distributed file system like afs, you may want to set up a
  58 ;;; symbolic link in your home directory or add pathname components to
  59 ;;; completer-file-skip so that the pathname components that go across
  60 ;;; machines do not get expanded.
  61 ;;;
  62 ;;; SPACE, TAB, LFD, RET, and ? do normal completion if possible
  63 ;;; otherwise they do partial completion.  In addition, C-DEL will
  64 ;;; undo the last partial expansion or contraction.  M-RET will always
  65 ;;; complete to the current match before returning.  This is useful
  66 ;;; when any string is possible, but you want to complete to a string
  67 ;;; as when calling find-file.  The bindings can be changed by using
  68 ;;; completer-load-hook.
  69 ;;;
  70 ;;; Modes that use comint-dynamic-complete (like cmushell and ilisp)
  71 ;;; will also do partial completion as will M-tab in Emacs LISP.
  72 ;;;
  73 ;;; Examples:
  74 ;;; a-f     auto-fill-mode
  75 ;;; b--d    *beginning-of-defun or byte-recompile-directory
  76 ;;; by  d   *byte-recompile-directory if completer-any-delimiter is " "
  77 ;;; ~/i.e   *~/ilisp.el or ~/il-el.el or ~/ilisp.elc
  78 ;;; /u/mi/  /usr/misc/
  79 ;;;
  80
  81
  82 (require 'cl)
  83
  84 (eval-and-compile
  85   (or (fboundp 'file-system-ignore-case-p)
  86       (defalias 'file-system-ignore-case-p
  87         (if (memq 'system-type '(windows-nt cygwin32 darwin cygwin))
  88          #'(lambda (path) t)
  89          #'(lambda (path) nil)))))
  90
  91 ;;;%Globals
  92 ;;;%%Switches
  93 (defvar completer-load-hook nil
  94   "Hook called when minibuffer partial completion is loaded.")
  95
  96 (defvar completer-disable nil
  97   "*If T, turn off partial completion.  Use the command
  98 \\[completer-toggle] to set this.")
  99
 100 (defvar completer-complete-filenames t
 101   "*If T, then each component of a filename will be completed,
 102 otherwise just the final component will be completed.")
 103
 104 (defvar completer-use-words nil ; jwz: this is HATEFUL!
 105   "*If T, then prefer completions with the same number of words as the
 106 pattern.")
 107
 108 (defvar completer-words "---. <"
 109   "*Delimiters used in partial completions.  It should be a set of
 110 characters suitable for inclusion in a [] regular expression.")
 111
 112 (defvar completer-any-delimiter nil
 113   "*If a character, then a delimiter in the pattern that matches the
 114 character will match any delimiter in completer-words.")
 115
 116 (defvar completer-file-skip "^cs/$\\|@sys\\|.edu/$\\|.gov/$\\|.com/$\\|:/$"
 117   "*Regular expression for pathname components to not complete.")
 118
 119 (defvar completer-exact nil
 120   "*If T, then you must have an exact match.  Otherwise, the shortest
 121 string that matches the pattern will be used.")
 122
 123 (defvar completer-cache-size 100
 124   "*Size of cache to use for partially completed pathnames.")
 125
 126 (defvar completer-use-cache t
 127   "*Set to nil to disable the partially completed pathname cache.")
 128
 129 ;;;%%Internal
 130 (defvar completer-last-pattern ""
 131   "The last pattern expanded.")
 132
 133 (defvar completer-message nil
 134   "T if temporary message was just displayed.")
 135
 136 (defvar completer-path-cache nil
 137   "Cache of (path . choices) for completer.")
 138
 139 (defvar completer-path-separator-string
 140   (if (eq system-type 'windows-nt) "\\" "/"))
 141
 142 (defvar completer-path-separator-regexp
 143   (if (eq system-type 'windows-nt) "[/\\]" "/"))
 144
 145 (defvar completer-path-delimiter-list
 146   (if (eq system-type 'windows-nt) '(?\\ ?/) '(?/)))
 147
 148 (defvar completer-path-separator-regexp-inside-brackets
 149   (if (eq system-type 'windows-nt) "/\\" "/"))
 150
 151 (defvar completer-dot-dot-list
 152   (if (eq system-type 'windows-nt) '("../" "..\\") '("../")))
 153
 154 (defvar completer-string nil "Last completer string.")
 155 (defvar completer-table nil "Last completer table.")
 156 (defvar completer-pred nil "Last completer pred.")
 157 (defvar completer-mode nil "Last completer mode.")
 158 (defvar completer-result nil "Last completer result.")
 159
 160 (eval-when (eval load compile)
 161   (if (not (fboundp 'completion-display-completion-list-function))
 162       (setf completion-display-completion-list-function
 163             'display-completion-list)))
 164
 165
 166 (unless (fboundp 'minibuffer-prompt-end)
 167   (defun minibuffer-prompt-end ()
 168     "Return the buffer position of the end of the minibuffer prompt.
 169 Return (point-min) if current buffer is not a mini-buffer."
 170     (point-min)))
 171
 172 ;;;%Utilities
 173 (defun completer-message (message &optional point)
 174   "Display MESSAGE at optional POINT for two seconds."
 175   (setq point (or point (point-max))
 176         completer-message t)
 177   (let ((end
 178          (save-excursion
 179            (goto-char point)
 180            (insert message)
 181            (point)))
 182         (inhibit-quit t))
 183     (sit-for 2)
 184     (delete-region point end)
 185     (if (and quit-flag
 186              (not (string-match "Lucid" emacs-version)))
 187         (setq quit-flag nil
 188               unread-command-char 7))))
 189
 190 ;;;
 191 (defun completer-deleter (regexp choices &optional keep)
 192   "Destructively remove strings that match REGEXP in CHOICES.
 193 Return the modified list.  If optional KEEP, then keep entries that
 194 match regexp."
 195   (let* ((choiceb choices)
 196          choicep)
 197     (if keep
 198         (progn
 199           (while (and choiceb (not (string-match regexp (car choiceb))))
 200             (setq choiceb (cdr choiceb)))
 201           (setq choicep choiceb)
 202           (while (cdr choicep)
 203             (if (string-match regexp (car (cdr choicep)))
 204                 (setq choicep (cdr choicep))
 205                 (rplacd choicep (cdr (cdr choicep))))))
 206         (while (and choiceb (string-match regexp (car choiceb)))
 207           (setq choiceb (cdr choiceb)))
 208         (setq choicep choiceb)
 209         (while (cdr choicep)
 210           (if (string-match regexp (car (cdr choicep)))
 211               (rplacd choicep (cdr (cdr choicep)))
 212               (setq choicep (cdr choicep)))))
 213     choiceb))
 214
 215 ;;;%%Regexp
 216 (defun completer-regexp (string delimiters any)
 217   "Convert STRING into a regexp with words delimited by chars in DELIMITERS.
 218 Any delimiter in STRING that is the same as ANY will match any delimiter."
 219   (let* ((delimiter-reg (concat "[" delimiters "]"))
 220          (limit (length string))
 221          (pos 0)
 222          (regexp "^"))
 223     (while (and (< pos limit) (string-match delimiter-reg string pos))
 224       (let* ((begin (match-beginning 0))
 225              (end (match-end 0))
 226              (delimiter (substring string begin end))
 227              (anyp (eq (elt string begin) any)))
 228         (setq regexp
 229               (format "%s%s[^%s]*%s"
 230                       regexp
 231                       (regexp-quote (substring string pos begin))
 232                       (if anyp delimiters delimiter)
 233                       (if anyp delimiter-reg (regexp-quote delimiter)))
 234               pos end)))
 235     (if (<= pos limit)
 236         (setq regexp (concat regexp
 237                              (regexp-quote (substring string pos limit)))))))
 238
 239 ;;;
 240 (defun completer-words (regexp string &optional limit)
 241   "Return the number of words matching REGEXP in STRING up to LIMIT."
 242   (setq limit (or limit 1000))
 243   (let ((count 1)
 244         (pos 0))
 245     (while (and (string-match regexp string pos) (<= count limit))
 246       (setq count (1+ count)
 247             pos (match-end 0)))
 248     count))
 249
 250 ;;;%Matcher
 251 (defun completer-matches (string choices delimiters any)
 252     "Return STRING's matches in CHOICES.
 253 DELIMITERS and the wildcard ANY are used  to segment the strings."
 254     (let* ((regexp (concat "[" delimiters "]"))
 255            (from nil)
 256            (to 0)
 257            (pattern nil)
 258            (len (length string))
 259            (matches nil)
 260            (string-equal-function
 261             (if case-fold-search
 262                 'equalp ;; We require 'cl above, this is always available.
 263               'string-equal))
 264            sub sublen choice word wordlen pat)
 265       ;; Segment pattern
 266       (while (< (or from 0) len)
 267         (setq to (or (string-match regexp string (if from (1+ from))) len))
 268         (if (eq (elt string (or from 0)) completer-any-delimiter)
 269             (setq sub (substring string (if from (1+ from) 0) to)
 270                   sublen (- (length sub)))
 271             (setq sub (substring string (or from 0) to)
 272                   sublen (length sub)))
 273         (setq pattern (cons (cons sub sublen) pattern)
 274               from to))
 275       (setq pattern (reverse pattern))
 276       ;; Find choices that match patterns
 277       (setq regexp (concat "[" delimiters "]"))
 278       (while choices
 279         (setq choice (car choices)
 280               word pattern
 281               from 0)
 282         (while (and word from
 283                     (let* (begin end)
 284                       (if (< (setq wordlen (cdr (setq pat (car word)))) 0)
 285                           (setq begin (1+ from)
 286                                 end (+ begin (- wordlen)))
 287                           (setq begin from
 288                                 end (+ begin wordlen)))
 289                       (and (<= end (length choice))
 290                            (or (zerop wordlen)
 291                                (funcall string-equal-function
 292                                         (car pat)
 293                                         (substring choice begin end))))))
 294           (setq from (string-match regexp choice
 295                                    (if (and (zerop from) (zerop wordlen))
 296                                        from
 297                                        (1+ from)))
 298                 word (cdr word)))
 299         (if (not word) (setq matches (cons choice matches)))
 300         (setq choices (cdr choices)))
 301       matches))
 302
 303 ;;;
 304 (defun completer-choice (string choices delimiters use-words)
 305   "Return a list with best match of STRING in CHOICES and T if it is unique.
 306 DELIMITERS are used to separate words.  A match is unique if it is the only
 307 possibility or when USE-WORDS the only possibility with the same
 308 number of words.  The shortest string of multiple possibilities will be
 309 the best match."
 310   (or (if (null (cdr choices)) (cons (car choices) t))
 311       (let* ((regexp (concat "[^" delimiters "]*[" delimiters "]"))
 312              (words (if use-words (completer-words regexp string)))
 313              (choice choices)
 314              (unique-p nil)
 315              (match nil)
 316              (match-count nil)
 317              (match-len 1000))
 318         (while choice
 319           (let* ((current (car choice))
 320                  (length (length current)))
 321             (if match-count
 322                 (if (= (completer-words regexp current words) words)
 323                     (progn
 324                       (setq unique-p nil)
 325                       (if (< length match-len)
 326                           (setq match current
 327                                 match-len length))))
 328                 (if (and use-words
 329                          (= (completer-words regexp current words) words))
 330                     (setq match current
 331                           match-len length
 332                           match-count t
 333                           unique-p t)
 334                     (if (< length match-len)
 335                         (setq match current
 336                               match-len length)))))
 337           (setq choice (cdr choice)))
 338         (cons match unique-p))))
 339
 340 ;;;%Completer
 341 ;;;%%Utilities
 342 ;; changed to understand and skip over backslashes
 343 (defun completer-region (delimiters)
 344   "Return the completion region bounded by characters in DELIMITERS.
 345 The search is for the current buffer assuming that point is in it."
 346    (let* ((inv (if (string-match "\\^" delimiters)
 347                    (substring delimiters 1)
 348                  (concat "^" delimiters)))
 349           (re (and (not (equal inv ""))
 350                    (concat "\\\\[" inv "]"))))
 351      (cons (save-excursion
 352              (let ((done nil))
 353                (while (not done)
 354                  (skip-chars-backward delimiters (minibuffer-prompt-end))
 355                  (if (and re
 356                           (> (point) (+ (point-min) 2))
 357                           (save-excursion
 358                             (forward-char -2)
 359                             (looking-at re)))
 360                      (goto-char (match-beginning 0))
 361                    (setq done t))))
 362              (point))
 363            (save-excursion
 364              (let ((done nil))
 365                (while (not done)
 366                  (skip-chars-forward delimiters)
 367                  (if (and re
 368                           (> (point) (+ (point-min) 1))
 369                           (save-excursion
 370                             (forward-char -1)
 371                             (looking-at re)))
 372                      (goto-char (match-end 0))
 373                    (setq done t))))
 374              (point)))))
 375
 376 ;;;
 377 (defun completer-last-component (string)
 378   "Return the start of the last filename component in STRING."
 379   (let ((last (1- (length string)))
 380         (match 0)
 381         (end 0))
 382     (while (and (setq match (string-match completer-path-separator-regexp string end))
 383                 (< match last))
 384       (setq end (1+ match)))
 385     end))
 386
 387 ;;;
 388 (defun completer-match-record (string matches delimiters any dir mode)
 389   "Return (match lcs choices unique) for STRING in MATCHES.
 390 DELIMITERS or ANY wildcards and DIR if a filename when in MODE."
 391   (let ((pattern (if dir
 392                      (substring string (completer-last-component string))
 393                      string))
 394         match)
 395     (setq matches (completer-matches pattern matches delimiters any)
 396           match (try-completion pattern (mapcar 'list matches)))
 397     ;; If try-completion produced an exact match for an element in 'matches',
 398     ;; then remove any partial matches from 'matches' and set the unique
 399     ;; match flag.
 400     (and (stringp match) (member match matches) (setq matches (list match)))
 401     (if (cdr matches)
 402         (let ((lcs (concat dir (try-completion "" (mapcar 'list matches)))))
 403           (setq match (if (not completer-exact)
 404                           (completer-choice
 405                            pattern matches delimiters completer-use-words)))
 406           (list (if match (concat dir (car match)))
 407                 lcs
 408                 matches
 409                 (cdr match)))
 410       (if matches
 411           (progn (setq match (concat dir (car matches)))
 412                  (list match match matches t))
 413         (list nil nil nil nil)))))
 414
 415 ;;;%%Complete file
 416 (defun completer-extension-regexp (extensions)
 417   "Return a regexp that matches a string ending with any string in EXTENSIONS."
 418   (concat "\\(" (mapconcat 'regexp-quote extensions "\\|") "\\)\\'"))
 419
 420 ;;;
 421 (defun completer-flush ()
 422   "Flush completer's pathname cache."
 423   (interactive)
 424   (setq completer-path-cache nil))
 425
 426 ;;;
 427 (defun completer-cache (path pred words any mode)
 428   "Check to see if PATH is in path cache with PRED, WORDS, ANY and MODE."
 429   (let* ((last nil)
 430          (ptr completer-path-cache)
 431          (size 0)
 432          (result nil))
 433     (if completer-use-cache
 434         (while ptr
 435           (let ((current (car (car ptr))))
 436             (if (string-equal current path)
 437                 (progn
 438                   (if last
 439                       (progn
 440                         (rplacd last (cdr ptr))
 441                         (rplacd ptr completer-path-cache)
 442                         (setq completer-path-cache ptr)))
 443                   (setq result (cdr (car ptr))
 444                         ptr nil))
 445               (if (cdr ptr) (setq last ptr))
 446               (setq size (1+ size)
 447                     ptr (cdr ptr))))))
 448     (or result
 449         (let* ((choices
 450                 (completer path 'read-file-name-internal pred words any
 451                            mode t)))
 452           (if (and (or (car (cdr (cdr (cdr choices))))
 453                        (string= path (car choices)))
 454                    (memq (elt (car choices) (1- (length (car choices))))
 455                          completer-path-delimiter-list))
 456               (progn
 457                 (if (>= size completer-cache-size) (rplacd last nil))
 458                 (setq completer-path-cache
 459                       (cons (cons path choices) completer-path-cache))))
 460           choices))))
 461
 462
 463 (defun completer-file (string pred words any mode)
 464   "Return (match common-substring matches unique-p) for STRING.
 465 It uses 'READ-FILE-NAME-INTERNAL' for choices that pass PRED using WORDS to
 466 delimit words.  Optional ANY is a delimiter that matches any of the
 467 delimiters in WORD.  If optional MODE is nil or 'help then possible
 468 matches will always be returned."
 469   ;; Canonicalize slashes under windows-nt for proper completion
 470   (if (eq system-type 'windows-nt)
 471       (setq string (replace-in-string string "/" "\\\\"))
 472     (setq string (replace-in-string string "\\\\\\(.\\)" "\\1")))
 473   (let* ((case-fold-search completion-ignore-case)
 474          (last (and (eq mode 'exit-ok) (completer-last-component string)))
 475          (position
 476
 477           ;; Original
 478           ;; Special hack for CMU RFS filenames
 479           ;; (if (string-match "^/\\.\\./[^/]*/" string)
 480           ;;    (match-end 0)
 481           ;;  (string-match "[^~/]" string))
 482
 483           ;; 2002-05-23
 484           ;; New by Ben Wing
 485           ;; Find beginning of first directory component.
 486           (cond ((string-match "^/\\.\\./[^/]*/" string)
 487                  ;; CMU RFS filenames like /../computername/foo/bar.c
 488                  (match-end 0))
 489
 490                 ((and (memq system-type '(windows-nt cygwin32))
 491                       (string-match "[/\\][/\\][^/\\]*[/\\]" string))
 492                  ;; windows-nt filenames like \\computername\foo\bar.c, or
 493                  ;; cygwin filenames like //d/foo/bar.c
 494                  (match-end 0))
 495
 496                 ((and (eq system-type 'windows-nt)
 497                       (string-match "[A-Za-z]:[/\\]?" string))
 498                  ;; windows-nt filenames like c:\foo\bar.c or c:bar.c
 499                  (match-end 0))
 500
 501                 (t
 502                  ;; normal absolute or relative names, or names beginning
 503                  ;; with ~/
 504                  (string-match
 505                   (concat "[^~" completer-path-separator-regexp-inside-brackets
 506                           "]") string)))
 507          )
 508          (new (substring string 0 position))
 509          (user (if (string= new "~")
 510                    (setq new (file-name-directory (expand-file-name new)))))
 511          (words (concat words completer-path-separator-regexp-inside-brackets))
 512          (len (length string))
 513          (choices nil)
 514          (end nil)
 515          (old-choices (list nil nil nil nil))
 516          match substr re)
 517     (while position
 518       (let* ((begin (string-match completer-path-separator-regexp
 519                                   string
 520                                   position))
 521              (exact-p nil))
 522         (setq end (when begin (match-end 0))
 523               choices
 524               ;; Ends with a /, so check files in directory
 525               (if (and (memq mode '(nil help)) (= position len))
 526                   (completer-match-record
 527                    ""
 528                    ;; This assumes that .. and . come at the end
 529                    (let* ((choices
 530                            (all-completions new 'read-file-name-internal))
 531                           (choicep choices))
 532                      (if (member* (first choicep) completer-dot-dot-list
 533                                   :test #'string=)
 534                          (cdr (cdr choicep))
 535                        (while (cdr choicep)
 536                          (if (member* (second choicep) completer-dot-dot-list
 537                                       :test #'string=)
 538                              (rplacd choicep nil))
 539                          (setq choicep (cdr choicep)))
 540                        choices))
 541                    words any new mode)
 542                 (if (eq position last)
 543                     (let ((new (concat new (substring string position))))
 544                       (list new new nil t))
 545                   (let ((component (substring string position end)))
 546                     (if (and end
 547                              (string-match completer-file-skip component))
 548                         ;; Assume component is complete
 549                         (list (concat new component)
 550                               (concat new component)
 551                               nil t)
 552                       (completer-cache
 553                        (concat new component)
 554                        pred words any mode))))))
 555         ;; Keep going if unique or we match exactly
 556         (if (or (car (cdr (cdr (cdr choices))))
 557                 (setq exact-p
 558                       (string= (concat new (substring string position end))
 559                                (car choices))))
 560             (setq old-choices
 561                   (let* ((lcs (car (cdr choices)))
 562                          (matches (car (cdr (cdr choices))))
 563                          ;; (slash (and lcs (string-match "/$" lcs))))
 564                          (slash
 565                           (and lcs
 566                                (string-match
 567                                 (concat completer-path-separator-regexp "$")
 568                                 lcs))))
 569
 570                     (list nil
 571                           (if slash (substring lcs 0 slash) lcs)
 572                           (if (and (cdr matches)
 573                                    (or (eq mode 'help) (not exact-p)))
 574                               matches)
 575                           nil))
 576                   new (car choices)
 577                   position end)
 578           ;; Its ok to not match user names because they may be in
 579           ;; different root directories
 580           (if (and (= position 1) (= (elt string 0) ?~))
 581               (setq new (substring string 0 end)
 582                     choices (list new new (list new) t)
 583                     user nil
 584                     position end)
 585             (setq position nil)))))
 586     (if (not (car choices))
 587         (setq choices old-choices))
 588     (if (and (car choices)
 589              (not (eq mode 'help))
 590              (not (car (cdr (cdr (cdr choices))))))
 591         ;; Try removing completion ignored extensions
 592         (let* ((extensions
 593                 (completer-extension-regexp completion-ignored-extensions))
 594                (choiceb (car (cdr (cdr choices))))
 595                (choicep choiceb)
 596                (isext nil)
 597                (noext nil))
 598           (while choicep
 599             (if (string-match extensions (car choicep))
 600                 (setq isext t)
 601               (setq noext t))
 602             (if (and isext noext)
 603                 ;; There are matches besides extensions
 604                 (setq choiceb (completer-deleter extensions choiceb)
 605                       choicep nil)
 606               (setq choicep (cdr choicep))))
 607           (if (and isext noext)
 608               (setq choices
 609                     (completer-match-record
 610                      (if end (substring string end) "")
 611                      choiceb words any
 612                      (file-name-directory (car (cdr choices)))
 613                      mode)))))
 614     (if user
 615         (let ((match (car choices))
 616               (lcs (car (cdr choices)))
 617               (len (length user)))
 618           (setq choices
 619                 (cons (if match (concat "~" (substring match len)))
 620                       (cons (if lcs (concat "~" (substring lcs len)))
 621                             (cdr (cdr choices)))))))
 622     (setq match (nth 0 choices)
 623           substr (nth 1 choices)
 624           re (concat "\\(["             ; "Now you have two problems":
 625                      "]["               ;   this has to come first;
 626                      "\\\\"             ;   this is one backslash;
 627                      "\""               ;   this is one quote;
 628                      "^"                        ;   this can't come first;
 629                      " \t"              ;   whitespace;
 630                      "#$&*?;!|'`()<>"   ;   easy.
 631                      "]\\)"))
 632     (if match
 633         (setf (nth 0 choices)
 634               (replace-in-string match re "\\\\\\1")))
 635     (if substr
 636         (setf (nth 1 choices)
 637               (replace-in-string substr re "\\\\\\1")))
 638     choices))
 639
 640 ;;;%Exported program interface
 641 ;;;%%Completer
 642 (defun completer (string table pred words
 643                          &optional any mode file-p)
 644   "Return (match common-substring matches unique-p) for STRING in TABLE.
 645 The choices must also pass PRED using WORDS to delimit words.  If the
 646 flag 'COMPLETER-COMPLETE-FILENAMES' is T and the table is
 647 'READ-FILE-NAME-INTERNAL', then filename components will be individually
 648 expanded.  Optional ANY is a delimiter that can match any delimiter in
 649 WORDS.  Optional MODE is nil for complete, 'help for help and 'exit
 650 for exit."
 651   (let ((completion-ignore-case
 652          (or (and file-p (file-system-ignore-case-p string))
 653              completion-ignore-case)))
 654     (if (and (stringp completer-string)
 655              (string= string completer-string)
 656              (eq table completer-table)
 657              (eq pred completer-pred)
 658              (not file-p)
 659              (or (eq mode completer-mode)
 660                  (not (memq table '(read-file-name-internal
 661                                     read-directory-name-internal)))))
 662         completer-result
 663       (setq
 664        completer-string ""
 665        completer-table table
 666        completer-pred pred
 667        completer-mode mode
 668        completer-result
 669        (if (and completer-complete-filenames
 670                 (not file-p)
 671                 (memq table '(read-file-name-internal
 672                               read-directory-name-internal)))
 673            (completer-file string pred words any mode)
 674          (let* ((file-p (or file-p
 675                             (memq table
 676                                   '(read-file-name-internal
 677                                     read-directory-name-internal))))
 678                 (case-fold-search completion-ignore-case)
 679                 (pattern (concat "[" words "]"))
 680                 (component (if file-p (completer-last-component string)))
 681                 (dir (if component (substring string 0 component)))
 682                 (string (if dir (substring string component) string))
 683                 (has-words (or (string-match pattern string)
 684                                (length string))))
 685            (if (and file-p (string-match "^\\$" string))
 686                ;; Handle environment variables
 687                (let ((match
 688                       (getenv (substring string 1
 689                                          ;; (string-match "/" string)))) ; old
 690                                          (string-match
 691                                           completer-path-separator-regexp
 692                                           string))))
 693                      )
 694                  ;; (if match (setq match (concat match "/"))) ; old
 695                  (when match
 696                    (setq match
 697                          (concat match
 698                                  completer-path-separator-string)))
 699
 700                  (list match match (list match) match))
 701              (let* ((choices
 702                      (all-completions
 703                       (concat dir (substring string 0 has-words))
 704                       table pred))
 705                     (regexp (completer-regexp string words any)))
 706                (if choices
 707                    (completer-match-record
 708                     string
 709                     (completer-deleter regexp choices t)
 710                     words any dir mode)
 711                  (list nil nil nil nil))))))
 712        completer-string string)
 713       completer-result)))
 714
 715 ;;;%%Display choices
 716 (defun completer-display-choices (choices &optional match message end
 717                                           display)
 718   "Display the list of possible CHOICES.
 719 MATCH, MESSAGE, END and DISPLAY are used optionally.  If MATCH is
 720 non-nil, it will be flagged as the best guess.  If there are no
 721 choices, display MESSAGE.  END is where to put temporary messages.  If
 722 DISPLAY is present then it will be called on each possible completion
 723 and should return a string."
 724
 725   (if choices
 726       (with-output-to-temp-buffer "*Completions*"
 727         (if (cdr choices)
 728             (funcall completion-display-completion-list-function
 729              (sort
 730               (if display
 731                   (let ((old choices)
 732                         (new nil))
 733                     (while old
 734                       (setq new (cons (funcall display (car old)) new)
 735                             old (cdr old)))
 736                     new)
 737                 (copy-sequence choices))
 738               (function (lambda (x y)
 739                           (string-lessp (or (car-safe x) x)
 740                                         (or (car-safe y) y)))))))
 741         (if match
 742             (save-excursion
 743               (set-buffer "*Completions*")
 744               (goto-char (point-min))
 745               (let ((buffer-read-only nil))
 746                 (insert "Guess = " match (if (cdr choices) ", " "") "\n")))))
 747       (beep)
 748       (completer-message (or message " (No completions)") end)))
 749
 750 ;;;%%Goto
 751 (defun completer-goto (match lcs choices unique delimiters words
 752                              &optional mode display)
 753   "Go to the part of the string that disambiguates CHOICES.
 754 MATCH is the best match, LCS is the longest common substring of all
 755 of the matches.  CHOICES is a list of the possibilities, UNIQUE
 756 indicates if MATCH is unique.  DELIMITERS are possible bounding
 757 characters for the completion region.  WORDS are the characters that
 758 delimit the words for partial matches.  Replace the region bounded by
 759 delimiters with the match if unique and the lcs otherwise unless
 760 optional MODE is 'help.  Then go to the part of the string that
 761 disambiguates CHOICES using WORDS to separate words and display the
 762 possibilities if the string was not extended.  If optional DISPLAY is
 763 present then it will be called on each possible completion and should
 764 return a string."
 765   (setq completer-message nil)
 766   (let* ((region (completer-region delimiters))
 767          (start (car region))
 768          (end (cdr region))
 769          (string (buffer-substring start end))
 770          ;; (file-p (string-match "[^ ]*\\(~\\|/\\|$\\)" string))
 771          (file-p (string-match (if (eq system-type 'windows-nt)
 772                                    "[^ ]*\\(~\\|/\\|\\\\\\|\\|$\\)"
 773                                  "[^ ]*\\(~\\|/\\|$\\)")
 774                                string))
 775          (no-insert (eq mode 'help))
 776          (message t)
 777          (new (not (string= (buffer-substring start (point)) lcs))))
 778     (if unique
 779         (if no-insert
 780             (progn
 781               (goto-char end)
 782               (completer-display-choices choices match nil end display))
 783             (if (string= string match)
 784                 (if (not file-p)
 785                     (progn (goto-char end)
 786                            (completer-message " (Sole completion)" end)))
 787                 (completer-insert match delimiters)))
 788         ;;Not unique
 789         (if lcs
 790             (let* ((regexp
 791                     ;; (concat "[" words (if file-p "/") "]")
 792                     (concat "["
 793                             words
 794                             (and file-p completer-path-separator-regexp-inside-brackets)
 795                             "]")
 796                     )
 797                    (words (completer-words regexp lcs))
 798                    (point nil))
 799               ;; Go to where its ambiguous
 800               (goto-char start)
 801               (unless no-insert
 802                 (insert lcs)
 803                 (setq completer-last-pattern
 804                       (list string delimiters (current-buffer) start)
 805                       start (point)
 806                       end (+ end (length lcs))))
 807               ;; Skip to the first delimiter in the original string
 808               ;; beyond the ambiguous point and keep from there on
 809               (if (re-search-forward regexp end 'move words)
 810                   (progn
 811                     (if (and (not no-insert) match)
 812                         (let ((delimiter
 813                                (progn
 814                                  (string-match (regexp-quote lcs) match)
 815                                  (substring match (match-end 0)
 816                                             (1+ (match-end 0))))))
 817                           (if (string-match regexp delimiter)
 818                               (insert delimiter))))
 819                     (forward-char -1)))
 820               (unless no-insert
 821                 (setq end (- end (- (point) start)))
 822                 (delete-region start (point)))))
 823         (if choices
 824             (when (or no-insert (not new))
 825               (completer-display-choices choices match nil end display))
 826             (when file-p
 827               (when (not (= (point) end)) (forward-char 1))
 828               (unless (save-excursion (re-search-forward completer-path-separator-regexp end t))
 829                 (goto-char end)))
 830             (when message
 831               (beep)
 832               (completer-message (if no-insert
 833                                      " (No completions)"
 834                                    " (No match)")
 835                                  end))))))
 836
 837 ;;;%Exported buffer interface
 838 ;;;%%Complete and go
 839 (defun completer-complete-goto (delimiters words table pred
 840                                            &optional no-insert display)
 841   "Complete the string bound by DELIMITERS using WORDS to bound words
 842 for partial matches in TABLE with PRED and then insert the longest
 843 common substring unless optional NO-INSERT and go to the point of
 844 ambiguity.  If optional DISPLAY, it will be called on each match when
 845 possible completions are shown and should return a string."
 846   (let* ((region (completer-region delimiters)))
 847     (apply 'completer-goto
 848            (append (completer (buffer-substring (car region) (cdr region))
 849                               table pred words completer-any-delimiter
 850                               no-insert)
 851                   (list delimiters words no-insert display)))))
 852
 853 ;;;%%Undo
 854 (defun completer-insert (match delimiters &optional buffer undo)
 855   "Replace the region bounded with characters in DELIMITERS by MATCH.
 856 Then save it so that it can be restored by completer-undo."
 857   (let* ((region (completer-region delimiters))
 858          (start (car region))
 859          (end (cdr region)))
 860     (if (and undo (or (not (= start undo))
 861                       (not (eq (current-buffer) buffer))))
 862         (error "No previous pattern")
 863         (setq completer-last-pattern (list (buffer-substring start end)
 864                                            delimiters
 865                                            (current-buffer)
 866                                            start))
 867         (delete-region start end)
 868         (goto-char start)
 869         (insert match))))
 870
 871 ;;;
 872 (defun completer-undo ()
 873   "Swap the last expansion and the last match pattern."
 874   (interactive)
 875   (if completer-last-pattern
 876       (apply 'completer-insert completer-last-pattern)
 877       (error "No previous pattern")))
 878
 879 ;;;%Minibuffer specific code
 880 ;;;%%Utilities
 881 (defun completer-minibuf-string ()
 882   "Remove dead filename specs from the minibuffer.
 883 Dead filename should be delimited by // or ~ or $ and return the
 884 resulting string."
 885   (save-excursion
 886     (goto-char (point-max))
 887     (if (and (memq minibuffer-completion-table
 888                    '(read-file-name-internal read-directory-name-internal))
 889              (re-search-backward
 890               ;; "//\\|/~\\|.\\$"
 891               (if (memq system-type '(windows-nt cygwin32))
 892                   ;; // is meaningful
 893                   "/~\\|.\\$"
 894                 "//\\|/~\\|.\\$")
 895               (minibuffer-prompt-end)
 896               t))
 897         (delete-region (minibuffer-prompt-end) (1+ (point))))
 898     (buffer-substring (minibuffer-prompt-end) (point-max))))
 899
 900 ;;;
 901 (defun completer-minibuf-exit ()
 902   "Exit the minibuffer and clear completer-last-pattern."
 903   (interactive)
 904   (setq completer-last-pattern nil)
 905   (exit-minibuffer))
 906
 907 ;;;
 908 (defun completer-new-cmd (cmd)
 909   "Return T if we can't execute the old minibuffer version of CMD."
 910   (if (or completer-disable
 911           (let ((string (completer-minibuf-string)))
 912             (or
 913              (not (string-match
 914                    (concat "["
 915                            completer-words
 916                            completer-path-separator-regexp-inside-brackets
 917                            "~]")
 918                    string))
 919               (condition-case ()
 920                   (let ((completion
 921                          (try-completion string
 922                                          minibuffer-completion-table
 923                                          minibuffer-completion-predicate)))
 924                     (if (memq minibuffer-completion-table
 925                               '(read-file-name-internal
 926                                 read-directory-name-internal))
 927                         ;; Directories complete as themselves
 928                         (and completion
 929                              (or (not (string= string completion))
 930                                  (file-exists-p completion)))
 931                         completion))
 932                 (error nil)))))
 933       (progn
 934         (funcall cmd)
 935         nil)
 936       t))
 937
 938 ;;;
 939 (defun completer-minibuf (&optional mode)
 940   "Partial completion of minibuffer expressions.
 941 Optional MODE is (quote help) for help and (quote exit) for exit.
 942
 943 If what has been typed so far matches any possibility normal
 944 completion will be done.  Otherwise, the string is considered to be a
 945 pattern with words delimited by the characters in
 946 completer-words.  If completer-exact is T, the best match will be
 947 the shortest one with the same number of words as the pattern if
 948 possible and otherwise the shortest matching expression.  If called
 949 with a prefix, caching will be temporarily disabled.
 950
 951 Examples:
 952 a-f     auto-fill-mode
 953 r-e     rmail-expunge
 954 b--d    *beginning-of-defun or byte-recompile-directory
 955 by  d   *byte-recompile-directory if completer-any-delimiter is \" \"
 956 ~/i.e   *~/ilisp.el or ~/il-el.el or ~/ilisp.elc
 957 /u/mi/  /usr/misc/"
 958   (interactive)
 959   (append
 960    (let ((completer-use-cache (not (or (not completer-use-cache)
 961                                        current-prefix-arg))))
 962      (completer (completer-minibuf-string)
 963                 minibuffer-completion-table
 964                 minibuffer-completion-predicate
 965                 completer-words
 966                 completer-any-delimiter
 967                 mode))
 968    (list "^" completer-words mode)))
 969
 970 ;;;%%Commands
 971 (defun completer-toggle ()
 972   "Turn partial completion on or off."
 973   (interactive)
 974   (setq completer-disable (not completer-disable))
 975   (message (if completer-disable
 976                "Partial completion OFF"
 977                "Partial completion ON")))
 978
 979 ;;;
 980 (defvar completer-old-help
 981   (lookup-key minibuffer-local-must-match-map "?")
 982   "Old binding of ? in minibuffer completion map.")
 983 (defun completer-help ()
 984   "Partial completion minibuffer-completion-help.
 985 See completer-minibuf for more information."
 986   (interactive)
 987   (if (completer-new-cmd completer-old-help)
 988       (apply 'completer-goto (completer-minibuf 'help))))
 989
 990 ;;;
 991 (defvar completer-old-completer
 992   (lookup-key minibuffer-local-must-match-map "\t")
 993   "Old binding of TAB in minibuffer completion map.")
 994
 995 (defun completer-complete ()
 996   "Partial completion minibuffer-complete.
 997 See completer-minibuf for more information."
 998   (interactive)
 999   (if (completer-new-cmd completer-old-completer)
1000       (apply 'completer-goto (completer-minibuf))))
1001
1002 ;;;
1003 (defvar completer-old-word
1004   (lookup-key minibuffer-local-must-match-map " ")
1005   "Old binding of SPACE in minibuffer completion map.")
1006 (defun completer-word ()
1007   "Partial completion minibuffer-complete.
1008 See completer-minibuf for more information."
1009   (interactive)
1010   (if (eq completer-any-delimiter ?\ )
1011       (insert ?\ )
1012       (if (completer-new-cmd completer-old-word)
1013           (apply 'completer-goto (completer-minibuf)))))
1014
1015 ;;;
1016 (defvar completer-old-exit
1017   (lookup-key minibuffer-local-must-match-map "\n")
1018   "Old binding of RET in minibuffer completion map.")
1019 (defun completer-exit ()
1020   "Partial completion minibuffer-complete-and-exit.
1021 See completer-minibuf for more information."
1022   (interactive)
1023   (if (completer-new-cmd completer-old-exit)
1024       (let* ((completions (completer-minibuf 'exit))
1025              (match (car completions))
1026              (unique-p (car (cdr (cdr (cdr completions))))))
1027         (apply 'completer-goto completions)
1028         (if unique-p
1029             (completer-minibuf-exit)
1030             (if match
1031                 (progn (completer-insert match "^")
1032                        (if minibuffer-completion-confirm
1033                            (completer-message " (Confirm)")
1034                            (completer-minibuf-exit)))
1035                 (if (not completer-message) (beep)))))))
1036
1037 ;;;
1038 (defun completer-match-exit ()
1039   "Exit the minibuffer with the current best match."
1040   (interactive)
1041   (let* ((completions (completer-minibuf 'exit))
1042          (guess (car completions)))
1043     (if (not guess)
1044         ;; OK if last filename component doesn't match
1045         (setq completions (completer-minibuf 'exit-ok)
1046               guess (car completions)))
1047     (if guess
1048         (progn
1049           (goto-char (minibuffer-prompt-end))
1050           (insert guess)
1051           (delete-region (point) (point-max))
1052           (exit-minibuffer))
1053         (apply 'completer-goto completions))))
1054
1055 ;;;%%Keymaps
1056 ;this interferes with normal undo.
1057 ;(define-key minibuffer-local-completion-map "\C-_"  'completer-undo)
1058 (define-key minibuffer-local-completion-map "\t"    'completer-complete)
1059 (define-key minibuffer-local-completion-map " "     'completer-word)
1060 (define-key minibuffer-local-completion-map "?"     'completer-help)
1061 (define-key minibuffer-local-completion-map "\n"    'completer-minibuf-exit)
1062 (define-key minibuffer-local-completion-map "\r"    'completer-minibuf-exit)
1063 (define-key minibuffer-local-completion-map "\M-\n" 'completer-match-exit)
1064 (define-key minibuffer-local-completion-map "\M-\r" 'completer-match-exit)
1065
1066 ;this interferes with normal undo.
1067 ;(define-key minibuffer-local-must-match-map "\C-_"  'completer-undo)
1068 (define-key minibuffer-local-must-match-map "\t"    'completer-complete)
1069 (define-key minibuffer-local-must-match-map " "     'completer-word)
1070 (define-key minibuffer-local-must-match-map "\n"    'completer-exit)
1071 (define-key minibuffer-local-must-match-map "\r"    'completer-exit)
1072 (define-key minibuffer-local-must-match-map "?"     'completer-help)
1073 (define-key minibuffer-local-must-match-map "\M-\n" 'completer-match-exit)
1074 (define-key minibuffer-local-must-match-map "\M-\r" 'completer-match-exit)
1075
1076 ;;;%comint
1077 (defun completer-comint-dynamic-list-completions (completions)
1078   "List in help buffer sorted COMPLETIONS.
1079 Typing SPC flushes the help buffer."
1080   (completer-comint-dynamic-complete-1 nil 'help))
1081
1082 (defun completer-comint-dynamic-complete-filename ()
1083   "Dynamically complete the filename at point."
1084   (interactive)
1085   (completer-comint-dynamic-complete-1 nil t))
1086
1087 ;;;
1088 (defun completer-comint-dynamic-complete-1 (&optional undo mode)
1089   "Complete the previous filename or display possibilities if done
1090 twice in a row.  If called with a prefix, undo the last completion."
1091   (interactive "P")
1092   (if undo
1093       (completer-undo)
1094     ;; added by jwz: don't cache completions in shell buffer!
1095     (setq completer-string nil)
1096     (let ((conf (current-window-configuration)));; lemacs change
1097       (completer-complete-goto "^ \t\n\""
1098                                completer-words
1099                                'read-file-name-internal
1100                                default-directory
1101                                mode)
1102       ;; lemacs change
1103       (when (eq mode 'help) (comint-restore-window-config conf))
1104       )))
1105
1106 ;(fset 'comint-dynamic-complete 'completer-comint-dynamic-complete)
1107 (fset 'comint-dynamic-complete-filename
1108       'completer-comint-dynamic-complete-filename)
1109 (fset 'comint-dynamic-list-completions
1110       'completer-comint-dynamic-list-completions)
1111
1112 ;;; Set the functions again if comint is loaded.
1113 (setq comint-load-hook
1114       (cons (function (lambda ()
1115                         ;; (fset 'comint-dynamic-complete
1116                         ;;       'completer-comint-dynamic-complete)
1117                         (fset 'comint-dynamic-complete-filename
1118                               'completer-comint-dynamic-complete-filename)
1119                         (fset 'comint-dynamic-list-completions
1120                               'completer-comint-dynamic-list-completions)))
1121             (when (and (boundp 'comint-load-hook) comint-load-hook)
1122               (if (consp comint-load-hook)
1123                   (if (eq (car comint-load-hook) 'lambda)
1124                       (list comint-load-hook)
1125                     comint-load-hook)
1126                 (list comint-load-hook)))))
1127
1128 ;;;%lisp-complete-symbol
1129 (defun lisp-complete-symbol (&optional mode)
1130   "Perform partial completion on Lisp symbol preceding point.
1131 That symbol is compared against the symbols that exist and any additional
1132 characters determined by what is there are inserted.  If the symbol
1133 starts just after an open-parenthesis, only symbols with function
1134 definitions are considered.  Otherwise, all symbols with function
1135 definitions, values or properties are considered.  If called with a
1136 negative prefix, the last completion will be undone."
1137   (interactive "P")
1138   (if (< (prefix-numeric-value mode) 0)
1139       (completer-undo)
1140       (let* ((end (save-excursion (skip-chars-forward "^ \t\n)]}\"") (point)))
1141              (beg (save-excursion
1142                     (backward-sexp 1)
1143                     (while (= (char-syntax (following-char)) ?\')
1144                       (forward-char 1))
1145                     (point)))
1146              (pattern (buffer-substring beg end))
1147              (predicate
1148               (if (eq (char-after (1- beg)) ?\()
1149                   'fboundp
1150                   (function (lambda (sym)
1151                     (or (boundp sym) (fboundp sym)
1152                         (symbol-plist sym))))))
1153              (completion (try-completion pattern obarray predicate)))
1154            (cond ((eq completion t))
1155               ((null completion)
1156                (completer-complete-goto
1157                 "^ \t\n\(\)[]{}'`" completer-words
1158                 obarray predicate
1159                 nil
1160                 (if (not (eq predicate 'fboundp))
1161                     (function (lambda (choice)
1162                       (if (fboundp (intern choice))
1163                           (list choice " <f>")
1164                           choice))))))
1165               ((not (string= pattern completion))
1166                (delete-region beg end)
1167                (insert completion))
1168               (t
1169                (message "Making completion list...")
1170                (let ((list (all-completions pattern obarray predicate)))
1171                  (or (eq predicate 'fboundp)
1172                      (let (new)
1173                        (while list
1174                          (setq new (cons (if (fboundp (intern (car list)))
1175                                              (list (car list) " <f>")
1176                                              (car list))
1177                                          new))
1178                          (setq list (cdr list)))
1179                        (setq list (nreverse new))))
1180                  (with-output-to-temp-buffer "*Help*"
1181                    (funcall completion-display-completion-list-function
1182                     (sort list (function (lambda (x y)
1183                                            (string-lessp
1184                                             (or (car-safe x) x)
1185                                             (or (car-safe y) y))))))))
1186                (message "Making completion list...%s" "done"))))))
1187
1188 ;;;%Hooks
1189 (provide 'completer)
1190 (run-hooks 'completer-load-hook)
1191
1192 ;;; end of file -- completer.el --