[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

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

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


;; 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)))
           ; set up new function bindings
           ,@(mapcar #'(lambda (x) `(fhave ',(car x) 
                                           ,(or (cadr x) 
                                                '(function nill))))
           ,@ body)
         ,@(mapcan #'(lambda (fpair) (restore-old (car fpair)))
         (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)
       (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.
  (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.
    ((window-click-event-handler #'loop-click-event-handler))
    ;; Loop until command-key down.
    ;; Try clicking within loop to test loop-click-event-handler.
    (do ()
         ;; Exit do when by pressing command-key.
      ;; Allow for other things to happen.
      (sleep 1/60)

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