Mercurial > hg > xemacs-beta
annotate lisp/cmdloop.el @ 5595:391d809fa4e9
Update tests that have started failing because of changed design decisions.
2011-11-09 Aidan Kehoe <kehoea@parhasard.net>
Update some tests that have started failing because of some
changed design decisions.
* automated/lisp-tests.el (eq):
(type-of 42) now returns the symbol fixnum.
* automated/lisp-tests.el (needs-lexical-context):
(function ...) doesn't create a lexical context, and this is now the
case in interpreted as well as in compiled code.
* automated/mule-tests.el (featurep):
Silence messages when byte-compiling files; if a file doesn't have
the escape-quoted coding cookie, it will now have the
raw-text-unix coding cookie, look for that instead of looking for
the absence of the escape-quoted coding cookie.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Wed, 09 Nov 2011 13:16:19 +0000 |
| parents | 4dee0387b9de |
| children | f9e4d44504a4 |
| 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 '()))) | |
| 453 (let* ((keys (events-to-keys (vector event))) | |
| 454 (def (lookup-key query-replace-map keys))) | |
| 455 (cond ((eq def 'skip) | |
| 456 (message "%s%sNo" prompt yn) | |
| 457 (setq yn nil)) | |
| 458 ((eq def 'act) | |
| 459 (message "%s%sYes" prompt yn) | |
| 460 (setq yn t)) | |
| 461 ((eq def 'recenter) | |
| 462 (recenter)) | |
| 463 ((or (eq def 'quit) (eq def 'exit-prefix)) | |
| 464 (signal 'quit '())) | |
| 465 ((button-release-event-p event) ; ignore them | |
| 466 nil) | |
| 467 (t | |
| 468 (message "%s%s%s%s" pre prompt yn | |
| 469 (single-key-description event)) | |
| 470 (ding nil 'y-or-n-p) | |
| 471 (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
|
472 (if (eql (length pre) 0) |
| 428 | 473 (setq pre (gettext "Please answer y or n. "))))))) |
| 474 yn))) | |
| 475 | |
| 476 (defun yes-or-no-p-minibuf (prompt) | |
| 477 "Ask user a yes-or-no question. Return t if answer is yes. | |
| 478 Takes one argument, which is the string to display to ask the question. | |
| 479 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. | |
| 480 The user must confirm the answer with RET, | |
| 481 and can edit it until it has been confirmed." | |
| 482 (save-excursion | |
| 483 (let ((p (concat (gettext prompt) (gettext "(yes or no) "))) | |
| 484 (ans "")) | |
| 485 (while (stringp ans) | |
| 486 (setq ans (downcase (read-string p nil t))) ;no history | |
| 487 (cond ((string-equal ans (gettext "yes")) | |
| 488 (setq ans t)) | |
| 489 ((string-equal ans (gettext "no")) | |
| 490 (setq ans nil)) | |
| 491 (t | |
| 492 (ding nil 'yes-or-no-p) | |
| 493 (discard-input) | |
| 494 (message "Please answer yes or no.") | |
| 495 (sleep-for 2)))) | |
| 496 ans))) | |
| 497 | |
| 442 | 498 (defun yes-or-no-p (prompt) |
| 499 "Ask user a yes-or-no question. Return t if answer is yes. | |
| 500 The question is asked with a dialog box or the minibuffer, as appropriate. | |
| 501 Takes one argument, which is the string to display to ask the question. | |
| 502 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. | |
| 503 The user must confirm the answer with RET, | |
| 504 and can edit it until it as been confirmed." | |
| 505 (if (should-use-dialog-box-p) | |
| 4222 | 506 ;; and-fboundp is redundant, since yes-or-no-p-dialog-box is only |
| 507 ;; bound if (featurep 'dialog). But it eliminates a compile-time | |
| 508 ;; 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
|
509 (and-fboundp 'yes-or-no-p-dialog-box (yes-or-no-p-dialog-box prompt)) |
| 442 | 510 (yes-or-no-p-minibuf prompt))) |
| 511 | |
| 512 (defun y-or-n-p (prompt) | |
| 513 "Ask user a \"y or n\" question. Return t if answer is \"y\". | |
| 514 Takes one argument, which is the string to display to ask the question. | |
| 515 The question is asked with a dialog box or the minibuffer, as appropriate. | |
| 516 It should end in a space; `y-or-n-p' adds `(y or n) ' to it. | |
| 517 No confirmation of the answer is requested; a single character is enough. | |
| 518 Also accepts Space to mean yes, or Delete to mean no." | |
| 519 (if (should-use-dialog-box-p) | |
| 520 (yes-or-no-p-dialog-box prompt) | |
| 521 (y-or-n-p-minibuf prompt))) | |
| 522 | |
| 428 | 523 |
| 524 | |
| 525 (defun read-char () | |
| 526 "Read a character from the command input (keyboard or macro). | |
| 527 If a mouse click or non-ASCII character is detected, an error is | |
| 528 signalled. The character typed is returned as an ASCII value. This | |
| 529 is most likely the wrong thing for you to be using: consider using | |
| 530 the `next-command-event' function instead." | |
| 531 (save-excursion | |
| 532 (let ((event (next-command-event))) | |
| 533 (or inhibit-quit | |
| 534 (and (event-matches-key-specifier-p event (quit-char)) | |
| 535 (signal 'quit nil))) | |
| 536 (prog1 (or (event-to-character event) | |
| 537 ;; Kludge. If the event we read was a mouse-release, | |
| 538 ;; discard it and read the next one. | |
| 539 (if (button-release-event-p event) | |
| 540 (event-to-character (next-command-event event))) | |
| 541 (error "Key read has no ASCII equivalent %S" event)) | |
| 542 ;; this is not necessary, but is marginally more efficient than GC. | |
| 543 (deallocate-event event))))) | |
| 544 | |
| 545 (defun read-char-exclusive () | |
| 546 "Read a character from the command input (keyboard or macro). | |
| 547 If a mouse click or non-ASCII character is detected, it is discarded. | |
| 548 The character typed is returned as an ASCII value. This is most likely | |
| 549 the wrong thing for you to be using: consider using the | |
| 550 `next-command-event' function instead." | |
| 551 (let (event ch) | |
| 552 (while (progn | |
| 553 (setq event (next-command-event)) | |
| 554 (or inhibit-quit | |
| 555 (and (event-matches-key-specifier-p event (quit-char)) | |
| 556 (signal 'quit nil))) | |
| 557 (setq ch (event-to-character event)) | |
| 558 (deallocate-event event) | |
| 559 (null ch))) | |
| 560 ch)) | |
| 561 | |
| 1333 | 562 ;;;; Input and display facilities. |
| 563 | |
| 564 ;; BEGIN SYNCHED WITH FSF 21.2. | |
| 565 | |
|
5284
d27c1ee1943b
Make the order of preloaded-file-list more sane.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5208
diff
changeset
|
566 (defcustom read-quoted-char-radix 8 |
| 1333 | 567 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'. |
| 568 Legitimate radix values are 8, 10 and 16." | |
| 569 :type '(choice (const 8) (const 10) (const 16)) | |
| 570 :group 'editing-basics) | |
| 571 | |
| 428 | 572 (defun read-quoted-char (&optional prompt) |
| 3341 | 573 ;; XEmacs change; description of the character code input |
| 1333 | 574 "Like `read-char', but do not allow quitting. |
| 3341 | 575 |
| 576 Also, if the first character read is a digit of base (the value of) | |
| 577 `read-quoted-char-radix', we read as many of such digits as are | |
| 578 typed and return a character with the corresponding Unicode code | |
| 3344 | 579 point. Any input that is not a digit (in the base used) terminates |
| 580 the sequence. If the terminator is RET, it is discarded; any other | |
| 3341 | 581 terminator is used itself as input. |
| 1333 | 582 |
| 583 The optional argument PROMPT specifies a string to use to prompt the user. | |
| 584 The variable `read-quoted-char-radix' controls which radix to use | |
| 585 for numeric input." | |
| 586 (let (;(message-log-max nil) | |
| 587 done (first t) (code 0) char event | |
| 428 | 588 (prompt (and prompt (gettext prompt))) |
| 1333 | 589 ) |
| 590 (while (not done) | |
| 591 (let ((inhibit-quit first) | |
| 3341 | 592 ;; Don't let C-h get the help message--only help |
| 593 ;; function keys. | |
| 594 ;; XEmacs: we don't support the help function keys as of | |
| 595 ;; 2006-04-16. GNU have a Vhelp_event_list in addition | |
| 596 ;; to help-char in src/keyboard.c, and it's only useful | |
| 597 ;; to set help-form while help-char is nil when that | |
| 598 ;; functionality is available. | |
| 428 | 599 (help-char nil) |
| 3341 | 600 (help-form (format |
| 428 | 601 "Type the special character you want to use, |
| 3341 | 602 or the character code, base %d (the value of `read-quoted-char-radix') |
| 1333 | 603 RET terminates the character code and is discarded; |
| 3341 | 604 any other non-digit terminates the character code and is then used as input." |
| 605 read-quoted-char-radix))) | |
| 428 | 606 (and prompt (display-message 'prompt (format "%s-" prompt))) |
| 607 (setq event (next-command-event) | |
| 3474 | 608 ;; If event-to-character fails, this is fine, we handle that |
| 609 ;; with the (null char) cond branch below. | |
| 610 char (event-to-character event)) | |
| 428 | 611 (if inhibit-quit (setq quit-flag nil))) |
| 1333 | 612 ;; Translate TAB key into control-I ASCII character, and so on. |
| 613 (and char | |
| 614 (let ((translated (lookup-key function-key-map (vector char)))) | |
| 615 (if (arrayp translated) | |
| 616 (setq char (aref translated 0))))) | |
| 617 (cond ((null char)) | |
| 618 ((not (characterp char)) | |
| 3196 | 619 ;; XEmacs change; event instead of char. |
| 620 (setq unread-command-events (list event) | |
| 1333 | 621 done t)) |
| 622 ; ((/= (logand char ?\M-\^@) 0) | |
| 623 ; ;; Turn a meta-character into a character with the 0200 bit set. | |
| 624 ; (setq code (logior (logand char (lognot ?\M-\^@)) 128) | |
| 625 ; done t)) | |
| 626 ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix)))) | |
| 627 (setq code (+ (* code read-quoted-char-radix) (- char ?0))) | |
| 628 (and prompt (setq prompt (display-message 'prompt | |
| 629 (format "%s %c" prompt char))))) | |
| 630 ((and (<= ?a (downcase char)) | |
| 631 (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix)))) | |
| 632 (setq code (+ (* code read-quoted-char-radix) | |
| 633 (+ 10 (- (downcase char) ?a)))) | |
| 634 (and prompt (setq prompt (display-message 'prompt | |
| 635 (format "%s %c" prompt char))))) | |
| 636 ((and (not first) (eq char ?\C-m)) | |
| 637 (setq done t)) | |
| 638 ((not first) | |
| 3196 | 639 ;; XEmacs change; event instead of char. |
| 640 (setq unread-command-events (list event) | |
| 428 | 641 done t)) |
| 1346 | 642 (t (setq code (char-to-int char) |
| 1333 | 643 done t))) |
| 644 (setq first nil)) | |
| 3341 | 645 ;; XEmacs change; unicode-to-char instead of int-to-char |
| 646 (unicode-to-char code))) | |
| 1333 | 647 |
| 648 ;; in passwd.el. | |
| 649 ; (defun read-passwd (prompt &optional confirm default) | |
| 650 ; "Read a password, prompting with PROMPT. Echo `.' for each character typed. | |
| 651 ; End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line. | |
| 652 ; Optional argument CONFIRM, if non-nil, then read it twice to make sure. | |
| 653 ; Optional DEFAULT is a default password to use instead of empty input." | |
| 654 ; (if confirm | |
| 655 ; (let (success) | |
| 656 ; (while (not success) | |
| 657 ; (let ((first (read-passwd prompt nil default)) | |
| 658 ; (second (read-passwd "Confirm password: " nil default))) | |
| 659 ; (if (equal first second) | |
| 660 ; (progn | |
| 661 ; (and (arrayp second) (fillarray second ?\0)) | |
| 662 ; (setq success first)) | |
| 663 ; (and (arrayp first) (fillarray first ?\0)) | |
| 664 ; (and (arrayp second) (fillarray second ?\0)) | |
| 665 ; (message "Password not repeated accurately; please start over") | |
| 666 ; (sit-for 1)))) | |
| 667 ; success) | |
| 668 ; (let ((pass nil) | |
| 669 ; (c 0) | |
| 670 ; (echo-keystrokes 0) | |
| 671 ; (cursor-in-echo-area t)) | |
| 672 ; (while (progn (message "%s%s" | |
| 673 ; prompt | |
| 674 ; (make-string (length pass) ?.)) | |
| 675 ; (setq c (read-char-exclusive nil t)) | |
| 676 ; (and (/= c ?\r) (/= c ?\n) (/= c ?\e))) | |
| 677 ; (clear-this-command-keys) | |
| 678 ; (if (= c ?\C-u) | |
| 679 ; (progn | |
| 680 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 681 ; (setq pass "")) | |
| 682 ; (if (and (/= c ?\b) (/= c ?\177)) | |
| 683 ; (let* ((new-char (char-to-string c)) | |
| 684 ; (new-pass (concat pass new-char))) | |
| 685 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 686 ; (fillarray new-char ?\0) | |
| 687 ; (setq c ?\0) | |
| 688 ; (setq pass new-pass)) | |
| 689 ; (if (> (length pass) 0) | |
| 690 ; (let ((new-pass (substring pass 0 -1))) | |
| 691 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 692 ; (setq pass new-pass)))))) | |
| 693 ; (message nil) | |
| 694 ; (or pass default "")))) | |
| 695 | |
| 696 ;; aliased to redraw-modeline, a built-in. | |
| 697 ; (defun force-mode-line-update (&optional all) | |
| 698 ; "Force the mode-line of the current buffer to be redisplayed. | |
| 699 ; With optional non-nil ALL, force redisplay of all mode-lines." | |
| 700 ; (if all (save-excursion (set-buffer (other-buffer)))) | |
| 701 ; (set-buffer-modified-p (buffer-modified-p))) | |
| 428 | 702 |
| 703 (defun momentary-string-display (string pos &optional exit-char message) | |
| 704 "Momentarily display STRING in the buffer at POS. | |
| 705 Display remains until next character is typed. | |
| 706 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed; | |
| 707 otherwise it is then available as input (as a command if nothing else). | |
| 708 Display MESSAGE (optional fourth arg) in the echo area. | |
| 709 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." | |
| 710 (or exit-char (setq exit-char ?\ )) | |
| 1333 | 711 (let ((inhibit-read-only t) |
| 428 | 712 ;; Don't modify the undo list at all. |
| 713 (buffer-undo-list t) | |
| 714 (modified (buffer-modified-p)) | |
| 715 (name buffer-file-name) | |
| 716 insert-end) | |
| 717 (unwind-protect | |
| 718 (progn | |
| 719 (save-excursion | |
| 720 (goto-char pos) | |
| 721 ;; defeat file locking... don't try this at home, kids! | |
| 722 (setq buffer-file-name nil) | |
| 723 (insert-before-markers (gettext string)) | |
| 724 (setq insert-end (point)) | |
| 1333 | 725 ;; If the message end is off screen, recenter now. |
| 726 (if (< (window-end nil t) insert-end) | |
| 428 | 727 (recenter (/ (window-height) 2))) |
| 728 ;; If that pushed message start off the frame, | |
| 729 ;; scroll to start it at the top of the frame. | |
| 730 (move-to-window-line 0) | |
| 731 (if (> (point) pos) | |
| 732 (progn | |
| 733 (goto-char pos) | |
| 734 (recenter 0)))) | |
| 735 (message (or message (gettext "Type %s to continue editing.")) | |
| 736 (single-key-description exit-char)) | |
| 737 (let ((event (save-excursion (next-command-event)))) | |
| 738 (or (eq (event-to-character event) exit-char) | |
| 1333 | 739 (setq unread-command-events (list event))))) |
| 428 | 740 (if insert-end |
| 741 (save-excursion | |
| 742 (delete-region pos insert-end))) | |
| 743 (setq buffer-file-name name) | |
| 744 (set-buffer-modified-p modified)))) | |
| 745 | |
| 1333 | 746 ;; END SYNCHED WITH FSF 21.2. |
| 747 | |
| 428 | 748 ;;; cmdloop.el ends here |