bug#26894: 25.1, 26.0.50; ‘eshell/which’ abuses ‘describe-function’

[npostavs@users.sourceforge.net]

[-- Attachment #1: Type: text/plain, Size: 452 bytes --]

npostavs@users.sourceforge.net writes:

> Dmitry Alexandrov <321942@gmail.com> writes:
>
>> ‘eshell/which’ in its part, that locates built-in commands (‘$ which
>> which’ for example) and elisp functions in general, looks like a dirty
>> hack [0]: it calls interactive ‘describe-function’ command and parses
>> *Help* buffer.
>
> Yeah, that's not great.  Here's a patch.

Sorry, I sent a broken version, here's the right one.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: patch --]
[-- Type: text/x-diff, Size: 8398 bytes --]

From ce259d2b7518a6822f5e0271ccf66d0fb53e63a1 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Sat, 3 Jun 2017 22:15:19 -0400
Subject: [PATCH v2] Don't read eshell/which output from *Help* buffer
 (Bug#26894)

* lisp/help-fns.el (help-fns--analyse-function)
(describe-function-header): New functions, extracted from
describe-function-1.
(describe-function-1): Use them.
* lisp/eshell/esh-cmd.el (eshell/which): Use
`describe-function-header' instead of `describe-function-1'.
---
 lisp/eshell/esh-cmd.el |  31 ++++++---------
 lisp/help-fns.el       | 103 +++++++++++++++++++++++++++----------------------
 2 files changed, 69 insertions(+), 65 deletions(-)

diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el
index 86e7b83c28..91e41b7224 100644
--- a/lisp/eshell/esh-cmd.el
+++ b/lisp/eshell/esh-cmd.el
@@ -1148,6 +1148,8 @@ (defun eshell-do-eval (form &optional synchronous-p)
 
 ;; command invocation
 
+(declare-function describe-function-header "help-fns")
+
 (defun eshell/which (command &rest names)
   "Identify the COMMAND, and where it is located."
   (dolist (name (cons command names))
@@ -1164,25 +1166,16 @@ (defun eshell/which (command &rest names)
 		(concat name " is an alias, defined as \""
 			(cadr alias) "\"")))
       (unless program
-	(setq program (eshell-search-path name))
-	(let* ((esym (eshell-find-alias-function name))
-	       (sym (or esym (intern-soft name))))
-	  (if (and (or esym (and sym (fboundp sym)))
-		   (or eshell-prefer-lisp-functions (not direct)))
-	      (let ((desc (let ((inhibit-redisplay t))
-			    (save-window-excursion
-			      (prog1
-				  (describe-function sym)
-				(message nil))))))
-		(setq desc (if desc (substring desc 0
-					       (1- (or (string-match "\n" desc)
-						       (length desc))))
-			     ;; This should not happen.
-			     (format "%s is defined, \
-but no documentation was found" name)))
-		(if (buffer-live-p (get-buffer "*Help*"))
-		    (kill-buffer "*Help*"))
-		(setq program (or desc name))))))
+        (setq program
+              (let* ((esym (eshell-find-alias-function name))
+                     (sym (or esym (intern-soft name))))
+                (if (and (or esym (and sym (fboundp sym)))
+                         (or eshell-prefer-lisp-functions (not direct)))
+                    (require 'help-fns)
+                    (or (with-output-to-string
+                          (describe-function-header sym))
+                        name)
+                  (eshell-search-path name)))))
       (if (not program)
 	  (eshell-error (format "which: no %s in (%s)\n"
 				name (getenv "PATH")))
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index 2c635ffa50..66e06df677 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -560,8 +560,9 @@ (defun help-fns-short-filename (filename)
             (setq short rel))))
     short))
 
-;;;###autoload
-(defun describe-function-1 (function)
+(defun help-fns--analyse-function (function)
+  "Return information about FUNCTION.
+Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
   (let* ((advised (and (symbolp function)
 		       (featurep 'nadvice)
 		       (advice--p (advice--symbol-function function))))
@@ -594,22 +595,24 @@ (defun describe-function-1 (function)
                          (setq f (symbol-function f)))
                        f))
 		    ((subrp def) (intern (subr-name def)))
-		    (t def)))
-	 (sig-key (if (subrp def)
-                      (indirect-function real-def)
-                    real-def))
-	 (file-name (find-lisp-object-file-name function (if aliased 'defun
-                                                           def)))
-         (pt1 (with-current-buffer (help-buffer) (point)))
-	 (beg (if (and (or (byte-code-function-p def)
-			   (keymapp def)
-			   (memq (car-safe def) '(macro lambda closure)))
-		       (stringp file-name)
-		       (help-fns--autoloaded-p function file-name))
-		  (if (commandp def)
-		      "an interactive autoloaded "
-		    "an autoloaded ")
-		(if (commandp def) "an interactive " "a "))))
+                    (t def))))
+    (list real-function def aliased real-def)))
+
+(defun describe-function-header (function)
+  "Print a line describing FUNCTION to `standard-output'."
+  (pcase-let* ((`(,_real-function ,def ,aliased ,real-def)
+                (help-fns--analyse-function function))
+               (file-name (find-lisp-object-file-name function (if aliased 'defun
+                                                                 def)))
+               (beg (if (and (or (byte-code-function-p def)
+                                 (keymapp def)
+                                 (memq (car-safe def) '(macro lambda closure)))
+                             (stringp file-name)
+                             (help-fns--autoloaded-p function file-name))
+                        (if (commandp def)
+                            "an interactive autoloaded "
+                          "an autoloaded ")
+                      (if (commandp def) "an interactive " "a "))))
 
     ;; Print what kind of function-like object FUNCTION is.
     (princ (cond ((or (stringp def) (vectorp def))
@@ -676,34 +679,42 @@ (defun describe-function-1 (function)
 	    (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")
                                 nil t)
 	    (help-xref-button 1 'help-function-def function file-name))))
-      (princ ".")
-      (with-current-buffer (help-buffer)
-	(fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point))
-				  (point)))
-      (terpri)(terpri)
-
-      (let ((doc-raw (documentation function t))
-            (key-bindings-buffer (current-buffer)))
-
-	;; If the function is autoloaded, and its docstring has
-	;; key substitution constructs, load the library.
-	(and (autoloadp real-def) doc-raw
-	     help-enable-auto-load
-	     (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw)
-	     (autoload-do-load real-def))
-
-        (help-fns--key-bindings function)
-        (with-current-buffer standard-output
-          (let ((doc (help-fns--signature function doc-raw sig-key
-                                          real-function key-bindings-buffer)))
-            (run-hook-with-args 'help-fns-describe-function-functions function)
-            (insert "\n"
-                    (or doc "Not documented."))
-            ;; Avoid asking the user annoying questions if she decides
-            ;; to save the help buffer, when her locale's codeset
-            ;; isn't UTF-8.
-            (unless (memq text-quoting-style '(straight grave))
-              (set-buffer-file-coding-system 'utf-8))))))))
+      (princ "."))))
+
+;;;###autoload
+(defun describe-function-1 (function)
+  (let ((pt1 (with-current-buffer (help-buffer) (point))))
+    (describe-function-header function)
+    (with-current-buffer (help-buffer)
+      (fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point))
+                                (point))))
+  (terpri)(terpri)
+
+  (pcase-let ((`(,real-function ,def ,_aliased ,real-def)
+               (help-fns--analyse-function function))
+              (doc-raw (documentation function t))
+              (key-bindings-buffer (current-buffer)))
+
+    ;; If the function is autoloaded, and its docstring has
+    ;; key substitution constructs, load the library.
+    (and (autoloadp real-def) doc-raw
+         help-enable-auto-load
+         (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw)
+         (autoload-do-load real-def))
+
+    (help-fns--key-bindings function)
+    (with-current-buffer standard-output
+      (let ((doc (help-fns--signature
+                  function doc-raw
+                  (if (subrp def) (indirect-function real-def) real-def)
+                  real-function key-bindings-buffer)))
+        (run-hook-with-args 'help-fns-describe-function-functions function)
+        (insert "\n" (or doc "Not documented.")))
+      ;; Avoid asking the user annoying questions if she decides
+      ;; to save the help buffer, when her locale's codeset
+      ;; isn't UTF-8.
+      (unless (memq text-quoting-style '(straight grave))
+        (set-buffer-file-coding-system 'utf-8)))))
 
 ;; Add defaults to `help-fns-describe-function-functions'.
 (add-hook 'help-fns-describe-function-functions #'help-fns--obsolete)
-- 
2.11.1