"with-handlers" code (may be helpful).

[nakamura@SOE.Berkeley.Edu (Mark Nakamura)]

Here is some code that I just hacked up.  If you're doing large amounts
of event-driven window interactions, then this might be of some use to
you.  Comments and questions please.  I _hope_ that the comments are
self-explanatory.

Mark


;; The with-handlers macro is designed to be used to temporarily modify the
;; event-handling behavior of a window, by setting up an extent (not a scope!)
;; during which some subset of the window's event handlers are redefined. This
;; should only be called under an ASK of a window.

;; The call

;;    (ask window
;;         (with-handlers ((handler-1-name new-def-1)
;;                         (handler-2-name new-def-2)
;;                         ...)
;;           BODY))
               
;; makes window FHAVE the handler-i-name's with definitions new-def-i, eval's
;; BODY as an implicit progn, rebinds the handler-i-name's to their initial
;; bindings or makes them funbound if they had no "window-local" definitions,
;; and returns what the last form of BODY returns.


(eval-when (compile eval load)
  
  (defmacro with-handlers (temp-fbindings &body body)
    ;; temp-fbindings is a list of pairs (function-name temp-binding). For
    ;; each of the pairs, function-name's current function is saved (as the
    ;; function binding of OLD-function-name) and function-name is temporarily
    ;; given temp-fbinding as its function binding. The forms in body are
    ;; eval'ed as in a progn, and the value(s) of the last form is/are returned
    ;; after the function-names have had their initial function bindings
    ;; restored. The temporary functions may call the initial functions by
    ;; name, e.g. OLD-foo.
    `(let ((wir ccl:*warn-if-redefine-kernel*)
           ,@(mapcar '(lambda (x) (name-had (car x))) temp-fbindings))
       ; make possible kernel-fn redefinitions silent
       (setq ccl:*warn-if-redefine-kernel* nil)
       ; save current fn-bindings
       ,@(mapcar #'(lambda (fpair) (save-old (car fpair)))
                 temp-fbindings)
       (unwind-protect
         (progn
           ; set up new function bindings
           ,@(mapcar #'(lambda (x) `(fhave ',(car x) 
                                           ,(or (cadr x) 
                                                '(function nill))))
                     temp-fbindings)
           ,@ body)
         ,@(mapcan #'(lambda (fpair) (restore-old (car fpair)))
                   temp-fbindings)
         (setq ccl:*warn-if-redefine-kernel* wir)))))


(defun save-old (fn)
  ;; Return a form that creates a new function named OLD-fn, and gives it the
  ;; current function binding of fn. Also, if fn is bound in the current
  ;; object, set variable HAD-fn to t.
  `(if (fboundp ',fn)
     (progn 
       (fhave ',(name-old fn)
           (symbol-function ',fn))
       (when (fownp ',fn) (setq ,(name-had fn) t)))
     (fmakunbound ',(name-old fn))))


(defun restore-old (fn)
  ;; Return a form to restore the function binding of fn: if variable HAD-fn
  ;; is t, restore the binding from OLD-fn, otherwise make the current object
  ;; have fn unbound as a function.
  `((if ,(name-had fn)
     (fhave ',fn (symbol-function ',(name-old fn)))
     (fmakunbound ',fn))
    (fmakunbound ',(name-old fn))))


(defun name-old (fn)
  ;; Create and return a (possibly new) symbol OLD-fn.
  (intern (concatenate 'string "OLD-" (string fn))))


(defun name-had (fn)
  ;; Create and return a (possibly new) symbol HAD-fn.
  (intern (concatenate 'string "HAD-" (string fn))))




;; Test code.

;; Define a new class of windows.
(defobject *new-window* *window*)
;; Create one of those windows.
(defvar *my-window* (oneof *new-window*))


(defobfun (window-click-event-handler *my-window*) (where)
  ;; Shadow the original click handler.
  ;; Beep then call the usual handler.
  (ed-beep)
  (usual-window-click-event-handler where))


(defobfun (loop-click-event-handler *my-window*) (where)
  ;; Click handler that is used in do-with-new-click-handler.
  ;; Print where we are in the window.
  (print (point-string where))
  ;; Do the old handler, which includes the usual handler.
  ;; Call the OLD-window-click-event-handler whose binding has been saved.
  (old-window-click-event-handler where))


(defobfun (do-with-new-click-handler *my-window*) ()
  ;; Loop within with-handler which temporarily assigns *new-window*
  ;; with a new click handler.
  (with-handlers
    ((window-click-event-handler #'loop-click-event-handler))
    ;; Loop until command-key down.
    ;; Try clicking within loop to test loop-click-event-handler.
    (do ()
        ((command-key-p)
         ;; Exit do when by pressing command-key.
         t)
      ;; Allow for other things to happen.
      (sleep 1/60)
      (event-dispatch))))


;; Call this to test.  Command-key to exit.
;; (ask *my-window* (do-with-new-click-handler))