diff --git a/ChangeLog.n b/ChangeLog.n index 474437bc1418a7589f65a3e742d21212b4c98aad..11546e110ca808eea22ddde86e88c0ed92908443 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -3,6 +3,13 @@ don't forget to change the version in utils/packages.lisp if you do anything user visible. +******************************************************************************* +2009-05-14 Andreas Fuchs <afuchs@franz.com> + + * silica/db-scroll.lisp: new gf `medium-can-scroll-by-copy-region-p': + Determines whether we can use copy-area to scroll. + * aclpc/acl-pixmaps.lisp: add a method to prevent copy-area scrolling + if gadget output records are present on the stream. [spr35502] ******************************************************************************* 2009-05-11 Duane Rettig <duane@franz.com> diff --git a/aclpc/acl-pixmaps.lisp b/aclpc/acl-pixmaps.lisp index e5577644712e37df045a77a062687c544bdca62b..35b38be24ceabd33ab325441f4a01ee1487985c5 100644 --- a/aclpc/acl-pixmaps.lisp +++ b/aclpc/acl-pixmaps.lisp @@ -30,6 +30,23 @@ (in-package :acl-clim) +(defmethod silica::medium-can-scroll-by-copy-region-p + ((medium acl-window-medium) old-region new-region) + "On Windows, copy-region corrupts the output if gadget output +records (like buttons) are present in the old or new regions." + (and (call-next-method) + (let ((sheet (medium-sheet medium))) + (flet ((any-gadget-output-records-p (region) + (map-over-output-records-overlapping-region + (lambda (record) + (when (typep record 'gadget-output-record) + (return-from any-gadget-output-records-p nil))) + (stream-output-history sheet) + region) + t)) + (not (or (any-gadget-output-records-p old-region) + (any-gadget-output-records-p new-region))))))) + (defmethod medium-copy-area ((from-medium acl-window-medium) from-x from-y width height (to-medium acl-window-medium) to-x to-y diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 2e7ef8d130ce756d13226e946110c7bdf4804ca2..ef600dad2b68373bade315533e3ddbba77c137c3 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -260,6 +260,14 @@ (defmethod mirror-region-updated :after ((port basic-port) (viewport viewport)) (update-scroll-bars viewport)) +(defgeneric medium-can-scroll-by-copy-region-p (medium old-region new-region) + (:method (medium old-region new-region) + (declare (ignore medium)) + (with-bounding-rectangle* (left top right bottom) old-region + (with-bounding-rectangle* (nleft ntop nright nbottom) new-region + (ltrb-overlaps-ltrb-p left top right bottom + nleft ntop nright nbottom))))) + (defmethod scroll-extent ((sheet basic-sheet) x y) ;;--- CER says that this really isn't right... (fix-coordinates x y) @@ -282,7 +290,9 @@ (update-region sheet nleft ntop nright nbottom) ;; Must go after bounding-rectangle-set-position (update-scroll-bars viewport) - (if (ltrb-overlaps-ltrb-p left top right bottom nleft ntop nright nbottom) + (if (medium-can-scroll-by-copy-region-p + medium (make-bounding-rectangle left top right bottom) + (pane-viewport-region sheet)) (progn ;; Move the old stuff to the new position (window-shift-visible-region sheet @@ -301,7 +311,7 @@ medium (bounding-rectangle* region)) (if (output-recording-stream-p sheet) (replay (stream-output-history sheet) sheet region) - (repaint-sheet sheet region))))))) + (repaint-sheet sheet region))))))) (let ((region (viewport-viewport-region viewport))) ;;--- We should make the sheet-region bigger at this point. ;;--- Perhaps we do a union of the sheet-region and the viewport.