diff --git a/helpful.el b/helpful.el index 9516e46..aff6f2b 100644 --- a/helpful.el +++ b/helpful.el @@ -222,22 +222,54 @@ error will be caught and displayed." :type type properties)) +(defun helpful--safe-indirect-function (sym) + "Resolve function indirection for SYM safely. +Like `indirect-function' but return nil if the alias chain is +cyclic, void, or exceeds a depth limit." + (let ((seen (list sym)) + (depth 0) + (result nil)) + (condition-case nil + (progn + (while (and (symbolp sym) (fboundp sym) (< depth 10)) + (setq sym (symbol-function sym)) + (when (and (symbolp sym) (memq sym seen)) + ;; Cyclic alias chain detected. + (setq sym nil)) + (when (symbolp sym) + (push sym seen)) + (setq depth (1+ depth))) + (setq result (if (symbolp sym) nil sym))) + (void-function nil) + (cyclic-function-indirection nil)) + result)) + (defun helpful--canonical-symbol (sym callable-p) "If SYM is an alias, return the underlying symbol. Return SYM otherwise." - (let ((depth 0)) + (let ((depth 0) + (seen (list sym))) (if (and (symbolp sym) callable-p) - (progn - ;; Follow the chain of symbols until we find a symbol that - ;; isn't pointing to a symbol. - (while (and (symbolp (symbol-function sym)) - (< depth 10)) - (setq sym (symbol-function sym)) - (setq depth (1+ depth))) - ;; If this is an alias to a primitive, return the - ;; primitive's symbol. - (when (subrp (symbol-function sym)) - (setq sym (intern (subr-name (symbol-function sym)))))) + (condition-case nil + (progn + ;; Follow the chain of symbols until we find a symbol that + ;; isn't pointing to a symbol. + (while (and (fboundp sym) + (symbolp (symbol-function sym)) + (< depth 10)) + (setq sym (symbol-function sym)) + (when (memq sym seen) + ;; Cyclic alias chain; stop here. + (setq depth 10)) + (push sym seen) + (setq depth (1+ depth))) + ;; If this is an alias to a primitive, return the + ;; primitive's symbol. + (when (and (fboundp sym) + (subrp (symbol-function sym))) + (setq sym (intern (subr-name (symbol-function sym)))))) + (void-function nil) + (cyclic-function-indirection nil)) (setq sym (indirect-variable sym)))) sym) @@ -391,7 +423,7 @@ source code to primitives." (defun helpful--edebug-p (sym) "Does function SYM have its definition patched by edebug?" - (let ((fn-def (indirect-function sym))) + (-when-let (fn-def (helpful--safe-indirect-function sym)) ;; Edebug replaces function source code with a sexp that has ;; `edebug-enter', `edebug-after' etc interleaved. This means the ;; function is interpreted, so `indirect-function' returns a list. @@ -1289,7 +1321,8 @@ If the source code cannot be found, return the sexp used." ;; a macro, or file has changed. ;; TODO: verify that the source hasn't changed before showing. ;; TODO: offer to download C sources for current version. - (throw 'source (indirect-function sym))))) + (throw 'source (or (helpful--safe-indirect-function sym) + sym))))) (defun helpful--has-shortdoc-p (sym) "Return non-nil if shortdoc.el is available and SYM is in a shortdoc group." @@ -1457,7 +1490,18 @@ buffer." (when (symbolp sym) (if callable-p - (setq library-name (cdr (find-function-library sym))) + ;; Only call find-function-library if the alias chain is + ;; resolvable. find-function-library has its own alias + ;; following loop that lacks cycle detection, so a cyclic + ;; alias chain (e.g. from define-obsolete-function-alias) + ;; would hang Emacs. + (when (or (not (and (fboundp sym) + (symbolp (symbol-function sym)))) + (helpful--safe-indirect-function sym)) + (setq library-name + (condition-case nil + (cdr (find-function-library sym)) + (error nil)))) ;; Based on `find-variable-noselect'. (setq library-name (or @@ -1742,9 +1786,11 @@ POSITION-HEADS takes the form ((123 (defun foo)) (456 (defun bar)))." #'subrp))) (cond ((and callable-p (helpful--advised-p sym)) - (funcall subrp (helpful--without-advice sym))) + (let ((orig (helpful--without-advice sym))) + (and orig (not (symbolp orig)) (funcall subrp orig)))) (callable-p - (funcall subrp (indirect-function sym))) + (-when-let (resolved (helpful--safe-indirect-function sym)) + (funcall subrp resolved))) (t (let ((filename (find-lisp-object-file-name sym 'defvar))) (or (eq filename 'C-source) diff --git a/test/helpful-unit-test.el b/test/helpful-unit-test.el index bdfdfc1..ff33070 100644 --- a/test/helpful-unit-test.el +++ b/test/helpful-unit-test.el @@ -1117,3 +1117,25 @@ that has advice attached before it is loadedl." (ert-deftest helpful--tree-any-p () (should (helpful--tree-any-p (lambda (x) (eq x 1)) '((((1)))))) (should (helpful--tree-any-p (lambda (x) (eq x 1)) (cons 2 1)))) + +;; Safe indirect function tests + +(ert-deftest helpful--safe-indirect-function-normal () + "Resolves a normal function." + (should (helpful--safe-indirect-function 'car))) + +(ert-deftest helpful--safe-indirect-function-alias () + "Resolves a function alias." + (defalias 'helpful-test--alias-target (lambda () nil)) + (defalias 'helpful-test--alias-source 'helpful-test--alias-target) + (should (helpful--safe-indirect-function 'helpful-test--alias-source))) + +(ert-deftest helpful--safe-indirect-function-void () + "Returns nil for a void function without hanging." + (should-not (helpful--safe-indirect-function 'helpful-test--nonexistent-sym))) + +(ert-deftest helpful--safe-indirect-function-cyclic () + "Returns nil for cyclic alias chain without hanging." + (fset 'helpful-test--cyc-a 'helpful-test--cyc-b) + (fset 'helpful-test--cyc-b 'helpful-test--cyc-a) + (should-not (helpful--safe-indirect-function 'helpful-test--cyc-a)))