diff --git a/ChangeLog.n b/ChangeLog.n index 773d2566bda401fb935d4f9884b040a166538326..57deb2af00a19353b4c300c45e0d7441808bf608 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -3,6 +3,11 @@ don't forget to change the version in utils/packages.lisp if you do anything user visible. ******************************************************************************* +2009-09-15 Andreas Fuchs <afuchs@franz.com> + + * aclpc/acl-mirror.lisp: Restrict window sizes to the maximum available client + rect size for each window. (spr36199). + 2009-09-10 Andreas Fuchs <afuchs@franz.com> * tk/font.lisp: Fix (obvious, in retrospect) printer error in warning about missing diff --git a/aclpc/acl-mirror.lisp b/aclpc/acl-mirror.lisp index d41798c75eb4b5d5b96e9539f122f6468d26293f..f225ceb782f152c395e9e74942f4b832d2586468 100644 --- a/aclpc/acl-mirror.lisp +++ b/aclpc/acl-mirror.lisp @@ -36,38 +36,61 @@ ;;--- This isn't really right, all ports only have kludges for this (defmethod sheet-shell (sheet) sheet) +(defun win-full-screen-area () + "Get the area of the screen that can be occupied by windows (screen - task/tool bars)." + (let ((rect (ct:ccallocate win:rect))) + (win:SystemParametersInfo win:SPI_GETWORKAREA 0 rect 0) + (values (coordinate (ct:cref win:rect rect win::left)) + (coordinate (ct:cref win:rect rect win::top)) + (coordinate (ct:cref win:rect rect win::right)) + (coordinate (ct:cref win:rect rect win::bottom))))) + (defmethod realize-graft ((port acl-port) graft) (let ((screen (slot-value (screen-device *acl-port*) 'device-handle1))) - (setf (port-screen port) screen) - (init-cursors) - (with-slots (silica::pixels-per-point - silica::pixel-width - silica::pixel-height - silica::mm-width - silica::mm-height - silica::units) graft - (with-dc (screen dc) - (let ((screen-width (win:GetSystemMetrics win:SM_CXSCREEN)) - (screen-height (win:GetSystemMetrics win:SM_CYSCREEN)) - (logpixelsx (win:GetDeviceCaps dc win:LOGPIXELSX)) - (logpixelsy (win:GetDeviceCaps dc win:LOGPIXELSY))) - (setf silica::pixel-width screen-width - silica::pixel-height screen-height - silica::mm-width (round (* screen-width 25.4s0) logpixelsx) - silica::mm-height (round (* screen-height 25.4s0) logpixelsy)) - (let* ((ppp (/ logpixelsy 72s0)) - (rounded-ppp (round ppp))) - (setf silica::pixels-per-point - (if (< (abs (- ppp rounded-ppp)) .1s0) rounded-ppp ppp))) - (setf (sheet-region graft) - (ecase silica::units - ((:device :pixel) - (make-bounding-rectangle - 0 0 - silica::pixel-width silica::pixel-height)))) - (setf (sheet-native-transformation graft) +identity-transformation+) - (setf (sheet-direct-mirror graft) screen) - (update-mirror-transformation port graft)))))) + (setf (port-screen port) screen) + (init-cursors) + (with-slots (silica::pixels-per-point + silica::pixel-width + silica::pixel-height + silica::mm-width + silica::mm-height + silica::units) graft + (with-dc (screen dc) + (multiple-value-bind (screen-left screen-top screen-right screen-bottom) + (win-full-screen-area) + (let ((screen-width (- screen-left screen-right)) + (screen-height (- screen-bottom screen-top)) + (logpixelsx (win:GetDeviceCaps dc win:LOGPIXELSX)) + (logpixelsy (win:GetDeviceCaps dc win:LOGPIXELSY))) + (setf silica::pixel-width (- screen-left screen-right) + silica::pixel-height (- screen-bottom screen-top) + silica::mm-width (round (* screen-width 25.4s0) logpixelsx) + silica::mm-height (round (* screen-height 25.4s0) logpixelsy)) + (let* ((ppp (/ logpixelsy 72s0)) + (rounded-ppp (round ppp))) + (setf silica::pixels-per-point + (if (< (abs (- ppp rounded-ppp)) .1s0) rounded-ppp ppp))) + + (setf (sheet-region graft) + (ecase silica::units + ((:device :pixel) + (make-bounding-rectangle + screen-left screen-top screen-right screen-bottom)))) + (format *trace-output* "~&height: ~A vs. real height: ~A~%" + screen-height (- screen-bottom screen-top)) + (setf (sheet-native-transformation graft) +identity-transformation+) + (setf (sheet-direct-mirror graft) screen) + (update-mirror-transformation port graft))))))) + +(defmethod resize-sheet :around ((sheet acl-top-level-sheet) width height) + "Restrict sheet sizes to the actual available client area." + (multiple-value-bind (-left -top dw dh) + (get-nonclient-deltas sheet) + (declare (ignore -left -top)) + (let* ((graft-br (sheet-region (graft sheet))) + (gw (bounding-rectangle-width graft-br)) + (gh (bounding-rectangle-height graft-br))) + (call-next-method sheet (min (- gw dw) width) (min (- gh dh) height))))) (defmethod modal-frame-p ((frame t)) nil) (defmethod modal-frame-p ((frame clim-internals::accept-values-own-window)) t)