[elpa] externals/hyperbole 6b7b4ea9b0: Patch from Stefan (#209)

[ELPA Syncer]

branch: externals/hyperbole
commit 6b7b4ea9b0eb1eae90738c7ac680fd2ffad883c3
Author: Mats Lidell <mats.lidell@lidells.se>
Commit: GitHub <noreply@github.com>

    Patch from Stefan (#209)
    
    Removes some code that digs in the guts of functions, replacing it with 
cleaner `advice-add`.
    
    It also adds various FIXMEs about advice which should be removed/replaced 
(it's OK as a temporary measure but it should come *together* with a better 
long-term solution).
---
 ChangeLog |  18 ++++++++++
 hgnus.el  |   9 +----
 hmh.el    |  32 ++++++++++--------
 hrmail.el |  72 ++++++++++++++++++++-------------------
 hypb.el   | 113 ++------------------------------------------------------------
 5 files changed, 76 insertions(+), 168 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f0c848c0bc..535f35c2ac 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,21 @@
+2022-07-13  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+* hrmail.el (rmail-cease-edit, rmail-forward, rmail-get-new-mail)
+    (rmail-new-summary): Use `advice-add` rather than straight redefinition
+    or `hypb:function-overload`.
+
+* hmh.el (mh-display-msg, mh-regenerate-headers): Use `advice-add`
+    rather than `hypb:function-overload`.
+
+* hgnus.el (gnus-inews-article): Remove hack on function that was
+    deleted back in Nov 1995.
+
+* hypb.el (hypb:emacs-byte-code-p): `byte-code-function-p` is always
+    defined in Emacs≥27.
+    (hypb:function-copy, hypb:function-overload)
+    (hypb:function-symbol-replace, hypb:map-sublists)
+    (hypb:constant-vector-symbol-replace): Delete functions.
+
 2022-07-12  Mats Lidell  <matsl@gnu.org>
 
 * test/hpath-tests.el (hpath:auto-variable-alist-load-path-test): Simplify
diff --git a/hgnus.el b/hgnus.el
index b878a5a665..53c1d972f1 100644
--- a/hgnus.el
+++ b/hgnus.el
@@ -5,7 +5,7 @@
 ;; Orig-Date:    24-Dec-91 at 22:29:28
 ;; Last-Mod:      9-May-22 at 00:01:49 by Bob Weiner
 ;;
-;; Copyright (C) 1991-2016  Free Software Foundation, Inc.
+;; Copyright (C) 1991-2022  Free Software Foundation, Inc.
 ;; See the "HY-COPY" file for license information.
 ;;
 ;; This file is part of GNU Hyperbole.
@@ -71,13 +71,6 @@
        (gnus-summary-display-article article))))
 
 
