428
+ − 1 ;;; cmdloop.el --- support functions for the top-level command loop.
+ − 2
+ − 3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
1123
+ − 4 ;; Copyright (C) 2001, 2002 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
+ − 13 ;; XEmacs is free software; you can redistribute it and/or modify it
+ − 14 ;; under the terms of the GNU General Public License as published by
+ − 15 ;; the Free Software Foundation; either version 2, or (at your option)
+ − 16 ;; any later version.
+ − 17
+ − 18 ;; XEmacs is distributed in the hope that it will be useful, but
+ − 19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
+ − 20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ − 21 ;; General Public License for more details.
+ − 22
+ − 23 ;; You should have received a copy of the GNU General Public License
+ − 24 ;; along with XEmacs; see the file COPYING. If not, write to the
+ − 25 ;; Free Software Foundation, 59 Temple Place - Suite 330,
+ − 26 ;; Boston, MA 02111-1307, USA.
+ − 27
+ − 28 ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.)
+ − 29
+ − 30 ;;; Commentary:
+ − 31
+ − 32 ;; This file is dumped with XEmacs.
+ − 33
+ − 34 ;;; Code:
+ − 35
+ − 36 (defun recursion-depth ()
+ − 37 "Return the current depth in recursive edits."
+ − 38 (+ command-loop-level (minibuffer-depth)))
+ − 39
+ − 40 (defun top-level ()
+ − 41 "Exit all recursive editing levels."
+ − 42 (interactive)
+ − 43 (throw 'top-level nil))
+ − 44
+ − 45 (defun exit-recursive-edit ()
+ − 46 "Exit from the innermost recursive edit or minibuffer."
+ − 47 (interactive)
+ − 48 (if (> (recursion-depth) 0)
+ − 49 (throw 'exit nil))
+ − 50 (error "No recursive edit is in progress"))
+ − 51
+ − 52 (defun abort-recursive-edit ()
+ − 53 "Abort the command that requested this recursive edit or minibuffer input."
+ − 54 (interactive)
+ − 55 (if (> (recursion-depth) 0)
+ − 56 (throw 'exit t))
+ − 57 (error "No recursive edit is in progress"))
+ − 58
+ − 59 ;; (defun keyboard-quit ()
+ − 60 ;; "Signal a `quit' condition."
+ − 61 ;; (interactive)
+ − 62 ;; (deactivate-mark)
+ − 63 ;; (signal 'quit nil))
+ − 64
+ − 65 ;; moved here from pending-del.
+ − 66 (defun keyboard-quit ()
+ − 67 "Signal a `quit' condition.
+ − 68 If this character is typed while lisp code is executing, it will be treated
+ − 69 as an interrupt.
+ − 70 If this character is typed at top-level, this simply beeps.
+ − 71 If `zmacs-regions' is true, and the zmacs region is active in this buffer,
+ − 72 then this key deactivates the region without beeping or signalling."
+ − 73 (interactive)
+ − 74 (if (and (region-active-p)
+ − 75 (eq (current-buffer) (zmacs-region-buffer)))
+ − 76 ;; pseudo-zmacs compatibility: don't beep if this ^G is simply
+ − 77 ;; deactivating the region. If it is inactive, beep.
+ − 78 nil
+ − 79 (signal 'quit nil)))
+ − 80
+ − 81 (defvar buffer-quit-function nil
+ − 82 "Function to call to \"quit\" the current buffer, or nil if none.
+ − 83 \\[keyboard-escape-quit] calls this function when its more local actions
+ − 84 \(such as cancelling a prefix argument, minibuffer or region) do not apply.")
+ − 85
+ − 86 (defun keyboard-escape-quit ()
+ − 87 "Exit the current \"mode\" (in a generalized sense of the word).
+ − 88 This command can exit an interactive command such as `query-replace',
+ − 89 can clear out a prefix argument or a region,
+ − 90 can get out of the minibuffer or other recursive edit,
+ − 91 cancel the use of the current buffer (for special-purpose buffers),
+ − 92 or go back to just one window (by deleting all but the selected window)."
+ − 93 (interactive)
+ − 94 (cond ((eq last-command 'mode-exited) nil)
+ − 95 ((> (minibuffer-depth) 0)
+ − 96 (abort-recursive-edit))
+ − 97 (current-prefix-arg
+ − 98 nil)
+ − 99 ((region-active-p)
+ − 100 (zmacs-deactivate-region))
+ − 101 ((> (recursion-depth) 0)
+ − 102 (exit-recursive-edit))
+ − 103 (buffer-quit-function
+ − 104 (funcall buffer-quit-function))
+ − 105 ((not (one-window-p t))
+ − 106 (delete-other-windows))
+ − 107 ((string-match "^ \\*" (buffer-name (current-buffer)))
+ − 108 (bury-buffer))))
+ − 109
+ − 110 ;; `cancel-mode-internal' is a function of a misc-user event, which is
+ − 111 ;; queued when window system directs XEmacs frame to cancel any modal
+ − 112 ;; behavior it exposes, like mouse pointer grabbing.
+ − 113 ;;
+ − 114 ;; This function does nothing at the top level, but the code which
+ − 115 ;; runs modal event loops, such as selection drag loop in `mouse-track',
+ − 116 ;; check if misc-user function symbol is `cancel-mode-internal', and
+ − 117 ;; takes necessary cleanup actions.
+ − 118 (defun cancel-mode-internal (object)
+ − 119 (setq zmacs-region-stays t))
+ − 120
+ − 121 ;; Someone wrote: "This should really be a ring of last errors."
+ − 122 ;;
+ − 123 ;; But why bother? This stuff is not all that necessary now that we
+ − 124 ;; have message log, anyway.
+ − 125 (defvar last-error nil
+ − 126 "Object describing the last signaled error.")
+ − 127
+ − 128 (defcustom errors-deactivate-region nil
+ − 129 "*Non-nil means that errors will cause the region to be deactivated."
+ − 130 :type 'boolean
+ − 131 :group 'editing-basics)
+ − 132
+ − 133 (defun command-error (error-object)
771
+ − 134 ;; if you want a backtrace before exiting, set stack-trace-on-error.
+ − 135 (let* ((inhibit-quit t)
442
+ − 136 (debug-on-error nil)
+ − 137 (etype (car-safe error-object)))
428
+ − 138 (setq quit-flag nil)
+ − 139 (setq standard-output t)
+ − 140 (setq standard-input t)
+ − 141 (setq executing-kbd-macro nil)
+ − 142 (and errors-deactivate-region
+ − 143 (zmacs-deactivate-region))
+ − 144 (discard-input)
+ − 145
+ − 146 (setq last-error error-object)
+ − 147
+ − 148 (message nil)
+ − 149 (ding nil (cond ((eq etype 'undefined-keystroke-sequence)
+ − 150 (if (and (vectorp (nth 1 error-object))
+ − 151 (/= 0 (length (nth 1 error-object)))
+ − 152 (button-event-p (aref (nth 1 error-object) 0)))
+ − 153 'undefined-click
+ − 154 'undefined-key))
+ − 155 ((eq etype 'quit)
+ − 156 'quit)
+ − 157 ((memq etype '(end-of-buffer beginning-of-buffer))
+ − 158 'buffer-bound)
+ − 159 ((eq etype 'buffer-read-only)
+ − 160 'read-only)
+ − 161 (t 'command-error)))
+ − 162 (display-error error-object t)
+ − 163
+ − 164 (if (noninteractive)
+ − 165 (progn
1123
+ − 166 (message "%s exiting.\n" emacs-program-name)
428
+ − 167 (kill-emacs -1)))
+ − 168 t))
+ − 169
+ − 170 (defun describe-last-error ()
+ − 171 "Redisplay the last error-message. See the variable `last-error'."
+ − 172 (interactive)
+ − 173 (if last-error
+ − 174 (with-displaying-help-buffer
+ − 175 (lambda ()
+ − 176 (princ "Last error was:\n" standard-output)
+ − 177 (display-error last-error standard-output)))
+ − 178 (message "No error yet")))
+ − 179
+ − 180
+ − 181 ;;#### Must be done later in the loadup sequence
+ − 182 ;(define-key (symbol-function 'help-command) "e" 'describe-last-error)
+ − 183
+ − 184
+ − 185 (defun truncate-command-history-for-gc ()
+ − 186 (let ((tail (nthcdr 30 command-history)))
+ − 187 (if tail (setcdr tail nil)))
+ − 188 (let ((tail (nthcdr 30 values)))
+ − 189 (if tail (setcdr tail nil)))
+ − 190 )
+ − 191
+ − 192 (add-hook 'pre-gc-hook 'truncate-command-history-for-gc)
+ − 193
+ − 194
+ − 195 ;;;; Object-oriented programming at its finest
+ − 196
+ − 197 ;; Now in src/print.c; used by Ferror_message_string and others
+ − 198 ;(defun display-error (error-object stream) ;(defgeneric report-condition ...)
+ − 199 ; "Display `error-object' on `stream' in a user-friendly way."
+ − 200 ; (funcall (or (let ((type (car-safe error-object)))
+ − 201 ; (catch 'error
+ − 202 ; (and (consp error-object)
+ − 203 ; (symbolp type)
+ − 204 ; ;;(stringp (get type 'error-message))
+ − 205 ; (consp (get type 'error-conditions))
+ − 206 ; (let ((tail (cdr error-object)))
+ − 207 ; (while (not (null tail))
+ − 208 ; (if (consp tail)
+ − 209 ; (setq tail (cdr tail))
+ − 210 ; (throw 'error nil)))
+ − 211 ; t)
+ − 212 ; ;; (check-type condition condition)
+ − 213 ; (get type 'error-conditions)
+ − 214 ; ;; Search class hierarchy
+ − 215 ; (let ((tail (get type 'error-conditions)))
+ − 216 ; (while (not (null tail))
+ − 217 ; (cond ((not (and (consp tail)
+ − 218 ; (symbolp (car tail))))
+ − 219 ; (throw 'error nil))
+ − 220 ; ((get (car tail) 'display-error)
+ − 221 ; (throw 'error (get (car tail)
+ − 222 ; 'display-error)))
+ − 223 ; (t
+ − 224 ; (setq tail (cdr tail)))))
+ − 225 ; ;; Default method
+ − 226 ; #'(lambda (error-object stream)
+ − 227 ; (let ((type (car error-object))
+ − 228 ; (tail (cdr error-object))
+ − 229 ; (first t)
+ − 230 ; (print-message-label 'error))
+ − 231 ; (if (eq type 'error)
+ − 232 ; (progn (princ (car tail) stream)
+ − 233 ; (setq tail (cdr tail)))
+ − 234 ; (princ (or (gettext (get type 'error-message)) type)
+ − 235 ; stream))
+ − 236 ; (while tail
+ − 237 ; (princ (if first ": " ", ") stream)
+ − 238 ; (prin1 (car tail) stream)
+ − 239 ; (setq tail (cdr tail)
+ − 240 ; first nil))))))))
+ − 241 ; #'(lambda (error-object stream)
+ − 242 ; (princ (gettext "Peculiar error ") stream)
+ − 243 ; (prin1 error-object stream)))
+ − 244 ; error-object stream))
+ − 245
+ − 246 (put 'file-error 'display-error
+ − 247 #'(lambda (error-object stream)
+ − 248 (let ((tail (cdr error-object))
+ − 249 (first t))
+ − 250 (princ (car tail) stream)
+ − 251 (while (setq tail (cdr tail))
+ − 252 (princ (if first ": " ", ") stream)
+ − 253 (princ (car tail) stream)
+ − 254 (setq first nil)))))
+ − 255
+ − 256 (put 'undefined-keystroke-sequence 'display-error
+ − 257 #'(lambda (error-object stream)
+ − 258 (princ (key-description (car (cdr error-object))) stream)
+ − 259 ;; #### I18N3: doesn't localize properly.
+ − 260 (princ (gettext " not defined.") stream) ; doo dah, doo dah.
+ − 261 ))
+ − 262
+ − 263
+ − 264 (defcustom teach-extended-commands-p t
+ − 265 "*If true, then `\\[execute-extended-command]' will teach you keybindings.
+ − 266 Any time you execute a command with \\[execute-extended-command] which has a
+ − 267 shorter keybinding, you will be shown the alternate binding before the
+ − 268 command executes. There is a short pause after displaying the binding,
+ − 269 before executing it; the length can be controlled by
+ − 270 `teach-extended-commands-timeout'."
+ − 271 :type 'boolean
+ − 272 :group 'keyboard)
+ − 273
+ − 274 (defcustom teach-extended-commands-timeout 4
+ − 275 "*How long to pause after displaying a keybinding before executing.
+ − 276 The value is measured in seconds. This only applies if
+ − 277 `teach-extended-commands-p' is true."
+ − 278 :type 'number
+ − 279 :group 'keyboard)
+ − 280
+ − 281 ;That damn RMS went off and implemented something differently, after
+ − 282 ;we had already implemented it. We can't support both properly until
+ − 283 ;we have Lisp magic variables.
+ − 284 ;(defvar suggest-key-bindings t
+ − 285 ; "*FSFmacs equivalent of `teach-extended-commands-*'.
+ − 286 ;Provided for compatibility only.
+ − 287 ;Non-nil means show the equivalent key-binding when M-x command has one.
+ − 288 ;The value can be a length of time to show the message for.
+ − 289 ;If the value is non-nil and not a number, we wait 2 seconds.")
+ − 290 ;
+ − 291 ;(make-obsolete-variable 'suggest-key-bindings 'teach-extended-commands-p)
+ − 292
+ − 293 (defun execute-extended-command (prefix-arg)
+ − 294 "Read a command name from the minibuffer using 'completing-read'.
+ − 295 Then call the specified command using 'command-execute' and return its
+ − 296 return value. If the command asks for a prefix argument, supply the
+ − 297 value of the current raw prefix argument, or the value of PREFIX-ARG
+ − 298 when called from Lisp."
+ − 299 (interactive "P")
+ − 300 ;; Note: This doesn't hack "this-command-keys"
+ − 301 (let ((prefix-arg prefix-arg))
+ − 302 (setq this-command (read-command
+ − 303 ;; Note: this has the hard-wired
+ − 304 ;; "C-u" and "M-x" string bug in common
613
+ − 305 ;; with all Emacs's.
428
+ − 306 ;; (i.e. it prints C-u and M-x regardless of
+ − 307 ;; whether some other keys were actually bound
+ − 308 ;; to `execute-extended-command' and
+ − 309 ;; `universal-argument'.
+ − 310 (cond ((eq prefix-arg '-)
+ − 311 "- M-x ")
+ − 312 ((equal prefix-arg '(4))
+ − 313 "C-u M-x ")
+ − 314 ((integerp prefix-arg)
+ − 315 (format "%d M-x " prefix-arg))
+ − 316 ((and (consp prefix-arg)
+ − 317 (integerp (car prefix-arg)))
+ − 318 (format "%d M-x " (car prefix-arg)))
+ − 319 (t
+ − 320 "M-x ")))))
+ − 321
+ − 322 (if (and teach-extended-commands-p
+ − 323 (interactive-p))
+ − 324 ;; Remember the keys, run the command, and show the keys (if
+ − 325 ;; any). The funny variable names are a poor man's guarantee
+ − 326 ;; that we don't get tripped by this-command doing something
+ − 327 ;; funny. Quoth our forefathers: "We want lexical scope!"
+ − 328 (let ((_execute_command_keys_ (where-is-internal this-command))
+ − 329 (_execute_command_name_ this-command)) ; the name can change
+ − 330 (command-execute this-command t)
+ − 331 (when _execute_command_keys_
+ − 332 ;; Normally the region is adjusted in post_command_hook;
+ − 333 ;; however, it is not called until after we finish. It
+ − 334 ;; looks ugly for the region to get updated after the
+ − 335 ;; delays, so we do it now. The code below is a Lispified
+ − 336 ;; copy of code in event-stream.c:post_command_hook().
+ − 337 (if (and (not zmacs-region-stays)
+ − 338 (or (not (eq (selected-window) (minibuffer-window)))
+ − 339 (eq (zmacs-region-buffer) (current-buffer))))
+ − 340 (zmacs-deactivate-region)
+ − 341 (zmacs-update-region))
+ − 342 ;; Wait for a while, so the user can see a message printed,
+ − 343 ;; if any.
+ − 344 (when (sit-for 1)
+ − 345 (display-message
+ − 346 'no-log
+ − 347 (format (if (cdr _execute_command_keys_)
+ − 348 "Command `%s' is bound to keys: %s"
+ − 349 "Command `%s' is bound to key: %s")
+ − 350 _execute_command_name_
+ − 351 (sorted-key-descriptions _execute_command_keys_)))
+ − 352 (sit-for teach-extended-commands-timeout)
+ − 353 (clear-message 'no-log))))
+ − 354 ;; Else, just run the command.
+ − 355 (command-execute this-command t)))
+ − 356
+ − 357
+ − 358 ;;; C code calls this; the underscores in the variable names are to avoid
+ − 359 ;;; cluttering the specbind namespace (lexical scope! lexical scope!)
+ − 360 ;;; Putting this in Lisp instead of C slows kbd macros by 50%.
+ − 361 ;(defun command-execute (_command &optional _record-flag)
+ − 362 ; "Execute CMD as an editor command.
+ − 363 ;CMD must be a symbol that satisfies the `commandp' predicate.
+ − 364 ;Optional second arg RECORD-FLAG non-nil
+ − 365 ;means unconditionally put this command in `command-history'.
+ − 366 ;Otherwise, that is done only if an arg is read using the minibuffer."
+ − 367 ; (let ((_prefix prefix-arg)
+ − 368 ; (_cmd (indirect-function _command)))
+ − 369 ; (setq prefix-arg nil
+ − 370 ; this-command _command
+ − 371 ; current-prefix-arg _prefix
+ − 372 ; zmacs-region-stays nil)
+ − 373 ; ;; #### debug_on_next_call = 0;
+ − 374 ; (cond ((and (symbolp _command)
+ − 375 ; (get _command 'disabled))
+ − 376 ; (run-hooks disabled-command-hook))
+ − 377 ; ((or (stringp _cmd) (vectorp _cmd))
+ − 378 ; ;; If requested, place the macro in the command history.
+ − 379 ; ;; For other sorts of commands, call-interactively takes
+ − 380 ; ;; care of this.
+ − 381 ; (if _record-flag
+ − 382 ; (setq command-history
+ − 383 ; (cons (list 'execute-kbd-macro _cmd _prefix)
+ − 384 ; command-history)))
+ − 385 ; (execute-kbd-macro _cmd _prefix))
+ − 386 ; (t
+ − 387 ; (call-interactively _command _record-flag)))))
+ − 388
+ − 389 (defun y-or-n-p-minibuf (prompt)
+ − 390 "Ask user a \"y or n\" question. Return t if answer is \"y\".
+ − 391 Takes one argument, which is the string to display to ask the question.
+ − 392 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
+ − 393 No confirmation of the answer is requested; a single character is enough.
+ − 394 Also accepts Space to mean yes, or Delete to mean no."
+ − 395 (save-excursion
+ − 396 (let* ((pre "")
+ − 397 (yn (gettext "(y or n) "))
+ − 398 ;; we need to translate the prompt ourselves because of the
+ − 399 ;; strange way we handle it.
+ − 400 (prompt (gettext prompt))
+ − 401 event)
+ − 402 (while (stringp yn)
+ − 403 (if (let ((cursor-in-echo-area t)
+ − 404 (inhibit-quit t))
+ − 405 (message "%s%s%s" pre prompt yn)
+ − 406 (setq event (next-command-event event))
+ − 407 (condition-case nil
+ − 408 (prog1
+ − 409 (or quit-flag (eq 'keyboard-quit (key-binding event)))
+ − 410 (setq quit-flag nil))
+ − 411 (wrong-type-argument t)))
+ − 412 (progn
+ − 413 (message "%s%s%s%s" pre prompt yn (single-key-description event))
+ − 414 (setq quit-flag nil)
+ − 415 (signal 'quit '())))
+ − 416 (let* ((keys (events-to-keys (vector event)))
+ − 417 (def (lookup-key query-replace-map keys)))
+ − 418 (cond ((eq def 'skip)
+ − 419 (message "%s%sNo" prompt yn)
+ − 420 (setq yn nil))
+ − 421 ((eq def 'act)
+ − 422 (message "%s%sYes" prompt yn)
+ − 423 (setq yn t))
+ − 424 ((eq def 'recenter)
+ − 425 (recenter))
+ − 426 ((or (eq def 'quit) (eq def 'exit-prefix))
+ − 427 (signal 'quit '()))
+ − 428 ((button-release-event-p event) ; ignore them
+ − 429 nil)
+ − 430 (t
+ − 431 (message "%s%s%s%s" pre prompt yn
+ − 432 (single-key-description event))
+ − 433 (ding nil 'y-or-n-p)
+ − 434 (discard-input)
+ − 435 (if (= (length pre) 0)
+ − 436 (setq pre (gettext "Please answer y or n. ")))))))
+ − 437 yn)))
+ − 438
+ − 439 (defun yes-or-no-p-minibuf (prompt)
+ − 440 "Ask user a yes-or-no question. Return t if answer is yes.
+ − 441 Takes one argument, which is the string to display to ask the question.
+ − 442 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
+ − 443 The user must confirm the answer with RET,
+ − 444 and can edit it until it has been confirmed."
+ − 445 (save-excursion
+ − 446 (let ((p (concat (gettext prompt) (gettext "(yes or no) ")))
+ − 447 (ans ""))
+ − 448 (while (stringp ans)
+ − 449 (setq ans (downcase (read-string p nil t))) ;no history
+ − 450 (cond ((string-equal ans (gettext "yes"))
+ − 451 (setq ans t))
+ − 452 ((string-equal ans (gettext "no"))
+ − 453 (setq ans nil))
+ − 454 (t
+ − 455 (ding nil 'yes-or-no-p)
+ − 456 (discard-input)
+ − 457 (message "Please answer yes or no.")
+ − 458 (sleep-for 2))))
+ − 459 ans)))
+ − 460
442
+ − 461 (defun yes-or-no-p (prompt)
+ − 462 "Ask user a yes-or-no question. Return t if answer is yes.
+ − 463 The question is asked with a dialog box or the minibuffer, as appropriate.
+ − 464 Takes one argument, which is the string to display to ask the question.
+ − 465 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it.
+ − 466 The user must confirm the answer with RET,
+ − 467 and can edit it until it as been confirmed."
+ − 468 (if (should-use-dialog-box-p)
+ − 469 (yes-or-no-p-dialog-box prompt)
+ − 470 (yes-or-no-p-minibuf prompt)))
+ − 471
+ − 472 (defun y-or-n-p (prompt)
+ − 473 "Ask user a \"y or n\" question. Return t if answer is \"y\".
+ − 474 Takes one argument, which is the string to display to ask the question.
+ − 475 The question is asked with a dialog box or the minibuffer, as appropriate.
+ − 476 It should end in a space; `y-or-n-p' adds `(y or n) ' to it.
+ − 477 No confirmation of the answer is requested; a single character is enough.
+ − 478 Also accepts Space to mean yes, or Delete to mean no."
+ − 479 (if (should-use-dialog-box-p)
+ − 480 (yes-or-no-p-dialog-box prompt)
+ − 481 (y-or-n-p-minibuf prompt)))
+ − 482
428
+ − 483
+ − 484
+ − 485 (defun read-char ()
+ − 486 "Read a character from the command input (keyboard or macro).
+ − 487 If a mouse click or non-ASCII character is detected, an error is
+ − 488 signalled. The character typed is returned as an ASCII value. This
+ − 489 is most likely the wrong thing for you to be using: consider using
+ − 490 the `next-command-event' function instead."
+ − 491 (save-excursion
+ − 492 (let ((event (next-command-event)))
+ − 493 (or inhibit-quit
+ − 494 (and (event-matches-key-specifier-p event (quit-char))
+ − 495 (signal 'quit nil)))
+ − 496 (prog1 (or (event-to-character event)
+ − 497 ;; Kludge. If the event we read was a mouse-release,
+ − 498 ;; discard it and read the next one.
+ − 499 (if (button-release-event-p event)
+ − 500 (event-to-character (next-command-event event)))
+ − 501 (error "Key read has no ASCII equivalent %S" event))
+ − 502 ;; this is not necessary, but is marginally more efficient than GC.
+ − 503 (deallocate-event event)))))
+ − 504
+ − 505 (defun read-char-exclusive ()
+ − 506 "Read a character from the command input (keyboard or macro).
+ − 507 If a mouse click or non-ASCII character is detected, it is discarded.
+ − 508 The character typed is returned as an ASCII value. This is most likely
+ − 509 the wrong thing for you to be using: consider using the
+ − 510 `next-command-event' function instead."
+ − 511 (let (event ch)
+ − 512 (while (progn
+ − 513 (setq event (next-command-event))
+ − 514 (or inhibit-quit
+ − 515 (and (event-matches-key-specifier-p event (quit-char))
+ − 516 (signal 'quit nil)))
+ − 517 (setq ch (event-to-character event))
+ − 518 (deallocate-event event)
+ − 519 (null ch)))
+ − 520 ch))
+ − 521
+ − 522 (defun read-quoted-char (&optional prompt)
+ − 523 "Like `read-char', except that if the first character read is an octal
+ − 524 digit, we read up to two more octal digits and return the character
+ − 525 represented by the octal number consisting of those digits.
+ − 526 Optional argument PROMPT specifies a string to use to prompt the user."
+ − 527 (let ((count 0) (code 0) done
+ − 528 (prompt (and prompt (gettext prompt)))
+ − 529 char event)
+ − 530 (while (and (not done) (< count 3))
+ − 531 (let ((inhibit-quit (zerop count))
+ − 532 ;; Don't let C-h get the help message--only help function keys.
+ − 533 (help-char nil)
+ − 534 (help-form
+ − 535 "Type the special character you want to use,
+ − 536 or three octal digits representing its character code."))
+ − 537 (and prompt (display-message 'prompt (format "%s-" prompt)))
+ − 538 (setq event (next-command-event)
+ − 539 char (or (event-to-character event nil nil t)
+ − 540 (signal 'error
+ − 541 (list "key read cannot be inserted in a buffer"
+ − 542 event))))
+ − 543 (if inhibit-quit (setq quit-flag nil)))
+ − 544 (cond ((<= ?0 char ?7)
+ − 545 (setq code (+ (* code 8) (- char ?0))
+ − 546 count (1+ count))
+ − 547 (when prompt
+ − 548 (display-message 'prompt
+ − 549 (setq prompt (format "%s %c" prompt char)))))
+ − 550 ((> count 0)
+ − 551 (setq unread-command-event event
+ − 552 done t))
+ − 553 (t (setq code (char-int char)
+ − 554 done t))))
+ − 555 (int-char code)
+ − 556 ;; Turn a meta-character into a character with the 0200 bit set.
+ − 557 ; (logior (if (/= (logand code ?\M-\^@) 0) 128 0)
+ − 558 ; (logand 255 code))))
+ − 559 ))
+ − 560
+ − 561 (defun momentary-string-display (string pos &optional exit-char message)
+ − 562 "Momentarily display STRING in the buffer at POS.
+ − 563 Display remains until next character is typed.
+ − 564 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
+ − 565 otherwise it is then available as input (as a command if nothing else).
+ − 566 Display MESSAGE (optional fourth arg) in the echo area.
+ − 567 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
+ − 568 (or exit-char (setq exit-char ?\ ))
+ − 569 (let ((buffer-read-only nil)
+ − 570 ;; Don't modify the undo list at all.
+ − 571 (buffer-undo-list t)
+ − 572 (modified (buffer-modified-p))
+ − 573 (name buffer-file-name)
+ − 574 insert-end)
+ − 575 (unwind-protect
+ − 576 (progn
+ − 577 (save-excursion
+ − 578 (goto-char pos)
+ − 579 ;; defeat file locking... don't try this at home, kids!
+ − 580 (setq buffer-file-name nil)
+ − 581 (insert-before-markers (gettext string))
+ − 582 (setq insert-end (point))
+ − 583 ;; If the message end is off frame, recenter now.
+ − 584 (if (> (window-end) insert-end)
+ − 585 (recenter (/ (window-height) 2)))
+ − 586 ;; If that pushed message start off the frame,
+ − 587 ;; scroll to start it at the top of the frame.
+ − 588 (move-to-window-line 0)
+ − 589 (if (> (point) pos)
+ − 590 (progn
+ − 591 (goto-char pos)
+ − 592 (recenter 0))))
+ − 593 (message (or message (gettext "Type %s to continue editing."))
+ − 594 (single-key-description exit-char))
+ − 595 (let ((event (save-excursion (next-command-event))))
+ − 596 (or (eq (event-to-character event) exit-char)
+ − 597 (setq unread-command-event event))))
+ − 598 (if insert-end
+ − 599 (save-excursion
+ − 600 (delete-region pos insert-end)))
+ − 601 (setq buffer-file-name name)
+ − 602 (set-buffer-modified-p modified))))
+ − 603
+ − 604 ;;; cmdloop.el ends here