Mercurial > hg > xemacs-beta
annotate lisp/cmdloop.el @ 5853:1044acf60048
Revert part of Jerry's December 2014 that broke gnuclient on some OS X.
lib-src/ChangeLog addition:
2015-03-08 Aidan Kehoe <kehoea@parhasard.net>
* gnuserv.c (echo_request):
No longer close the file handle unconditionally, leave this to the
individual socket types.
* gnuserv.c (handle_internet_request):
Close the file handle here.
* gnuserv.c (handle_unix_request):
Don't close the file handle here, document why (it broke gnuclient
under OS X). It should actually be OK, but my suspicion is that
the issues is that the Unix (local) domain sockets are still
underdocumented compared to the internet sockets.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 08 Mar 2015 20:59:25 +0000 |
| parents | 0e9f791cc655 |
| children | c87b776ab0e1 |
| rev | line source |
|---|---|
| 428 | 1 ;;; cmdloop.el --- support functions for the top-level command loop. |
| 2 | |
| 3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. | |
| 1333 | 4 ;; Copyright (C) 2001, 2002, 2003 Ben Wing. |
| 428 | 5 |
| 6 ;; Author: Richard Mlynarik | |
| 7 ;; Date: 8-Jul-92 | |
| 8 ;; Maintainer: XEmacs Development Team | |
| 9 ;; Keywords: internal, dumped | |
| 10 | |
| 11 ;; This file is part of XEmacs. | |
| 12 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
13 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
14 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
15 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
16 ;; option) any later version. |
| 428 | 17 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
18 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
19 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
20 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
21 ;; for more details. |
| 428 | 22 |
| 23 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5208
diff
changeset
|
24 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 25 |
| 26 ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.) | |
| 1333 | 27 ;;; Some parts synched with FSF 21.2. |
| 428 | 28 |
| 29 ;;; Commentary: | |
| 30 | |
| 31 ;; This file is dumped with XEmacs. | |
| 32 | |
| 33 ;;; Code: | |
| 34 | |
| 35 (defun recursion-depth () | |
| 36 "Return the current depth in recursive edits." | |
| 37 (+ command-loop-level (minibuffer-depth))) | |
| 38 | |
| 39 (defun top-level () | |
| 40 "Exit all recursive editing levels." | |
| 41 (interactive) | |
| 42 (throw 'top-level nil)) | |
| 43 | |
| 44 (defun exit-recursive-edit () | |
| 45 "Exit from the innermost recursive edit or minibuffer." | |
| 46 (interactive) | |
| 47 (if (> (recursion-depth) 0) | |
| 48 (throw 'exit nil)) | |
| 49 (error "No recursive edit is in progress")) | |
| 50 | |
| 51 (defun abort-recursive-edit () | |
| 52 "Abort the command that requested this recursive edit or minibuffer input." | |
| 53 (interactive) | |
| 54 (if (> (recursion-depth) 0) | |
| 55 (throw 'exit t)) | |
| 56 (error "No recursive edit is in progress")) | |
| 57 | |
| 58 ;; (defun keyboard-quit () | |
| 59 ;; "Signal a `quit' condition." | |
| 60 ;; (interactive) | |
| 61 ;; (deactivate-mark) | |
| 62 ;; (signal 'quit nil)) | |
| 63 | |
| 64 ;; moved here from pending-del. | |
| 65 (defun keyboard-quit () | |
| 66 "Signal a `quit' condition. | |
| 67 If this character is typed while lisp code is executing, it will be treated | |
| 68 as an interrupt. | |
| 69 If this character is typed at top-level, this simply beeps. | |
| 70 If `zmacs-regions' is true, and the zmacs region is active in this buffer, | |
| 71 then this key deactivates the region without beeping or signalling." | |
| 72 (interactive) | |
| 2611 | 73 (if (region-active-p) |
| 428 | 74 ;; pseudo-zmacs compatibility: don't beep if this ^G is simply |
| 75 ;; deactivating the region. If it is inactive, beep. | |
| 76 nil | |
| 77 (signal 'quit nil))) | |
| 78 | |
| 79 (defvar buffer-quit-function nil | |
| 80 "Function to call to \"quit\" the current buffer, or nil if none. | |
| 81 \\[keyboard-escape-quit] calls this function when its more local actions | |
| 82 \(such as cancelling a prefix argument, minibuffer or region) do not apply.") | |
| 83 | |
| 84 (defun keyboard-escape-quit () | |
| 85 "Exit the current \"mode\" (in a generalized sense of the word). | |
| 86 This command can exit an interactive command such as `query-replace', | |
| 87 can clear out a prefix argument or a region, | |
| 88 can get out of the minibuffer or other recursive edit, | |
| 89 cancel the use of the current buffer (for special-purpose buffers), | |
| 90 or go back to just one window (by deleting all but the selected window)." | |
| 91 (interactive) | |
| 92 (cond ((eq last-command 'mode-exited) nil) | |
| 93 ((> (minibuffer-depth) 0) | |
| 94 (abort-recursive-edit)) | |
| 95 (current-prefix-arg | |
| 96 nil) | |
| 97 ((region-active-p) | |
| 98 (zmacs-deactivate-region)) | |
| 99 ((> (recursion-depth) 0) | |
| 100 (exit-recursive-edit)) | |
| 101 (buffer-quit-function | |
| 102 (funcall buffer-quit-function)) | |
| 103 ((not (one-window-p t)) | |
| 104 (delete-other-windows)) | |
| 105 ((string-match "^ \\*" (buffer-name (current-buffer))) | |
| 106 (bury-buffer)))) | |
| 107 | |
| 108 ;; `cancel-mode-internal' is a function of a misc-user event, which is | |
| 109 ;; queued when window system directs XEmacs frame to cancel any modal | |
| 110 ;; behavior it exposes, like mouse pointer grabbing. | |
| 111 ;; | |
| 112 ;; This function does nothing at the top level, but the code which | |
| 113 ;; runs modal event loops, such as selection drag loop in `mouse-track', | |
| 114 ;; check if misc-user function symbol is `cancel-mode-internal', and | |
| 115 ;; takes necessary cleanup actions. | |
| 116 (defun cancel-mode-internal (object) | |
| 117 (setq zmacs-region-stays t)) | |
| 118 | |
| 119 ;; Someone wrote: "This should really be a ring of last errors." | |
| 120 ;; | |
| 121 ;; But why bother? This stuff is not all that necessary now that we | |
| 122 ;; have message log, anyway. | |
| 123 (defvar last-error nil | |
| 124 "Object describing the last signaled error.") | |
| 125 | |
| 126 (defcustom errors-deactivate-region nil | |
| 127 "*Non-nil means that errors will cause the region to be deactivated." | |
| 128 :type 'boolean | |
| 129 :group 'editing-basics) | |
| 130 | |
| 131 (defun command-error (error-object) | |
| 771 | 132 ;; if you want a backtrace before exiting, set stack-trace-on-error. |
| 133 (let* ((inhibit-quit t) | |
| 442 | 134 (debug-on-error nil) |
| 135 (etype (car-safe error-object))) | |
| 428 | 136 (setq quit-flag nil) |
| 137 (setq standard-output t) | |
| 138 (setq standard-input t) | |
| 139 (setq executing-kbd-macro nil) | |
| 140 (and errors-deactivate-region | |
| 141 (zmacs-deactivate-region)) | |
| 142 (discard-input) | |
| 143 | |
| 144 (setq last-error error-object) | |
| 145 | |
| 146 (message nil) | |
| 147 (ding nil (cond ((eq etype 'undefined-keystroke-sequence) | |
| 148 (if (and (vectorp (nth 1 error-object)) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
149 (not (eql 0 (length (nth 1 error-object)))) |
| 428 | 150 (button-event-p (aref (nth 1 error-object) 0))) |
| 151 'undefined-click | |
| 152 'undefined-key)) | |
| 153 ((eq etype 'quit) | |
| 154 'quit) | |
| 155 ((memq etype '(end-of-buffer beginning-of-buffer)) | |
| 156 'buffer-bound) | |
| 157 ((eq etype 'buffer-read-only) | |
| 158 'read-only) | |
| 159 (t 'command-error))) | |
| 160 (display-error error-object t) | |
| 161 | |
| 162 (if (noninteractive) | |
| 163 (progn | |
| 1445 | 164 (message "\n%s exiting.\n" emacs-program-name) |
| 428 | 165 (kill-emacs -1))) |
| 166 t)) | |
| 167 | |
| 168 (defun describe-last-error () | |
| 169 "Redisplay the last error-message. See the variable `last-error'." | |
| 170 (interactive) | |
| 171 (if last-error | |
| 172 (with-displaying-help-buffer | |
| 173 (lambda () | |
| 174 (princ "Last error was:\n" standard-output) | |
| 175 (display-error last-error standard-output))) | |
| 176 (message "No error yet"))) | |
| 177 | |
| 178 | |
| 179 ;;#### Must be done later in the loadup sequence | |
| 180 ;(define-key (symbol-function 'help-command) "e" 'describe-last-error) | |
| 181 | |
| 182 | |
| 183 (defun truncate-command-history-for-gc () | |
| 3698 | 184 ;; We should try to avoid accessing any bindings to speak of in this |
| 185 ;; function; as this hook is called asynchronously, the search for | |
| 186 ;; those bindings might search local bindings from essentially | |
| 187 ;; arbitrary functions. We force the body of the function to run at | |
| 188 ;; command-loop level, where the danger of local bindings is much | |
| 189 ;; reduced; the code can still do its job because the command history | |
| 190 ;; and values list will not grow before then anyway. | |
| 191 ;; | |
| 192 ;; Nothing is done in batch mode, both because it is a waste of time | |
| 193 ;; (there is no command loop!) and because this any GCs during dumping | |
| 194 ;; will invoke this code, and if it were to enqueue an eval event, | |
| 195 ;; the portable dumper would try to dump it and fail. | |
| 196 (if (not (noninteractive)) | |
| 197 (enqueue-eval-event | |
| 198 (lambda (arg) | |
| 199 (let ((tail (nthcdr 30 command-history))) | |
| 200 (if tail (setcdr tail nil))) | |
| 201 (let ((tail (nthcdr 30 values))) | |
| 202 (if tail (setcdr tail nil)))) | |
| 203 nil))) | |
| 428 | 204 |
| 205 (add-hook 'pre-gc-hook 'truncate-command-history-for-gc) | |
| 206 | |
| 207 | |
| 208 ;;;; Object-oriented programming at its finest | |
| 209 | |
| 210 ;; Now in src/print.c; used by Ferror_message_string and others | |
| 211 ;(defun display-error (error-object stream) ;(defgeneric report-condition ...) | |
| 212 ; "Display `error-object' on `stream' in a user-friendly way." | |
| 213 ; (funcall (or (let ((type (car-safe error-object))) | |
| 214 ; (catch 'error | |
| 215 ; (and (consp error-object) | |
| 216 ; (symbolp type) | |
| 217 ; ;;(stringp (get type 'error-message)) | |
| 218 ; (consp (get type 'error-conditions)) | |
| 219 ; (let ((tail (cdr error-object))) | |
| 220 ; (while (not (null tail)) | |
| 221 ; (if (consp tail) | |
| 222 ; (setq tail (cdr tail)) | |
| 223 ; (throw 'error nil))) | |
| 224 ; t) | |
| 225 ; ;; (check-type condition condition) | |
| 226 ; (get type 'error-conditions) | |
| 227 ; ;; Search class hierarchy | |
| 228 ; (let ((tail (get type 'error-conditions))) | |
| 229 ; (while (not (null tail)) | |
| 230 ; (cond ((not (and (consp tail) | |
| 231 ; (symbolp (car tail)))) | |
| 232 ; (throw 'error nil)) | |
| 233 ; ((get (car tail) 'display-error) | |
| 234 ; (throw 'error (get (car tail) | |
| 235 ; 'display-error))) | |
| 236 ; (t | |
| 237 ; (setq tail (cdr tail))))) | |
| 238 ; ;; Default method | |
| 239 ; #'(lambda (error-object stream) | |
| 240 ; (let ((type (car error-object)) | |
| 241 ; (tail (cdr error-object)) | |
| 242 ; (first t) | |
| 243 ; (print-message-label 'error)) | |
| 244 ; (if (eq type 'error) | |
| 245 ; (progn (princ (car tail) stream) | |
| 246 ; (setq tail (cdr tail))) | |
| 247 ; (princ (or (gettext (get type 'error-message)) type) | |
| 248 ; stream)) | |
| 249 ; (while tail | |
| 250 ; (princ (if first ": " ", ") stream) | |
| 251 ; (prin1 (car tail) stream) | |
| 252 ; (setq tail (cdr tail) | |
| 253 ; first nil)))))))) | |
| 254 ; #'(lambda (error-object stream) | |
| 255 ; (princ (gettext "Peculiar error ") stream) | |
| 256 ; (prin1 error-object stream))) | |
| 257 ; error-object stream)) | |
| 258 | |
| 259 (put 'file-error 'display-error | |
| 260 #'(lambda (error-object stream) | |
| 1346 | 261 (let ((type (car error-object)) |
| 262 (tail (cdr error-object)) | |
| 263 (first t) | |
| 264 (print-message-label 'error)) | |
| 265 (if (eq type 'file-error) | |
| 266 (progn (princ (car tail) stream) | |
| 267 (setq tail (cdr tail))) | |
| 268 (princ (or (gettext (get type 'error-message)) type) | |
| 269 stream)) | |
| 270 (while tail | |
| 271 (princ (if first ": " ", ") stream) | |
| 272 (prin1 (car tail) stream) | |
| 273 (setq tail (cdr tail) | |
| 274 first nil))))) | |
| 428 | 275 |
| 276 (put 'undefined-keystroke-sequence 'display-error | |
| 277 #'(lambda (error-object stream) | |
| 278 (princ (key-description (car (cdr error-object))) stream) | |
| 279 ;; #### I18N3: doesn't localize properly. | |
| 280 (princ (gettext " not defined.") stream) ; doo dah, doo dah. | |
| 281 )) | |
| 282 | |
| 283 | |
| 284 (defcustom teach-extended-commands-p t | |
| 285 "*If true, then `\\[execute-extended-command]' will teach you keybindings. | |
| 286 Any time you execute a command with \\[execute-extended-command] which has a | |
| 287 shorter keybinding, you will be shown the alternate binding before the | |
| 288 command executes. There is a short pause after displaying the binding, | |
| 289 before executing it; the length can be controlled by | |
| 290 `teach-extended-commands-timeout'." | |
| 291 :type 'boolean | |
| 292 :group 'keyboard) | |
| 293 | |
| 294 (defcustom teach-extended-commands-timeout 4 | |
| 295 "*How long to pause after displaying a keybinding before executing. | |
| 296 The value is measured in seconds. This only applies if | |
| 297 `teach-extended-commands-p' is true." | |
| 298 :type 'number | |
| 299 :group 'keyboard) | |
| 300 | |
| 301 ;That damn RMS went off and implemented something differently, after | |
|
5208
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
302 ;we had already implemented it. |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
303 (defcustom suggest-key-bindings t |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
304 "*FSFmacs equivalent of `teach-extended-commands-p'. |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
305 Provided for compatibility only. |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
306 Non-nil means show the equivalent key-binding when M-x command has one. |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
307 The value can be a length of time to show the message for, in seconds. |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
308 |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
309 If the value is non-nil and not a number, we wait the number of seconds |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
310 specified by `teach-extended-commands-timeout'." |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
311 :type '(choice |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
312 (const :tag "off" nil) |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
313 (integer :tag "time" 2) |
|
5383
294ab9180fad
#'custom-add-to-group: warn if GROUP is nil.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5368
diff
changeset
|
314 (other :tag "on")) |
|
294ab9180fad
#'custom-add-to-group: warn if GROUP is nil.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5368
diff
changeset
|
315 :group 'keyboard) |
|
5208
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
316 |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
317 (dontusethis-set-symbol-value-handler |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
318 'suggest-key-bindings |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
319 'set-value |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
320 #'(lambda (sym args fun harg handler) |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
321 (setq args (car args)) |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
322 (if (null args) |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
323 (setq teach-extended-commands-p nil) |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
324 (setq teach-extended-commands-p t |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
325 teach-extended-commands-timeout |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
326 (or (and (integerp args) args) |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
327 (and args teach-extended-commands-timeout)))))) |
| 428 | 328 |
| 329 (defun execute-extended-command (prefix-arg) | |
| 330 "Read a command name from the minibuffer using 'completing-read'. | |
| 331 Then call the specified command using 'command-execute' and return its | |
| 332 return value. If the command asks for a prefix argument, supply the | |
| 333 value of the current raw prefix argument, or the value of PREFIX-ARG | |
| 334 when called from Lisp." | |
| 335 (interactive "P") | |
| 336 ;; Note: This doesn't hack "this-command-keys" | |
| 337 (let ((prefix-arg prefix-arg)) | |
| 338 (setq this-command (read-command | |
| 339 ;; Note: this has the hard-wired | |
| 340 ;; "C-u" and "M-x" string bug in common | |
| 613 | 341 ;; with all Emacs's. |
| 428 | 342 ;; (i.e. it prints C-u and M-x regardless of |
| 343 ;; whether some other keys were actually bound | |
| 344 ;; to `execute-extended-command' and | |
| 345 ;; `universal-argument'. | |
| 346 (cond ((eq prefix-arg '-) | |
| 347 "- M-x ") | |
| 348 ((equal prefix-arg '(4)) | |
| 349 "C-u M-x ") | |
| 350 ((integerp prefix-arg) | |
| 351 (format "%d M-x " prefix-arg)) | |
| 352 ((and (consp prefix-arg) | |
| 353 (integerp (car prefix-arg))) | |
| 354 (format "%d M-x " (car prefix-arg))) | |
| 355 (t | |
| 356 "M-x "))))) | |
| 357 | |
| 358 (if (and teach-extended-commands-p | |
| 359 (interactive-p)) | |
| 360 ;; Remember the keys, run the command, and show the keys (if | |
|
4806
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
361 ;; any). The symbol-macrolet avoids some lexical-scope lossage. |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
362 (symbol-macrolet |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
363 ((execute-command-keys #:execute-command-keys) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
364 (execute-command-name #:execute-command-name)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
365 (let ((execute-command-keys (where-is-internal this-command)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
366 (execute-command-name this-command)) ; the name can change |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
367 (command-execute this-command t) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
368 (when execute-command-keys |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
369 ;; Normally the region is adjusted in post_command_hook; |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
370 ;; however, it is not called until after we finish. It |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
371 ;; looks ugly for the region to get updated after the |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
372 ;; delays, so we do it now. The code below is a Lispified |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
373 ;; copy of code in event-stream.c:post_command_hook(). |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
374 (if (and (not zmacs-region-stays) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
375 (or (not (eq (selected-window) (minibuffer-window))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
376 (eq (zmacs-region-buffer) (current-buffer)))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
377 (zmacs-deactivate-region) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
378 (zmacs-update-region)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
379 ;; Wait for a while, so the user can see a message printed, |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
380 ;; if any. |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
381 (when (sit-for 1) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
382 (display-message |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
383 'no-log |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
384 (format (if (cdr execute-command-keys) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
385 "Command `%s' is bound to keys: %s" |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
386 "Command `%s' is bound to key: %s") |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
387 execute-command-name |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
388 (sorted-key-descriptions execute-command-keys))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
389 (sit-for teach-extended-commands-timeout) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
390 (clear-message 'no-log))))) |
| 428 | 391 ;; Else, just run the command. |
| 392 (command-execute this-command t))) | |
| 393 | |
| 394 | |
| 395 ;;; C code calls this; the underscores in the variable names are to avoid | |
| 396 ;;; cluttering the specbind namespace (lexical scope! lexical scope!) | |
| 397 ;;; Putting this in Lisp instead of C slows kbd macros by 50%. | |
| 398 ;(defun command-execute (_command &optional _record-flag) | |
| 399 ; "Execute CMD as an editor command. | |
| 400 ;CMD must be a symbol that satisfies the `commandp' predicate. | |
| 401 ;Optional second arg RECORD-FLAG non-nil | |
| 402 ;means unconditionally put this command in `command-history'. | |
| 403 ;Otherwise, that is done only if an arg is read using the minibuffer." | |
| 404 ; (let ((_prefix prefix-arg) | |
| 405 ; (_cmd (indirect-function _command))) | |
| 406 ; (setq prefix-arg nil | |
| 407 ; this-command _command | |
| 408 ; current-prefix-arg _prefix | |
| 409 ; zmacs-region-stays nil) | |
| 410 ; ;; #### debug_on_next_call = 0; | |
| 411 ; (cond ((and (symbolp _command) | |
| 412 ; (get _command 'disabled)) | |
| 413 ; (run-hooks disabled-command-hook)) | |
| 414 ; ((or (stringp _cmd) (vectorp _cmd)) | |
| 415 ; ;; If requested, place the macro in the command history. | |
| 416 ; ;; For other sorts of commands, call-interactively takes | |
| 417 ; ;; care of this. | |
| 418 ; (if _record-flag | |
| 419 ; (setq command-history | |
| 420 ; (cons (list 'execute-kbd-macro _cmd _prefix) | |
| 421 ; command-history))) | |
| 422 ; (execute-kbd-macro _cmd _prefix)) | |
| 423 ; (t | |
| 424 ; (call-interactively _command _record-flag))))) | |
| 425 | |
| 426 (defun y-or-n-p-minibuf (prompt) | |
| 427 "Ask user a \"y or n\" question. Return t if answer is \"y\". | |
| 428 Takes one argument, which is the string to display to ask the question. | |
| 429 It should end in a space; `y-or-n-p' adds `(y or n) ' to it. | |
| 430 No confirmation of the answer is requested; a single character is enough. | |
| 431 Also accepts Space to mean yes, or Delete to mean no." | |
| 432 (save-excursion | |
| 433 (let* ((pre "") | |
| 434 (yn (gettext "(y or n) ")) | |
| 435 ;; we need to translate the prompt ourselves because of the | |
| 436 ;; strange way we handle it. | |
| 437 (prompt (gettext prompt)) | |
| 438 event) | |
| 439 (while (stringp yn) | |
| 440 (if (let ((cursor-in-echo-area t) | |
| 441 (inhibit-quit t)) | |
| 442 (message "%s%s%s" pre prompt yn) | |
| 443 (setq event (next-command-event event)) | |
| 444 (condition-case nil | |
| 445 (prog1 | |
| 446 (or quit-flag (eq 'keyboard-quit (key-binding event))) | |
| 447 (setq quit-flag nil)) | |
| 448 (wrong-type-argument t))) | |
| 449 (progn | |
| 450 (message "%s%s%s%s" pre prompt yn (single-key-description event)) | |
| 451 (setq quit-flag nil) | |
| 452 (signal 'quit '()))) | |
|
5745
f9e4d44504a4
Document #'events-to-keys some more, use it less.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5474
diff
changeset
|
453 (let ((def (lookup-key query-replace-map (vector event)))) |
| 428 | 454 (cond ((eq def 'skip) |
| 455 (message "%s%sNo" prompt yn) | |
| 456 (setq yn nil)) | |
| 457 ((eq def 'act) | |
| 458 (message "%s%sYes" prompt yn) | |
| 459 (setq yn t)) | |
| 460 ((eq def 'recenter) | |
| 461 (recenter)) | |
| 462 ((or (eq def 'quit) (eq def 'exit-prefix)) | |
| 463 (signal 'quit '())) | |
| 464 ((button-release-event-p event) ; ignore them | |
| 465 nil) | |
| 466 (t | |
| 467 (message "%s%s%s%s" pre prompt yn | |
| 468 (single-key-description event)) | |
| 469 (ding nil 'y-or-n-p) | |
| 470 (discard-input) | |
|
5366
f00192e1cd49
Examining the result of #'length: `eql', not `=', it's better style & cheaper
Aidan Kehoe <kehoea@parhasard.net>
parents:
5284
diff
changeset
|
471 (if (eql (length pre) 0) |
| 428 | 472 (setq pre (gettext "Please answer y or n. "))))))) |
| 473 yn))) | |
| 474 | |
| 475 (defun yes-or-no-p-minibuf (prompt) | |
| 476 "Ask user a yes-or-no question. Return t if answer is yes. | |
| 477 Takes one argument, which is the string to display to ask the question. | |
| 478 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. | |
| 479 The user must confirm the answer with RET, | |
| 480 and can edit it until it has been confirmed." | |
| 481 (save-excursion | |
| 482 (let ((p (concat (gettext prompt) (gettext "(yes or no) "))) | |
| 483 (ans "")) | |
| 484 (while (stringp ans) | |
| 485 (setq ans (downcase (read-string p nil t))) ;no history | |
| 486 (cond ((string-equal ans (gettext "yes")) | |
| 487 (setq ans t)) | |
| 488 ((string-equal ans (gettext "no")) | |
| 489 (setq ans nil)) | |
| 490 (t | |
| 491 (ding nil 'yes-or-no-p) | |
| 492 (discard-input) | |
| 493 (message "Please answer yes or no.") | |
| 494 (sleep-for 2)))) | |
| 495 ans))) | |
| 496 | |
| 442 | 497 (defun yes-or-no-p (prompt) |
| 498 "Ask user a yes-or-no question. Return t if answer is yes. | |
| 499 The question is asked with a dialog box or the minibuffer, as appropriate. | |
| 500 Takes one argument, which is the string to display to ask the question. | |
| 501 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. | |
| 502 The user must confirm the answer with RET, | |
| 503 and can edit it until it as been confirmed." | |
| 504 (if (should-use-dialog-box-p) | |
| 4222 | 505 ;; and-fboundp is redundant, since yes-or-no-p-dialog-box is only |
| 506 ;; bound if (featurep 'dialog). But it eliminates a compile-time | |
| 507 ;; warning. | |
|
5368
ed74d2ca7082
Use ', not #', when a given symbol may not have a function binding at read time
Aidan Kehoe <kehoea@parhasard.net>
parents:
5366
diff
changeset
|
508 (and-fboundp 'yes-or-no-p-dialog-box (yes-or-no-p-dialog-box prompt)) |
| 442 | 509 (yes-or-no-p-minibuf prompt))) |
| 510 | |
| 511 (defun y-or-n-p (prompt) | |
| 512 "Ask user a \"y or n\" question. Return t if answer is \"y\". | |
| 513 Takes one argument, which is the string to display to ask the question. | |
| 514 The question is asked with a dialog box or the minibuffer, as appropriate. | |
| 515 It should end in a space; `y-or-n-p' adds `(y or n) ' to it. | |
| 516 No confirmation of the answer is requested; a single character is enough. | |
| 517 Also accepts Space to mean yes, or Delete to mean no." | |
| 518 (if (should-use-dialog-box-p) | |
| 519 (yes-or-no-p-dialog-box prompt) | |
| 520 (y-or-n-p-minibuf prompt))) | |
| 521 | |
| 428 | 522 |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
523 (labels |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
524 ((read-char-1 (errorp prompt inherit-input-method seconds) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
525 "Return a character from command input or the current macro. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
526 Look up said input in `function-key-map' as appropriate. |
| 428 | 527 |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
528 PROMPT is a prompt for `next-command-event', which see. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
529 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
530 If ERRORP is non-nil, error if the key sequence has no character equivalent. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
531 Otherwise, loop, discarding non-character keystrokes or mouse movements. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
532 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
533 If INHERIT-INPUT-METHOD is non-nil, and a Quail input method is active in |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
534 the current buffer, use its translation when choosing a character to return. |
| 428 | 535 |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
536 If SECONDS is non-nil, only wait that number of seconds for input. If no |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
537 input is received in that time, return nil." |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
538 (let ((timeout |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
539 (if seconds |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
540 (add-timeout seconds #'(lambda (ignore) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
541 (return-from read-char-1 nil)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
542 nil))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
543 (events []) binding character) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
544 (unwind-protect |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
545 (while t |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
546 ;; Read keystrokes scanning `function-key-map'. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
547 (while (keymapp |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
548 (setq binding |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
549 (lookup-key |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
550 function-key-map |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
551 (setq events |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
552 (vconcat events (list |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
553 (next-key-event |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
554 nil prompt)))))))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
555 (when binding |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
556 ;; Found something in function-key-map. If it's a function |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
557 ;; (e.g. synthesize-keysym), call it. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
558 (if (functionp binding) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
559 (setq binding (funcall binding nil))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
560 (setq events (map 'vector #'character-to-event binding))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
561 ;; Put the remaining keystrokes back on the input queue. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
562 (setq unread-command-events |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
563 (nconc (reduce #'cons events :start 1 :from-end t |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
564 :initial-value nil) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
565 unread-command-events)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
566 (unless inhibit-quit |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
567 (and (event-matches-key-specifier-p (aref events 0) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
568 (quit-char)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
569 (signal 'quit nil))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
570 (if (setq character (event-to-character (aref events 0))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
571 (progn |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
572 ;; If we have a character (the usual case), deallocate |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
573 ;; the event and return the character. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
574 (deallocate-event (aref events 0)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
575 ;; Handle quail, if we've been asked to (maybe we |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
576 ;; should default to this). |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
577 (if (and inherit-input-method (and-boundp 'quail-mode |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
578 quail-mode)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
579 (with-fboundp |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
580 '(quail-map-definition quail-lookup-key) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
581 (let ((binding |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
582 (quail-map-definition |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
583 (quail-lookup-key (string character))))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
584 (if (characterp binding) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
585 (return-from read-char-1 binding)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
586 ;; #### Bug, we don't allow users to select from |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
587 ;; among multiple characters that may be input |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
588 ;; with the same key sequence. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
589 (if (and (consp binding) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
590 (characterp |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
591 (aref (cdr binding) (caar binding)))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
592 (return-from read-char-1 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
593 (aref (cdr binding) (caar binding))))))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
594 (return-from read-char-1 character))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
595 (if errorp |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
596 (error 'invalid-key-binding "Not a character keystroke" |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
597 (aref events 0))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
598 ;; If we're not erroring, loop until we get a character |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
599 (setq events [])) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
600 (if timeout (disable-timeout timeout)))))) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
601 ;; Because of byte compiler limitations, each function has its own copy of |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
602 ;; #'read-char-1, so why not inline it. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
603 (declare (inline read-char-1)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
604 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
605 (defun read-char (&optional prompt inherit-input-method seconds) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
606 "Read a character from the command input (keyboard or macro). |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
607 If a mouse click or non-character keystroke is detected, signal an error. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
608 The character typed is returned as a Lisp object. This is most likely the |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
609 wrong thing for you to be using: consider using the `next-command-event' |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
610 function instead. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
611 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
612 PROMPT is a prompt, as used by `next-command-event'. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
613 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
614 If INHERIT-INPUT-METHOD is non-nil, and a Quail input method is active in |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
615 the current buffer, use its translation for the character returned. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
616 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
617 If SECONDS is non-nil, only wait that number of seconds for input. If no |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
618 input is received in that time, return nil." |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
619 (read-char-1 t prompt inherit-input-method seconds)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
620 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
621 (defun read-char-exclusive (&optional prompt inherit-input-method seconds) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
622 "Read a character from the command input (keyboard or macro). |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
623 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
624 If a mouse click or a non-character keystroke is detected, it is discarded. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
625 The character typed is returned as a Lisp object. This is most likely the |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
626 wrong thing for you to be using: consider using the `next-command-event' |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
627 function instead. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
628 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
629 PROMPT is a prompt, as used by `next-command-event'. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
630 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
631 If INHERIT-INPUT-METHOD is non-nil, and a Quail input method is active in |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
632 the current buffer, use its translation for the character returned. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
633 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
634 If SECONDS is non-nil, only wait that number of seconds for input. If no |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
635 input is received in that time, return nil." |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
636 (read-char-1 nil prompt inherit-input-method seconds))) |
| 428 | 637 |
| 1333 | 638 ;;;; Input and display facilities. |
| 639 | |
| 640 ;; BEGIN SYNCHED WITH FSF 21.2. | |
| 641 | |
|
5284
d27c1ee1943b
Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5208
diff
changeset
|
642 (defcustom read-quoted-char-radix 8 |
| 1333 | 643 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'. |
| 644 Legitimate radix values are 8, 10 and 16." | |
| 645 :type '(choice (const 8) (const 10) (const 16)) | |
| 646 :group 'editing-basics) | |
| 647 | |
| 428 | 648 (defun read-quoted-char (&optional prompt) |
| 3341 | 649 ;; XEmacs change; description of the character code input |
| 1333 | 650 "Like `read-char', but do not allow quitting. |
| 3341 | 651 |
| 652 Also, if the first character read is a digit of base (the value of) | |
| 653 `read-quoted-char-radix', we read as many of such digits as are | |
| 654 typed and return a character with the corresponding Unicode code | |
| 3344 | 655 point. Any input that is not a digit (in the base used) terminates |
| 656 the sequence. If the terminator is RET, it is discarded; any other | |
| 3341 | 657 terminator is used itself as input. |
| 1333 | 658 |
| 659 The optional argument PROMPT specifies a string to use to prompt the user. | |
| 660 The variable `read-quoted-char-radix' controls which radix to use | |
| 661 for numeric input." | |
| 662 (let (;(message-log-max nil) | |
| 663 done (first t) (code 0) char event | |
| 428 | 664 (prompt (and prompt (gettext prompt))) |
| 1333 | 665 ) |
| 666 (while (not done) | |
| 667 (let ((inhibit-quit first) | |
| 3341 | 668 ;; Don't let C-h get the help message--only help |
| 669 ;; function keys. | |
| 670 ;; XEmacs: we don't support the help function keys as of | |
| 671 ;; 2006-04-16. GNU have a Vhelp_event_list in addition | |
| 672 ;; to help-char in src/keyboard.c, and it's only useful | |
| 673 ;; to set help-form while help-char is nil when that | |
| 674 ;; functionality is available. | |
| 428 | 675 (help-char nil) |
| 3341 | 676 (help-form (format |
| 428 | 677 "Type the special character you want to use, |
| 3341 | 678 or the character code, base %d (the value of `read-quoted-char-radix') |
| 1333 | 679 RET terminates the character code and is discarded; |
| 3341 | 680 any other non-digit terminates the character code and is then used as input." |
| 681 read-quoted-char-radix))) | |
| 428 | 682 (and prompt (display-message 'prompt (format "%s-" prompt))) |
| 683 (setq event (next-command-event) | |
| 3474 | 684 ;; If event-to-character fails, this is fine, we handle that |
| 685 ;; with the (null char) cond branch below. | |
| 686 char (event-to-character event)) | |
| 428 | 687 (if inhibit-quit (setq quit-flag nil))) |
| 1333 | 688 ;; Translate TAB key into control-I ASCII character, and so on. |
| 689 (and char | |
| 690 (let ((translated (lookup-key function-key-map (vector char)))) | |
| 691 (if (arrayp translated) | |
| 692 (setq char (aref translated 0))))) | |
| 693 (cond ((null char)) | |
| 694 ((not (characterp char)) | |
| 3196 | 695 ;; XEmacs change; event instead of char. |
| 696 (setq unread-command-events (list event) | |
| 1333 | 697 done t)) |
| 698 ; ((/= (logand char ?\M-\^@) 0) | |
| 699 ; ;; Turn a meta-character into a character with the 0200 bit set. | |
| 700 ; (setq code (logior (logand char (lognot ?\M-\^@)) 128) | |
| 701 ; done t)) | |
| 702 ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix)))) | |
| 703 (setq code (+ (* code read-quoted-char-radix) (- char ?0))) | |
| 704 (and prompt (setq prompt (display-message 'prompt | |
| 705 (format "%s %c" prompt char))))) | |
| 706 ((and (<= ?a (downcase char)) | |
| 707 (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix)))) | |
| 708 (setq code (+ (* code read-quoted-char-radix) | |
| 709 (+ 10 (- (downcase char) ?a)))) | |
| 710 (and prompt (setq prompt (display-message 'prompt | |
| 711 (format "%s %c" prompt char))))) | |
| 712 ((and (not first) (eq char ?\C-m)) | |
| 713 (setq done t)) | |
| 714 ((not first) | |
| 3196 | 715 ;; XEmacs change; event instead of char. |
| 716 (setq unread-command-events (list event) | |
| 428 | 717 done t)) |
| 1346 | 718 (t (setq code (char-to-int char) |
| 1333 | 719 done t))) |
| 720 (setq first nil)) | |
| 3341 | 721 ;; XEmacs change; unicode-to-char instead of int-to-char |
| 722 (unicode-to-char code))) | |
| 1333 | 723 |
| 724 ;; in passwd.el. | |
| 725 ; (defun read-passwd (prompt &optional confirm default) | |
| 726 ; "Read a password, prompting with PROMPT. Echo `.' for each character typed. | |
| 727 ; End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line. | |
| 728 ; Optional argument CONFIRM, if non-nil, then read it twice to make sure. | |
| 729 ; Optional DEFAULT is a default password to use instead of empty input." | |
| 730 ; (if confirm | |
| 731 ; (let (success) | |
| 732 ; (while (not success) | |
| 733 ; (let ((first (read-passwd prompt nil default)) | |
| 734 ; (second (read-passwd "Confirm password: " nil default))) | |
| 735 ; (if (equal first second) | |
| 736 ; (progn | |
| 737 ; (and (arrayp second) (fillarray second ?\0)) | |
| 738 ; (setq success first)) | |
| 739 ; (and (arrayp first) (fillarray first ?\0)) | |
| 740 ; (and (arrayp second) (fillarray second ?\0)) | |
| 741 ; (message "Password not repeated accurately; please start over") | |
| 742 ; (sit-for 1)))) | |
| 743 ; success) | |
| 744 ; (let ((pass nil) | |
| 745 ; (c 0) | |
| 746 ; (echo-keystrokes 0) | |
| 747 ; (cursor-in-echo-area t)) | |
| 748 ; (while (progn (message "%s%s" | |
| 749 ; prompt | |
| 750 ; (make-string (length pass) ?.)) | |
| 751 ; (setq c (read-char-exclusive nil t)) | |
| 752 ; (and (/= c ?\r) (/= c ?\n) (/= c ?\e))) | |
| 753 ; (clear-this-command-keys) | |
| 754 ; (if (= c ?\C-u) | |
| 755 ; (progn | |
| 756 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 757 ; (setq pass "")) | |
| 758 ; (if (and (/= c ?\b) (/= c ?\177)) | |
| 759 ; (let* ((new-char (char-to-string c)) | |
| 760 ; (new-pass (concat pass new-char))) | |
| 761 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 762 ; (fillarray new-char ?\0) | |
| 763 ; (setq c ?\0) | |
| 764 ; (setq pass new-pass)) | |
| 765 ; (if (> (length pass) 0) | |
| 766 ; (let ((new-pass (substring pass 0 -1))) | |
| 767 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 768 ; (setq pass new-pass)))))) | |
| 769 ; (message nil) | |
| 770 ; (or pass default "")))) | |
| 771 | |
| 772 ;; aliased to redraw-modeline, a built-in. | |
| 773 ; (defun force-mode-line-update (&optional all) | |
| 774 ; "Force the mode-line of the current buffer to be redisplayed. | |
| 775 ; With optional non-nil ALL, force redisplay of all mode-lines." | |
| 776 ; (if all (save-excursion (set-buffer (other-buffer)))) | |
| 777 ; (set-buffer-modified-p (buffer-modified-p))) | |
| 428 | 778 |
| 779 (defun momentary-string-display (string pos &optional exit-char message) | |
| 780 "Momentarily display STRING in the buffer at POS. | |
| 781 Display remains until next character is typed. | |
| 782 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed; | |
| 783 otherwise it is then available as input (as a command if nothing else). | |
| 784 Display MESSAGE (optional fourth arg) in the echo area. | |
| 785 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." | |
| 786 (or exit-char (setq exit-char ?\ )) | |
| 1333 | 787 (let ((inhibit-read-only t) |
| 428 | 788 ;; Don't modify the undo list at all. |
| 789 (buffer-undo-list t) | |
| 790 (modified (buffer-modified-p)) | |
| 791 (name buffer-file-name) | |
| 792 insert-end) | |
| 793 (unwind-protect | |
| 794 (progn | |
| 795 (save-excursion | |
| 796 (goto-char pos) | |
| 797 ;; defeat file locking... don't try this at home, kids! | |
| 798 (setq buffer-file-name nil) | |
| 799 (insert-before-markers (gettext string)) | |
| 800 (setq insert-end (point)) | |
| 1333 | 801 ;; If the message end is off screen, recenter now. |
| 802 (if (< (window-end nil t) insert-end) | |
| 428 | 803 (recenter (/ (window-height) 2))) |
| 804 ;; If that pushed message start off the frame, | |
| 805 ;; scroll to start it at the top of the frame. | |
| 806 (move-to-window-line 0) | |
| 807 (if (> (point) pos) | |
| 808 (progn | |
| 809 (goto-char pos) | |
| 810 (recenter 0)))) | |
| 811 (message (or message (gettext "Type %s to continue editing.")) | |
| 812 (single-key-description exit-char)) | |
| 813 (let ((event (save-excursion (next-command-event)))) | |
| 814 (or (eq (event-to-character event) exit-char) | |
| 1333 | 815 (setq unread-command-events (list event))))) |
| 428 | 816 (if insert-end |
| 817 (save-excursion | |
| 818 (delete-region pos insert-end))) | |
| 819 (setq buffer-file-name name) | |
| 820 (set-buffer-modified-p modified)))) | |
| 821 | |
| 1333 | 822 ;; END SYNCHED WITH FSF 21.2. |
| 823 | |
| 428 | 824 ;;; cmdloop.el ends here |