git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/cmdloop.el

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