Mercurial > hg > xemacs-beta
annotate lisp/minibuf.el @ 5353:38e24b8be4ea
Improve the lexical scoping in #'block, #'return-from.
lisp/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el:
* bytecomp.el (byte-compile-initial-macro-environment):
Shadow `block', `return-from' here, we implement them differently
when byte-compiling.
* bytecomp.el (byte-compile-active-blocks): New.
* bytecomp.el (byte-compile-block-1): New.
* bytecomp.el (byte-compile-return-from-1): New.
* bytecomp.el (return-from-1): New.
* bytecomp.el (block-1): New.
These are two aliases that exist to have their own associated
byte-compile functions, which functions implement `block' and
`return-from'.
* cl-extra.el (cl-macroexpand-all):
Fix a bug here when macros in the environment have been compiled.
* cl-macs.el (block):
* cl-macs.el (return):
* cl-macs.el (return-from):
Be more careful about lexical scope in these macros.
* cl.el:
* cl.el ('cl-block-wrapper): Removed.
* cl.el ('cl-block-throw): Removed.
These aren't needed in code generated by this XEmacs. They
shouldn't be needed in code generated by XEmacs 21.4, but if it
turns out the packages do need them, we can put them back.
2011-01-30 Mike Sperber <mike@xemacs.org>
* font-lock.el (font-lock-fontify-pending-extents): Don't fail if
`font-lock-mode' is unset, which can happen in the middle of
`revert-buffer'.
2011-01-23 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete):
* cl-macs.el (delq):
* cl-macs.el (remove):
* cl-macs.el (remq):
Don't use the compiler macro if these functions were given the
wrong number of arguments, as happens in lisp-tests.el.
* cl-seq.el (remove, remq): Removed.
I added these to subr.el, and forgot to remove them from here.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-setq, byte-compile-set):
Remove kludge allowing keywords' values to be set, all the code
that does that is gone.
* cl-compat.el (elt-satisfies-test-p):
* faces.el (set-face-parent):
* faces.el (face-doc-string):
* gtk-font-menu.el:
* gtk-font-menu.el (gtk-reset-device-font-menus):
* msw-font-menu.el:
* msw-font-menu.el (mswindows-reset-device-font-menus):
* package-get.el (package-get-installedp):
* select.el (select-convert-from-image-data):
* sound.el:
* sound.el (load-sound-file):
* x-font-menu.el (x-reset-device-font-menus-core):
Don't quote keywords, they're self-quoting, and the
win from backward-compatibility is sufficiently small now that the
style problem overrides it.
2011-01-22 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (block, return-from): Require that NAME be a symbol
in these macros, as always documented in the #'block docstring and
as required by Common Lisp.
* descr-text.el (unidata-initialize-unihan-database):
Correct the use of non-symbols in #'block and #'return-from in
this function.
2011-01-15 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (concatenate): Accept more complicated TYPEs in this
function, handing the sequences over to #'coerce if we don't
understand them here.
* cl-macs.el (inline): Don't proclaim #'concatenate as inline, its
compiler macro is more useful than doing that.
2011-01-11 Aidan Kehoe <kehoea@parhasard.net>
* subr.el (delete, delq, remove, remq): Move #'remove, #'remq
here, they don't belong in cl-seq.el; move #'delete, #'delq here
from fns.c, implement them in terms of #'delete*, allowing support
for sequences generally.
* update-elc.el (do-autoload-commands): Use #'delete*, not #'delq
here, now the latter's no longer dumped.
* cl-macs.el (delete, delq): Add compiler macros transforming
#'delete and #'delq to #'delete* calls.
2011-01-10 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box): Correct a misplaced parenthesis
here, thank you Mats Lidell in 87zkr9gqrh.fsf@mail.contactor.se !
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* dialog.el (make-dialog-box):
* list-mode.el (display-completion-list):
These functions used to use cl-parsing-keywords; change them to
use defun* instead, fixing the build. (Not sure what led to me
not including this change in d1b17a33450b!)
2011-01-02 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (define-star-compiler-macros):
Make sure the form has ITEM and LIST specified before attempting
to change to calls with explicit tests; necessary for some tests
in lisp-tests.el to compile correctly.
(stable-union, stable-intersection): Add compiler macros for these
functions, in the same way we do for most of the other functions
in cl-seq.el.
2011-01-01 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
(symbol-macrolet):
Define these macros with defmacro* instead of parsing the argument
list by hand, for the sake of style and readability; use backquote
where appropriate, instead of calling #'list and and friends, for
the same reason.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* x-misc.el (device-x-display):
Provide this function, documented in the Lispref for years, but
not existing previously. Thank you Julian Bradfield, thank you
Jeff Mincy.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl-seq.el:
Move the heavy lifting from this file to C. Dump the
cl-parsing-keywords macro, but don't use defun* for the functions
we define that do take keywords, dynamic scope lossage makes that
not practical.
* subr.el (sort, fillarray): Move these aliases here.
(map-plist): #'nsublis is now built-in, but at this point #'eql
isn't necessarily available as a test; use #'eq.
* obsolete.el (cl-delete-duplicates): Make this available for old
compiler macros and old code.
(memql): Document that this is equivalent to #'member*, and worse.
* cl.el (adjoin, subst): Removed. These are in C.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (assoc-ignore-case): Remove a duplicate definition of
this function (it's already in subr.el).
* iso8859-1.el (char-width):
On non-Mule, make this function equivalent to that produced by
(constantly 1), but preserve its docstring.
* subr.el (subst-char-in-string): Define this in terms of
#'substitute, #'nsubstitute.
(string-width): Define this using #'reduce and #'char-width.
(char-width): Give this a simpler definition, it makes far more
sense to check for mule at load time and redefine, as we do in
iso8859-1.el.
(store-substring): Implement this in terms of #'replace, now
#'replace is cheap.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* update-elc.el (lisp-files-needed-for-byte-compilation)
(lisp-files-needing-early-byte-compilation):
cl-macs belongs in the former, not the latter, it is as
fundamental as bytecomp.el.
2010-12-30 Aidan Kehoe <kehoea@parhasard.net>
* cl.el:
Provde the Common Lisp program-error, type-error as error
symbols. This doesn't nearly go far enough for anyone using the
Common Lisp errors.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (delete-duplicates):
If the form has an incorrect number of arguments, don't attempt a
compiler macroexpansion.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (cl-safe-expr-p):
Forms that start with the symbol lambda are also safe.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
For these functions' compiler macros, the optimisation is safe
even if the first and the last arguments have side effects, since
they're only used the once.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (inline-side-effect-free-compiler-macros):
Unroll a loop here at macro-expansion time, so these compiler
macros are compiled. Use #'eql instead of #'eq in a couple of
places for better style.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (notany, notevery): Avoid some dynamic scope
stupidity with local variable names in these functions, when they
weren't prefixed with cl-; go into some more detail in the doc
strings.
2010-12-29 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns): #'remove, #'remq are
free of side-effects.
(side-effect-and-error-free-fns):
Drop dot, dot-marker from the list.
2010-11-17 Aidan Kehoe <kehoea@parhasard.net>
* cl-extra.el (coerce):
In the argument list, name the first argument OBJECT, not X; the
former name was always used in the doc string and is clearer.
Handle vector type specifications which include the length of the
target sequence, error if there's a mismatch.
* cl-macs.el (cl-make-type-test): Handle type specifications
starting with the symbol 'eql.
2010-11-14 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (eql): Don't remove the byte-compile property of this
symbol. That was necessary to override a bug in bytecomp.el where
#'eql was confused with #'eq, which bug we no longer have.
If neither expression is constant, don't attempt to handle the
expression in this compiler macro, leave it to byte-compile-eql,
which produces better code anyway.
* bytecomp.el (eq): #'eql is not the function associated with the
byte-eq byte code.
(byte-compile-eql): Add an explicit compile method for this
function, for cases where the cl-macs compiler macro hasn't
reduced it to #'eq or #'equal.
2010-10-25 Aidan Kehoe <kehoea@parhasard.net>
Add compiler macros and compilation sanity-checking for various
functions that take keywords.
* byte-optimize.el (side-effect-free-fns): #'symbol-value is
side-effect free and not error free.
* bytecomp.el (byte-compile-normal-call): Check keyword argument
lists for sanity; store information about the positions where
keyword arguments start using the new byte-compile-keyword-start
property.
* cl-macs.el (cl-const-expr-val): Take a new optional argument,
cl-not-constant, defaulting to nil, in this function; return it if
the expression is not constant.
(cl-non-fixnum-number-p): Make this into a separate function, we
want to pass it to #'every.
(eql): Use it.
(define-star-compiler-macros): Use the same code to generate the
member*, assoc* and rassoc* compiler macros; special-case some
code in #'add-to-list in subr.el.
(remove, remq): Add compiler macros for these two functions, in
preparation for #'remove being in C.
(define-foo-if-compiler-macros): Transform (remove-if-not ...) calls to
(remove ... :if-not) at compile time, which will be a real win
once the latter is in C.
(define-substitute-if-compiler-macros)
(define-subst-if-compiler-macros): Similarly for these functions.
(delete-duplicates): Change this compiler macro to use
#'plists-equal; if we don't have information about the type of
SEQUENCE at compile time, don't bother attempting to inline the
call, the function will be in C soon enough.
(equalp): Remove an old commented-out compiler macro for this, if
we want to see it it's in version control.
(subst-char-in-string): Transform this to a call to nsubstitute or
nsubstitute, if that is appropriate.
* cl.el (ldiff): Don't call setf here, this makes for a load-time
dependency problem in cl-macs.el
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* term/vt100.el:
Refer to XEmacs, not GNU Emacs, in permissions.
* term/bg-mouse.el:
* term/sup-mouse.el:
Put copyright notice in canonical "Copyright DATE AUTHOR" form.
Refer to XEmacs, not GNU Emacs, in permissions.
* site-load.el:
Add permission boilerplate.
* mule/canna-leim.el:
* alist.el:
Refer to XEmacs, not APEL/this program, in permissions.
* mule/canna-leim.el:
Remove my copyright, I've assigned it to the FSF.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* gtk.el:
* gtk-widget-accessors.el:
* gtk-package.el:
* gtk-marshal.el:
* gtk-compose.el:
* gnome.el:
Add copyright notice based on internal evidence.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* easymenu.el: Add reference to COPYING to permission notice.
* gutter.el:
* gutter-items.el:
* menubar-items.el:
Fix typo "Xmacs" in permissions notice.
2010-06-14 Stephen J. Turnbull <stephen@xemacs.org>
* auto-save.el:
* font.el:
* fontconfig.el:
* mule/kinsoku.el:
Add "part of XEmacs" text to permission notice.
2010-10-14 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (side-effect-free-fns):
* cl-macs.el (remf, getf):
* cl-extra.el (tailp, cl-set-getf, cl-do-remf):
* cl.el (ldiff, endp):
Tighten up Common Lisp compatibility for #'ldiff, #'endp, #'tailp;
add circularity checking for the first two.
#'cl-set-getf and #'cl-do-remf were Lisp implementations of
#'plist-put and #'plist-remprop; change the names to aliases,
changes the macros that use them to using #'plist-put and
#'plist-remprop directly.
2010-10-12 Aidan Kehoe <kehoea@parhasard.net>
* abbrev.el (fundamental-mode-abbrev-table, global-abbrev-table):
Create both these abbrev tables using the usual
#'define-abbrev-table calls, rather than attempting to
special-case them.
* cl-extra.el: Force cl-macs to be loaded here, if cl-extra.el is
being loaded interpreted. Previously other, later files would
redundantly call (load "cl-macs") when interpreted, it's more
reasonable to do it here, once.
* cmdloop.el (read-quoted-char-radix): Use defcustom here, we
don't have any dump-order dependencies that would prevent that.
* custom.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling, rely on cl-extra.el in the
former case and the appropriate entry in bytecomp-load-hook in the
latter. Get rid of custom-declare-variable-list, we have no
dump-time dependencies that would require it.
* faces.el (eval-when-compile): Don't load cl-macs when
interpreted or when byte-compiling.
* packages.el: Remove some inaccurate comments.
* post-gc.el (cleanup-simple-finalizers): Use #'delete-if-not
here, now the order of preloaded-file-list has been changed to
make it available.
* subr.el (custom-declare-variable-list): Remove. No need for it.
Also remove a stub define-abbrev-table from this file, given the
current order of preloaded-file-list there's no need for it.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-constp) Forms quoted with FUNCTION are
also constant.
(byte-compile-initial-macro-environment): In #'the, if FORM is
constant and does not match TYPE, warn at byte-compile time.
2010-10-10 Aidan Kehoe <kehoea@parhasard.net>
* backquote.el (bq-vector-contents, bq-list*): Remove; the former
is equivalent to (append VECTOR nil), the latter to (list* ...).
(bq-process-2): Use (append VECTOR nil) instead of using
#'bq-vector-contents to convert to a list.
(bq-process-1): Now we use list* instead of bq-list
* subr.el (list*): Moved from cl.el, since it is now required to
be available the first time a backquoted form is encountered.
* cl.el (list*): Move to subr.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* test-harness.el (Check-Message):
Add an omitted comma here, thank you the buildbot.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* hash-table.el (hash-table-key-list, hash-table-value-list)
(hash-table-key-value-alist, hash-table-key-value-plist):
Remove some useless #'nreverse calls in these files; our hash
tables have no order, it's not helpful to pretend they do.
* behavior.el (read-behavior):
Do the same in this file, in some code evidently copied from
hash-table.el.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* info.el (Info-insert-dir):
* format.el (format-deannotate-region):
* files.el (cd, save-buffers-kill-emacs):
Use #'some, #'every and related functions for applying boolean
operations to lists, instead of rolling our own ones that cons and
don't short-circuit.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-initial-macro-environment):
* cl-macs.el (the):
Rephrase the docstring, make its implementation when compiling
files a little nicer.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* descr-text.el (unidata-initialize-unicodedata-database)
(unidata-initialize-unihan-database, describe-char-unicode-data)
(describe-char-unicode-data):
Wrap calls to the database functions with (with-fboundp ...),
avoiding byte compile warnings on builds without support for the
database functions.
(describe-char): (reduce #'max ...), not (apply #'max ...), no
need to cons needlessly.
(describe-char): Remove a redundant lambda wrapping
#'extent-properties.
(describe-char-unicode-data): Call #'nsubst when replacing "" with
nil in the result of #'split-string, instead of consing inside
mapcar.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* x-faces.el (x-available-font-sizes):
* specifier.el (let-specifier):
* package-ui.el (pui-add-required-packages):
* msw-faces.el (mswindows-available-font-sizes):
* modeline.el (modeline-minor-mode-menu):
* minibuf.el (minibuf-directory-files):
Replace the O2N (delq nil (mapcar (lambda (W) (and X Y)) Z)) with
the ON (mapcan (lambda (W) (and X (list Y))) Z) in these files.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* cl-macs.el (= < > <= >=):
When these functions are handed more than two arguments, and those
arguments have no side effects, transform to a series of two
argument calls, avoiding funcall in the byte-compiled code.
* mule/mule-cmds.el (finish-set-language-environment):
Take advantage of this change in a function called 256 times at
startup.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* byte-optimize.el (byte-optimize-apply): Transform (apply 'nconc
(mapcar ...)) to (mapcan ...); warn about use of the first idiom.
* update-elc.el (do-autoload-commands):
* packages.el (packages-find-package-library-path):
* frame.el (frame-list):
* extents.el (extent-descendants):
* etags.el (buffer-tag-table-files):
* dumped-lisp.el (preloaded-file-list):
* device.el (device-list):
* bytecomp-runtime.el (proclaim-inline, proclaim-notinline)
Use #'mapcan, not (apply #'nconc (mapcar ...) in all these files.
* bytecomp-runtime.el (eval-when-compile, eval-and-compile):
In passing, mention that these macros also evaluate the body when
interpreted.
tests/ChangeLog addition:
2011-02-07 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-tests.el:
Test lexical scope for `block', `return-from'; add a
Known-Bug-Expect-Failure for a contorted example that fails when
byte-compiled.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 07 Feb 2011 12:01:24 +0000 |
| parents | 668c73e222fd |
| children | f00192e1cd49 308d34e9f07d |
| rev | line source |
|---|---|
| 428 | 1 ;;; minibuf.el --- Minibuffer functions for XEmacs |
| 2 | |
| 3 ;; Copyright (C) 1992, 1993, 1994, 1997 Free Software Foundation, Inc. | |
| 442 | 4 ;; Copyright (C) 1995 Tinker Systems. |
| 771 | 5 ;; Copyright (C) 1995, 1996, 2000, 2002 Ben Wing. |
| 428 | 6 |
| 7 ;; Author: Richard Mlynarik | |
| 8 ;; Created: 2-Oct-92 | |
| 9 ;; Maintainer: XEmacs Development Team | |
| 10 ;; Keywords: internal, dumped | |
| 11 | |
| 12 ;; This file is part of XEmacs. | |
| 13 | |
| 14 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 15 ;; under the terms of the GNU General Public License as published by | |
| 16 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 17 ;; any later version. | |
| 18 | |
| 19 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 22 ;; General Public License for more details. | |
| 23 | |
| 24 ;; You should have received a copy of the GNU General Public License | |
| 25 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 3000 | 26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 27 ;; Boston, MA 02110-1301, USA. | |
| 428 | 28 |
| 29 ;;; Synched up with: all the minibuffer history stuff is synched with | |
| 30 ;;; 19.30. Not sure about the rest. | |
| 31 | |
| 32 ;;; Commentary: | |
| 33 | |
| 34 ;; This file is dumped with XEmacs. | |
| 35 | |
| 36 ;; Written by Richard Mlynarik 2-Oct-92 | |
| 37 | |
| 38 ;; 06/11/1997 - Use char-(after|before) instead of | |
| 39 ;; (following|preceding)-char. -slb | |
| 40 | |
| 41 ;;; Code: | |
| 42 | |
|
4734
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
43 (require 'cl) |
|
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
44 |
| 428 | 45 (defgroup minibuffer nil |
| 46 "Controling the behavior of the minibuffer." | |
| 47 :group 'environment) | |
| 48 | |
| 49 | |
| 50 (defcustom insert-default-directory t | |
| 51 "*Non-nil means when reading a filename start with default dir in minibuffer." | |
| 52 :type 'boolean | |
| 53 :group 'minibuffer) | |
| 54 | |
| 55 (defcustom minibuffer-history-uniquify t | |
| 56 "*Non-nil means when adding an item to a minibuffer history, remove | |
| 442 | 57 previous occurrences of the same item from the history list first, |
| 428 | 58 rather than just consing the new element onto the front of the list." |
| 59 :type 'boolean | |
| 60 :group 'minibuffer) | |
| 61 | |
| 62 (defvar minibuffer-completion-table nil | |
| 63 "Alist or obarray used for completion in the minibuffer. | |
| 64 This becomes the ALIST argument to `try-completion' and `all-completions'. | |
| 65 | |
| 66 The value may alternatively be a function, which is given three arguments: | |
| 67 STRING, the current buffer contents; | |
| 68 PREDICATE, the predicate for filtering possible matches; | |
| 69 CODE, which says what kind of things to do. | |
| 70 CODE can be nil, t or `lambda'. | |
| 71 nil means to return the best completion of STRING, nil if there is none, | |
| 72 or t if it is already a unique completion. | |
| 73 t means to return a list of all possible completions of STRING. | |
| 74 `lambda' means to return t if STRING is a valid completion as it stands.") | |
| 75 | |
| 76 (defvar minibuffer-completion-predicate nil | |
| 77 "Within call to `completing-read', this holds the PREDICATE argument.") | |
| 78 | |
| 79 (defvar minibuffer-completion-confirm nil | |
| 80 "Non-nil => demand confirmation of completion before exiting minibuffer.") | |
| 81 | |
| 438 | 82 (defcustom minibuffer-confirm-incomplete nil |
| 428 | 83 "If true, then in contexts where completing-read allows answers which |
| 84 are not valid completions, an extra RET must be typed to confirm the | |
| 438 | 85 response. This is helpful for catching typos, etc." |
| 86 :type 'boolean | |
| 87 :group 'minibuffer) | |
| 428 | 88 |
| 89 (defcustom completion-auto-help t | |
| 90 "*Non-nil means automatically provide help for invalid completion input." | |
| 91 :type 'boolean | |
| 92 :group 'minibuffer) | |
| 93 | |
| 94 (defcustom enable-recursive-minibuffers nil | |
| 95 "*Non-nil means to allow minibuffer commands while in the minibuffer. | |
| 96 More precisely, this variable makes a difference when the minibuffer window | |
| 97 is the selected window. If you are in some other window, minibuffer commands | |
| 98 are allowed even if a minibuffer is active." | |
| 99 :type 'boolean | |
| 100 :group 'minibuffer) | |
| 101 | |
| 102 (defcustom minibuffer-max-depth 1 | |
| 103 ;; See comment in #'minibuffer-max-depth-exceeded | |
| 104 "*Global maximum number of minibuffers allowed; | |
| 105 compare to enable-recursive-minibuffers, which is only consulted when the | |
| 106 minibuffer is reinvoked while it is the selected window." | |
| 107 :type '(choice integer | |
| 108 (const :tag "Indefinite" nil)) | |
| 109 :group 'minibuffer) | |
| 110 | |
| 111 ;; Moved to C. The minibuffer prompt must be setup before this is run | |
| 112 ;; and that can only be done from the C side. | |
| 113 ;(defvar minibuffer-setup-hook nil | |
| 114 ; "Normal hook run just after entry to minibuffer.") | |
| 115 | |
| 442 | 116 ;; see comment at list-mode-hook. |
| 117 (put 'minibuffer-setup-hook 'permanent-local t) | |
| 118 | |
| 428 | 119 (defvar minibuffer-exit-hook nil |
| 120 "Normal hook run just after exit from minibuffer.") | |
| 442 | 121 (put 'minibuffer-exit-hook 'permanent-local t) |
| 428 | 122 |
| 123 (defvar minibuffer-help-form nil | |
| 124 "Value that `help-form' takes on inside the minibuffer.") | |
| 125 | |
| 126 (defvar minibuffer-default nil | |
| 127 "Default value for minibuffer input.") | |
| 128 | |
| 129 (defvar minibuffer-local-map | |
| 130 (let ((map (make-sparse-keymap 'minibuffer-local-map))) | |
| 131 map) | |
| 132 "Default keymap to use when reading from the minibuffer.") | |
| 133 | |
| 134 (defvar minibuffer-local-completion-map | |
| 135 (let ((map (make-sparse-keymap 'minibuffer-local-completion-map))) | |
| 136 (set-keymap-parents map (list minibuffer-local-map)) | |
| 137 map) | |
| 138 "Local keymap for minibuffer input with completion.") | |
| 139 | |
| 140 (defvar minibuffer-local-must-match-map | |
| 141 (let ((map (make-sparse-keymap 'minibuffer-must-match-map))) | |
| 142 (set-keymap-parents map (list minibuffer-local-completion-map)) | |
| 143 map) | |
| 144 "Local keymap for minibuffer input with completion, for exact match.") | |
| 145 | |
| 146 ;; (define-key minibuffer-local-map "\C-g" 'abort-recursive-edit) | |
| 147 (define-key minibuffer-local-map "\C-g" 'minibuffer-keyboard-quit) ;; moved here from pending-del.el | |
| 148 (define-key minibuffer-local-map "\r" 'exit-minibuffer) | |
| 149 (define-key minibuffer-local-map "\n" 'exit-minibuffer) | |
| 150 | |
| 151 ;; Historical crock. Unused by anything but user code, if even that | |
| 152 ;(defvar minibuffer-local-ns-map | |
| 153 ; (let ((map (make-sparse-keymap 'minibuffer-local-ns-map))) | |
| 154 ; (set-keymap-parents map (list minibuffer-local-map)) | |
| 155 ; map) | |
| 156 ; "Local keymap for the minibuffer when spaces are not allowed.") | |
| 157 ;(define-key minibuffer-local-ns-map [space] 'exit-minibuffer) | |
| 158 ;(define-key minibuffer-local-ns-map [tab] 'exit-minibuffer) | |
| 159 ;(define-key minibuffer-local-ns-map [?\?] 'self-insert-and-exit) | |
| 160 | |
| 161 (define-key minibuffer-local-completion-map "\t" 'minibuffer-complete) | |
| 162 (define-key minibuffer-local-completion-map " " 'minibuffer-complete-word) | |
| 163 (define-key minibuffer-local-completion-map "?" 'minibuffer-completion-help) | |
| 164 (define-key minibuffer-local-must-match-map "\r" 'minibuffer-complete-and-exit) | |
| 165 (define-key minibuffer-local-must-match-map "\n" 'minibuffer-complete-and-exit) | |
| 166 | |
| 167 (define-key minibuffer-local-map "\M-n" 'next-history-element) | |
| 168 (define-key minibuffer-local-map "\M-p" 'previous-history-element) | |
| 169 (define-key minibuffer-local-map '[next] "\M-n") | |
| 170 (define-key minibuffer-local-map '[prior] "\M-p") | |
| 171 (define-key minibuffer-local-map "\M-r" 'previous-matching-history-element) | |
| 172 (define-key minibuffer-local-map "\M-s" 'next-matching-history-element) | |
| 173 (define-key minibuffer-local-must-match-map [next] | |
| 174 'next-complete-history-element) | |
| 175 (define-key minibuffer-local-must-match-map [prior] | |
| 176 'previous-complete-history-element) | |
| 177 | |
| 178 ;; This is an experiment--make up and down arrows do history. | |
| 179 (define-key minibuffer-local-map [up] 'previous-history-element) | |
| 180 (define-key minibuffer-local-map [down] 'next-history-element) | |
| 181 (define-key minibuffer-local-completion-map [up] 'previous-history-element) | |
| 182 (define-key minibuffer-local-completion-map [down] 'next-history-element) | |
| 183 (define-key minibuffer-local-must-match-map [up] 'previous-history-element) | |
| 184 (define-key minibuffer-local-must-match-map [down] 'next-history-element) | |
| 185 | |
| 186 (defvar read-expression-map (let ((map (make-sparse-keymap | |
| 187 'read-expression-map))) | |
| 188 (set-keymap-parents map | |
| 189 (list minibuffer-local-map)) | |
| 190 (define-key map "\M-\t" 'lisp-complete-symbol) | |
| 191 map) | |
| 192 "Minibuffer keymap used for reading Lisp expressions.") | |
| 193 | |
| 194 (defvar read-shell-command-map | |
| 195 (let ((map (make-sparse-keymap 'read-shell-command-map))) | |
| 196 (set-keymap-parents map (list minibuffer-local-map)) | |
| 197 (define-key map "\t" 'comint-dynamic-complete) | |
| 198 (define-key map "\M-\t" 'comint-dynamic-complete) | |
| 199 (define-key map "\M-?" 'comint-dynamic-list-completions) | |
| 200 map) | |
| 444 | 201 "Minibuffer keymap used by `shell-command' and related commands.") |
| 428 | 202 |
| 203 (defcustom use-dialog-box t | |
| 204 "*Variable controlling usage of the dialog box. | |
| 205 If nil, the dialog box will never be used, even in response to mouse events." | |
| 206 :type 'boolean | |
| 207 :group 'minibuffer) | |
| 208 | |
| 209 (defcustom minibuffer-electric-file-name-behavior t | |
| 210 "*If non-nil, slash and tilde in certain places cause immediate deletion. | |
| 211 These are the same places where this behavior would occur later on anyway, | |
| 212 in `substitute-in-file-name'." | |
| 213 :type 'boolean | |
| 214 :group 'minibuffer) | |
| 215 | |
| 216 ;; originally by Stig@hackvan.com | |
| 217 (defun minibuffer-electric-separator () | |
| 218 (interactive) | |
| 219 (let ((c last-command-char)) | |
| 220 (and minibuffer-electric-file-name-behavior | |
| 221 (eq c directory-sep-char) | |
| 222 (eq c (char-before (point))) | |
| 223 (not (save-excursion | |
| 224 (goto-char (point-min)) | |
| 225 (and (looking-at "/.+:~?[^/]*/.+") | |
| 226 (re-search-forward "^/.+:~?[^/]*" nil t) | |
| 227 (progn | |
| 228 (delete-region (point) (point-max)) | |
| 229 t)))) | |
| 230 (not (save-excursion | |
| 231 (goto-char (point-min)) | |
| 232 (and (looking-at ".+://[^/]*/.+") | |
| 233 (re-search-forward "^.+:/" nil t) | |
| 234 (progn | |
| 235 (delete-region (point) (point-max)) | |
| 236 t)))) | |
| 237 ;; permit `//hostname/path/to/file' | |
| 238 (not (eq (point) (1+ (point-min)))) | |
| 239 ;; permit `http://url/goes/here' | |
| 240 (or (not (eq ?: (char-after (- (point) 2)))) | |
| 241 (eq ?/ (char-after (point-min)))) | |
| 242 (delete-region (point-min) (point))) | |
| 243 (insert c))) | |
| 244 | |
| 245 (defun minibuffer-electric-tilde () | |
| 246 (interactive) | |
| 247 (and minibuffer-electric-file-name-behavior | |
| 248 (eq directory-sep-char (char-before (point))) | |
| 249 ;; permit URL's with //, for e.g. http://hostname/~user | |
| 250 (not (save-excursion (search-backward "//" nil t))) | |
| 251 (delete-region (point-min) (point))) | |
| 252 (insert ?~)) | |
| 253 | |
| 254 | |
| 255 (defvar read-file-name-map | |
| 256 (let ((map (make-sparse-keymap 'read-file-name-map))) | |
| 257 (set-keymap-parents map (list minibuffer-local-completion-map)) | |
| 258 (define-key map (vector directory-sep-char) 'minibuffer-electric-separator) | |
| 259 (define-key map "~" 'minibuffer-electric-tilde) | |
| 260 map | |
| 261 )) | |
| 262 | |
| 263 (defvar read-file-name-must-match-map | |
| 264 (let ((map (make-sparse-keymap 'read-file-name-map))) | |
| 265 (set-keymap-parents map (list minibuffer-local-must-match-map)) | |
| 266 (define-key map (vector directory-sep-char) 'minibuffer-electric-separator) | |
| 267 (define-key map "~" 'minibuffer-electric-tilde) | |
| 268 map | |
| 269 )) | |
| 270 | |
| 271 (defun minibuffer-keyboard-quit () | |
| 272 "Abort recursive edit. | |
| 273 If `zmacs-regions' is true, and the zmacs region is active in this buffer, | |
| 274 then this key deactivates the region without beeping." | |
| 275 (interactive) | |
| 2611 | 276 (if (region-active-p) |
| 428 | 277 ;; pseudo-zmacs compatibility: don't beep if this ^G is simply |
| 278 ;; deactivating the region. If it is inactive, beep. | |
| 279 nil | |
| 280 (abort-recursive-edit))) | |
| 281 | |
| 282 ;;;; Guts of minibuffer invocation | |
| 283 | |
| 284 ;;#### The only things remaining in C are | |
| 285 ;; "Vminibuf_prompt" and the display junk | |
| 286 ;; "minibuf_prompt_width" and "minibuf_prompt_pix_width" | |
| 287 ;; Also "active_frame", though I suspect I could already | |
| 288 ;; hack that in Lisp if I could make any sense of the | |
| 289 ;; complete mess of frame/frame code in XEmacs. | |
| 290 ;; Vminibuf_prompt could easily be made Lisp-bindable. | |
| 291 ;; I suspect that minibuf_prompt*_width are actually recomputed | |
| 292 ;; by redisplay as needed -- or could be arranged to be so -- | |
| 293 ;; and that there could be need for read-minibuffer-internal to | |
| 294 ;; save and restore them. | |
| 295 ;;#### The only other thing which read-from-minibuffer-internal does | |
| 296 ;; which we can't presently do in Lisp is move the frame cursor | |
| 297 ;; to the start of the minibuffer line as it returns. This is | |
| 298 ;; a rather nice touch and should be preserved -- probably by | |
| 299 ;; providing some Lisp-level mechanism (extension to cursor-in-echo-area ?) | |
| 300 ;; to effect it. | |
| 301 | |
| 302 | |
| 303 ;; Like reset_buffer in FSF's buffer.c | |
| 304 ;; (Except that kill-all-local-variables doesn't nuke 'permanent-local | |
| 305 ;; variables -- we preserve them, reset_buffer doesn't.) | |
| 306 (defun reset-buffer (buffer) | |
| 307 (with-current-buffer buffer | |
| 308 ;(if (fboundp 'unlock-buffer) (unlock-buffer)) | |
| 309 (kill-all-local-variables) | |
| 310 (setq buffer-read-only nil) | |
| 311 ;; don't let read only text yanked into the minibuffer | |
| 312 ;; permanently wedge it. | |
| 313 (make-local-variable 'inhibit-read-only) | |
| 314 (setq inhibit-read-only t) | |
| 315 (erase-buffer) | |
| 316 ;(setq default-directory nil) | |
| 317 (setq buffer-file-name nil) | |
| 318 (setq buffer-file-truename nil) | |
| 319 (set-buffer-modified-p nil) | |
| 320 (setq buffer-backed-up nil) | |
| 321 (setq buffer-auto-save-file-name nil) | |
| 322 (set-buffer-dedicated-frame buffer nil) | |
| 2021 | 323 (set-marker (mark-marker t buffer) nil) |
| 428 | 324 buffer)) |
| 325 | |
| 326 (defvar minibuffer-history-variable 'minibuffer-history | |
| 327 "History list symbol to add minibuffer values to. | |
| 328 Each minibuffer output is added with | |
| 329 (set minibuffer-history-variable | |
| 330 (cons STRING (symbol-value minibuffer-history-variable)))") | |
| 331 (defvar minibuffer-history-position) | |
| 332 | |
| 333 ;; Added by hniksic: | |
| 334 (defvar initial-minibuffer-history-position) | |
| 335 (defvar current-minibuffer-contents) | |
| 336 (defvar current-minibuffer-point) | |
| 337 | |
| 338 (defcustom minibuffer-history-minimum-string-length nil | |
| 339 "*If this variable is non-nil, a string will not be added to the | |
| 340 minibuffer history if its length is less than that value." | |
| 341 :type '(choice (const :tag "Any" nil) | |
| 342 integer) | |
| 343 :group 'minibuffer) | |
| 344 | |
| 510 | 345 (define-error 'input-error "Keyboard input error" 'io-error) |
| 428 | 346 |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
347 ((macro |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
348 . (lambda (read-from-minibuffer-definition) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
349 (nsublis |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
350 ;; `M-x doctor' makes (the interned) history a local variable, use an |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
351 ;; uninterned symbol here so we don't interact with it. |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
352 '((history . #:history)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
353 read-from-minibuffer-definition))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
354 (defun read-from-minibuffer (prompt &optional initial-contents keymap |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
355 readp history abbrev-table default) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
356 "Read a string from the minibuffer, prompting with string PROMPT. |
| 428 | 357 If optional second arg INITIAL-CONTENTS is non-nil, it is a string |
| 358 to be inserted into the minibuffer before reading input. | |
| 359 If INITIAL-CONTENTS is (STRING . POSITION), the initial input | |
| 360 is STRING, but point is placed POSITION characters into the string. | |
| 361 Third arg KEYMAP is a keymap to use while reading; | |
| 362 if omitted or nil, the default is `minibuffer-local-map'. | |
| 363 If fourth arg READ is non-nil, then interpret the result as a lisp object | |
| 364 and return that object: | |
| 365 in other words, do `(car (read-from-string INPUT-STRING))' | |
| 366 Fifth arg HISTORY, if non-nil, specifies a history list | |
| 367 and optionally the initial position in the list. | |
| 368 It can be a symbol, which is the history list variable to use, | |
| 369 or it can be a cons cell (HISTVAR . HISTPOS). | |
| 370 In that case, HISTVAR is the history list variable to use, | |
| 371 and HISTPOS is the initial position (the position in the list | |
| 372 which INITIAL-CONTENTS corresponds to). | |
| 373 If HISTORY is `t', no history will be recorded. | |
| 374 Positions are counted starting from 1 at the beginning of the list. | |
| 375 Sixth arg ABBREV-TABLE, if non-nil, becomes the value of `local-abbrev-table' | |
| 376 in the minibuffer. | |
| 430 | 377 Seventh arg DEFAULT, if non-nil, will be returned when user enters |
| 378 an empty string. | |
| 428 | 379 |
| 444 | 380 See also the variable `completion-highlight-first-word-only' for |
| 381 control over completion display." | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
382 (if (and (not enable-recursive-minibuffers) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
383 (> (minibuffer-depth) 0) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
384 (eq (selected-window) (minibuffer-window))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
385 (error "Command attempted to use minibuffer while in minibuffer")) |
| 428 | 386 |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
387 (if (and minibuffer-max-depth |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
388 (> minibuffer-max-depth 0) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
389 (>= (minibuffer-depth) minibuffer-max-depth)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
390 (minibuffer-max-depth-exceeded)) |
| 428 | 391 |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
392 ;; catch this error before the poor user has typed something... |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
393 (if history |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
394 (if (symbolp history) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
395 (or (boundp history) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
396 (error "History list %S is unbound" history)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
397 (or (boundp (car history)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
398 (error "History list %S is unbound" (car history))))) |
| 428 | 399 |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
400 (if (noninteractive) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
401 (progn |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
402 ;; XEmacs in -batch mode calls minibuffer: print the prompt. |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
403 (message "%s" (gettext prompt)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
404 ;;#### force-output |
| 428 | 405 |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
406 ;;#### Should this even be falling though to the code below? |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
407 ;;#### How does this stuff work now, anyway? |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
408 )) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
409 (let* ((dir default-directory) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
410 (owindow (selected-window)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
411 (oframe (selected-frame)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
412 (window (minibuffer-window)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
413 (buffer (get-buffer-create (format " *Minibuf-%d*" |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
414 (minibuffer-depth)))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
415 (frame (window-frame window)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
416 (mconfig (if (eq frame (selected-frame)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
417 nil (current-window-configuration frame))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
418 (oconfig (current-window-configuration)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
419 (minibuffer-default default)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
420 (unwind-protect |
| 428 | 421 (progn |
| 422 (set-buffer (reset-buffer buffer)) | |
| 423 (setq default-directory dir) | |
| 424 (make-local-variable 'print-escape-newlines) | |
| 425 (setq print-escape-newlines t) | |
| 426 (make-local-variable 'current-minibuffer-contents) | |
| 427 (make-local-variable 'current-minibuffer-point) | |
| 428 (make-local-variable 'initial-minibuffer-history-position) | |
| 429 (setq current-minibuffer-contents "" | |
| 430 current-minibuffer-point 1) | |
| 431 (if (not minibuffer-smart-completion-tracking-behavior) | |
| 432 nil | |
| 433 (make-local-variable 'mode-motion-hook) | |
| 434 (or mode-motion-hook | |
| 435 ;;####disgusting | |
| 436 (setq mode-motion-hook 'minibuffer-smart-mouse-tracker)) | |
| 437 (make-local-variable 'mouse-track-click-hook) | |
| 438 (add-hook 'mouse-track-click-hook | |
| 439 'minibuffer-smart-maybe-select-highlighted-completion)) | |
| 440 (set-window-buffer window buffer) | |
| 441 (select-window window) | |
| 442 (set-window-hscroll window 0) | |
| 443 (buffer-enable-undo buffer) | |
| 444 (message nil) | |
| 445 (if initial-contents | |
| 446 (if (consp initial-contents) | |
| 447 (progn | |
| 448 (insert (car initial-contents)) | |
| 449 (goto-char (1+ (cdr initial-contents))) | |
| 450 (setq current-minibuffer-contents (car initial-contents) | |
| 451 current-minibuffer-point (cdr initial-contents))) | |
| 452 (insert initial-contents) | |
| 453 (setq current-minibuffer-contents initial-contents | |
| 454 current-minibuffer-point (point)))) | |
| 455 (use-local-map (help-keymap-with-help-key | |
| 456 (or keymap minibuffer-local-map) | |
| 457 minibuffer-help-form)) | |
| 458 (let ((mouse-grabbed-buffer | |
| 459 (and minibuffer-smart-completion-tracking-behavior | |
| 460 (current-buffer))) | |
| 461 (current-prefix-arg current-prefix-arg) | |
| 462 ;; (help-form minibuffer-help-form) | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
463 (minibuffer-history-variable (cond ((not history) |
| 428 | 464 'minibuffer-history) |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
465 ((consp history) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
466 (car history)) |
| 428 | 467 (t |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
468 history))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
469 (minibuffer-history-position (cond ((consp history) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
470 (cdr history)) |
| 428 | 471 (t |
| 472 0))) | |
| 473 (minibuffer-scroll-window owindow)) | |
| 474 (setq initial-minibuffer-history-position | |
| 475 minibuffer-history-position) | |
| 476 (if abbrev-table | |
| 477 (setq local-abbrev-table abbrev-table | |
| 478 abbrev-mode t)) | |
| 479 ;; This is now run from read-minibuffer-internal | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
480 ;(if minibuffer-setup-hook |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
481 ; (run-hooks 'minibuffer-setup-hook)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
482 ;(message nil) |
| 428 | 483 (if (eq 't |
| 484 (catch 'exit | |
| 485 (if (> (recursion-depth) (minibuffer-depth)) | |
| 486 (let ((standard-output t) | |
| 487 (standard-input t)) | |
| 488 (read-minibuffer-internal prompt)) | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
489 (read-minibuffer-internal prompt)))) |
| 428 | 490 ;; Translate an "abort" (throw 'exit 't) |
| 491 ;; into a real quit | |
| 492 (signal 'quit '()) | |
| 493 ;; return value | |
| 494 (let* ((val (progn (set-buffer buffer) | |
| 495 (if minibuffer-exit-hook | |
| 496 (run-hooks 'minibuffer-exit-hook)) | |
| 430 | 497 (if (and (eq (char-after (point-min)) nil) |
| 498 default) | |
| 499 default | |
| 500 (buffer-string)))) | |
| 501 (histval (if (and default (string= val "")) | |
| 502 default | |
| 503 val)) | |
| 428 | 504 (err nil)) |
| 505 (if readp | |
| 506 (condition-case e | |
| 507 (let ((v (read-from-string val))) | |
| 508 (if (< (cdr v) (length val)) | |
| 509 (save-match-data | |
| 510 (or (string-match "[ \t\n]*\\'" val (cdr v)) | |
| 511 (error "Trailing garbage following expression")))) | |
| 512 (setq v (car v)) | |
| 513 ;; total total kludge | |
| 514 (if (stringp v) (setq v (list 'quote v))) | |
| 515 (setq val v)) | |
| 516 (end-of-file | |
| 517 (setq err | |
| 518 '(input-error "End of input before end of expression"))) | |
| 519 (error (setq err e)))) | |
| 520 ;; Add the value to the appropriate history list unless | |
| 521 ;; it's already the most recent element, or it's only | |
| 522 ;; two characters long. | |
| 523 (if (and (symbolp minibuffer-history-variable) | |
| 524 (boundp minibuffer-history-variable)) | |
| 525 (let ((list (symbol-value minibuffer-history-variable))) | |
| 526 (or (eq list t) | |
| 527 (null val) | |
| 528 (and list (equal histval (car list))) | |
| 529 (and (stringp val) | |
| 530 minibuffer-history-minimum-string-length | |
| 531 (< (length val) | |
| 532 minibuffer-history-minimum-string-length)) | |
| 533 (set minibuffer-history-variable | |
| 534 (if minibuffer-history-uniquify | |
| 535 (cons histval (remove histval list)) | |
| 536 (cons histval list)))))) | |
| 537 (if err (signal (car err) (cdr err))) | |
| 538 val)))) | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
539 ;; stupid display code requires this for some reason |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
540 (set-buffer buffer) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
541 (buffer-disable-undo buffer) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
542 (setq buffer-read-only nil) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
543 (erase-buffer) |
| 428 | 544 |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
545 ;; restore frame configurations |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
546 (if (and mconfig (frame-live-p oframe) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
547 (eq frame (selected-frame))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
548 ;; if we changed frames (due to surrogate minibuffer), |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
549 ;; and we're still on the new frame, go back to the old one. |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
550 (select-frame oframe)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
551 (if mconfig (set-window-configuration mconfig)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4734
diff
changeset
|
552 (set-window-configuration oconfig))))) |
| 428 | 553 |
| 554 (defun minibuffer-max-depth-exceeded () | |
| 555 ;; | |
| 556 ;; This signals an error if an Nth minibuffer is invoked while N-1 are | |
| 557 ;; already active, whether the minibuffer window is selected or not. | |
| 558 ;; Since, under X, it's easy to jump out of the minibuffer (by doing M-x, | |
| 559 ;; getting distracted, and clicking elsewhere) many many novice users have | |
| 560 ;; had the problem of having multiple minibuffers build up, even to the | |
| 561 ;; point of exceeding max-lisp-eval-depth. Since the variable | |
| 562 ;; enable-recursive-minibuffers historically/crockishly is only consulted | |
| 563 ;; when the minibuffer is currently active (like typing M-x M-x) it doesn't | |
| 564 ;; help in this situation. | |
| 565 ;; | |
| 566 ;; This routine also offers to edit .emacs for you to get rid of this | |
| 567 ;; complaint, like `disabled' commands do, since it's likely that non-novice | |
| 568 ;; users will be annoyed by this change, so we give them an easy way to get | |
| 569 ;; rid of it forever. | |
| 570 ;; | |
| 571 (beep t 'minibuffer-limit-exceeded) | |
| 572 (message | |
| 573 "Minibuffer already active: abort it with `^]', enable new one with `n': ") | |
| 574 (let ((char (let ((cursor-in-echo-area t)) ; #### doesn't always work?? | |
| 575 (read-char)))) | |
| 576 (cond | |
| 577 ((eq char ?n) | |
| 578 (cond | |
| 579 ((y-or-n-p "Enable recursive minibuffers for other sessions too? ") | |
| 580 ;; This is completely disgusting, but it's basically what novice.el | |
| 581 ;; does. This kind of thing should be generalized. | |
| 582 (setq minibuffer-max-depth nil) | |
| 583 (save-excursion | |
| 584 (set-buffer | |
| 585 (find-file-noselect | |
| 586 (substitute-in-file-name custom-file))) | |
| 587 (goto-char (point-min)) | |
| 588 (if (re-search-forward | |
| 589 "^(setq minibuffer-max-depth \\([0-9]+\\|'?nil\\|'?()\\))\n" | |
| 590 nil t) | |
| 591 (delete-region (match-beginning 0 ) (match-end 0)) | |
| 592 ;; Must have been disabled by default. | |
| 593 (goto-char (point-max))) | |
| 594 (insert"\n(setq minibuffer-max-depth nil)\n") | |
| 595 (save-buffer)) | |
| 596 (message "Multiple minibuffers enabled") | |
| 597 (sit-for 1)))) | |
| 598 ((eq char ? ) | |
| 599 (abort-recursive-edit)) | |
| 600 (t | |
| 601 (error "Minibuffer already active"))))) | |
| 602 | |
| 603 | |
| 604 ;;;; Guts of minibuffer completion | |
| 605 | |
| 606 | |
| 607 ;; Used by minibuffer-do-completion | |
| 442 | 608 (defvar last-exact-completion nil) |
| 428 | 609 |
| 610 (defun temp-minibuffer-message (m) | |
| 611 (let ((savemax (point-max))) | |
| 612 (save-excursion | |
| 613 (goto-char (point-max)) | |
| 614 (message nil) | |
| 615 (insert m)) | |
| 616 (let ((inhibit-quit t)) | |
| 617 (sit-for 2) | |
| 618 (delete-region savemax (point-max)) | |
| 619 ;; If the user types a ^G while we're in sit-for, then quit-flag | |
| 620 ;; gets set. In this case, we want that ^G to be interpreted | |
| 621 ;; as a normal character, and act just like typeahead. | |
| 622 (if (and quit-flag (not unread-command-event)) | |
| 623 (setq unread-command-event (character-to-event (quit-char)) | |
| 624 quit-flag nil))))) | |
| 625 | |
| 626 | |
| 627 ;; Determines whether buffer-string is an exact completion | |
| 628 (defun exact-minibuffer-completion-p (buffer-string) | |
| 629 (cond ((not minibuffer-completion-table) | |
| 630 ;; Empty alist | |
| 631 nil) | |
| 632 ((vectorp minibuffer-completion-table) | |
| 633 (let ((tem (intern-soft buffer-string | |
| 634 minibuffer-completion-table))) | |
| 635 (if (or tem | |
| 636 (and (string-equal buffer-string "nil") | |
| 637 ;; intern-soft loses for 'nil | |
| 638 (catch 'found | |
| 639 (mapatoms #'(lambda (s) | |
| 640 (if (string-equal | |
| 641 (symbol-name s) | |
| 642 buffer-string) | |
| 643 (throw 'found t))) | |
| 644 minibuffer-completion-table) | |
| 645 nil))) | |
| 646 (if minibuffer-completion-predicate | |
| 647 (funcall minibuffer-completion-predicate | |
| 648 tem) | |
| 649 t) | |
| 650 nil))) | |
| 651 ((and (consp minibuffer-completion-table) | |
| 652 ;;#### Emacs-Lisp truly sucks! | |
| 653 ;; lambda, autoload, etc | |
| 654 (not (symbolp (car minibuffer-completion-table)))) | |
| 655 (if (not completion-ignore-case) | |
| 656 (assoc buffer-string minibuffer-completion-table) | |
| 657 (let ((s (upcase buffer-string)) | |
| 658 (tail minibuffer-completion-table) | |
| 659 tem) | |
| 660 (while tail | |
| 661 (setq tem (car (car tail))) | |
| 662 (if (or (equal tem buffer-string) | |
| 663 (equal tem s) | |
| 664 (if tem (equal (upcase tem) s))) | |
| 665 (setq s 'win | |
| 666 tail nil) ;exit | |
| 667 (setq tail (cdr tail)))) | |
| 668 (eq s 'win)))) | |
| 669 (t | |
| 670 (funcall minibuffer-completion-table | |
| 671 buffer-string | |
| 672 minibuffer-completion-predicate | |
| 673 'lambda))) | |
| 674 ) | |
| 675 | |
| 676 ;; 0 'none no possible completion | |
| 677 ;; 1 'unique was already an exact and unique completion | |
| 678 ;; 3 'exact was already an exact (but nonunique) completion | |
| 679 ;; NOT USED 'completed-exact-unique completed to an exact and completion | |
| 680 ;; 4 'completed-exact completed to an exact (but nonunique) completion | |
| 681 ;; 5 'completed some completion happened | |
| 682 ;; 6 'uncompleted no completion happened | |
| 683 (defun minibuffer-do-completion-1 (buffer-string completion) | |
| 684 (cond ((not completion) | |
| 685 'none) | |
| 686 ((eq completion t) | |
| 687 ;; exact and unique match | |
| 688 'unique) | |
| 689 (t | |
| 690 ;; It did find a match. Do we match some possibility exactly now? | |
| 691 (let ((completedp (not (string-equal completion buffer-string)))) | |
| 692 (if completedp | |
| 693 (progn | |
| 694 ;; Some completion happened | |
| 695 (erase-buffer) | |
| 696 (insert completion) | |
| 697 (setq buffer-string completion))) | |
| 698 (if (exact-minibuffer-completion-p buffer-string) | |
| 699 ;; An exact completion was possible | |
| 700 (if completedp | |
| 701 ;; Since no callers need to know the difference, don't bother | |
| 702 ;; with this (potentially expensive) discrimination. | |
| 703 ;; (if (eq (try-completion completion | |
| 704 ;; minibuffer-completion-table | |
| 705 ;; minibuffer-completion-predicate) | |
| 706 ;; 't) | |
| 707 ;; 'completed-exact-unique | |
| 708 'completed-exact | |
| 709 ;; ) | |
| 710 'exact) | |
| 711 ;; Not an exact match | |
| 712 (if completedp | |
| 713 'completed | |
| 714 'uncompleted)))))) | |
| 715 | |
| 716 | |
| 717 (defun minibuffer-do-completion (buffer-string) | |
| 718 (let* ((completion (try-completion buffer-string | |
| 719 minibuffer-completion-table | |
| 720 minibuffer-completion-predicate)) | |
| 721 (status (minibuffer-do-completion-1 buffer-string completion)) | |
| 722 (last last-exact-completion)) | |
| 723 (setq last-exact-completion nil) | |
| 724 (cond ((eq status 'none) | |
| 725 ;; No completions | |
| 726 (ding nil 'no-completion) | |
| 727 (temp-minibuffer-message " [No match]")) | |
| 728 ((eq status 'unique) | |
| 729 ) | |
| 730 (t | |
| 731 ;; It did find a match. Do we match some possibility exactly now? | |
| 732 (if (not (string-equal completion buffer-string)) | |
| 733 (progn | |
| 734 ;; Some completion happened | |
| 735 (erase-buffer) | |
| 736 (insert completion) | |
| 737 (setq buffer-string completion))) | |
| 738 (cond ((eq status 'exact) | |
| 739 ;; If the last exact completion and this one were | |
| 740 ;; the same, it means we've already given a | |
| 741 ;; "Complete but not unique" message and that the | |
| 742 ;; user's hit TAB again, so now we give help. | |
| 743 (setq last-exact-completion completion) | |
| 744 (if (equal buffer-string last) | |
| 745 (minibuffer-completion-help))) | |
| 746 ((eq status 'uncompleted) | |
| 747 (if completion-auto-help | |
| 748 (minibuffer-completion-help) | |
| 749 (temp-minibuffer-message " [Next char not unique]"))) | |
| 750 (t | |
| 751 nil)))) | |
| 752 status)) | |
| 753 | |
| 754 | |
| 755 ;;;; completing-read | |
| 756 | |
| 757 (defun completing-read (prompt table | |
| 758 &optional predicate require-match | |
| 759 initial-contents history default) | |
| 760 "Read a string in the minibuffer, with completion. | |
| 863 | 761 |
| 428 | 762 PROMPT is a string to prompt with; normally it ends in a colon and a space. |
| 763 TABLE is an alist whose elements' cars are strings, or an obarray. | |
| 863 | 764 TABLE can also be a function which does the completion itself. |
| 428 | 765 PREDICATE limits completion to a subset of TABLE. |
| 765 | 766 See `try-completion' and `all-completions' for more details |
| 767 on completion, TABLE, and PREDICATE. | |
| 768 | |
| 428 | 769 If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless |
| 765 | 770 the input is (or completes to) an element of TABLE or is null. |
| 771 If it is also not t, Return does not exit if it does non-null completion. | |
| 428 | 772 If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially. |
| 773 If it is (STRING . POSITION), the initial input | |
| 774 is STRING, but point is placed POSITION characters into the string. | |
| 765 | 775 |
| 428 | 776 HISTORY, if non-nil, specifies a history list |
| 777 and optionally the initial position in the list. | |
| 778 It can be a symbol, which is the history list variable to use, | |
| 779 or it can be a cons cell (HISTVAR . HISTPOS). | |
| 780 In that case, HISTVAR is the history list variable to use, | |
| 781 and HISTPOS is the initial position (the position in the list | |
| 782 which INITIAL-CONTENTS corresponds to). | |
| 783 If HISTORY is `t', no history will be recorded. | |
| 784 Positions are counted starting from 1 at the beginning of the list. | |
| 765 | 785 DEFAULT, if non-nil, will be returned when the user enters an empty |
| 786 string. | |
| 787 | |
| 428 | 788 Completion ignores case if the ambient value of |
| 789 `completion-ignore-case' is non-nil." | |
| 790 (let ((minibuffer-completion-table table) | |
| 791 (minibuffer-completion-predicate predicate) | |
| 792 (minibuffer-completion-confirm (if (eq require-match 't) nil t)) | |
| 793 (last-exact-completion nil) | |
| 794 ret) | |
| 795 (setq ret (read-from-minibuffer prompt | |
| 796 initial-contents | |
| 797 (if (not require-match) | |
| 798 minibuffer-local-completion-map | |
| 799 minibuffer-local-must-match-map) | |
| 800 nil | |
| 430 | 801 history |
| 802 nil | |
| 803 default)) | |
| 428 | 804 (if (and (string= ret "") |
| 805 default) | |
| 806 default | |
| 807 ret))) | |
| 808 | |
| 809 | |
| 810 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 811 ;;;; Minibuffer completion commands ;;;; | |
| 812 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 813 | |
| 814 | |
| 815 (defun minibuffer-complete () | |
| 816 "Complete the minibuffer contents as far as possible. | |
| 817 Return nil if there is no valid completion, else t. | |
| 818 If no characters can be completed, display a list of possible completions. | |
| 819 If you repeat this command after it displayed such a list, | |
| 820 scroll the window of possible completions." | |
| 821 (interactive) | |
| 822 ;; If the previous command was not this, then mark the completion | |
| 823 ;; buffer obsolete. | |
| 824 (or (eq last-command this-command) | |
| 825 (setq minibuffer-scroll-window nil)) | |
| 826 (let ((window minibuffer-scroll-window)) | |
| 827 (if (and window (windowp window) (window-buffer window) | |
| 828 (buffer-name (window-buffer window))) | |
| 829 ;; If there's a fresh completion window with a live buffer | |
| 830 ;; and this command is repeated, scroll that window. | |
| 831 (let ((obuf (current-buffer))) | |
| 832 (unwind-protect | |
| 833 (progn | |
| 834 (set-buffer (window-buffer window)) | |
| 835 (if (pos-visible-in-window-p (point-max) window) | |
| 836 ;; If end is in view, scroll up to the beginning. | |
| 837 (set-window-start window (point-min)) | |
| 838 ;; Else scroll down one frame. | |
| 839 (scroll-other-window))) | |
| 840 (set-buffer obuf)) | |
| 841 nil) | |
| 842 (let ((status (minibuffer-do-completion (buffer-string)))) | |
| 843 (if (eq status 'none) | |
| 844 nil | |
| 845 (progn | |
| 846 (cond ((eq status 'unique) | |
| 847 (temp-minibuffer-message | |
| 848 " [Sole completion]")) | |
| 849 ((eq status 'exact) | |
| 850 (temp-minibuffer-message | |
| 851 " [Complete, but not unique]"))) | |
| 852 t)))))) | |
| 853 | |
| 854 | |
| 855 (defun minibuffer-complete-and-exit () | |
| 856 "Complete the minibuffer contents, and maybe exit. | |
| 857 Exit if the name is valid with no completion needed. | |
| 858 If name was completed to a valid match, | |
| 859 a repetition of this command will exit." | |
| 860 (interactive) | |
| 861 (if (= (point-min) (point-max)) | |
| 862 ;; Crockishly allow user to specify null string | |
| 863 (throw 'exit nil)) | |
| 864 (let ((buffer-string (buffer-string))) | |
| 865 ;; Short-cut -- don't call minibuffer-do-completion if we already | |
| 866 ;; have an (possibly nonunique) exact completion. | |
| 867 (if (exact-minibuffer-completion-p buffer-string) | |
| 868 (throw 'exit nil)) | |
| 869 (let ((status (minibuffer-do-completion buffer-string))) | |
| 870 (if (or (eq status 'unique) | |
| 871 (eq status 'exact) | |
| 872 (if (or (eq status 'completed-exact) | |
| 873 (eq status 'completed-exact-unique)) | |
| 874 (if minibuffer-completion-confirm | |
| 875 (progn (temp-minibuffer-message " [Confirm]") | |
| 876 nil) | |
| 877 t))) | |
| 878 (throw 'exit nil))))) | |
| 879 | |
| 880 | |
| 881 (defun self-insert-and-exit () | |
| 882 "Terminate minibuffer input." | |
| 883 (interactive) | |
| 884 (self-insert-command 1) | |
| 885 (throw 'exit nil)) | |
| 886 | |
| 887 (defun exit-minibuffer () | |
| 888 "Terminate this minibuffer argument. | |
| 889 If minibuffer-confirm-incomplete is true, and we are in a completing-read | |
| 890 of some kind, and the contents of the minibuffer is not an existing | |
| 891 completion, requires an additional RET before the minibuffer will be exited | |
| 892 \(assuming that RET was the character that invoked this command: | |
| 893 the character in question must be typed again)." | |
| 894 (interactive) | |
| 895 (if (not minibuffer-confirm-incomplete) | |
| 896 (throw 'exit nil)) | |
| 897 (let ((buffer-string (buffer-string))) | |
| 898 (if (exact-minibuffer-completion-p buffer-string) | |
| 899 (throw 'exit nil)) | |
| 900 (let ((completion (if (not minibuffer-completion-table) | |
| 901 t | |
| 902 (try-completion buffer-string | |
| 903 minibuffer-completion-table | |
| 904 minibuffer-completion-predicate)))) | |
| 905 (if (or (eq completion 't) | |
| 906 ;; Crockishly allow user to specify null string | |
| 907 (string-equal buffer-string "")) | |
| 908 (throw 'exit nil)) | |
| 909 (if completion ;; rewritten for I18N3 snarfing | |
| 910 (temp-minibuffer-message " [incomplete; confirm]") | |
| 911 (temp-minibuffer-message " [no completions; confirm]")) | |
| 912 (let ((event (let ((inhibit-quit t)) | |
| 913 (prog1 | |
| 914 (next-command-event) | |
| 915 (setq quit-flag nil))))) | |
| 916 (cond ((equal event last-command-event) | |
| 917 (throw 'exit nil)) | |
| 918 ((equal (quit-char) (event-to-character event)) | |
| 919 ;; Minibuffer abort. | |
| 920 (throw 'exit t))) | |
| 921 (dispatch-event event))))) | |
| 922 | |
| 923 ;;;; minibuffer-complete-word | |
| 924 | |
| 925 | |
| 926 ;;;#### I think I have done this correctly; it certainly is simpler | |
| 927 ;;;#### than what the C code seemed to be trying to do. | |
| 928 (defun minibuffer-complete-word () | |
| 929 "Complete the minibuffer contents at most a single word. | |
| 930 After one word is completed as much as possible, a space or hyphen | |
| 931 is added, provided that matches some possible completion. | |
| 932 Return nil if there is no valid completion, else t." | |
| 933 (interactive) | |
| 934 (let* ((buffer-string (buffer-string)) | |
| 935 (completion (try-completion buffer-string | |
| 936 minibuffer-completion-table | |
| 937 minibuffer-completion-predicate)) | |
| 938 (status (minibuffer-do-completion-1 buffer-string completion))) | |
| 939 (cond ((eq status 'none) | |
| 940 (ding nil 'no-completion) | |
| 941 (temp-minibuffer-message " [No match]") | |
| 942 nil) | |
| 943 ((eq status 'unique) | |
| 944 ;; New message, only in this new Lisp code | |
| 945 (temp-minibuffer-message " [Sole completion]") | |
| 946 t) | |
| 947 (t | |
| 948 (cond ((or (eq status 'uncompleted) | |
| 949 (eq status 'exact)) | |
| 950 (let ((foo #'(lambda (s) | |
| 951 (condition-case nil | |
| 952 (if (try-completion | |
| 953 (concat buffer-string s) | |
| 954 minibuffer-completion-table | |
| 955 minibuffer-completion-predicate) | |
| 956 (progn | |
| 957 (goto-char (point-max)) | |
| 958 (insert s) | |
| 959 t) | |
| 960 nil) | |
| 961 (error nil)))) | |
| 962 (char last-command-char)) | |
| 963 ;; Try to complete by adding a word-delimiter | |
| 964 (or (and (characterp char) (> char 0) | |
| 965 (funcall foo (char-to-string char))) | |
| 966 (and (not (eq char ?\ )) | |
| 967 (funcall foo " ")) | |
| 968 (and (not (eq char ?\-)) | |
| 969 (funcall foo "-")) | |
| 970 (progn | |
| 971 (if completion-auto-help | |
| 972 (minibuffer-completion-help) | |
| 973 ;; New message, only in this new Lisp code | |
| 974 ;; rewritten for I18N3 snarfing | |
| 975 (if (eq status 'exact) | |
| 976 (temp-minibuffer-message | |
| 977 " [Complete, but not unique]") | |
| 978 (temp-minibuffer-message " [Ambiguous]"))) | |
| 979 nil)))) | |
| 980 (t | |
| 981 (erase-buffer) | |
| 982 (insert completion) | |
| 983 ;; First word-break in stuff found by completion | |
| 984 (goto-char (point-min)) | |
| 985 (let ((len (length buffer-string)) | |
| 986 n) | |
| 987 (if (and (< len (length completion)) | |
| 988 (catch 'match | |
| 989 (setq n 0) | |
| 990 (while (< n len) | |
| 991 (if (char-equal | |
| 992 (upcase (aref buffer-string n)) | |
| 993 (upcase (aref completion n))) | |
| 994 (setq n (1+ n)) | |
| 995 (throw 'match nil))) | |
| 996 t) | |
| 997 (progn | |
| 998 (goto-char (point-min)) | |
| 999 (forward-char len) | |
| 1000 (re-search-forward "\\W" nil t))) | |
| 1001 (delete-region (point) (point-max)) | |
| 1002 (goto-char (point-max)))) | |
| 1003 t)))))) | |
| 1004 | |
| 1005 | |
| 1006 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1007 ;;;; "Smart minibuffer" hackery ;;;; | |
| 1008 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1009 | |
| 1010 ;;; ("Kludgy minibuffer hackery" is perhaps a better name) | |
| 1011 | |
| 1012 ;; This works by setting `mouse-grabbed-buffer' to the minibuffer, | |
| 1013 ;; defining button2 in the minibuffer keymap to | |
| 1014 ;; `minibuffer-smart-select-highlighted-completion', and setting the | |
| 1015 ;; mode-motion-hook of the minibuffer to `minibuffer-mouse-tracker'. | |
| 1016 ;; By setting `mouse-grabbed-buffer', the minibuffer's keymap and | |
| 1017 ;; mode-motion-hook apply (for mouse motion and presses) no matter | |
| 1018 ;; what buffer the mouse is over. Then, `minibuffer-mouse-tracker' | |
| 1019 ;; examines the text under the mouse looking for something that looks | |
| 1020 ;; like a completion, and causes it to be highlighted, and | |
| 1021 ;; `minibuffer-smart-select-highlighted-completion' looks for a | |
| 1022 ;; flagged completion under the mouse and inserts it. This has the | |
| 1023 ;; following advantages: | |
| 1024 ;; | |
| 1025 ;; -- filenames and such in any buffer can be inserted by clicking, | |
| 1026 ;; not just completions | |
| 1027 ;; | |
| 1028 ;; but the following disadvantages: | |
| 1029 ;; | |
| 1030 ;; -- unless you're aware of the "filename in any buffer" feature, | |
| 1031 ;; the fact that strings in arbitrary buffers get highlighted appears | |
| 1032 ;; as a bug | |
| 1033 ;; -- mouse motion can cause ange-ftp actions -- bad bad bad. | |
| 1034 ;; | |
| 1035 ;; There's some hackery in minibuffer-mouse-tracker to try to avoid the | |
| 1036 ;; ange-ftp stuff, but it doesn't work. | |
| 1037 ;; | |
| 1038 | |
| 1039 (defcustom minibuffer-smart-completion-tracking-behavior nil | |
| 1040 "*If non-nil, look for completions under mouse in all buffers. | |
| 1041 This allows you to click on something that looks like a completion | |
| 1042 and have it selected, regardless of what buffer it is in. | |
| 1043 | |
| 1044 This is not enabled by default because | |
| 1045 | |
| 1046 -- The \"mysterious\" highlighting in normal buffers is confusing to | |
| 1047 people not expecting it, and looks like a bug | |
| 1048 -- If ange-ftp is enabled, this tracking sometimes causes ange-ftp | |
| 1049 action as a result of mouse motion, which is *bad bad bad*. | |
| 1050 Hopefully this bug will be fixed at some point." | |
| 1051 :type 'boolean | |
| 1052 :group 'minibuffer) | |
| 1053 | |
| 1054 (defun minibuffer-smart-mouse-tracker (event) | |
| 1055 ;; Used as the mode-motion-hook of the minibuffer window, which is the | |
| 1056 ;; value of `mouse-grabbed-buffer' while the minibuffer is active. If | |
| 1057 ;; the word under the mouse is a valid minibuffer completion, then it | |
| 1058 ;; is highlighted. | |
| 1059 ;; | |
| 1060 ;; We do some special voodoo when we're reading a pathname, because | |
| 1061 ;; the way filename completion works is funny. Possibly there's some | |
| 1062 ;; more general way this could be dealt with... | |
| 1063 ;; | |
| 1064 ;; We do some further voodoo when reading a pathname that is an | |
| 1065 ;; ange-ftp or efs path, because causing FTP activity as a result of | |
| 1066 ;; mouse motion is a really bad time. | |
| 1067 ;; | |
| 1068 (and minibuffer-smart-completion-tracking-behavior | |
| 1069 (event-point event) | |
| 1070 ;; avoid conflict with display-completion-list extents | |
| 1071 (not (extent-at (event-point event) | |
| 1072 (event-buffer event) | |
| 1073 'list-mode-item)) | |
| 1074 (let ((filename-kludge-p (eq minibuffer-completion-table | |
| 1075 'read-file-name-internal))) | |
| 1076 (mode-motion-highlight-internal | |
| 1077 event | |
| 1078 #'(lambda () (default-mouse-track-beginning-of-word | |
| 1079 (if filename-kludge-p 'nonwhite t))) | |
| 1080 #'(lambda () | |
| 1081 (let ((p (point)) | |
| 1082 (string "")) | |
| 1083 (default-mouse-track-end-of-word | |
| 1084 (if filename-kludge-p 'nonwhite t)) | |
| 1085 (if (and (/= p (point)) minibuffer-completion-table) | |
| 1086 (setq string (buffer-substring p (point)))) | |
| 1087 (if (string-match "\\`[ \t\n]*\\'" string) | |
| 1088 (goto-char p) | |
| 1089 (if filename-kludge-p | |
| 1090 (setq string (minibuffer-smart-select-kludge-filename | |
| 1091 string))) | |
| 1092 ;; try-completion bogusly returns a string even when | |
| 1093 ;; that string is complete if that string is also a | |
| 1094 ;; prefix for other completions. This means that we | |
| 1095 ;; can't just do the obvious thing, (eq t | |
| 1096 ;; (try-completion ...)). | |
| 1097 (let (comp) | |
| 1098 (if (and filename-kludge-p | |
| 1099 ;; #### evil evil evil evil | |
| 1100 (or (and (fboundp 'ange-ftp-ftp-path) | |
| 502 | 1101 (declare-fboundp |
| 1102 (ange-ftp-ftp-path string))) | |
| 428 | 1103 (and (fboundp 'efs-ftp-path) |
| 502 | 1104 (declare-fboundp |
| 1105 (efs-ftp-path string))))) | |
| 428 | 1106 (setq comp t) |
| 1107 (setq comp | |
| 1108 (try-completion string | |
| 1109 minibuffer-completion-table | |
| 1110 minibuffer-completion-predicate))) | |
| 1111 (or (eq comp t) | |
| 1112 (and (equal comp string) | |
| 1113 (or (null minibuffer-completion-predicate) | |
| 1114 (stringp | |
| 1115 minibuffer-completion-predicate) ; ??? | |
| 1116 (funcall minibuffer-completion-predicate | |
| 1117 (if (vectorp | |
| 1118 minibuffer-completion-table) | |
| 1119 (intern-soft | |
| 1120 string | |
| 1121 minibuffer-completion-table) | |
| 1122 string)))) | |
| 1123 (goto-char p)))))))))) | |
| 1124 | |
| 1125 (defun minibuffer-smart-select-kludge-filename (string) | |
| 1126 (save-excursion | |
| 1127 (set-buffer mouse-grabbed-buffer) ; the minibuf | |
| 1128 (let ((kludge-string (concat (buffer-string) string))) | |
| 1129 (if (or (and (fboundp 'ange-ftp-ftp-path) | |
| 502 | 1130 (declare-fboundp (ange-ftp-ftp-path kludge-string))) |
| 1131 (and (fboundp 'efs-ftp-path) | |
| 1132 (declare-fboundp (efs-ftp-path kludge-string)))) | |
| 1133 ;; #### evil evil evil, but more so. | |
| 1134 string | |
| 1135 (append-expand-filename (buffer-string) string))))) | |
| 428 | 1136 |
| 1137 (defun minibuffer-smart-select-highlighted-completion (event) | |
| 1138 "Select the highlighted text under the mouse as a minibuffer response. | |
| 1139 When the minibuffer is being used to prompt the user for a completion, | |
| 1140 any valid completions which are visible on the frame will highlight | |
| 1141 when the mouse moves over them. Clicking \\<minibuffer-local-map>\ | |
| 1142 \\[minibuffer-smart-select-highlighted-completion] will select the | |
| 1143 highlighted completion under the mouse. | |
| 1144 | |
| 1145 If the mouse is clicked while not over a highlighted completion, | |
| 1146 then the global binding of \\[minibuffer-smart-select-highlighted-completion] \ | |
| 1147 will be executed instead. In this\nway you can get at the normal global \ | |
| 1148 behavior of \\[minibuffer-smart-select-highlighted-completion] as well as | |
| 1149 the special minibuffer behavior." | |
| 1150 (interactive "e") | |
| 1151 (if minibuffer-smart-completion-tracking-behavior | |
| 1152 (minibuffer-smart-select-highlighted-completion-1 event t) | |
| 1153 (let ((command (lookup-key global-map | |
| 1154 (vector current-mouse-event)))) | |
| 1155 (if command (call-interactively command))))) | |
| 1156 | |
| 1157 (defun minibuffer-smart-select-highlighted-completion-1 (event global-p) | |
| 1158 (let* ((filename-kludge-p (eq minibuffer-completion-table | |
| 1159 'read-file-name-internal)) | |
| 1160 completion | |
| 1161 command-p | |
| 1162 (evpoint (event-point event)) | |
| 1163 (evextent (and evpoint (extent-at evpoint (event-buffer event) | |
| 1164 'list-mode-item)))) | |
| 1165 (if evextent | |
| 1166 ;; avoid conflict with display-completion-list extents. | |
| 1167 ;; if we find one, do that behavior instead. | |
| 1168 (list-mode-item-selected-1 evextent event) | |
| 1169 (save-excursion | |
| 1170 (let* ((buffer (window-buffer (event-window event))) | |
| 1171 (p (event-point event)) | |
| 1172 (extent (and p (extent-at p buffer 'mouse-face)))) | |
| 1173 (set-buffer buffer) | |
| 1174 (if (not (and (extent-live-p extent) | |
| 1175 (eq (extent-object extent) (current-buffer)) | |
| 1176 (not (extent-detached-p extent)))) | |
| 1177 (setq command-p t) | |
| 1178 ;; ...else user has selected a highlighted completion. | |
| 1179 (setq completion | |
| 1180 (buffer-substring (extent-start-position extent) | |
| 1181 (extent-end-position extent))) | |
| 1182 (if filename-kludge-p | |
| 1183 (setq completion (minibuffer-smart-select-kludge-filename | |
| 1184 completion))) | |
| 1185 ;; remove the extent so that it's not hanging around in | |
| 1186 ;; *Completions* | |
| 1187 (detach-extent extent) | |
| 1188 (set-buffer mouse-grabbed-buffer) | |
| 1189 (erase-buffer) | |
| 1190 (insert completion)))) | |
| 1191 ;; we need to execute the command or do the throw outside of the | |
| 1192 ;; save-excursion. | |
| 1193 (cond ((and command-p global-p) | |
| 1194 (let ((command (lookup-key global-map | |
| 1195 (vector current-mouse-event)))) | |
| 1196 (if command | |
| 1197 (call-interactively command) | |
| 1198 (if minibuffer-completion-table | |
| 1199 (error | |
| 1200 "Highlighted words are valid completions. You may select one.") | |
| 1201 (error "no completions"))))) | |
| 1202 ((not command-p) | |
| 1203 ;; things get confused if the minibuffer is terminated while | |
| 1204 ;; not selected. | |
| 1205 (select-window (minibuffer-window)) | |
| 1206 (if (and filename-kludge-p (file-directory-p completion)) | |
| 1207 ;; if the user clicked middle on a directory name, display the | |
| 1208 ;; files in that directory. | |
| 1209 (progn | |
| 1210 (goto-char (point-max)) | |
| 1211 (minibuffer-completion-help)) | |
| 1212 ;; otherwise, terminate input | |
| 1213 (throw 'exit nil))))))) | |
| 1214 | |
| 1215 (defun minibuffer-smart-maybe-select-highlighted-completion | |
| 1216 (event &optional click-count) | |
| 444 | 1217 "Like `minibuffer-smart-select-highlighted-completion' but does nothing if |
| 428 | 1218 there is no completion (as opposed to executing the global binding). Useful |
| 1219 as the value of `mouse-track-click-hook'." | |
| 1220 (interactive "e") | |
| 1221 (minibuffer-smart-select-highlighted-completion-1 event nil)) | |
| 1222 | |
| 1223 (define-key minibuffer-local-map 'button2 | |
| 1224 'minibuffer-smart-select-highlighted-completion) | |
| 1225 | |
| 1226 | |
| 1227 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1228 ;;;; Minibuffer History ;;;; | |
| 1229 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1230 | |
| 1231 (defvar minibuffer-history '() | |
| 1232 "Default minibuffer history list. | |
| 1233 This is used for all minibuffer input except when an alternate history | |
| 1234 list is specified.") | |
| 1235 | |
| 1236 ;; Some other history lists: | |
| 1237 ;; | |
| 1238 (defvar minibuffer-history-search-history '()) | |
| 1239 (defvar function-history '()) | |
| 1240 (defvar variable-history '()) | |
| 1241 (defvar buffer-history '()) | |
| 1242 (defvar shell-command-history '()) | |
| 1243 (defvar file-name-history '()) | |
| 1244 | |
| 1245 (defvar read-expression-history nil) | |
| 1246 | |
| 1247 (defvar minibuffer-history-sexp-flag nil ;weird FSF Emacs kludge | |
| 1248 "Non-nil when doing history operations on `command-history'. | |
| 1249 More generally, indicates that the history list being acted on | |
| 1250 contains expressions rather than strings.") | |
| 1251 | |
| 1252 (defun previous-matching-history-element (regexp n) | |
| 1253 "Find the previous history element that matches REGEXP. | |
| 1254 \(Previous history elements refer to earlier actions.) | |
| 1255 With prefix argument N, search for Nth previous match. | |
| 1256 If N is negative, find the next or Nth next match." | |
| 1257 (interactive | |
| 1258 (let ((enable-recursive-minibuffers t) | |
| 438 | 1259 (minibuffer-history-sexp-flag nil) |
| 1260 (minibuffer-max-depth (and minibuffer-max-depth | |
| 1261 (1+ minibuffer-max-depth)))) | |
| 428 | 1262 (if (eq 't (symbol-value minibuffer-history-variable)) |
| 1263 (error "History is not being recorded in this context")) | |
| 1264 (list (read-from-minibuffer "Previous element matching (regexp): " | |
| 1265 (car minibuffer-history-search-history) | |
| 1266 minibuffer-local-map | |
| 1267 nil | |
| 1268 'minibuffer-history-search-history) | |
| 1269 (prefix-numeric-value current-prefix-arg)))) | |
| 1270 (let ((history (symbol-value minibuffer-history-variable)) | |
| 1271 prevpos | |
| 1272 (pos minibuffer-history-position)) | |
| 1273 (if (eq history t) | |
| 1274 (error "History is not being recorded in this context")) | |
| 1275 (while (/= n 0) | |
| 1276 (setq prevpos pos) | |
| 1277 (setq pos (min (max 1 (+ pos (if (< n 0) -1 1))) (length history))) | |
| 1278 (if (= pos prevpos) | |
| 1279 (if (= pos 1) ;; rewritten for I18N3 snarfing | |
| 1280 (error "No later matching history item") | |
| 1281 (error "No earlier matching history item"))) | |
| 1282 (if (string-match regexp | |
| 1283 (if minibuffer-history-sexp-flag | |
| 1284 (let ((print-level nil)) | |
| 1285 (prin1-to-string (nth (1- pos) history))) | |
| 1286 (nth (1- pos) history))) | |
| 1287 (setq n (+ n (if (< n 0) 1 -1))))) | |
| 1288 (setq minibuffer-history-position pos) | |
| 1289 (setq current-minibuffer-contents (buffer-string) | |
| 1290 current-minibuffer-point (point)) | |
| 1291 (erase-buffer) | |
| 1292 (let ((elt (nth (1- pos) history))) | |
| 1293 (insert (if minibuffer-history-sexp-flag | |
| 1294 (let ((print-level nil)) | |
| 1295 (prin1-to-string elt)) | |
| 1296 elt))) | |
| 1297 (goto-char (point-min))) | |
| 1298 (if (or (eq (car (car command-history)) 'previous-matching-history-element) | |
| 1299 (eq (car (car command-history)) 'next-matching-history-element)) | |
| 1300 (setq command-history (cdr command-history)))) | |
| 1301 | |
| 1302 (defun next-matching-history-element (regexp n) | |
| 1303 "Find the next history element that matches REGEXP. | |
| 1304 \(The next history element refers to a more recent action.) | |
| 1305 With prefix argument N, search for Nth next match. | |
| 1306 If N is negative, find the previous or Nth previous match." | |
| 1307 (interactive | |
| 1308 (let ((enable-recursive-minibuffers t) | |
| 438 | 1309 (minibuffer-history-sexp-flag nil) |
| 1310 (minibuffer-max-depth (and minibuffer-max-depth | |
| 1311 (1+ minibuffer-max-depth)))) | |
| 428 | 1312 (if (eq t (symbol-value minibuffer-history-variable)) |
| 1313 (error "History is not being recorded in this context")) | |
| 1314 (list (read-from-minibuffer "Next element matching (regexp): " | |
| 1315 (car minibuffer-history-search-history) | |
| 1316 minibuffer-local-map | |
| 1317 nil | |
| 1318 'minibuffer-history-search-history) | |
| 1319 (prefix-numeric-value current-prefix-arg)))) | |
| 1320 (previous-matching-history-element regexp (- n))) | |
| 1321 | |
| 1322 (defun next-history-element (n) | |
| 1323 "Insert the next element of the minibuffer history into the minibuffer." | |
| 1324 (interactive "p") | |
| 1325 (if (eq 't (symbol-value minibuffer-history-variable)) | |
| 1326 (error "History is not being recorded in this context")) | |
| 1327 (unless (zerop n) | |
| 1328 (when (eq minibuffer-history-position | |
| 1329 initial-minibuffer-history-position) | |
| 1330 (setq current-minibuffer-contents (buffer-string) | |
| 1331 current-minibuffer-point (point))) | |
| 1332 (let ((narg (- minibuffer-history-position n)) | |
| 1333 (minimum (if minibuffer-default -1 0))) | |
| 442 | 1334 ;; a weird special case here; when in repeat-complex-command, we're |
| 1335 ;; trying to edit the top command, and minibuffer-history-position | |
| 1336 ;; points to 1, the next-to-top command. in this case, the top | |
| 1337 ;; command in the history is suppressed in favor of the one being | |
| 1338 ;; edited, and there is no more command below it, except maybe the | |
| 1339 ;; default. | |
| 1340 (if (and (zerop narg) (eq minibuffer-history-position | |
| 1341 initial-minibuffer-history-position)) | |
| 1342 (setq minimum (1+ minimum))) | |
| 428 | 1343 (cond ((< narg minimum) |
| 440 | 1344 (error (if minibuffer-default |
| 1345 "No following item in %s" | |
| 1346 "No following item in %s; no default available") | |
| 1347 minibuffer-history-variable)) | |
| 428 | 1348 ((> narg (length (symbol-value minibuffer-history-variable))) |
| 1349 (error "No preceding item in %s" minibuffer-history-variable))) | |
| 1350 (erase-buffer) | |
| 1351 (setq minibuffer-history-position narg) | |
| 1352 (if (eq narg initial-minibuffer-history-position) | |
| 1353 (progn | |
| 1354 (insert current-minibuffer-contents) | |
| 1355 (goto-char current-minibuffer-point)) | |
| 442 | 1356 (let ((elt (if (> narg 0) |
| 428 | 1357 (nth (1- minibuffer-history-position) |
| 1358 (symbol-value minibuffer-history-variable)) | |
| 1359 minibuffer-default))) | |
| 1360 (insert | |
| 1361 (if (not (stringp elt)) | |
| 1362 (let ((print-level nil)) | |
| 1363 (condition-case nil | |
| 1364 (let ((print-readably t) | |
| 1365 (print-escape-newlines t)) | |
| 1366 (prin1-to-string elt)) | |
| 1367 (error (prin1-to-string elt)))) | |
| 1368 elt))) | |
| 1369 ;; FSF has point-min here. | |
| 1370 (goto-char (point-max)))))) | |
| 1371 | |
| 1372 (defun previous-history-element (n) | |
| 1373 "Insert the previous element of the minibuffer history into the minibuffer." | |
| 1374 (interactive "p") | |
| 1375 (next-history-element (- n))) | |
| 1376 | |
| 1377 (defun next-complete-history-element (n) | |
| 1378 "Get next element of history which is a completion of minibuffer contents." | |
| 1379 (interactive "p") | |
| 1380 (let ((point-at-start (point))) | |
| 1381 (next-matching-history-element | |
| 1382 (concat "^" (regexp-quote (buffer-substring (point-min) (point)))) n) | |
| 1383 ;; next-matching-history-element always puts us at (point-min). | |
| 1384 ;; Move to the position we were at before changing the buffer contents. | |
| 1385 ;; This is still sensical, because the text before point has not changed. | |
| 1386 (goto-char point-at-start))) | |
| 1387 | |
| 1388 (defun previous-complete-history-element (n) | |
| 1389 "Get previous element of history which is a completion of minibuffer contents." | |
| 1390 (interactive "p") | |
| 1391 (next-complete-history-element (- n))) | |
| 1392 | |
| 1393 | |
| 1394 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1395 ;;;; reading various things from a minibuffer ;;;; | |
| 1396 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1397 | |
| 440 | 1398 (defun read-expression (prompt &optional initial-contents history default-value) |
| 1399 "Return a Lisp object read using the minibuffer, prompting with PROMPT. | |
| 1400 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert | |
| 1401 in the minibuffer before reading. | |
| 1402 Third arg HISTORY, if non-nil, specifies a history list. | |
| 1403 Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used | |
| 1404 for history command, and as the value to return if the user enters the | |
| 1405 empty string." | |
| 428 | 1406 (let ((minibuffer-history-sexp-flag t) |
| 1407 ;; Semi-kludge to get around M-x C-x o M-ESC trying to do completion. | |
| 1408 (minibuffer-completion-table nil)) | |
| 1409 (read-from-minibuffer prompt | |
| 1410 initial-contents | |
| 1411 read-expression-map | |
| 1412 t | |
| 1413 (or history 'read-expression-history) | |
| 440 | 1414 lisp-mode-abbrev-table |
| 1415 default-value))) | |
| 428 | 1416 |
| 440 | 1417 (defun read-string (prompt &optional initial-contents history default-value) |
| 428 | 1418 "Return a string from the minibuffer, prompting with string PROMPT. |
| 1419 If non-nil, optional second arg INITIAL-CONTENTS is a string to insert | |
| 440 | 1420 in the minibuffer before reading. |
| 1421 Third arg HISTORY, if non-nil, specifies a history list. | |
| 1422 Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used | |
| 1423 for history command, and as the value to return if the user enters the | |
| 1424 empty string." | |
| 428 | 1425 (let ((minibuffer-completion-table nil)) |
| 1426 (read-from-minibuffer prompt | |
| 1427 initial-contents | |
| 1428 minibuffer-local-map | |
| 440 | 1429 nil history nil default-value))) |
| 428 | 1430 |
| 440 | 1431 (defun eval-minibuffer (prompt &optional initial-contents history default-value) |
| 428 | 1432 "Return value of Lisp expression read using the minibuffer. |
| 1433 Prompt with PROMPT. If non-nil, optional second arg INITIAL-CONTENTS | |
| 1434 is a string to insert in the minibuffer before reading. | |
| 440 | 1435 Third arg HISTORY, if non-nil, specifies a history list. |
| 1436 Fourth arg DEFAULT-VALUE is the default value. If non-nil, it is used | |
| 1437 for history command, and as the value to return if the user enters the | |
| 1438 empty string." | |
| 1439 (eval (read-expression prompt initial-contents history default-value))) | |
| 428 | 1440 |
| 1441 ;; The name `command-history' is already taken | |
| 1442 (defvar read-command-history '()) | |
| 1443 | |
| 440 | 1444 (defun read-command (prompt &optional default-value) |
| 428 | 1445 "Read the name of a command and return as a symbol. |
| 440 | 1446 Prompts with PROMPT. By default, return DEFAULT-VALUE." |
| 428 | 1447 (intern (completing-read prompt obarray 'commandp t nil |
| 1448 ;; 'command-history is not right here: that's a | |
| 1449 ;; list of evalable forms, not a history list. | |
| 1450 'read-command-history | |
| 440 | 1451 default-value))) |
| 428 | 1452 |
| 440 | 1453 (defun read-function (prompt &optional default-value) |
| 428 | 1454 "Read the name of a function and return as a symbol. |
| 440 | 1455 Prompts with PROMPT. By default, return DEFAULT-VALUE." |
| 428 | 1456 (intern (completing-read prompt obarray 'fboundp t nil |
| 440 | 1457 'function-history default-value))) |
| 428 | 1458 |
| 440 | 1459 (defun read-variable (prompt &optional default-value) |
| 428 | 1460 "Read the name of a user variable and return it as a symbol. |
| 440 | 1461 Prompts with PROMPT. By default, return DEFAULT-VALUE. |
| 428 | 1462 A user variable is one whose documentation starts with a `*' character." |
| 1463 (intern (completing-read prompt obarray 'user-variable-p t nil | |
| 442 | 1464 'variable-history |
| 1465 (if (symbolp default-value) | |
| 1466 (symbol-name default-value) | |
| 1467 default-value)))) | |
| 428 | 1468 |
|
4734
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1469 (defun read-buffer (prompt &optional default require-match exclude) |
| 428 | 1470 "Read the name of a buffer and return as a string. |
| 1471 Prompts with PROMPT. Optional second arg DEFAULT is value to return if user | |
| 1472 enters an empty line. If optional third arg REQUIRE-MATCH is non-nil, | |
|
4734
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1473 only existing buffer names are allowed. Optional fourth argument EXCLUDE is |
|
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1474 a buffer or a list of buffers to exclude from the completion list." |
|
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1475 (when (bufferp exclude) |
|
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1476 (setq exclude (list exclude))) |
| 428 | 1477 (let ((prompt (if default |
| 1478 (format "%s(default %s) " | |
| 1479 (gettext prompt) (if (bufferp default) | |
| 1480 (buffer-name default) | |
| 1481 default)) | |
|
4734
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1482 prompt)) |
|
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1483 (alist (mapcar #'(lambda (b) (cons (buffer-name b) b)) |
|
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1484 (remove-if (lambda (elt) (member elt exclude)) |
|
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1485 (buffer-list)))) |
|
74a5eaa67982
Make switch-to-buffer completion avoid current buffer.
Didier Verna <didier@xemacs.org>
parents:
4720
diff
changeset
|
1486 result) |
| 428 | 1487 (while (progn |
| 1488 (setq result (completing-read prompt alist nil require-match | |
| 430 | 1489 nil 'buffer-history |
| 434 | 1490 (if (bufferp default) |
| 1491 (buffer-name default) | |
| 1492 default))) | |
| 428 | 1493 (cond ((not (equal result "")) |
| 1494 nil) | |
| 1495 ((not require-match) | |
| 1496 (setq result default) | |
| 1497 nil) | |
| 1498 ((not default) | |
| 3000 | 1499 nil) |
| 428 | 1500 ((not (get-buffer default)) |
| 1501 t) | |
| 1502 (t | |
| 1503 (setq result default) | |
| 1504 nil)))) | |
| 1505 (if (bufferp result) | |
| 1506 (buffer-name result) | |
| 1507 result))) | |
| 1508 | |
| 440 | 1509 (defun read-number (prompt &optional integers-only default-value) |
| 1510 "Read a number from the minibuffer, prompting with PROMPT. | |
| 1511 If optional second argument INTEGERS-ONLY is non-nil, accept | |
| 1512 only integer input. | |
| 1513 If DEFAULT-VALUE is non-nil, return that if user enters an empty | |
| 1514 line." | |
| 428 | 1515 (let ((pred (if integers-only 'integerp 'numberp)) |
| 1516 num) | |
| 1517 (while (not (funcall pred num)) | |
| 1518 (setq num (condition-case () | |
| 1519 (let ((minibuffer-completion-table nil)) | |
| 1520 (read-from-minibuffer | |
| 1521 prompt (if num (prin1-to-string num)) nil t | |
| 440 | 1522 nil nil default-value)) |
| 428 | 1523 (input-error nil) |
| 1524 (invalid-read-syntax nil) | |
| 1525 (end-of-file nil))) | |
| 1526 (or (funcall pred num) (beep))) | |
| 1527 num)) | |
| 1528 | |
| 440 | 1529 (defun read-shell-command (prompt &optional initial-input history default-value) |
| 428 | 1530 "Just like read-string, but uses read-shell-command-map: |
| 1531 \\{read-shell-command-map}" | |
| 1532 (let ((minibuffer-completion-table nil)) | |
| 1533 (read-from-minibuffer prompt initial-input read-shell-command-map | |
| 440 | 1534 nil (or history 'shell-command-history) |
| 1535 nil default-value))) | |
| 428 | 1536 |
| 1537 | |
| 1538 ;;; This read-file-name stuff probably belongs in files.el | |
| 1539 | |
| 1540 ;; Quote "$" as "$$" to get it past substitute-in-file-name | |
| 1541 (defun un-substitute-in-file-name (string) | |
| 1542 (let ((regexp "\\$") | |
| 1543 (olen (length string)) | |
| 1544 new | |
| 1545 n o ch) | |
| 1546 (if (not (string-match regexp string)) | |
| 1547 string | |
| 1548 (setq n 1) | |
| 1549 (while (string-match regexp string (match-end 0)) | |
| 1550 (setq n (1+ n))) | |
| 1551 (setq new (make-string (+ olen n) ?$)) | |
| 1552 (setq n 0 o 0) | |
| 1553 (while (< o olen) | |
| 1554 (setq ch (aref string o)) | |
| 1555 (aset new n ch) | |
| 1556 (setq o (1+ o) n (1+ n)) | |
| 1557 (if (eq ch ?$) | |
| 1558 ;; already aset by make-string initial-value | |
| 1559 (setq n (1+ n)))) | |
| 1560 new))) | |
| 1561 | |
| 442 | 1562 |
| 1563 ;; Wrapper for `directory-files' for use in generating completion lists. | |
| 1564 ;; Generates output in the same format as `file-name-all-completions'. | |
| 1565 ;; | |
| 1566 ;; The EFS replacement for `directory-files' doesn't support the FILES-ONLY | |
| 1567 ;; option, so it has to be faked. The listing cache will hopefully | |
| 1568 ;; improve the performance of this operation. | |
| 1569 (defun minibuf-directory-files (dir &optional match-regexp files-only) | |
| 1570 (let ((want-file (or (eq files-only nil) (eq files-only t))) | |
| 1571 (want-dirs (or (eq files-only nil) (not (eq files-only t))))) | |
|
5267
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1572 (mapcan |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1573 #'(lambda (f) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1574 (and (not (equal "." f)) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1575 (if (file-directory-p (expand-file-name f dir)) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1576 (and want-dirs (list (file-name-as-directory f))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1577 (and want-file (list f))))) |
|
668c73e222fd
Change forms like (delq nil (mapcar ...)) to (mapcan ...).
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
1578 (directory-files dir nil match-regexp)))) |
| 442 | 1579 |
| 1580 | |
| 428 | 1581 (defun read-file-name-2 (history prompt dir default |
| 1582 must-match initial-contents | |
| 1583 completer) | |
| 1584 (if (not dir) | |
| 1585 (setq dir default-directory)) | |
| 1586 (setq dir (abbreviate-file-name dir t)) | |
| 1587 (let* ((insert (cond ((and (not insert-default-directory) | |
| 1588 (not initial-contents)) | |
| 1589 "") | |
| 1590 (initial-contents | |
| 1591 (cons (un-substitute-in-file-name | |
| 1592 (concat dir initial-contents)) | |
| 1593 (length dir))) | |
| 1594 (t | |
| 1595 (un-substitute-in-file-name dir)))) | |
| 1596 (val | |
| 1597 ;; Hateful, broken, case-sensitive un*x | |
| 1598 ;;; (completing-read prompt | |
| 1599 ;;; completer | |
| 1600 ;;; dir | |
| 1601 ;;; must-match | |
| 1602 ;;; insert | |
| 1603 ;;; history) | |
| 1604 ;; #### - this is essentially the guts of completing read. | |
| 1605 ;; There should be an elegant way to pass a pair of keymaps to | |
| 1606 ;; completing read, but this will do for now. All sins are | |
| 1607 ;; relative. --Stig | |
| 1608 (let ((minibuffer-completion-table completer) | |
| 1609 (minibuffer-completion-predicate dir) | |
| 1610 (minibuffer-completion-confirm (if (eq must-match 't) | |
| 1611 nil t)) | |
| 1612 (last-exact-completion nil)) | |
| 1613 (read-from-minibuffer prompt | |
| 1614 insert | |
| 1615 (if (not must-match) | |
| 1616 read-file-name-map | |
| 1617 read-file-name-must-match-map) | |
| 1618 nil | |
| 434 | 1619 history |
| 1620 nil | |
| 1621 default)))) | |
| 428 | 1622 ;;; ;; Kludge! Put "/foo/bar" on history rather than "/default//foo/bar" |
| 1623 ;;; (let ((hist (cond ((not history) 'minibuffer-history) | |
| 1624 ;;; ((consp history) (car history)) | |
| 1625 ;;; (t history)))) | |
| 1626 ;;; (if (and val | |
| 1627 ;;; hist | |
| 1628 ;;; (not (eq hist 't)) | |
| 1629 ;;; (boundp hist) | |
| 1630 ;;; (equal (car-safe (symbol-value hist)) val)) | |
| 1631 ;;; (let ((e (condition-case nil | |
| 1632 ;;; (expand-file-name val) | |
| 1633 ;;; (error nil)))) | |
| 1634 ;;; (if (and e (not (equal e val))) | |
| 1635 ;;; (set hist (cons e (cdr (symbol-value hist)))))))) | |
| 1636 | |
| 1637 (cond ((not val) | |
| 1638 (error "No file name specified")) | |
| 1639 ((and default | |
| 1640 (equal val (if (consp insert) (car insert) insert))) | |
| 1641 default) | |
| 1642 (t | |
| 1643 (substitute-in-file-name val))))) | |
| 1644 | |
| 1645 ;; #### this function should use minibuffer-completion-table | |
| 1646 ;; or something. But that is sloooooow. | |
| 1647 ;; #### all this shit needs better documentation!!!!!!!! | |
| 1648 (defun read-file-name-activate-callback (event extent dir-p) | |
| 1649 ;; used as the activate-callback of the filename list items | |
| 1650 ;; in the completion buffer, in place of default-choose-completion. | |
| 1651 ;; if a regular file was selected, we call default-choose-completion | |
| 1652 ;; (which just inserts the string in the minibuffer and calls | |
| 1653 ;; exit-minibuffer). If a directory was selected, we display | |
| 1654 ;; the contents of the directory. | |
| 1655 (let* ((file (extent-string extent)) | |
| 1656 (completion-buf (extent-object extent)) | |
| 1657 (minibuf (symbol-value-in-buffer 'completion-reference-buffer | |
| 1658 completion-buf)) | |
| 1659 (in-dir (file-name-directory (buffer-substring nil nil minibuf))) | |
| 1660 (full (expand-file-name file in-dir))) | |
| 1661 (if (not (file-directory-p full)) | |
| 1662 (default-choose-completion event extent minibuf) | |
| 1663 (erase-buffer minibuf) | |
| 1664 (insert-string (file-name-as-directory | |
| 1665 (abbreviate-file-name full t)) minibuf) | |
| 1666 (reset-buffer completion-buf) | |
| 1667 (let ((standard-output completion-buf)) | |
| 1668 (display-completion-list | |
| 442 | 1669 (minibuf-directory-files full nil (if dir-p 'directory)) |
| 428 | 1670 :user-data dir-p |
| 1671 :reference-buffer minibuf | |
| 1672 :activate-callback 'read-file-name-activate-callback) | |
| 1673 (goto-char (point-min) completion-buf))))) | |
| 1674 | |
| 673 | 1675 (defun read-file-name-1 (type history prompt dir default |
| 1676 must-match initial-contents | |
| 1677 completer) | |
| 428 | 1678 (if (should-use-dialog-box-p) |
| 442 | 1679 (condition-case nil |
| 1680 (let ((file | |
| 1681 (apply #'make-dialog-box | |
| 673 | 1682 type `(:title ,(capitalize-string-as-title |
| 1683 ;; Kludge: Delete ": " off the end. | |
| 1684 (replace-in-string prompt ": $" "")) | |
| 1685 ,@(and dir (list :initial-directory | |
| 1686 dir)) | |
| 1687 :file-must-exist ,must-match | |
| 1688 ,@(and initial-contents | |
| 1689 (list :initial-filename | |
| 1690 initial-contents)))))) | |
| 442 | 1691 ;; hack -- until we implement reading a directory properly, |
| 1692 ;; allow a file as indicating the directory it's in | |
| 1693 (if (and (eq completer 'read-directory-name-internal) | |
| 1694 (not (file-directory-p file))) | |
| 1695 (file-name-directory file) | |
| 1696 file)) | |
| 1697 (unimplemented | |
| 1698 ;; this calls read-file-name-2 | |
| 1699 (mouse-read-file-name-1 history prompt dir default must-match | |
| 1700 initial-contents completer) | |
| 1701 )) | |
| 1702 (add-one-shot-hook | |
| 1703 'minibuffer-setup-hook | |
| 1704 (lambda () | |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4675
diff
changeset
|
1705 (and (file-system-ignore-case-p (or dir default-directory)) |
| 442 | 1706 (set (make-local-variable 'completion-ignore-case) t)) |
| 1707 (set | |
| 1708 (make-local-variable | |
| 1709 'completion-display-completion-list-function) | |
| 1710 #'(lambda (completions) | |
| 1711 (display-completion-list | |
| 1712 completions | |
| 1713 :user-data (not (eq completer 'read-file-name-internal)) | |
| 1714 :activate-callback | |
| 1715 'read-file-name-activate-callback))))) | |
| 1716 (read-file-name-2 history prompt dir default must-match | |
| 1717 initial-contents completer))) | |
| 428 | 1718 |
| 1719 (defun read-file-name (prompt | |
| 1720 &optional dir default must-match initial-contents | |
| 1721 history) | |
| 1722 "Read file name, prompting with PROMPT and completing in directory DIR. | |
| 1723 This will prompt with a dialog box if appropriate, according to | |
| 1724 `should-use-dialog-box-p'. | |
| 1725 Value is not expanded---you must call `expand-file-name' yourself. | |
| 438 | 1726 Value is subject to interpretation by `substitute-in-file-name' however. |
| 428 | 1727 Default name to DEFAULT if user enters a null string. |
| 1728 (If DEFAULT is omitted, the visited file name is used, | |
| 1729 except that if INITIAL-CONTENTS is specified, that combined with DIR is | |
| 1730 used.) | |
| 1731 Fourth arg MUST-MATCH non-nil means require existing file's name. | |
| 1732 Non-nil and non-t means also require confirmation after completion. | |
| 440 | 1733 Fifth arg INITIAL-CONTENTS specifies text to start with. If this is not |
| 1734 specified, and `insert-default-directory' is non-nil, DIR or the current | |
| 1735 directory will be used. | |
| 428 | 1736 Sixth arg HISTORY specifies the history list to use. Default is |
| 1737 `file-name-history'. | |
| 1738 DIR defaults to current buffer's directory default." | |
| 673 | 1739 (read-file-name-1 |
| 1740 'file (or history 'file-name-history) | |
| 428 | 1741 prompt dir (or default |
| 440 | 1742 (and initial-contents |
| 1743 (abbreviate-file-name (expand-file-name | |
| 1744 initial-contents dir) t)) | |
| 1745 (and buffer-file-truename | |
| 1746 (abbreviate-file-name buffer-file-name t))) | |
| 428 | 1747 must-match initial-contents |
| 1748 ;; A separate function (not an anonymous lambda-expression) | |
| 1749 ;; and passed as a symbol because of disgusting kludges in various | |
| 1750 ;; places which do stuff like (let ((filename-kludge-p (eq minibuffer-completion-table 'read-file-name-internal))) ...) | |
| 1751 'read-file-name-internal)) | |
| 1752 | |
| 1753 (defun read-directory-name (prompt | |
| 1754 &optional dir default must-match initial-contents | |
| 1755 history) | |
| 1756 "Read directory name, prompting with PROMPT and completing in directory DIR. | |
| 1757 This will prompt with a dialog box if appropriate, according to | |
| 1758 `should-use-dialog-box-p'. | |
| 1759 Value is not expanded---you must call `expand-file-name' yourself. | |
| 1760 Value is subject to interpreted by substitute-in-file-name however. | |
| 1761 Default name to DEFAULT if user enters a null string. | |
| 1762 (If DEFAULT is omitted, the current buffer's default directory is used.) | |
| 1763 Fourth arg MUST-MATCH non-nil means require existing directory's name. | |
| 1764 Non-nil and non-t means also require confirmation after completion. | |
| 1765 Fifth arg INITIAL-CONTENTS specifies text to start with. | |
| 1766 Sixth arg HISTORY specifies the history list to use. Default is | |
| 1767 `file-name-history'. | |
| 1768 DIR defaults to current buffer's directory default." | |
| 1769 (read-file-name-1 | |
| 673 | 1770 'directory (or history 'file-name-history) |
| 1771 prompt dir (or default default-directory) must-match initial-contents | |
| 1772 'read-directory-name-internal)) | |
| 428 | 1773 |
| 1774 | |
| 1775 ;; Environment-variable and ~username completion hack | |
| 1776 (defun read-file-name-internal-1 (string dir action completer) | |
| 1777 (if (not (string-match | |
| 1778 "\\([^$]\\|\\`\\)\\(\\$\\$\\)*\\$\\([A-Za-z0-9_]*\\|{[^}]*\\)\\'" | |
| 1779 string)) | |
| 1780 ;; Not doing environment-variable completion hack | |
| 1781 (let* ((orig (if (equal string "") nil string)) | |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4675
diff
changeset
|
1782 (completion-ignore-case (file-system-ignore-case-p |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4675
diff
changeset
|
1783 (or dir default-directory))) |
| 428 | 1784 (sstring (if orig (substitute-in-file-name string) string)) |
| 1785 (specdir (if orig (file-name-directory sstring) nil)) | |
| 1786 (name (if orig (file-name-nondirectory sstring) string)) | |
| 1787 (direct (if specdir (expand-file-name specdir dir) dir))) | |
| 1788 ;; ~username completion | |
| 1789 (if (and (fboundp 'user-name-completion-1) | |
| 1790 (string-match "^[~]" name)) | |
| 1791 (let ((user (substring name 1))) | |
| 1792 (cond ((eq action 'lambda) | |
| 1793 (file-directory-p name)) | |
| 1794 ((eq action 't) | |
| 1795 ;; all completions | |
| 1796 (mapcar #'(lambda (p) (concat "~" p)) | |
| 502 | 1797 (declare-fboundp |
| 1798 (user-name-all-completions user)))) | |
| 428 | 1799 (t;; 'nil |
| 1800 ;; complete | |
| 502 | 1801 (let* ((val+uniq (declare-fboundp |
| 1802 (user-name-completion-1 user))) | |
| 428 | 1803 (val (car val+uniq)) |
| 1804 (uniq (cdr val+uniq))) | |
| 1805 (cond ((stringp val) | |
| 1806 (if uniq | |
| 1807 (file-name-as-directory (concat "~" val)) | |
| 1808 (concat "~" val))) | |
| 1809 ((eq val t) | |
| 1810 (file-name-as-directory name)) | |
| 1811 (t nil)))))) | |
| 1812 (funcall completer | |
| 1813 action | |
| 1814 orig | |
| 1815 sstring | |
| 1816 specdir | |
| 1817 direct | |
| 1818 name))) | |
| 1819 ;; An odd number of trailing $'s | |
| 1820 (let* ((start (match-beginning 3)) | |
|
4720
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4675
diff
changeset
|
1821 (completion-ignore-case (file-system-ignore-case-p |
|
3c92890f3750
Add `file-system-ignore-case-p', use it.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4675
diff
changeset
|
1822 (or dir default-directory))) |
| 428 | 1823 (env (substring string |
| 1824 (cond ((= start (length string)) | |
| 1825 ;; "...$" | |
| 1826 start) | |
| 1827 ((= (aref string start) ?{) | |
| 1828 ;; "...${..." | |
| 1829 (1+ start)) | |
| 1830 (t | |
| 1831 start)))) | |
| 1832 (head (substring string 0 (1- start))) | |
| 1833 (alist #'(lambda () | |
| 1834 (mapcar #'(lambda (x) | |
| 1835 (cons (substring x 0 (string-match "=" x)) | |
| 1836 nil)) | |
| 1837 process-environment)))) | |
| 1838 | |
| 1839 (cond ((eq action 'lambda) | |
| 1840 nil) | |
| 1841 ((eq action 't) | |
| 1842 ;; all completions | |
| 1843 (mapcar #'(lambda (p) | |
| 1844 (if (and (> (length p) 0) | |
| 1845 ;;#### Unix-specific | |
| 1846 ;;#### -- need absolute-pathname-p | |
| 1847 (/= (aref p 0) ?/)) | |
| 1848 (concat "$" p) | |
| 1849 (concat head "$" p))) | |
| 1850 (all-completions env (funcall alist)))) | |
| 1851 (t ;; nil | |
| 1852 ;; complete | |
| 1853 (let* ((e (funcall alist)) | |
| 1854 (val (try-completion env e))) | |
| 1855 (cond ((stringp val) | |
| 1856 (if (string-match "[^A-Za-z0-9_]" val) | |
| 1857 (concat head | |
| 1858 "${" val | |
| 1859 ;; completed uniquely? | |
| 1860 (if (eq (try-completion val e) 't) | |
| 1861 "}" "")) | |
| 1862 (concat head "$" val))) | |
| 1863 ((eql val 't) | |
| 1864 (concat head | |
| 1865 (un-substitute-in-file-name (getenv env)))) | |
| 1866 (t nil)))))))) | |
| 1867 | |
| 1868 | |
| 1869 (defun read-file-name-internal (string dir action) | |
| 1870 (read-file-name-internal-1 | |
| 1871 string dir action | |
| 1872 #'(lambda (action orig string specdir dir name) | |
| 1873 (cond ((eq action 'lambda) | |
| 1874 (if (not orig) | |
| 1875 nil | |
| 1876 (let ((sstring (condition-case nil | |
| 1877 (expand-file-name string) | |
| 1878 (error nil)))) | |
| 1879 (if (not sstring) | |
| 1880 ;; Some pathname syntax error in string | |
| 1881 nil | |
| 1882 (file-exists-p sstring))))) | |
| 1883 ((eq action 't) | |
| 1884 ;; all completions | |
| 1885 (mapcar #'un-substitute-in-file-name | |
| 442 | 1886 (if (string= name "") |
| 1887 (delete "./" (file-name-all-completions "" dir)) | |
| 1888 (file-name-all-completions name dir)))) | |
| 428 | 1889 (t;; nil |
| 1890 ;; complete | |
| 1891 (let* ((d (or dir default-directory)) | |
| 1892 (val (file-name-completion name d))) | |
| 1893 (if (and (eq val 't) | |
| 1894 (not (null completion-ignored-extensions))) | |
| 1895 ;;#### (file-name-completion "foo") returns 't | |
| 1896 ;; when both "foo" and "foo~" exist and the latter | |
| 1897 ;; is "pruned" by completion-ignored-extensions. | |
| 1898 ;; I think this is a bug in file-name-completion. | |
| 1899 (setq val (let ((completion-ignored-extensions '())) | |
| 1900 (file-name-completion name d)))) | |
| 1901 (if (stringp val) | |
| 1902 (un-substitute-in-file-name (if specdir | |
| 1903 (concat specdir val) | |
| 1904 val)) | |
| 1905 (let ((tem (un-substitute-in-file-name string))) | |
| 1906 (if (not (equal tem orig)) | |
| 1907 ;; substitute-in-file-name did something | |
| 1908 tem | |
| 1909 val))))))))) | |
| 1910 | |
| 1911 (defun read-directory-name-internal (string dir action) | |
| 1912 (read-file-name-internal-1 | |
| 1913 string dir action | |
| 1914 #'(lambda (action orig string specdir dir name) | |
| 1915 (let* ((dirs #'(lambda (fn) | |
| 1916 (let ((l (if (equal name "") | |
| 442 | 1917 (minibuf-directory-files |
| 428 | 1918 dir |
| 1919 "" | |
| 1920 'directories) | |
| 442 | 1921 (minibuf-directory-files |
| 428 | 1922 dir |
| 1923 (concat "\\`" (regexp-quote name)) | |
| 1924 'directories)))) | |
| 1925 (mapcar fn | |
| 1926 ;; Wretched unix | |
| 1927 (delete "." l)))))) | |
| 1928 (cond ((eq action 'lambda) | |
| 1929 ;; complete? | |
| 1930 (if (not orig) | |
| 1931 nil | |
| 1932 (file-directory-p string))) | |
| 1933 ((eq action 't) | |
| 1934 ;; all completions | |
| 1935 (funcall dirs #'(lambda (n) | |
| 1936 (un-substitute-in-file-name | |
| 1937 (file-name-as-directory n))))) | |
| 1938 (t | |
| 1939 ;; complete | |
| 1940 (let ((val (try-completion | |
| 1941 name | |
| 1942 (funcall dirs | |
| 1943 #'(lambda (n) | |
| 1944 (list (file-name-as-directory | |
| 1945 n))))))) | |
| 1946 (if (stringp val) | |
| 1947 (un-substitute-in-file-name (if specdir | |
| 1948 (concat specdir val) | |
| 1949 val)) | |
| 1950 (let ((tem (un-substitute-in-file-name string))) | |
| 1951 (if (not (equal tem orig)) | |
| 1952 ;; substitute-in-file-name did something | |
| 1953 tem | |
| 1954 val)))))))))) | |
| 1955 | |
| 1956 (defun append-expand-filename (file-string string) | |
| 1957 "Append STRING to FILE-STRING differently depending on whether STRING | |
| 1958 is a username (~string), an environment variable ($string), | |
| 1959 or a filename (/string). The resultant string is returned with the | |
| 1960 environment variable or username expanded and resolved to indicate | |
| 1961 whether it is a file(/result) or a directory (/result/)." | |
| 1962 (let ((file | |
| 1963 (cond ((string-match "\\([~$]\\)\\([^~$/]*\\)$" file-string) | |
| 1964 (cond ((string= (substring file-string | |
| 1965 (match-beginning 1) | |
| 1966 (match-end 1)) "~") | |
| 1967 (concat (substring file-string 0 (match-end 1)) | |
| 1968 string)) | |
| 1969 (t (substitute-in-file-name | |
| 1970 (concat (substring file-string 0 (match-end 1)) | |
| 1971 string))))) | |
| 1972 (t (concat (file-name-directory | |
| 1973 (substitute-in-file-name file-string)) string)))) | |
| 1974 result) | |
| 1975 | |
| 1976 (cond ((stringp (setq result (and (file-exists-p (expand-file-name file)) | |
| 1977 (read-file-name-internal | |
| 1978 (condition-case nil | |
| 1979 (expand-file-name file) | |
| 1980 (error file)) | |
| 1981 "" nil)))) | |
| 1982 result) | |
| 1983 (t file)))) | |
| 1984 | |
| 442 | 1985 (defun mouse-rfn-setup-vars (prompt) |
| 1986 ;; a specifier would be nice. | |
| 1987 (set (make-local-variable 'frame-title-format) | |
| 1988 (capitalize-string-as-title | |
| 1989 ;; Kludge: Delete ": " off the end. | |
| 1990 (replace-in-string prompt ": $" ""))) | |
| 1991 ;; ensure that killing the frame works right, | |
| 1992 ;; instead of leaving us in the minibuffer. | |
| 1993 (add-local-hook 'delete-frame-hook | |
| 1994 #'(lambda (frame) | |
| 1995 (abort-recursive-edit)))) | |
| 1996 | |
| 428 | 1997 (defun mouse-file-display-completion-list (window dir minibuf user-data) |
| 1998 (let ((standard-output (window-buffer window))) | |
| 1999 (condition-case nil | |
| 2000 (display-completion-list | |
| 442 | 2001 (minibuf-directory-files dir nil t) |
| 2002 :window-width (window-width window) | |
| 2003 :window-height (window-text-area-height window) | |
| 2004 :completion-string "" | |
| 428 | 2005 :activate-callback |
| 2006 'mouse-read-file-name-activate-callback | |
| 2007 :user-data user-data | |
| 2008 :reference-buffer minibuf | |
| 2009 :help-string "") | |
| 442 | 2010 (t nil)) |
| 2011 )) | |
| 428 | 2012 |
| 2013 (defun mouse-directory-display-completion-list (window dir minibuf user-data) | |
| 2014 (let ((standard-output (window-buffer window))) | |
| 2015 (condition-case nil | |
| 2016 (display-completion-list | |
| 442 | 2017 (minibuf-directory-files dir nil 1) |
| 428 | 2018 :window-width (window-width window) |
| 442 | 2019 :window-height (window-text-area-height window) |
| 2020 :completion-string "" | |
| 428 | 2021 :activate-callback |
| 2022 'mouse-read-file-name-activate-callback | |
| 2023 :user-data user-data | |
| 2024 :reference-buffer minibuf | |
| 2025 :help-string "") | |
| 442 | 2026 (t nil)) |
| 2027 )) | |
| 428 | 2028 |
| 2029 (defun mouse-read-file-name-activate-callback (event extent user-data) | |
| 2030 (let* ((file (extent-string extent)) | |
| 2031 (minibuf (symbol-value-in-buffer 'completion-reference-buffer | |
| 2032 (extent-object extent))) | |
| 442 | 2033 (ministring (buffer-substring nil nil minibuf)) |
| 2034 (in-dir (file-name-directory ministring)) | |
| 428 | 2035 (full (expand-file-name file in-dir)) |
| 2036 (filebuf (nth 0 user-data)) | |
| 442 | 2037 (dirbuf (nth 1 user-data)) |
| 428 | 2038 (filewin (nth 2 user-data)) |
| 2039 (dirwin (nth 3 user-data))) | |
| 2040 (if (file-regular-p full) | |
| 2041 (default-choose-completion event extent minibuf) | |
| 2042 (erase-buffer minibuf) | |
| 2043 (insert-string (file-name-as-directory | |
| 2044 (abbreviate-file-name full t)) minibuf) | |
| 2045 (reset-buffer filebuf) | |
| 442 | 2046 (if (not dirbuf) |
| 428 | 2047 (mouse-directory-display-completion-list filewin full minibuf |
| 2048 user-data) | |
| 2049 (mouse-file-display-completion-list filewin full minibuf user-data) | |
| 442 | 2050 (reset-buffer dirbuf) |
| 428 | 2051 (mouse-directory-display-completion-list dirwin full minibuf |
| 2052 user-data))))) | |
| 2053 | |
| 442 | 2054 ;; our cheesy but god-awful time consuming file dialog box implementation. |
| 2055 ;; this will be replaced with use of the native file dialog box (when | |
| 2056 ;; available). | |
| 428 | 2057 (defun mouse-read-file-name-1 (history prompt dir default |
| 442 | 2058 must-match initial-contents |
| 2059 completer) | |
| 2060 ;; file-p is t if we're reading files, nil if directories. | |
| 428 | 2061 (let* ((file-p (eq 'read-file-name-internal completer)) |
| 2062 (filebuf (get-buffer-create "*Completions*")) | |
| 442 | 2063 (dirbuf (and file-p (generate-new-buffer " *mouse-read-file*"))) |
|
4376
53e507d77416
Fix problem with file dialog box.
Mike Sperber <sperber@deinprogramm.de>
parents:
4222
diff
changeset
|
2064 (butbuf (generate-new-buffer " *mouse-read-file-buttons*")) |
| 428 | 2065 (frame (make-dialog-frame)) |
| 2066 filewin dirwin | |
|
4384
c7e65155cb35
Improve upon previous patch to minibuf.el.
Mike Sperber <sperber@deinprogramm.de>
parents:
4376
diff
changeset
|
2067 user-data |
|
c7e65155cb35
Improve upon previous patch to minibuf.el.
Mike Sperber <sperber@deinprogramm.de>
parents:
4376
diff
changeset
|
2068 (window-min-height 1)) ; allow button window to be height 2 |
| 428 | 2069 (unwind-protect |
| 2070 (progn | |
| 2071 (reset-buffer filebuf) | |
| 442 | 2072 |
| 2073 ;; set up the frame. | |
| 2074 (focus-frame frame) | |
|
4384
c7e65155cb35
Improve upon previous patch to minibuf.el.
Mike Sperber <sperber@deinprogramm.de>
parents:
4376
diff
changeset
|
2075 (split-window nil (- (window-height) 2)) |
| 428 | 2076 (if file-p |
| 2077 (progn | |
| 2078 (split-window-horizontally 16) | |
| 2079 (setq filewin (frame-rightmost-window frame) | |
| 2080 dirwin (frame-leftmost-window frame)) | |
| 2081 (set-window-buffer filewin filebuf) | |
| 442 | 2082 (set-window-buffer dirwin dirbuf)) |
| 428 | 2083 (setq filewin (frame-highest-window frame)) |
| 2084 (set-window-buffer filewin filebuf)) | |
| 442 | 2085 (setq user-data (list filebuf dirbuf filewin dirwin)) |
| 2086 (set-window-buffer (frame-lowest-window frame) butbuf) | |
| 2087 | |
| 2088 ;; set up completion buffers. | |
| 2089 (let ((rfcshookfun | |
| 2090 ;; kludge! | |
| 2091 ;; #### I really need to flesh out the object | |
| 2092 ;; hierarchy better to avoid these kludges. | |
| 2093 ;; (?? I wrote this comment above some time ago, | |
| 2094 ;; and I don't understand what I'm referring to | |
| 2095 ;; any more. --ben | |
| 2096 (lambda () | |
| 2097 (mouse-rfn-setup-vars prompt) | |
| 4222 | 2098 (when-boundp #'scrollbar-width |
| 442 | 2099 (set-specifier scrollbar-width 0 (current-buffer))) |
| 2100 (setq truncate-lines t)))) | |
| 2101 | |
| 2102 (set-buffer filebuf) | |
| 2103 (add-local-hook 'completion-setup-hook rfcshookfun) | |
| 2104 (when file-p | |
| 2105 (set-buffer dirbuf) | |
| 2106 (add-local-hook 'completion-setup-hook rfcshookfun))) | |
| 2107 | |
| 2108 ;; set up minibuffer. | |
| 2109 (add-one-shot-hook | |
| 2110 'minibuffer-setup-hook | |
| 2111 (lambda () | |
| 2112 (if (not file-p) | |
| 2113 (mouse-directory-display-completion-list | |
| 2114 filewin dir (current-buffer) user-data) | |
| 2115 (mouse-file-display-completion-list | |
| 2116 filewin dir (current-buffer) user-data) | |
| 2117 (mouse-directory-display-completion-list | |
| 2118 dirwin dir (current-buffer) user-data)) | |
| 2119 (set | |
| 2120 (make-local-variable | |
| 2121 'completion-display-completion-list-function) | |
| 2122 (lambda (completions) | |
| 2123 (display-completion-list | |
| 2124 completions | |
| 2125 :help-string "" | |
| 2126 :window-width (window-width filewin) | |
| 2127 :window-height (window-text-area-height filewin) | |
| 2128 :completion-string "" | |
| 2129 :activate-callback | |
| 2130 'mouse-read-file-name-activate-callback | |
| 2131 :user-data user-data))) | |
| 2132 (mouse-rfn-setup-vars prompt) | |
| 2133 (save-selected-window | |
| 2134 ;; kludge to ensure the frame title is correct. | |
| 2135 ;; the minibuffer leaves the frame title the way | |
| 2136 ;; it was before (i.e. of the selected window before | |
| 2137 ;; the dialog box was opened), so to get it correct | |
| 2138 ;; we have to be tricky. | |
| 2139 (select-window filewin) | |
| 2140 (redisplay-frame nil t) | |
| 2141 ;; #### another kludge. sometimes the focus ends up | |
| 2142 ;; back in the main window, not the dialog box. it | |
| 2143 ;; occurs randomly and it's not possible to reliably | |
| 2144 ;; reproduce. We try to fix it by draining non-user | |
| 2145 ;; events and then setting the focus back on the frame. | |
| 2146 (sit-for 0 t) | |
| 2147 (focus-frame frame)))) | |
| 2148 | |
| 2149 ;; set up button buffer. | |
| 2150 (set-buffer butbuf) | |
| 2151 (mouse-rfn-setup-vars prompt) | |
| 428 | 2152 (when dir |
| 2153 (setq default-directory dir)) | |
| 2154 (when (featurep 'scrollbar) | |
| 442 | 2155 (set-specifier scrollbar-width 0 butbuf)) |
| 428 | 2156 (insert " ") |
| 2157 (insert-gui-button (make-gui-button "OK" | |
| 2158 (lambda (foo) | |
| 2159 (exit-minibuffer)))) | |
| 2160 (insert " ") | |
| 2161 (insert-gui-button (make-gui-button "Cancel" | |
| 2162 (lambda (foo) | |
| 2163 (abort-recursive-edit)))) | |
| 442 | 2164 |
| 2165 ;; now start reading filename. | |
| 2166 (read-file-name-2 history prompt dir default | |
| 2167 must-match initial-contents | |
| 2168 completer)) | |
| 2169 | |
| 2170 ;; always clean up. | |
| 2171 ;; get rid of our hook that calls abort-recursive-edit -- not a good | |
| 2172 ;; idea here. | |
| 2173 (kill-local-variable 'delete-frame-hook) | |
| 428 | 2174 (delete-frame frame) |
| 2175 (kill-buffer filebuf) | |
| 442 | 2176 (kill-buffer butbuf) |
| 2177 (and dirbuf (kill-buffer dirbuf))))) | |
| 428 | 2178 |
| 2179 (defun read-face (prompt &optional must-match) | |
| 2180 "Read the name of a face from the minibuffer and return it as a symbol." | |
| 2181 (intern (completing-read prompt obarray 'find-face must-match))) | |
| 2182 | |
| 2183 (defun read-color-completion-table () | |
| 2527 | 2184 (mapcar #'list (color-list))) |
| 428 | 2185 |
| 2186 (defun read-color (prompt &optional must-match initial-contents) | |
| 2187 "Read the name of a color from the minibuffer. | |
| 2188 On X devices, this uses `x-library-search-path' to find rgb.txt in order | |
| 2189 to build a completion table. | |
| 2190 On TTY devices, this uses `tty-color-list'. | |
| 2191 On mswindows devices, this uses `mswindows-color-list'." | |
| 2192 (let ((table (read-color-completion-table))) | |
| 2193 (completing-read prompt table nil (and table must-match) | |
| 2194 initial-contents))) | |
| 2195 | |
| 2196 | |
| 2197 (defun read-coding-system (prompt &optional default-coding-system) | |
| 2198 "Read a coding-system (or nil) from the minibuffer. | |
| 2199 Prompting with string PROMPT. | |
| 2200 If the user enters null input, return second argument DEFAULT-CODING-SYSTEM. | |
| 2201 DEFAULT-CODING-SYSTEM can be a string, symbol, or coding-system object." | |
| 2202 (intern (completing-read prompt obarray 'find-coding-system t nil nil | |
| 2203 (cond ((symbolp default-coding-system) | |
| 2204 (symbol-name default-coding-system)) | |
| 2205 ((coding-system-p default-coding-system) | |
| 2206 (symbol-name (coding-system-name default-coding-system))) | |
| 2207 (t | |
| 2208 default-coding-system))))) | |
| 2209 | |
| 2210 (defun read-non-nil-coding-system (prompt) | |
| 2211 "Read a non-nil coding-system from the minibuffer. | |
| 2212 Prompt with string PROMPT." | |
| 2213 (let ((retval (intern ""))) | |
| 2214 (while (= 0 (length (symbol-name retval))) | |
| 2215 (setq retval (intern (completing-read prompt obarray | |
| 2216 'find-coding-system | |
| 2217 t)))) | |
| 2218 retval)) | |
| 2219 | |
| 2220 | |
| 2221 | |
| 2222 (defcustom force-dialog-box-use nil | |
| 2223 "*If non-nil, always use a dialog box for asking questions, if possible. | |
| 2224 You should *bind* this, not set it. This is useful if you're doing | |
| 2225 something mousy but which wasn't actually invoked using the mouse." | |
| 2226 :type 'boolean | |
| 2227 :group 'minibuffer) | |
| 2228 | |
| 2229 ;; We include this here rather than dialog.el so it is defined | |
| 2230 ;; even when dialog boxes are not present. | |
| 2231 (defun should-use-dialog-box-p () | |
| 2232 "If non-nil, questions should be asked with a dialog box instead of the | |
| 2233 minibuffer. This looks at `last-command-event' to see if it was a mouse | |
| 2234 event, and checks whether dialog-support exists and the current device | |
| 2235 supports dialog boxes. | |
| 2236 | |
| 2237 The dialog box is totally disabled if the variable `use-dialog-box' | |
| 2238 is set to nil." | |
| 2239 (and (featurep 'dialog) | |
| 2240 (device-on-window-system-p) | |
| 2241 use-dialog-box | |
| 2242 (or force-dialog-box-use | |
| 2243 (button-press-event-p last-command-event) | |
| 2244 (button-release-event-p last-command-event) | |
| 2245 (misc-user-event-p last-command-event)))) | |
| 2246 | |
| 2730 | 2247 (defun get-user-response (position question answers) |
| 2248 "Ask a question and get a response from the user, in minibuffer or dialog box. | |
| 2249 POSITION specifies which frame to use. | |
| 2250 This is normally an event or a window or frame. | |
| 2251 If POSITION is t or nil, it means to use the frame the mouse is on. | |
| 2252 The dialog box appears in the middle of the specified frame. | |
| 2253 | |
| 2254 QUESTION is the question to ask (it should end with a question mark followed | |
| 2255 by a space). | |
| 2256 | |
| 2257 ANSWERS are the possible answers. It is a list; each item looks like | |
| 2258 | |
| 2259 (KEY BUTTON-TEXT RESPONSE) | |
| 2260 | |
| 2261 where KEY is the key to be pressed in the minibuffer, BUTTON-TEXT is the | |
| 2262 text to be displayed in a dialog box button (you should put %_ in it to | |
| 2263 indicate the accelerator), and RESPONSE is a value (typically a symbol) | |
| 2264 to be returned if the user selects this response. KEY should be either a | |
| 2265 single character or a string; which one you use needs to be consistent for | |
| 2266 all responses and determines whether the user responds by hitting a single | |
| 2267 key or typing in a string and hitting ENTER. | |
| 2268 | |
| 2269 An item may also be just a string--that makes a nonselectable item in the | |
| 2270 dialog box and is ignored in the minibuffer. | |
| 2271 | |
| 2272 An item may also be nil -- that means to put all preceding items | |
| 2273 on the left of the dialog box and all following items on the right; ignored | |
| 2274 in the minibuffer." | |
| 2275 (if (should-use-dialog-box-p) | |
| 2276 (get-dialog-box-response | |
| 2277 position | |
| 2278 (cons question | |
| 2279 (mapcar #'(lambda (x) | |
| 2280 (cond | |
| 2281 ((null x) nil) | |
| 2282 ((stringp x) x) | |
| 2283 (t (cons (second x) (third x))))) | |
| 2284 answers))) | |
| 2285 (save-excursion | |
| 2286 (let* ((answers (remove-if-not #'consp answers)) | |
| 2287 (possible | |
| 2288 (gettext | |
| 2289 (flet ((car-to-string-if (x) | |
| 2290 (setq x (car x)) | |
| 2291 (if (stringp x) x (char-to-string x)))) | |
| 2292 (concat (mapconcat #'car-to-string-if | |
| 2293 (butlast answers) ", ") " or " | |
| 2294 (car-to-string-if (car (last answers))))))) | |
| 2295 (question (gettext question)) | |
| 2296 (p (format "%s(%s) " question possible))) | |
| 2297 (block nil | |
| 2298 (if (stringp (caar answers)) | |
| 2299 ;; based on yes-or-no-p. | |
| 2300 (while t | |
| 2301 (let* ((ans (downcase (read-string p nil t))) ;no history | |
| 2302 (res (member* ans answers :test #'equal :key #'car))) | |
| 2303 (if res (return (third (car res))) | |
| 2304 (ding nil 'yes-or-no-p) | |
| 2305 (discard-input) | |
| 2306 (message "Please answer %s." possible) | |
| 2307 (sleep-for 2)))) | |
| 2308 ;; based on y-or-n-p. | |
| 2309 (save-excursion | |
| 2310 (let* ((pre "") event) | |
| 2311 (while t | |
| 2312 (if (let ((cursor-in-echo-area t) | |
| 2313 (inhibit-quit t)) | |
| 2314 (message "%s%s(%s) " pre question possible) | |
| 2315 (setq event (next-command-event event)) | |
| 2316 (condition-case nil | |
| 2317 (prog1 | |
| 2318 (or quit-flag (eq 'keyboard-quit | |
| 2319 (key-binding event))) | |
| 2320 (setq quit-flag nil)) | |
| 2321 (wrong-type-argument t))) | |
| 2322 (progn | |
| 2323 (message "%s%s(%s) %s" pre question possible | |
| 2324 (single-key-description event)) | |
| 2325 (setq quit-flag nil) | |
| 2326 (signal 'quit '()))) | |
| 2327 (let* ((keys (events-to-keys (vector event))) | |
| 2328 (def (lookup-key query-replace-map keys))) | |
| 2329 (cond | |
| 2330 ; ((eq def 'skip) | |
| 2331 ; (message "%s%sNo" question possible) | |
| 2332 ; (return nil)) | |
| 2333 ; ((eq def 'act) | |
| 2334 ; (message "%s%sYes" question possible) | |
| 2335 ; (return t)) | |
| 2336 ((eq def 'recenter) | |
| 2337 (recenter)) | |
| 2338 ((or (eq def 'quit) (eq def 'exit-prefix)) | |
| 2339 (signal 'quit '())) | |
| 2340 ((button-release-event-p event) ; ignore them | |
| 2341 nil) | |
| 2342 (t | |
| 2343 (let ((res (member* (event-to-character event) answers | |
| 2344 :key #'car))) | |
| 2345 (if res (return (third (car res))) | |
| 2346 (message "%s%s(%s) %s" pre question possible | |
| 2347 (single-key-description event)) | |
| 2348 (ding nil 'y-or-n-p) | |
| 2349 (discard-input) | |
| 2350 (if (= (length pre) 0) | |
| 2351 (setq pre (format "Please answer %s. " | |
| 2352 ;; 17 parens! a record in | |
| 2353 ;; our lisp code. | |
| 2354 possible))))))))))))))))) | |
| 2355 | |
| 428 | 2356 ;;; minibuf.el ends here |