diff --git a/ChangeLog b/ChangeLog index f0c848c0..535f35c2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,21 @@ +2022-07-13 Stefan Monnier + +* 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 * test/hpath-tests.el (hpath:auto-variable-alist-load-path-test): Simplify diff --git a/hgnus.el b/hgnus.el index b878a5a6..53c1d972 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 e0d43228..48aa8d15 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 a7bbc210..7a67ffec 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 38c24f6a..fcf41d5c 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."