/[mcclim]/mcclim/input.lisp
ViewVC logotype

Diff of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.16 by moore, Wed Jun 26 06:27:19 2002 UTC revision 1.17 by adejneka, Sat Jul 13 07:58:56 2002 UTC
# Line 382  Line 382 
382    
383  (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)  (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
384    ())    ())
385    
386    ;;;
387    (defmacro tracking-pointer
388        ((sheet &rest args
389                &key pointer multiple-window transformp context-type highlight)
390         &body body)
391      (declare (ignorable pointer multiple-window transformp context-type highlight))
392      (when (eq sheet 't)
393        (setq sheet '*standard-output*))
394      (check-type sheet symbol)
395      (loop for event-name in '(:pointer-motion
396                                :presentation
397                                :pointer-button-press
398                                :presentation-button-press
399                                :pointer-button-release
400                                :presentation-button-release
401                                :keyboard)
402         for handler-name = (gensym (symbol-name event-name))
403         collect `(,handler-name ,@ (or (cdr (assoc event-name body))
404                                        '((&rest args) (declare (ignore args)))))
405         into bindings
406         collect `#',handler-name into handler-names
407         finally
408         (return `(flet ,bindings
409                    (declare (dynamic-extent ,@handler-names))
410                    (invoke-tracking-pointer ,sheet ,@handler-names
411                                             ,@args)))))
412    
413    (defun invoke-tracking-pointer
414        (sheet
415         pointer-motion-handler presentation-handler
416         pointer-button-press-handler presentation-button-press-handler
417         pointer-button-release-handler presentation-button-release-handler
418         keyboard-handler
419         &key pointer multiple-window transformp context-type highlight)
420      ;; (setq pointer (port-pointer sheet))
421      (let ((port (port sheet)))
422        (with-method (distribute-event :around ((port (eql port)) event)
423                                       ;; XXX specialize on EVENT?
424                                       (queue-event sheet event))
425          (loop for event = (event-read sheet)
426             do (cond ((and (typep event 'pointer-event)
427                            #+nil
428                            (eq (pointer-event-pointer event)
429                                pointer))
430                       (let ((x (pointer-event-x event))
431                             (y (pointer-event-y event))
432                             (window (event-sheet event)))
433                         ;; XXX Convert X,Y to SHEET coordinates
434                         ;; XXX user coordinates
435                         (typecase event
436                           (pointer-motion-event
437                            (funcall pointer-motion-handler
438                                     :window window :x x :y y))
439                           (pointer-button-press-event
440                            (funcall pointer-button-press-handler
441                                     :event event :x x :y y))
442                           (pointer-button-release-event
443                            (funcall pointer-button-release-handler
444                                     :event event :x x :y y)))))
445                      ((typep event 'keyboard-event)
446                       (funcall keyboard-handler
447                                :gesture event #|XXX|#))
448                      (t (handle-event #|XXX|# (event-sheet event) event)))))))

Legend:
Removed from v.1.16  
changed lines
  Added in v.1.17

  ViewVC Help
Powered by ViewVC 1.1.5