Support mode aliases in 'provided-mode-derived-p'

andyleejordan · Eli-Zaretskii · commit 48ff4c0b2f78 · 2018-09-29T09:56:46.000+03:00
* lisp/subr.el (provided-mode-derived-p): Check aliases of
MODES as well as MODES themselves.  (Bug#32795)

* test/lisp/subr-tests.el (provided-mode-derived-p): New test.

Copyright-paperwork-exempt: yes
diff --git a/etc/NEWS b/etc/NEWS
@@ -982,6 +982,11 @@ This works like 'dolist', but reports progress similar to
 This works like 'delete-frame-functions', but runs after the frame to
 be deleted has been made dead and removed from the frame list.
 
+---
+** The function 'provided-mode-derived-p' was extended to support aliases.
+The function now returns non-nil when the argument MODE is derived
+from any alias of any of MODES.
+
 +++
 ** New frame focus state inspection interface.
 The hooks 'focus-in-hook' and 'focus-out-hook' are now obsolete.
diff --git a/lisp/subr.el b/lisp/subr.el
@@ -1918,11 +1918,15 @@ Only affects hooks run in the current buffer."
 ;; PUBLIC: find if the current mode derives from another.
 
 (defun provided-mode-derived-p (mode &rest modes)
-  "Non-nil if MODE is derived from one of MODES.
+  "Non-nil if MODE is derived from one of MODES or their aliases.
 Uses the `derived-mode-parent' property of the symbol to trace backwards.
 If you just want to check `major-mode', use `derived-mode-p'."
-  (while (and (not (memq mode modes))
-              (setq mode (get mode 'derived-mode-parent))))
+  (while
+      (and
+       (not (memq mode modes))
+       (let* ((parent (get mode 'derived-mode-parent))
+              (parentfn (symbol-function parent)))
+         (setq mode (if (and parentfn (symbolp parentfn)) parentfn parent)))))
   mode)
 
 (defun derived-mode-p (&rest modes)
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
@@ -61,6 +61,18 @@
                      (quote
                       (0 font-lock-keyword-face))))))))
 
+(ert-deftest provided-mode-derived-p ()
+  ;; base case: `derived-mode' directly derives `prog-mode'
+  (should (progn
+            (define-derived-mode derived-mode prog-mode "test")
+            (provided-mode-derived-p 'derived-mode 'prog-mode)))
+  ;; edge case: `derived-mode' derives an alias of `prog-mode'
+  (should (progn
+            (defalias 'parent-mode
+              (if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode))
+            (define-derived-mode derived-mode parent-mode "test")
+            (provided-mode-derived-p 'derived-mode 'prog-mode))))
+
 (ert-deftest number-sequence-test ()
   (should (= (length
               (number-sequence (1- most-positive-fixnum) most-positive-fixnum))
