[mcclim-cvs] CVS update: mcclim/frames.lisp

[Timothy Moore]

Update of /project/mcclim/cvsroot/mcclim
In directory common-lisp.net:/tmp/cvs-serv15555

Modified Files:
	frames.lisp 
Log Message:

Eat the pointer-release events from a menu choose action. Otherwise,
they will still be around when if a command, invoked by the menu,
starts looking at the event queue.

Completely bypass the standard presentation translator mechanism when
determining whether to call the presentation clauses in
TRACKING-POINTER. Presentation translators and actions can't do
anything here.

Date: Tue Jan 11 14:14:19 2005
Author: tmoore

Index: mcclim/frames.lisp
diff -u mcclim/frames.lisp:1.103 mcclim/frames.lisp:1.104
--- mcclim/frames.lisp:1.103	Fri Nov 12 07:38:50 2004
+++ mcclim/frames.lisp	Tue Jan 11 14:14:18 2005
@@ -1337,23 +1337,47 @@
 				    (cdr hilited)
 				    :unhighlight)))))
 
+;;; Poor man's find-applicable-translators. tracking-pointer doesn't want to
+;;; see any results from presentation translators.
+
+(defun highlight-for-tracking-pointer (frame stream x y input-context)
+  (let ((context-ptype (input-context-type (car input-context)))
+	(presentation nil)
+	(current-hilited (frame-hilited-presentation frame)))
+    (if (output-recording-stream-p stream)
+	(progn
+	  (block found-presentation
+	    (flet ((do-presentation (p)
+		     (when (presentation-subtypep (presentation-type p)
+						  context-ptype)
+		       (setq presentation p)
+		       (return-from found-presentation nil))))
+	      (declare (dynamic-extent #'do-presentation))
+	      (map-over-presentations-containing-position
+	       #'do-presentation (stream-output-history stream) x y)))
+	  (when (and current-hilited
+		     (not (eq (car current-hilited) presentation)))
+	    (highlight-presentation-1 (car current-hilited)
+				      (cdr current-hilited)
+				      :unhighlight))
+	  (if presentation
+	      (progn
+		(setf (frame-hilited-presentation frame)
+		      (cons presentation stream))
+		(highlight-presentation-1 presentation stream :highlight)))
+	  presentation))))
+
 (defmethod tracking-pointer-loop-step :before
     ((state frame-tracking-pointer-state) (event pointer-event) x y)
   (declare (ignore x y))
   (when (highlight state)
     (let ((stream (event-sheet event)))
       (setf (applicable-presentation state)
-	    (frame-highlight-at-position *application-frame* stream
-					 (device-event-x event)
-					 (device-event-y event)
-					 (event-modifier-state event)
-					 (input-context state)
-					 :highlight (highlight state)))
-      ;;; Hmmm, probably don't want to do this
-      #+nil (frame-update-pointer-documentation frame
-					  (input-context state)
-					  stream
-					  event))))
+	    (highlight-for-tracking-pointer *application-frame* stream
+					    (device-event-x event)
+					    (device-event-y event)
+					    (input-context state))))))
+
 
 (macrolet ((frob (event handler)
 	     `(defmethod tracking-pointer-loop-step