Path: utzoo!attcan!uunet!seismo!sundc!pitstop!sun!decwrl!ucbvax!PEBBLES.BBN.COM!jr
From: jr@PEBBLES.BBN.COM (John Robinson)
Newsgroups: comp.emacs
Subject: Re: redefining functions in gnuemacs
Message-ID: <4535.579446565@pebbles>
Date: 12 May 88 13:22:45 GMT
References: <10804@steinmetz.ge.com>
Sender: daemon@ucbvax.BERKELEY.EDU
Reply-To: jr@bbn.com
Organization: The Internet
Lines: 98

>> Someone has also posted some code for adding hooks to arbitrary
>> functions; this is probably the best way to go, but I don't
>> recall the poster.

Here 'tis...

/jr
jr@bbn.com or bbn!jr
--------
Date: 8 May 88 17:22:00 GMT
From: Mark Weissman 
Organization: Apollo Computer, Chelmsford, Mass.
Subject: redefining functions in gnuemacs
Message-Id: <3bee854e.12972@apollo.uucp>
Sender: unix-emacs-request@BBN.COM
To: unix-emacs@BBN.COM

Here's a macro that takes an existing function and adds
before and after hooks to it.   It may lose for some
interactive arguments but its great for things like
checking parenthesis before saving a file etc.

Its used like:
(mdw:add-hooks some-existing-function)
(setq 
  mdw:some-existing-function-before-hooks '(func-1 func-2 ...)
  mdw:some-existing-function-after-hooks  '(func-3 func-4 ...))

Mark Weissman
APOLLO Computer Inc.

;;; -*- Mode: Emacs-Lisp -*-
(defvar mdw:gensym-name "GENSYM")
(defvar mdw:genysm-number 0)
(defmacro mdw:gensym ()
  "Generate a new unused symbol"
  (let (s)
    (while (or (boundp (setq s (intern (format "mdw:%s-%s"
                                               mdw:gensym-name
                                               (setq mdw:gensym-number
                                                     (1+ mdw:gensym-number))))))
               (fboundp s)))
    (list 'quote s)))

(defmacro mdw:add-hooks (function)
  "This macro is called with a symbol representing an emacs lisp
          function.  This function is redefined to funcall a list
          of hooks before and after function execution.
	  This will may lose with complex (interactive) args.
          This will create local-variables as follows:
          mdw: bound to the symbol function of function
          mdw:-documentation which will be the doc
                string for the function.
          mdw:-before-hooks, a list of functions to funcall
                before execution. These functions will be called with the
                same arguments as the original function.
          mdw:-after-hooks, a list of functions to funcall
                after execution.  These functions will be called with the
                result of executing the original function followed by the
                original arguments.
          This will take and return the same arguments as the original function.
          "
  (let* ((mdw-name   (concat "mdw:" (symbol-name function)))
         (mdw-before (concat mdw-name "-before-hooks"))
         (mdw-after  (concat mdw-name "-after-hooks"))
         (mdw-doc    (concat mdw-name "-documentation"))
         (args       (mdw:gensym))
         (hook       (mdw:gensym))
         (result     (mdw:gensym)))
    (if (fboundp function)
        (list 'progn
              (list 'defvar (intern mdw-name)
                    (list 'symbol-function (list 'quote function)))
              (list 'defvar (intern mdw-doc)
                    (list 'documentation   (list 'quote function)))
              (list 'defvar (intern mdw-before) nil)
              (list 'defvar (intern mdw-after)  nil)
              (list 'defun function (list '&rest args)
                    (concat
                      (if (boundp (intern mdw-doc))
                          (eval (intern mdw-doc))
                          (documentation function))
                      "\n\nAdded hooks: " mdw-before " &\n"
                      "             " mdw-after ".")
                    '(interactive)
                    (list 'mapcar
                          (list 'function
                                (list 'lambda (list hook)
                                      (list 'apply hook args)))
                          (intern mdw-before))
                    (list 'let
                          (list
                            (list result (list 'apply (intern mdw-name) args)))
                          (list 'mapcar
                                (list 'function (list 'lambda (list hook)
                                                      (list 'apply hook args)))
                                (intern mdw-after))
                          result))))))