Mercurial > hg > xemacs-beta
annotate lisp/cmdloop.el @ 5940:c608d4b0b75e cygwin64 tip
rescue lost branch from 64bit.backup
| author | Henry Thompson <ht@markup.co.uk> |
|---|---|
| date | Thu, 16 Dec 2021 18:48:58 +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 |