Mercurial > hg > xemacs-beta
annotate lisp/cmdloop.el @ 5914:bd4d2c8ef9cc
Use the existing C-level line number cache within #'line-number.
src/ChangeLog addition:
2015-05-15 Aidan Kehoe <kehoea@parhasard.net>
* buffer.c:
* buffer.c (Fline_number): New C implementation, using the line
number cache of line-number.c, with a new optional BUFFER
argument.
* buffer.c (syms_of_buffer):
Make it available to Lisp.
* line-number.c (buffer_line_number):
New argument, RESPECT-NARROWING, describing whether to count from
the beginning of the visible region or from the beginning of the
buffer.
* line-number.h:
* line-number.h (buffer_line_number): Update its declaration.
* redisplay.c (window_line_number): Call it with the new argument.
lisp/ChangeLog addition:
2015-05-15 Aidan Kehoe <kehoea@parhasard.net>
* simple.el:
* simple.el (line-number): Moved to buffer.c; we have an existing
line number cache in C, it's a shame not to have it available.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Fri, 15 May 2015 18:11:47 +0100 |
| parents | f9e59cd39a9a |
| children |
| 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 | |
|
5861
c87b776ab0e1
Create a new error for when a char is needed but event-to-character gives nil
Aidan Kehoe <kehoea@parhasard.net>
parents:
5801
diff
changeset
|
283 (put 'no-character-typed 'display-error |
|
c87b776ab0e1
Create a new error for when a char is needed but event-to-character gives nil
Aidan Kehoe <kehoea@parhasard.net>
parents:
5801
diff
changeset
|
284 #'(lambda (error-object stream) |
|
c87b776ab0e1
Create a new error for when a char is needed but event-to-character gives nil
Aidan Kehoe <kehoea@parhasard.net>
parents:
5801
diff
changeset
|
285 (write-sequence "Not a character keystroke, " stream) |
|
c87b776ab0e1
Create a new error for when a char is needed but event-to-character gives nil
Aidan Kehoe <kehoea@parhasard.net>
parents:
5801
diff
changeset
|
286 (write-sequence (key-description (cadr error-object)) stream))) |
| 428 | 287 |
| 288 (defcustom teach-extended-commands-p t | |
| 289 "*If true, then `\\[execute-extended-command]' will teach you keybindings. | |
| 290 Any time you execute a command with \\[execute-extended-command] which has a | |
| 291 shorter keybinding, you will be shown the alternate binding before the | |
| 292 command executes. There is a short pause after displaying the binding, | |
| 293 before executing it; the length can be controlled by | |
| 294 `teach-extended-commands-timeout'." | |
| 295 :type 'boolean | |
| 296 :group 'keyboard) | |
| 297 | |
| 298 (defcustom teach-extended-commands-timeout 4 | |
| 299 "*How long to pause after displaying a keybinding before executing. | |
| 300 The value is measured in seconds. This only applies if | |
| 301 `teach-extended-commands-p' is true." | |
| 302 :type 'number | |
| 303 :group 'keyboard) | |
| 304 | |
| 305 ;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
|
306 ;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
|
307 (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
|
308 "*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
|
309 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
|
310 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
|
311 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
|
312 |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
313 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
|
314 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
|
315 :type '(choice |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
316 (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
|
317 (integer :tag "time" 2) |
|
5383
294ab9180fad
#'custom-add-to-group: warn if GROUP is nil.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5368
diff
changeset
|
318 (other :tag "on")) |
|
294ab9180fad
#'custom-add-to-group: warn if GROUP is nil.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5368
diff
changeset
|
319 :group 'keyboard) |
|
5208
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
320 |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
321 (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
|
322 'suggest-key-bindings |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
323 'set-value |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
324 #'(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
|
325 (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
|
326 (if (null args) |
|
9fa29ec759e3
Implement suggest-key-bindings in terms of teach-extended-commands-p
Aidan Kehoe <kehoea@parhasard.net>
parents:
4806
diff
changeset
|
327 (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
|
328 (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
|
329 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
|
330 (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
|
331 (and args teach-extended-commands-timeout)))))) |
| 428 | 332 |
| 333 (defun execute-extended-command (prefix-arg) | |
| 334 "Read a command name from the minibuffer using 'completing-read'. | |
| 335 Then call the specified command using 'command-execute' and return its | |
| 336 return value. If the command asks for a prefix argument, supply the | |
| 337 value of the current raw prefix argument, or the value of PREFIX-ARG | |
| 338 when called from Lisp." | |
| 339 (interactive "P") | |
| 340 ;; Note: This doesn't hack "this-command-keys" | |
| 341 (let ((prefix-arg prefix-arg)) | |
| 342 (setq this-command (read-command | |
| 343 ;; Note: this has the hard-wired | |
| 344 ;; "C-u" and "M-x" string bug in common | |
| 613 | 345 ;; with all Emacs's. |
| 428 | 346 ;; (i.e. it prints C-u and M-x regardless of |
| 347 ;; whether some other keys were actually bound | |
| 348 ;; to `execute-extended-command' and | |
| 349 ;; `universal-argument'. | |
| 350 (cond ((eq prefix-arg '-) | |
| 351 "- M-x ") | |
| 352 ((equal prefix-arg '(4)) | |
| 353 "C-u M-x ") | |
| 354 ((integerp prefix-arg) | |
| 355 (format "%d M-x " prefix-arg)) | |
| 356 ((and (consp prefix-arg) | |
| 357 (integerp (car prefix-arg))) | |
| 358 (format "%d M-x " (car prefix-arg))) | |
| 359 (t | |
| 360 "M-x "))))) | |
| 361 | |
| 362 (if (and teach-extended-commands-p | |
| 363 (interactive-p)) | |
| 364 ;; 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
|
365 ;; 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
|
366 (symbol-macrolet |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
367 ((execute-command-keys #:execute-command-keys) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
368 (execute-command-name #:execute-command-name)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
369 (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
|
370 (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
|
371 (command-execute this-command t) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
372 (when execute-command-keys |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
373 ;; 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
|
374 ;; 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
|
375 ;; 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
|
376 ;; 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
|
377 ;; 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
|
378 (if (and (not zmacs-region-stays) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
379 (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
|
380 (eq (zmacs-region-buffer) (current-buffer)))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
381 (zmacs-deactivate-region) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
382 (zmacs-update-region)) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
383 ;; 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
|
384 ;; if any. |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
385 (when (sit-for 1) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
386 (display-message |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
387 'no-log |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
388 (format (if (cdr execute-command-keys) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
389 "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
|
390 "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
|
391 execute-command-name |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
392 (sorted-key-descriptions execute-command-keys))) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
393 (sit-for teach-extended-commands-timeout) |
|
fd36a980d701
Use uninterned symbols in various information-hiding contexts.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
394 (clear-message 'no-log))))) |
| 428 | 395 ;; Else, just run the command. |
| 396 (command-execute this-command t))) | |
| 397 | |
| 398 | |
| 399 ;;; C code calls this; the underscores in the variable names are to avoid | |
| 400 ;;; cluttering the specbind namespace (lexical scope! lexical scope!) | |
| 401 ;;; Putting this in Lisp instead of C slows kbd macros by 50%. | |
| 402 ;(defun command-execute (_command &optional _record-flag) | |
| 403 ; "Execute CMD as an editor command. | |
| 404 ;CMD must be a symbol that satisfies the `commandp' predicate. | |
| 405 ;Optional second arg RECORD-FLAG non-nil | |
| 406 ;means unconditionally put this command in `command-history'. | |
| 407 ;Otherwise, that is done only if an arg is read using the minibuffer." | |
| 408 ; (let ((_prefix prefix-arg) | |
| 409 ; (_cmd (indirect-function _command))) | |
| 410 ; (setq prefix-arg nil | |
| 411 ; this-command _command | |
| 412 ; current-prefix-arg _prefix | |
| 413 ; zmacs-region-stays nil) | |
| 414 ; ;; #### debug_on_next_call = 0; | |
| 415 ; (cond ((and (symbolp _command) | |
| 416 ; (get _command 'disabled)) | |
| 417 ; (run-hooks disabled-command-hook)) | |
| 418 ; ((or (stringp _cmd) (vectorp _cmd)) | |
| 419 ; ;; If requested, place the macro in the command history. | |
| 420 ; ;; For other sorts of commands, call-interactively takes | |
| 421 ; ;; care of this. | |
| 422 ; (if _record-flag | |
| 423 ; (setq command-history | |
| 424 ; (cons (list 'execute-kbd-macro _cmd _prefix) | |
| 425 ; command-history))) | |
| 426 ; (execute-kbd-macro _cmd _prefix)) | |
| 427 ; (t | |
| 428 ; (call-interactively _command _record-flag))))) | |
| 429 | |
| 430 (defun y-or-n-p-minibuf (prompt) | |
| 431 "Ask user a \"y or n\" question. Return t if answer is \"y\". | |
| 432 Takes one argument, which is the string to display to ask the question. | |
| 433 It should end in a space; `y-or-n-p' adds `(y or n) ' to it. | |
| 434 No confirmation of the answer is requested; a single character is enough. | |
| 435 Also accepts Space to mean yes, or Delete to mean no." | |
| 436 (save-excursion | |
| 437 (let* ((pre "") | |
| 438 (yn (gettext "(y or n) ")) | |
| 439 ;; we need to translate the prompt ourselves because of the | |
| 440 ;; strange way we handle it. | |
| 441 (prompt (gettext prompt)) | |
| 442 event) | |
| 443 (while (stringp yn) | |
| 444 (if (let ((cursor-in-echo-area t) | |
| 445 (inhibit-quit t)) | |
| 446 (message "%s%s%s" pre prompt yn) | |
| 447 (setq event (next-command-event event)) | |
| 448 (condition-case nil | |
| 449 (prog1 | |
| 450 (or quit-flag (eq 'keyboard-quit (key-binding event))) | |
| 451 (setq quit-flag nil)) | |
| 452 (wrong-type-argument t))) | |
| 453 (progn | |
| 454 (message "%s%s%s%s" pre prompt yn (single-key-description event)) | |
| 455 (setq quit-flag nil) | |
| 456 (signal 'quit '()))) | |
|
5745
f9e4d44504a4
Document #'events-to-keys some more, use it less.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5474
diff
changeset
|
457 (let ((def (lookup-key query-replace-map (vector event)))) |
| 428 | 458 (cond ((eq def 'skip) |
| 459 (message "%s%sNo" prompt yn) | |
| 460 (setq yn nil)) | |
| 461 ((eq def 'act) | |
| 462 (message "%s%sYes" prompt yn) | |
| 463 (setq yn t)) | |
| 464 ((eq def 'recenter) | |
| 465 (recenter)) | |
| 466 ((or (eq def 'quit) (eq def 'exit-prefix)) | |
| 467 (signal 'quit '())) | |
| 468 ((button-release-event-p event) ; ignore them | |
| 469 nil) | |
| 470 (t | |
| 471 (message "%s%s%s%s" pre prompt yn | |
| 472 (single-key-description event)) | |
| 473 (ding nil 'y-or-n-p) | |
| 474 (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
|
475 (if (eql (length pre) 0) |
| 428 | 476 (setq pre (gettext "Please answer y or n. "))))))) |
| 477 yn))) | |
| 478 | |
| 479 (defun yes-or-no-p-minibuf (prompt) | |
| 480 "Ask user a yes-or-no question. Return t if answer is yes. | |
| 481 Takes one argument, which is the string to display to ask the question. | |
| 482 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. | |
| 483 The user must confirm the answer with RET, | |
| 484 and can edit it until it has been confirmed." | |
| 485 (save-excursion | |
| 486 (let ((p (concat (gettext prompt) (gettext "(yes or no) "))) | |
| 487 (ans "")) | |
| 488 (while (stringp ans) | |
| 489 (setq ans (downcase (read-string p nil t))) ;no history | |
| 490 (cond ((string-equal ans (gettext "yes")) | |
| 491 (setq ans t)) | |
| 492 ((string-equal ans (gettext "no")) | |
| 493 (setq ans nil)) | |
| 494 (t | |
| 495 (ding nil 'yes-or-no-p) | |
| 496 (discard-input) | |
| 497 (message "Please answer yes or no.") | |
| 498 (sleep-for 2)))) | |
| 499 ans))) | |
| 500 | |
| 442 | 501 (defun yes-or-no-p (prompt) |
| 502 "Ask user a yes-or-no question. Return t if answer is yes. | |
| 503 The question is asked with a dialog box or the minibuffer, as appropriate. | |
| 504 Takes one argument, which is the string to display to ask the question. | |
| 505 It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. | |
| 506 The user must confirm the answer with RET, | |
| 507 and can edit it until it as been confirmed." | |
| 508 (if (should-use-dialog-box-p) | |
| 4222 | 509 ;; and-fboundp is redundant, since yes-or-no-p-dialog-box is only |
| 510 ;; bound if (featurep 'dialog). But it eliminates a compile-time | |
| 511 ;; 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
|
512 (and-fboundp 'yes-or-no-p-dialog-box (yes-or-no-p-dialog-box prompt)) |
| 442 | 513 (yes-or-no-p-minibuf prompt))) |
| 514 | |
| 515 (defun y-or-n-p (prompt) | |
| 516 "Ask user a \"y or n\" question. Return t if answer is \"y\". | |
| 517 Takes one argument, which is the string to display to ask the question. | |
| 518 The question is asked with a dialog box or the minibuffer, as appropriate. | |
| 519 It should end in a space; `y-or-n-p' adds `(y or n) ' to it. | |
| 520 No confirmation of the answer is requested; a single character is enough. | |
| 521 Also accepts Space to mean yes, or Delete to mean no." | |
| 522 (if (should-use-dialog-box-p) | |
| 523 (yes-or-no-p-dialog-box prompt) | |
| 524 (y-or-n-p-minibuf prompt))) | |
| 525 | |
| 428 | 526 |
|
5872
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
527 (defcustom read-quoted-char-radix 8 |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
528 "Radix for \\[quoted-insert] and other uses of `read-quoted-char'. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
529 See `digit-char-p' and its RADIX argument for possible values." |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
530 :type '(choice (const 8) (const 10) (const 16)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
531 :group 'editing-basics) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
532 |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
533 (labels |
|
5872
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
534 ((read-function-key-map (events prompt) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
535 "Read keystrokes scanning `function-key-map'. Return an event vector." |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
536 (let (binding) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
537 (while (keymapp |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
538 (setq binding |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
539 (lookup-key function-key-map |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
540 (setq events |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
541 (vconcat events |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
542 (list (next-key-event |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
543 nil prompt)))))))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
544 (when binding |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
545 ;; Found something in function-key-map. If it's a function |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
546 ;; (e.g. synthesize-keysym), call it. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
547 (if (functionp binding) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
548 (setq binding (funcall binding nil))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
549 (setq events (map 'vector #'character-to-event binding))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
550 events)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
551 (read-char-1 (errorp prompt inherit-input-method seconds) |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
552 "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
|
553 Look up said input in `function-key-map' as appropriate. |
| 428 | 554 |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
555 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
|
556 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
557 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
|
558 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
|
559 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
560 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
|
561 the current buffer, use its translation when choosing a character to return. |
| 428 | 562 |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
563 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
|
564 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
|
565 (let ((timeout |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
566 (if seconds |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
567 (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
|
568 (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
|
569 nil))) |
|
5872
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
570 (events []) character) |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
571 (unwind-protect |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
572 (while t |
|
5872
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
573 (setq events (read-function-key-map events prompt) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
574 ;; Put the remaining keystrokes back on the input queue. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
575 unread-command-events (reduce #'cons events |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
576 :start 1 :from-end t |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
577 :initial-value |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
578 unread-command-events)) |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
579 (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
|
580 (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
|
581 (quit-char)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
582 (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
|
583 (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
|
584 (progn |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
585 ;; 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
|
586 ;; 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
|
587 (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
|
588 ;; 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
|
589 ;; 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
|
590 (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
|
591 quail-mode)) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
592 (with-fboundp |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
593 '(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
|
594 (let ((binding |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
595 (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
|
596 (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
|
597 (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
|
598 (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
|
599 ;; #### 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
|
600 ;; 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
|
601 ;; 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
|
602 (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
|
603 (characterp |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
604 (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
|
605 (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
|
606 (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
|
607 (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
|
608 (if errorp |
|
5861
c87b776ab0e1
Create a new error for when a char is needed but event-to-character gives nil
Aidan Kehoe <kehoea@parhasard.net>
parents:
5801
diff
changeset
|
609 (error 'no-character-typed (aref events 0))) |
|
5801
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
610 ;; 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
|
611 (setq events [])) |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
612 (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
|
613 ;; 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
|
614 ;; #'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
|
615 (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
|
616 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
617 (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
|
618 "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
|
619 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
|
620 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
|
621 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
|
622 function instead. |
|
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 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
|
625 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
626 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
|
627 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
|
628 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
629 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
|
630 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
|
631 (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
|
632 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
633 (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
|
634 "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
|
635 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
636 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
|
637 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
|
638 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
|
639 function instead. |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
640 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
641 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
|
642 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
643 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
|
644 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
|
645 |
|
0e9f791cc655
Support `function-key-map' in #'read-char{,-exclusive}, sync API with GNU
Aidan Kehoe <kehoea@parhasard.net>
parents:
5745
diff
changeset
|
646 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
|
647 input is received in that time, return nil." |
|
5872
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
648 (read-char-1 nil prompt inherit-input-method seconds)) |
| 428 | 649 |
|
5872
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
650 (defun read-quoted-char (&optional prompt) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
651 "Like `read-char', but do not allow quitting. |
| 1333 | 652 |
|
5872
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
653 Also, if the first character read is a digit of base `read-quoted-char-radix', |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
654 we read as many of such digits as are typed and return a character with the |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
655 corresponding Unicode code point. Any input that is not a digit (in the base |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
656 used) terminates the sequence. If the terminator is RET, it is discarded; any |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
657 other 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 | |
|
5872
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
661 for numeric input. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
662 |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
663 There is no INHERIT-INPUT-METHOD option, the intent is that `read-quoted-char' |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
664 is a mechanism to escape briefly from an input method and from other key |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
665 bindings." |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
666 (let (done (first t) (code 0) char (events []) event fixnum |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
667 (prompt (and prompt (gettext prompt))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
668 (help-event-list |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
669 ;; Don't let C-h get the help message--only help function |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
670 ;; keys. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
671 (remove-if #'event-to-character |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
672 ;; Fold help-char into help-event-list to make |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
673 ;; our code below easier. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
674 (cons help-char help-event-list) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
675 :key #'character-to-event)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
676 (help-char nil) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
677 (help-form |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
678 (format |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
679 "Type the special character you want to use, or the \ |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
680 character code, \nbase %d (the value of `read-quoted-char-radix'). |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
681 |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
682 RET terminates the character code and is discarded; any other non-digit |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
683 terminates the character code and is then used as input." |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
684 read-quoted-char-radix)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
685 window-configuration) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
686 (while (not done) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
687 (let ((inhibit-quit first)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
688 (setq events (read-function-key-map events |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
689 (and prompt (concat prompt |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
690 " - "))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
691 event (aref events 0) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
692 unread-command-events (reduce #'cons events :from-end t |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
693 :start 1 :initial-value |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
694 unread-command-events) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
695 events [] |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
696 ;; Possibly the only place within XEmacs we still want meta |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
697 ;; equivalence, always! |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
698 char (event-to-character event nil 'meta)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
699 (if inhibit-quit (setq quit-flag nil)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
700 (cond ((null char) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
701 (if (find event help-event-list |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
702 :test #'event-matches-key-specifier-p) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
703 ;; If we're on a TTY and f1 comes from function-key-map, |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
704 ;; event-stream.c may not handle it as it should. Show |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
705 ;; help ourselves. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
706 (when (not window-configuration) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
707 (with-output-to-temp-buffer (help-buffer-name nil) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
708 (setq window-configuration |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
709 (current-window-configuration)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
710 (write-sequence help-form))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
711 ;; Require at least one keystroke that can be converted |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
712 ;; into a character, no point inserting ^@ into the buffer |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
713 ;; when the user types F8. This differs from GNU Emacs. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
714 (if first |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
715 (error 'no-character-typed event) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
716 ;; Not first; a non-character keystroke terminates. |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
717 (setq unread-command-events |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
718 (cons event unread-command-events) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
719 done t)))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
720 ((setq fixnum (digit-char-p char read-quoted-char-radix)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
721 (setq code (+ (* code read-quoted-char-radix) fixnum)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
722 (and prompt (setq prompt |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
723 (concat prompt " " (list char))))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
724 ((and (not first) (eql char ?\C-m)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
725 (setq done t)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
726 ((not first) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
727 (setq unread-command-events (cons event |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
728 unread-command-events) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
729 done t)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
730 (t |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
731 (setq code (char-to-unicode char) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
732 done t))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
733 (setq first (and first (null char))))) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
734 (and window-configuration |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
735 (set-window-configuration window-configuration)) |
|
f9e59cd39a9a
Clean up #'read-quoted-char, support help-event-list there.
Aidan Kehoe <kehoea@parhasard.net>
parents:
5861
diff
changeset
|
736 (unicode-to-char code)))) |
| 1333 | 737 |
| 738 ;; in passwd.el. | |
| 739 ; (defun read-passwd (prompt &optional confirm default) | |
| 740 ; "Read a password, prompting with PROMPT. Echo `.' for each character typed. | |
| 741 ; End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line. | |
| 742 ; Optional argument CONFIRM, if non-nil, then read it twice to make sure. | |
| 743 ; Optional DEFAULT is a default password to use instead of empty input." | |
| 744 ; (if confirm | |
| 745 ; (let (success) | |
| 746 ; (while (not success) | |
| 747 ; (let ((first (read-passwd prompt nil default)) | |
| 748 ; (second (read-passwd "Confirm password: " nil default))) | |
| 749 ; (if (equal first second) | |
| 750 ; (progn | |
| 751 ; (and (arrayp second) (fillarray second ?\0)) | |
| 752 ; (setq success first)) | |
| 753 ; (and (arrayp first) (fillarray first ?\0)) | |
| 754 ; (and (arrayp second) (fillarray second ?\0)) | |
| 755 ; (message "Password not repeated accurately; please start over") | |
| 756 ; (sit-for 1)))) | |
| 757 ; success) | |
| 758 ; (let ((pass nil) | |
| 759 ; (c 0) | |
| 760 ; (echo-keystrokes 0) | |
| 761 ; (cursor-in-echo-area t)) | |
| 762 ; (while (progn (message "%s%s" | |
| 763 ; prompt | |
| 764 ; (make-string (length pass) ?.)) | |
| 765 ; (setq c (read-char-exclusive nil t)) | |
| 766 ; (and (/= c ?\r) (/= c ?\n) (/= c ?\e))) | |
| 767 ; (clear-this-command-keys) | |
| 768 ; (if (= c ?\C-u) | |
| 769 ; (progn | |
| 770 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 771 ; (setq pass "")) | |
| 772 ; (if (and (/= c ?\b) (/= c ?\177)) | |
| 773 ; (let* ((new-char (char-to-string c)) | |
| 774 ; (new-pass (concat pass new-char))) | |
| 775 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 776 ; (fillarray new-char ?\0) | |
| 777 ; (setq c ?\0) | |
| 778 ; (setq pass new-pass)) | |
| 779 ; (if (> (length pass) 0) | |
| 780 ; (let ((new-pass (substring pass 0 -1))) | |
| 781 ; (and (arrayp pass) (fillarray pass ?\0)) | |
| 782 ; (setq pass new-pass)))))) | |
| 783 ; (message nil) | |
| 784 ; (or pass default "")))) | |
| 785 | |
| 786 ;; aliased to redraw-modeline, a built-in. | |
| 787 ; (defun force-mode-line-update (&optional all) | |
| 788 ; "Force the mode-line of the current buffer to be redisplayed. | |
| 789 ; With optional non-nil ALL, force redisplay of all mode-lines." | |
| 790 ; (if all (save-excursion (set-buffer (other-buffer)))) | |
| 791 ; (set-buffer-modified-p (buffer-modified-p))) | |
| 428 | 792 |
| 793 (defun momentary-string-display (string pos &optional exit-char message) | |
| 794 "Momentarily display STRING in the buffer at POS. | |
| 795 Display remains until next character is typed. | |
| 796 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed; | |
| 797 otherwise it is then available as input (as a command if nothing else). | |
| 798 Display MESSAGE (optional fourth arg) in the echo area. | |
| 799 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." | |
| 800 (or exit-char (setq exit-char ?\ )) | |
| 1333 | 801 (let ((inhibit-read-only t) |
| 428 | 802 ;; Don't modify the undo list at all. |
| 803 (buffer-undo-list t) | |
| 804 (modified (buffer-modified-p)) | |
| 805 (name buffer-file-name) | |
| 806 insert-end) | |
| 807 (unwind-protect | |
| 808 (progn | |
| 809 (save-excursion | |
| 810 (goto-char pos) | |
| 811 ;; defeat file locking... don't try this at home, kids! | |
| 812 (setq buffer-file-name nil) | |
| 813 (insert-before-markers (gettext string)) | |
| 814 (setq insert-end (point)) | |
| 1333 | 815 ;; If the message end is off screen, recenter now. |
| 816 (if (< (window-end nil t) insert-end) | |
| 428 | 817 (recenter (/ (window-height) 2))) |
| 818 ;; If that pushed message start off the frame, | |
| 819 ;; scroll to start it at the top of the frame. | |
| 820 (move-to-window-line 0) | |
| 821 (if (> (point) pos) | |
| 822 (progn | |
| 823 (goto-char pos) | |
| 824 (recenter 0)))) | |
| 825 (message (or message (gettext "Type %s to continue editing.")) | |
| 826 (single-key-description exit-char)) | |
| 827 (let ((event (save-excursion (next-command-event)))) | |
| 828 (or (eq (event-to-character event) exit-char) | |
| 1333 | 829 (setq unread-command-events (list event))))) |
| 428 | 830 (if insert-end |
| 831 (save-excursion | |
| 832 (delete-region pos insert-end))) | |
| 833 (setq buffer-file-name name) | |
| 834 (set-buffer-modified-p modified)))) | |
| 835 | |
| 1333 | 836 ;; END SYNCHED WITH FSF 21.2. |
| 837 | |
| 428 | 838 ;;; cmdloop.el ends here |