]> code.delx.au - gnu-emacs/blobdiff - lisp/simple.el
* lisp/simple.el (execute-extended-command--shorter): Fix the "M-p" case.
[gnu-emacs] / lisp / simple.el
index a50294e54fdb82d0018159d0b069430086843ff4..16db05a2158e2f740fe4bb9b42bedad16fff3fa5 100644 (file)
@@ -28,6 +28,8 @@
 
 ;;; Code:
 
+(eval-when-compile (require 'cl-lib))
+
 (declare-function widget-convert "wid-edit" (type &rest args))
 (declare-function shell-mode "shell" ())
 
@@ -410,6 +412,7 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
           ;; Do the rest in post-self-insert-hook, because we want to do it
           ;; *before* other functions on that hook.
           (lambda ()
+            (cl-assert (eq ?\n (char-before)))
             ;; Mark the newline(s) `hard'.
             (if use-hard-newlines
                 (set-hard-newline-properties
@@ -428,7 +431,8 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
             ;; starts a page.
             (or was-page-start
                 (move-to-left-margin nil t)))))
-    (if (not interactive)
+    (unwind-protect
+        (if (not interactive)
         ;; FIXME: For non-interactive uses, many calls actually just want
         ;; (insert "\n"), so maybe we should do just that, so as to avoid
         ;; the risk of filling or running abbrevs unexpectedly.
@@ -441,7 +445,9 @@ A non-nil INTERACTIVE argument means to run the `post-self-insert-hook'."
         ;; We first used let-binding to protect the hook, but that was naive
         ;; since add-hook affects the symbol-default value of the variable,
         ;; whereas the let-binding might only protect the buffer-local value.
-        (remove-hook 'post-self-insert-hook postproc))))
+        (remove-hook 'post-self-insert-hook postproc)))
+      (cl-assert (not (member postproc post-self-insert-hook)))
+      (cl-assert (not (member postproc (default-value 'post-self-insert-hook))))))
   nil)
 
 (defun set-hard-newline-properties (from to)
@@ -1533,11 +1539,17 @@ to get different commands to edit and resubmit."
 
 
 (defvar extended-command-history nil)
+(defvar execute-extended-command--last-typed nil)
 
 (defun read-extended-command ()
   "Read command name to invoke in `execute-extended-command'."
   (minibuffer-with-setup-hook
       (lambda ()
+        (add-hook 'post-self-insert-hook
+                  (lambda ()
+                    (setq execute-extended-command--last-typed
+                              (minibuffer-contents)))
+                  nil 'local)
        (set (make-local-variable 'minibuffer-default-add-function)
             (lambda ()
               ;; Get a command name at point in the original buffer
@@ -1565,7 +1577,17 @@ to get different commands to edit and resubmit."
             ;; because "M-x" is a well-known prompt to read a command
             ;; and it serves as a shorthand for "Extended command: ".
             "M-x ")
-     obarray 'commandp t nil 'extended-command-history)))
+     (lambda (string pred action)
+       (let ((pred
+              (if (memq action '(nil t))
+                  ;; Exclude obsolete commands from completions.
+                  (lambda (sym)
+                    (and (funcall pred sym)
+                         (or (equal string (symbol-name sym))
+                             (not (get sym 'byte-obsolete-info)))))
+                pred)))
+         (complete-with-action action obarray string pred)))
+     #'commandp t nil 'extended-command-history)))
 
 (defcustom suggest-key-bindings t
   "Non-nil means show the equivalent key-binding when M-x command has one.
@@ -1576,19 +1598,59 @@ If the value is non-nil and not a number, we wait 2 seconds."
                  (integer :tag "time" 2)
                  (other :tag "on")))
 
-(defun execute-extended-command (prefixarg &optional command-name)
+(defun execute-extended-command--shorter-1 (name length)
+  (cond
+   ((zerop length) (list ""))
+   ((equal name "") nil)
+   (t
+    (nconc (mapcar (lambda (s) (concat (substring name 0 1) s))
+                   (execute-extended-command--shorter-1
+                    (substring name 1) (1- length)))
+           (when (string-match "\\`\\(-\\)?[^-]*" name)
+             (execute-extended-command--shorter-1
+              (substring name (match-end 0)) length))))))
+
+(defun execute-extended-command--shorter (name typed)
+  (let ((candidates '())
+        (max (length typed))
+        (len 1)
+        binding)
+    (while (and (not binding)
+                (progn
+                  (unless candidates
+                    (setq len (1+ len))
+                    (setq candidates (execute-extended-command--shorter-1
+                                      name len)))
+                  ;; Don't show the help message if the binding isn't
+                  ;; significantly shorter than the M-x command the user typed.
+                  (< len (- max 5))))
+      (let ((candidate (pop candidates)))
+        (when (equal name
+                       (car-safe (completion-try-completion
+                                  candidate obarray 'commandp len)))
+          (setq binding candidate))))
+    binding))
+
+(defun execute-extended-command (prefixarg &optional command-name typed)
   ;; Based on Fexecute_extended_command in keyboard.c of Emacs.
   ;; Aaron S. Hawley <aaron.s.hawley(at)gmail.com> 2009-08-24
   "Read a command name, then read the arguments and call the command.
-Interactively, to pass a prefix argument to the command you are
-invoking, give a prefix argument to `execute-extended-command'.
-Noninteractively, the argument PREFIXARG is the prefix argument to
-give to the command you invoke."
-  (interactive (list current-prefix-arg (read-extended-command)))
+To pass a prefix argument to the command you are
+invoking, give a prefix argument to `execute-extended-command'."
+  (declare (interactive-only command-execute))
+  ;; FIXME: Remember the actual text typed by the user before completion,
+  ;; so that we don't later on suggest the same shortening.
+  (interactive
+   (let ((execute-extended-command--last-typed nil))
+     (list current-prefix-arg
+           (read-extended-command)
+           execute-extended-command--last-typed)))
   ;; Emacs<24 calling-convention was with a single `prefixarg' argument.
-  (if (null command-name)
-      (setq command-name (let ((current-prefix-arg prefixarg)) ; for prompt
-                           (read-extended-command))))
+  (unless command-name
+    (let ((current-prefix-arg prefixarg) ; for prompt
+          (execute-extended-command--last-typed nil))
+      (setq command-name (read-extended-command))
+      (setq typed execute-extended-command--last-typed)))
   (let* ((function (and (stringp command-name) (intern-soft command-name)))
          (binding (and suggest-key-bindings
                       (not executing-kbd-macro)
@@ -1605,19 +1667,34 @@ give to the command you invoke."
     (let ((prefix-arg prefixarg))
       (command-execute function 'record))
     ;; If enabled, show which key runs this command.
-    (when binding
-      ;; But first wait, and skip the message if there is input.
-      (let* ((waited
-              ;; If this command displayed something in the echo area;
-              ;; wait a few seconds, then display our suggestion message.
-              (sit-for (cond
-                        ((zerop (length (current-message))) 0)
-                        ((numberp suggest-key-bindings) suggest-key-bindings)
-                        (t 2)))))
-        (when (and waited (not (consp unread-command-events)))
+    ;; (when binding
+    ;; But first wait, and skip the message if there is input.
+    (let* ((waited
+            ;; If this command displayed something in the echo area;
+            ;; wait a few seconds, then display our suggestion message.
+            ;; FIXME: Wait *after* running post-command-hook!
+            ;; FIXME: Don't wait if execute-extended-command--shorter won't
+            ;; find a better answer anyway!
+            (sit-for (cond
+                      ((zerop (length (current-message))) 0)
+                      ((numberp suggest-key-bindings) suggest-key-bindings)
+                      (t 2)))))
+      (when (and waited (not (consp unread-command-events)))
+        (unless (or binding executing-kbd-macro (not (symbolp function))
+                    (<= (length (symbol-name function)) 2))
+          ;; There's no binding for CMD.  Let's try and find the shortest
+          ;; string to use in M-x.
+          ;; FIXME: Can be slow.  Cache it maybe?
+          (while-no-input
+            (setq binding (execute-extended-command--shorter
+                           (symbol-name function) typed))))
+        (when binding
           (with-temp-message
               (format "You can run the command `%s' with %s"
-                      function (key-description binding))
+                      function
+                      (if (stringp binding)
+                          (concat "M-x " binding " RET")
+                        (key-description binding)))
             (sit-for (if (numberp suggest-key-bindings)
                          suggest-key-bindings
                        2))))))))
@@ -1907,6 +1984,38 @@ With argument N, it uses the Nth previous element."
   (or (zerop n)
       (goto-history-element (+ minibuffer-history-position n))))
 
+(defun next-line-or-history-element (&optional arg)
+  "Move cursor vertically down ARG lines, or to the next history element.
+When point moves over the bottom line of multi-line minibuffer, puts ARGth
+next element of the minibuffer history in the minibuffer."
+  (interactive "^p")
+  (or arg (setq arg 1))
+  (let ((old-point (point)))
+    (condition-case nil
+       (with-no-warnings
+         (next-line arg))
+      (end-of-buffer
+       ;; Restore old position since `line-move-visual' moves point to
+       ;; the end of the line when it fails to go to the next line.
+       (goto-char old-point)
+       (next-history-element arg)))))
+
+(defun previous-line-or-history-element (&optional arg)
+  "Move cursor vertically up ARG lines, or to the previous history element.
+When point moves over the top line of multi-line minibuffer, puts ARGth
+previous element of the minibuffer history in the minibuffer."
+  (interactive "^p")
+  (or arg (setq arg 1))
+  (let ((old-point (point)))
+    (condition-case nil
+       (with-no-warnings
+         (previous-line arg))
+      (beginning-of-buffer
+       ;; Restore old position since `line-move-visual' moves point to
+       ;; the beginning of the line when it fails to go to the previous line.
+       (goto-char old-point)
+       (previous-history-element arg)))))
+
 (defun next-complete-history-element (n)
   "Get next history element which completes the minibuffer before the point.
 The contents of the minibuffer after the point are deleted, and replaced
@@ -3002,12 +3111,14 @@ the use of a shell (with its need to quote arguments)."
                    ;; If will create a new buffer, query first.
                    (if (yes-or-no-p "A command is running in the default buffer.  Use a new buffer? ")
                        (setq buffer (generate-new-buffer
-                                     (or output-buffer "*Async Shell Command*")))
+                                     (or (and (bufferp output-buffer) (buffer-name output-buffer))
+                                         output-buffer "*Async Shell Command*")))
                      (error "Shell command in progress")))
                   ((eq async-shell-command-buffer 'new-buffer)
                    ;; It will create a new buffer.
                    (setq buffer (generate-new-buffer
-                                 (or output-buffer "*Async Shell Command*"))))
+                                 (or (and (bufferp output-buffer) (buffer-name output-buffer))
+                                     output-buffer "*Async Shell Command*"))))
                   ((eq async-shell-command-buffer 'confirm-rename-buffer)
                    ;; If will rename the buffer, query first.
                    (if (yes-or-no-p "A command is running in the default buffer.  Rename it? ")
@@ -3984,7 +4095,7 @@ of this sample text; it defaults to 40."
          (goto-char point)
          ;; If user quit, deactivate the mark
          ;; as C-g would as a command.
-         (and quit-flag mark-active
+         (and quit-flag (region-active-p)
               (deactivate-mark)))
       (let ((len (min (abs (- mark point))
                      (or message-len 40))))
@@ -4517,7 +4628,7 @@ If Transient Mark mode was temporarily enabled, reset the value
 of the variable `transient-mark-mode'; if this causes Transient
 Mark mode to be disabled, don't change `mark-active' to nil or
 run `deactivate-mark-hook'."
-  (when (or transient-mark-mode force)
+  (when (or (region-active-p) force)
     (when (and (if (eq select-active-regions 'only)
                   (eq (car-safe transient-mark-mode) 'only)
                 select-active-regions)