Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25030
Modified Files: presentation-defs.lisp presentations.lisp Log Message: Moved with-input-context and related machinery to to presentations.lisp.
--- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/01/31 12:14:05 1.74 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/02/01 17:02:55 1.75 @@ -685,122 +685,6 @@ (unless (and top-ptype (eql object top-object) (equal ptype top-ptype)) (presentation-history-insert history object ptype))))
-;;; Context-dependent input -;;; An input context is a cons of a presentation type and a continuation to -;;; call to return a presentation to that input context. - -(defvar *input-context* nil) - -(defun input-context-type (context-entry) - (car context-entry)) - -;;; Many presentation functions, internal and external, take an input -;;; context as an argument, but they really only need to look at one -;;; presentation type. -(defun make-fake-input-context (ptype) - (list (cons (expand-presentation-type-abbreviation ptype) - #'(lambda (object type event options) - (declare (ignore event options)) - (error "Fake input context called with object ~S type ~S. ~ - This shouldn't happen!" - object type))))) - -(defun input-context-wait-test (stream) - (let* ((queue (stream-input-buffer stream)) - (event (event-queue-peek queue))) - (when event - (let ((sheet (event-sheet event))) - (when (and (output-recording-stream-p sheet) - (or (typep event 'pointer-event) - (typep event 'keyboard-event)) - (not (gadgetp sheet))) - (return-from input-context-wait-test t)))) - nil)) - -(defun highlight-applicable-presentation (frame stream input-context - &optional (prefer-pointer-window t)) - (let* ((queue (stream-input-buffer stream)) - (event (event-queue-peek queue))) - (when (and event - (or (and (typep event 'pointer-event) - (or prefer-pointer-window - (eq stream (event-sheet event)))) - (typep event 'keyboard-event))) - ;; Stream only needs to see button press events. - ;; XXX Need to think about this more. Should any pointer events be - ;; passed through? If there's no presentation, maybe? - (unless (typep event 'keyboard-event) - (event-queue-read queue)) - (progn - (frame-input-context-track-pointer frame - input-context - (event-sheet event) - event) - (when (typep event 'pointer-button-press-event) - (funcall *pointer-button-press-handler* stream event))) - #+nil - (if (and (typep event 'pointer-motion-event) - (pointer-event-button event)) - (frame-drag frame input-context (event-sheet event) event) - )))) - -(defun input-context-event-handler (stream) - (highlight-applicable-presentation *application-frame* - stream - *input-context*)) - -(defun input-context-button-press-handler (stream button-event) - (declare (ignore stream)) - (frame-input-context-button-press-handler *application-frame* - (event-sheet button-event) - button-event)) - -(defun highlight-current-presentation (frame input-context) - (let ((event (synthesize-pointer-motion-event (port-pointer - (port - *application-frame*))))) - (when event - (frame-input-context-track-pointer frame - input-context - (event-sheet event) - event)))) - -(defmacro with-input-context ((type &key override) - (&optional (object-var (gensym)) - (type-var (gensym)) - event-var - options-var) - form - &body pointer-cases) - (let ((vars `(,object-var - ,type-var - ,@(and event-var `(,event-var)) - ,@(and options-var `(,options-var)))) - (return-block (gensym "RETURN-BLOCK")) - (context-block (gensym "CONTEXT-BLOCK"))) - `(block ,return-block - (multiple-value-bind ,vars - (block ,context-block - (let ((*input-context* - (cons (cons (expand-presentation-type-abbreviation ,type) - #'(lambda (object type event options) - (return-from ,context-block - (values object type event options)))) - ,(if override nil '*input-context*))) - (*pointer-button-press-handler* - #'input-context-button-press-handler) - (*input-wait-test* #'input-context-wait-test) - (*input-wait-handler* #'input-context-event-handler)) - (return-from ,return-block ,form ))) - (declare (ignorable ,@vars)) - (highlight-current-presentation *application-frame* *input-context*) - (cond ,@(mapcar #'(lambda (pointer-case) - (destructuring-bind (case-type &body case-body) - pointer-case - `((presentation-subtypep ,type-var ',case-type) - ,@case-body))) - pointer-cases)))))) - (define-presentation-generic-function %accept accept (type-key parameters options type stream view &key))
--- /project/mcclim/cvsroot/mcclim/presentations.lisp 2008/01/31 12:14:05 1.84 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2008/02/01 17:02:55 1.85 @@ -1978,4 +1978,120 @@ (map-over-output-records (lambda (child) (highlight-output-record child stream state)) - record)) \ No newline at end of file + record)) + +;;; Context-dependent input +;;; An input context is a cons of a presentation type and a continuation to +;;; call to return a presentation to that input context. + +(defvar *input-context* nil) + +(defun input-context-type (context-entry) + (car context-entry)) + +;;; Many presentation functions, internal and external, take an input +;;; context as an argument, but they really only need to look at one +;;; presentation type. +(defun make-fake-input-context (ptype) + (list (cons (expand-presentation-type-abbreviation ptype) + #'(lambda (object type event options) + (declare (ignore event options)) + (error "Fake input context called with object ~S type ~S. ~ + This shouldn't happen!" + object type))))) + +(defun input-context-wait-test (stream) + (let* ((queue (stream-input-buffer stream)) + (event (event-queue-peek queue))) + (when event + (let ((sheet (event-sheet event))) + (when (and (output-recording-stream-p sheet) + (or (typep event 'pointer-event) + (typep event 'keyboard-event)) + (not (gadgetp sheet))) + (return-from input-context-wait-test t)))) + nil)) + +(defun highlight-applicable-presentation (frame stream input-context + &optional (prefer-pointer-window t)) + (let* ((queue (stream-input-buffer stream)) + (event (event-queue-peek queue))) + (when (and event + (or (and (typep event 'pointer-event) + (or prefer-pointer-window + (eq stream (event-sheet event)))) + (typep event 'keyboard-event))) + ;; Stream only needs to see button press events. + ;; XXX Need to think about this more. Should any pointer events be + ;; passed through? If there's no presentation, maybe? + (unless (typep event 'keyboard-event) + (event-queue-read queue)) + (progn + (frame-input-context-track-pointer frame + input-context + (event-sheet event) + event) + (when (typep event 'pointer-button-press-event) + (funcall *pointer-button-press-handler* stream event))) + #+nil + (if (and (typep event 'pointer-motion-event) + (pointer-event-button event)) + (frame-drag frame input-context (event-sheet event) event) + )))) + +(defun input-context-event-handler (stream) + (highlight-applicable-presentation *application-frame* + stream + *input-context*)) + +(defun input-context-button-press-handler (stream button-event) + (declare (ignore stream)) + (frame-input-context-button-press-handler *application-frame* + (event-sheet button-event) + button-event)) + +(defun highlight-current-presentation (frame input-context) + (let ((event (synthesize-pointer-motion-event (port-pointer + (port + *application-frame*))))) + (when event + (frame-input-context-track-pointer frame + input-context + (event-sheet event) + event)))) + +(defmacro with-input-context ((type &key override) + (&optional (object-var (gensym)) + (type-var (gensym)) + event-var + options-var) + form + &body pointer-cases) + (let ((vars `(,object-var + ,type-var + ,@(and event-var `(,event-var)) + ,@(and options-var `(,options-var)))) + (return-block (gensym "RETURN-BLOCK")) + (context-block (gensym "CONTEXT-BLOCK"))) + `(block ,return-block + (multiple-value-bind ,vars + (block ,context-block + (let ((*input-context* + (cons (cons (expand-presentation-type-abbreviation ,type) + #'(lambda (object type event options) + (return-from ,context-block + (values object type event options)))) + ,(if override nil '*input-context*))) + (*pointer-button-press-handler* + #'input-context-button-press-handler) + (*input-wait-test* #'input-context-wait-test) + (*input-wait-handler* #'input-context-event-handler)) + (return-from ,return-block ,form ))) + (declare (ignorable ,@vars)) + (highlight-current-presentation *application-frame* *input-context*) + (cond ,@(mapcar #'(lambda (pointer-case) + (destructuring-bind (case-type &body case-body) + pointer-case + `((presentation-subtypep ,type-var ',case-type) + ,@case-body))) + pointer-cases))))))