-;;; Redefine 'gnus-inews-article' from "gnuspost.el" to make it include
-;;; any signature before Hyperbole button data.  Does this by having
-;;; signature inserted within narrowed buffer and then applies a hook to
-;;; have the buffer widened before sending.
-(hypb:function-symbol-replace
-  'gnus-inews-article 'widen 'hmail:msg-narrow)
-
 ;;; Overload this function from "rnewspost.el" for supercite compatibility
 ;;; only when supercite is in use.
 (if (hypb:supercite-p)
diff --git a/hmh.el b/hmh.el
index e0d4322896..48aa8d15c4 100644
--- a/hmh.el
+++ b/hmh.el
@@ -5,7 +5,7 @@
 ;; Orig-Date:    21-May-91 at 17:06:36
 ;; Last-Mod:      9-May-22 at 22:36:31 by Bob Weiner
 ;;
-;; Copyright (C) 1991-2016  Free Software Foundation, Inc.
+;; Copyright (C) 1991-2022  Free Software Foundation, Inc.
 ;; See the "HY-COPY" file for license information.
 ;;
 ;; This file is part of GNU Hyperbole.
@@ -135,20 +135,24 @@ Returns t if successful, else nil."
 ;;; Private functions
 ;;; ************************************************************************
 ;;;
-;;; Redefine version of this function from mh-e.el to run mh-show-hook at end.
-;;; This hook may already be run, depending on the version of mh-e you are
-;;; running, but running it twice shouldn't do any harm.  Comment this out if
-;;; you know that your mh-e.el already runs the hook.
-(hypb:function-overload 'mh-display-msg nil
-                       '(run-hooks 'mh-show-hook))
+;; Redefine version of this function from mh-e.el to run mh-show-hook at end.
+;; This hook may already be run, depending on the version of mh-e you are
+;; running, but running it twice shouldn't do any harm.  Comment this out if
+;; you know that your mh-e.el already runs the hook.
+;; FIXME: `mh-show.el' has not changed much since Emacs-27 (which we require),
+;; so we should not need such an advice, yet AFAICT `mh-display-msg'
+;; doesn't run this hook, on `mh-show-msg' does.
+(advice-add 'mh-display-msg :after #'hmh--run-show-hook)
+(defun hmh--run-show-hook (&rest _) (run-hooks 'mh-show-hook))
 
-;;;
-;;; Redefine version of 'mh-regenerate-headers' to highlight Hyperbole
-;;; buttons when possible.
-;;;
-(hypb:function-overload 'mh-regenerate-headers nil
-                       '(if (fboundp 'hproperty:but-create)
-                            (hproperty:but-create)))
+;;
+;; Redefine version of 'mh-regenerate-headers' to highlight Hyperbole
+;; buttons when possible.
+;;
+;; FIXME: Add a hook to MH-E so we don't need this advice.
+(advice-add 'mh-regenerate-headers :after #'hmh--highlight-buttons)
+(defun hmh--highlight-buttons (&rest _)
+  (if (fboundp 'hproperty:but-create) (hproperty:but-create)))
 
 ;;;
 ;;; Set 'mh-send-letter' hook to widen to include button data before sending.
diff --git a/hrmail.el b/hrmail.el
index a7bbc210b8..7a67ffeca2 100644
--- a/hrmail.el
+++ b/hrmail.el
@@ -5,7 +5,7 @@
 ;; Orig-Date:     9-May-91 at 04:22:02
 ;; Last-Mod:      5-Jun-22 at 17:59:19 by Bob Weiner
 ;;
-;; Copyright (C) 1991-2016  Free Software Foundation, Inc.
+;; Copyright (C) 1991-2022  Free Software Foundation, Inc.
 ;; See the "HY-COPY" file for license information.
 ;;
 ;; This file is part of GNU Hyperbole.
@@ -167,15 +167,18 @@ Return t if successful, else nil."
 ;;; Overloaded functions
 ;;; ************************************************************************
 
-(if (featurep 'rmail-hyperbole)
+(if (featurep 'rmail-hyperbole)         ;FIXME: Nowhere to be found.
     ;; No overloads are necessary, the needed features are built-in.
     nil
 
-;;; else
-;;;
-;;; Redefine version of this function from "rmailedit.el" to include any
-;;; hidden Hyperbole button data when computing message length.
-(defun rmail-cease-edit ()
+;; else
+;;
+;; Redefine version of this function from "rmailedit.el" to include any
+;; hidden Hyperbole button data when computing message length.
+;; FIXME: Copy&redefine like this is *evil*.  Use an advice or a hook.
+;; We can make changes to `rmail.el' if needed.
+(advice-add 'rmail-cease-edit :override #'hrmail--rmail-cease-edit)
+(defun hrmail--rmail-cease-edit ()
   "Finish editing message; switch back to Rmail proper."
   (interactive)
   ;; Make sure buffer ends with a newline.
@@ -251,9 +254,12 @@ Return t if successful, else nil."
   (setq buffer-read-only t))
 
 
-;;; Redefine version of this function from "rmail.el" to include any
-;;; Hyperbole button data.
-(defun rmail-forward (resend)
+;; Redefine version of this function from "rmail.el" to include any
+;; Hyperbole button data.
+;; FIXME: Copy&redefine like this is *evil*.  Use an advice or a hook.
+;; We can make changes to `rmail.el' if needed.
+(advice-add 'rmail-forward :override #'hrmail--rmail-forward)
+(defun hrmail--rmail-forward (resend)
   "Forward the current message to another user.
 With prefix argument, \"resend\" the message instead of forwarding it;
 see the documentation of `rmail-resend'."
@@ -320,31 +326,27 @@ see the documentation of `rmail-resend'."
                (insert-buffer-substring forward-buffer)
                (hmail:msg-narrow))))))))
 
-;;; Redefine version of 'rmail-get-new-mail' from "rmail.el" to highlight
-;;; Hyperbole buttons when possible.
-;;;
-(if (boundp 'rmail-get-new-mail-post-hook)
-    (add-hook 'rmail-get-new-mail-post-hook
-             (lambda ()
-               (if (fboundp 'hproperty:but-create)
-                   (progn (widen) (hproperty:but-create)
-                          (rmail-show-message)))))
-  (hypb:function-overload 'rmail-get-new-mail nil
-                         '(if (fboundp 'hproperty:but-create)
-                              (progn (widen) (hproperty:but-create)
-                                     (rmail-show-message)))))
-
-;;; Redefine version of 'rmail-new-summary' from "rmailsum.el" to
-;;; highlight Hyperbole buttons when possible.
-;;;
-(if (boundp 'rmail-summary-create-post-hook)
-    (add-hook 'rmail-summary-create-post-hook
-             (lambda ()
-               (if (fboundp 'hproperty:but-create)
-                   (hproperty:but-create))))
-  (hypb:function-overload 'rmail-new-summary nil
-                         '(if (fboundp 'hproperty:but-create)
-                              (hproperty:but-create))))
+;; Redefine version of 'rmail-get-new-mail' from "rmail.el" to highlight
+;; Hyperbole buttons when possible.
+;;
+
+(defun hrmail--show-msg-and-buttons (&rest _)
+  (if (fboundp 'hproperty:but-create)
+      (progn (widen) (hproperty:but-create)
+            (rmail-show-message))))
+(if (boundp 'rmail-get-new-mail-post-hook) ;FIXME: Doesn't exist.  XEmacs?
+    (add-hook 'rmail-get-new-mail-post-hook #'hrmail--show-msg-and-buttons)
+  ;; FIXME: Why change `rmail-get-new-mail' rather than `rmail-show-message'?
+  (advice-add 'rmail-get-new-mail :after #'hrmail--show-msg-and-buttons))
+
+;; Redefine version of 'rmail-new-summary' from "rmailsum.el" to
+;; highlight Hyperbole buttons when possible.
+;;
+(defun hrmail--highlight-buttons (&rest _)
+  (if (fboundp 'hproperty:but-create) (hproperty:but-create)))
+(if (boundp 'rmail-summary-create-post-hook) ;FIXME: Doesn't exist.  XEmacs?
+    (add-hook 'rmail-summary-create-post-hook #'hrmail--highlight-buttons)
+  (advice-add 'rmail-new-summary :after #'hrmail--highlight-buttons))
 
 ;; end not InfoDock
 )
diff --git a/hypb.el b/hypb.el
index 38c24f6a5f..fcf41d5c41 100644
--- a/hypb.el
+++ b/hypb.el
@@ -303,10 +303,8 @@ If no matching installation type is found, return a list 
of (\"unknown\" hyperb:
       (concat "@" dname))))
 
 ;;;###autoload
-(defun hypb:emacs-byte-code-p (obj)
-  "Return non-nil iff OBJ is an Emacs byte compiled object."
-  (or (and (fboundp 'byte-code-function-p) (byte-code-function-p obj))
-      (and (fboundp 'compiled-function-p) (compiled-function-p obj))))
+(define-obsolete-function-alias 'hypb:emacs-byte-code-p
+  #'byte-code-function-p "2022")
 
 (defun hypb:error (&rest args)
   "Signal an error typically to be caught by `hyperbole'."
@@ -356,88 +354,6 @@ Return either the modified string or the original ARG when 
not modified."
        nil t)
     arg))
 
-(defun hypb:function-copy (func-symbol)
-  "Copy FUNC-SYMBOL's body for overloading.  Return a copy of the body or the 
original if a subr/primitive."
-  (if (fboundp func-symbol)
-      (let ((func (hypb:indirect-function func-symbol)))
-       (cond ((listp func) (copy-sequence func))
-             ((subrp func) func)
-             ((and (hypb:emacs-byte-code-p func) (fboundp 'make-byte-code))
-              (let ((new-code (append func nil))) ; turn it into a list
-                (apply 'make-byte-code new-code)))
-             (t (error "(hypb:function-copy): Can't copy function body: %s" 
func))))
-    (error "(hypb:function-copy): `%s' symbol is not bound to a function"
-          func-symbol)))
-
-(defun hypb:function-overload (func-sym prepend &rest new-forms)
-  "Redefine function named FUNC-SYM by either PREPENDing (or appending if nil) 
rest of quoted NEW-FORMS."
-  (let ((old-func-sym (intern
-                       (concat "hypb--old-"
-                               (symbol-name func-sym)))))
-    (unless (fboundp old-func-sym)
-      (defalias old-func-sym (hypb:function-copy func-sym)))
-    (let* ((old-func (hypb:indirect-function old-func-sym))
-          (old-param-list (action:params old-func))
-          (param-list (action:param-list old-func))
-          (old-func-call
-            (list (if (memq '&rest old-param-list)
-                      ;; Have to account for extra list wrapper from &rest.
-                      (cons 'apply
-                            (cons (list 'quote old-func-sym) param-list))
-                    (cons old-func-sym param-list)))))
-      (eval (append
-             (list 'defun func-sym old-param-list)
-             (delq nil
-                   (list
-                     (documentation old-func-sym)
-                     (action:commandp old-func-sym)))
-             (if prepend
-                 (append new-forms old-func-call)
-               (append old-func-call new-forms)))))))
-
-(defun hypb:function-symbol-replace (func-sym sym-to-replace replace-with-sym)
-  "Replace in body of FUNC-SYM SYM-TO-REPLACE with REPLACE-WITH-SYM.
-FUNC-SYM may be a function symbol or its body.  All occurrences within lists
-are replaced.  Returns body of modified FUNC-SYM."
-  (let ((body (hypb:indirect-function func-sym))
-       (constant-vector) (constant))
-    (if (subrp body)
-        ;; Non-Lisp code, can't do any replacement
-        body
-      (if (listp body)
-         ;; assume V18 byte compiler
-         (setq constant-vector
-               (car (delq nil (mapcar
-                               (lambda (elt)
-                                 (and (listp elt)
-                                      (vectorp (setq constant-vector (nth 2 
elt)))
-                                      constant-vector))
-                               body))))
-        ;; assume EMACS byte compiler   (eq (compiled-function-p body) t)
-        (setq constant (if (fboundp 'compiled-function-constants)
-                          (compiled-function-constants body)
-                        (aref body 2))
-             constant-vector (when (vectorp constant) constant)))
-      (if constant-vector
-         ;; Code is byte-compiled.
-         (hypb:constant-vector-symbol-replace
-          constant-vector sym-to-replace replace-with-sym)
-        ;;
-        ;; Code is not byte-compiled.
-        ;; Replaces occurrence of symbol within lists only.
-        (hypb:map-sublists
-         (lambda (atom list)
-          ;; The ' in the next line *is* required for proper substitution.
-          (when (eq atom 'sym-to-replace)
-            (let ((again t))
-              (while (and again list)
-                (if (eq (car list) atom)
-                    (progn (setcar list replace-with-sym)
-                           (setq again nil))
-                  (setq list (cdr list)))))))
-         body))
-      body)))
-
 ;; Extracted from part of `choose-completion' in "simple.el"
 (defun hypb:get-completion (&optional event)
   "Return the completion at point.
@@ -586,17 +502,6 @@ then `locate-post-command-hook'."
           collect (funcall func k v) into result
           finally return result))
 
-(defun hypb:map-sublists (func list)
-  "Apply FUNC to every atom found at any level of LIST.
-FUNC must take two arguments, an atom and a list in which the atom is found.
-Returns values from applications of FUNC as a list with the same
-structure as LIST.  FUNC is therefore normally used just for its side-effects."
-  (mapcar (lambda (elt)
-           (if (atom elt)
-               (funcall func elt list)
-             (hypb:map-sublists func elt)))
-         list))
-
 (defun hypb:map-vector (func object)
   "Return list of results of application of FUNC to each element of OBJECT.
 OBJECT should be a vector or `byte-code' object."
@@ -888,20 +793,6 @@ If FILE is not an absolute path, expand it relative to 
`hyperb:dir'."
 ;;; Private functions
 ;;; ************************************************************************
 
-(defun hypb:constant-vector-symbol-replace
-  (constant-vector sym-to-replace replace-with-sym)
-  "Replace symbols within a byte-compiled constant vector."
-  (let ((i (length constant-vector))
-       constant)
-    (while (>= (setq i (1- i)) 0)
-      (setq constant (aref constant-vector i))
-      (cond ((eq constant sym-to-replace)
-            (aset constant-vector i replace-with-sym))
-           ((and (fboundp 'compiled-function-p)
-                 (compiled-function-p constant))
-            (hypb:function-symbol-replace
-             constant sym-to-replace replace-with-sym))))))
-
 (defun hypb:insert-hyperbole-banner ()
   "Display an optional text FILE with the Hyperbole banner prepended.
 Without file, the banner is prepended to the current buffer."