[mcclim-cvs] CVS mcclim

[tmoore]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv28040

Modified Files:
	frames.lisp 
Log Message:
drag-and-drop mostly working except for highlighting of destination presentations

--- /project/mcclim/cvsroot/mcclim/frames.lisp	2006/03/12 23:09:27	1.115
+++ /project/mcclim/cvsroot/mcclim/frames.lisp	2006/03/13 06:08:12	1.116
@@ -1562,7 +1562,7 @@
 			      :filled nil :line-dashes #(4 4))))
 	  (:unhighlight
 	   (with-double-buffering
-	       ((stream hilite-x1 hilite-y1 hilite-x2 hilite-y2)
+	       ((stream hilite-x1 hilite-y1 (1+ hilite-x2) (1+ hilite-y2))
 		(buffer-rectangle))
 	     (stream-replay stream buffer-rectangle))))))))
 
@@ -1590,7 +1590,8 @@
 					      :window window
 					      :x x
 					      :y y
-					      :event event)))
+					      :event event)
+				     (list trans)))
 			      (find-presentation-translators
 			       (presentation-type from-presentation)
 			       context-type
@@ -1623,13 +1624,11 @@
 							   window x y))
 		   do (return-from find-dest-translator translator))
 	     nil)
-	   (do-feedback (window x y state do-it)
-	     (when do-it
-	       (funcall feedback-fn frame from-presentation window
-			initial-x initial-y x y state)))
+	   (do-feedback (window x y state)
+	     (funcall feedback-fn frame from-presentation window
+			initial-x initial-y x y state))
 	   (do-hilite (presentation window state)
-	     (when presentation
-	       (funcall hilite-fn frame presentation window state)))
+	     (funcall hilite-fn frame presentation window state))
 	   (last-window ()
 	     (event-sheet last-event))
 	   (last-x ()
@@ -1646,27 +1645,29 @@
 	  (:presentation (&key presentation window event x y)
 	    (let ((dest-translator (find-dest-translator presentation window
 							 x y)))
-	      (do-feedback (last-window) (last-x) (last-y)
-			   :unhighlight feedback-activated)
+	      (when feedback-activated
+		(do-feedback (last-window) (last-x) (last-y) :unhighlight))
 	      (setq feedback-activated t
 		    last-event event)
-	      (do-hilite last-presentation (last-window) :unhighlight)
+	      (when last-presentation
+		(do-hilite last-presentation (last-window) :unhighlight))
 	      (setq last-presentation presentation
 		    feedback-fn (feedback dest-translator)
 		    hilite-fn (highlighting dest-translator))
 	      (do-hilite presentation window :highlight)
-	      (do-feedback window x y :highlight t)
+	      (do-feedback window x y :highlight)
 	      (document-drag-n-drop dest-translator presentation
 				    context-type frame event window
 				    x y)))
 	  (:pointer-motion (&key event window x y)
-	    (do-feedback (last-window) (last-x) (last-y)
-			 :unhighlight feedback-activated)
+	    (when feedback-activated
+	      (do-feedback (last-window) (last-x) (last-y) :unhighlight))
 	    (setq feedback-activated t
 		  last-event event)
-	    (do-hilite last-presentation (last-window) :unhighlight)
+	    (when last-presentation
+	      (do-hilite last-presentation (last-window) :unhighlight))
 	    (setq last-presentation nil)
-	    (do-feedback window x y :highlight t)
+	    (do-feedback window x y :highlight)
 	    (document-drag-n-drop translator nil
 				  context-type frame event window
 				  x y))
@@ -1683,9 +1684,10 @@
       ;;
       ;; XXX Assumes x y from :button-release are the same as for the preceding
       ;; button-motion; is that correct?
-      (do-feedback (last-window) (last-x) (last-y)
-		   :unhighlight feedback-activated)
-      (do-hilite last-presentation (last-window) :unhighlight)
+      (when feedback-activated
+	(do-feedback (last-window) (last-x) (last-y) :unhighlight))
+      (when last-presentation
+	(do-hilite last-presentation (last-window) :unhighlight))
       (if destination-presentation
 	  (let ((final-translator (find-dest-translator destination-presentation
 							(last-window)
@@ -1714,14 +1716,19 @@
       (window-clear s)
       (with-end-of-page-action (s :allow)
 	(with-end-of-line-action (s :allow)
-	  (document-presentation-translator translator
-					    presentation
-					    context-type
-					    frame
-					    event
-					    window
-					    x y
-					    :stream s
-					    :documentation-type :pointer))))))
+	  (funcall (pointer-documentation translator)
+	   *dragged-object*
+	   :presentation *dragged-presentation*
+	   :destination-object (and presentation
+				    (presentation-object presentation))
+	   :destination-presentation presentation
+	   :context-type context-type
+	   :frame frame
+	   :event event
+	   :window window
+	   :x x
+	   :y y
+	   :stream s))))))
+