Author: junrue Date: Fri Jun 2 16:16:50 2006 New Revision: 144
Added: trunk/src/tests/uitoolkit/misc-unit-tests.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: fixed stupid bugs in obtain-displays; refactored display methods to call centralized query-display-info function
Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Jun 2 16:16:50 2006 @@ -248,10 +248,6 @@ list of all @code{display}s (more than one if the system has multiple monitors), or @ref{obtain-primary-display} to get the primary. It derives from @ref{native-object}. -@deffn Reader primary-p -Returns T if the system regards this display as the primary -display; nil otherwise. -@end deffn @end deftp
@anchor{event-dispatcher} @@ -965,6 +961,11 @@ must determine how tall it would be given that width. @end deffn
+@deffn Function primary-p display +Returns T if the system regards the specified display as the primary +display; nil otherwise. +@end deffn + @deffn GenericFunction redraw self Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn
Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Fri Jun 2 16:16:50 2006 @@ -78,6 +78,7 @@ (:file "image-unit-tests") (:file "layout-unit-tests") (:file "widget-unit-tests") + (:file "misc-unit-tests") (:file "hello-world") (:file "event-tester") (:file "layout-tester")
Added: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Fri Jun 2 16:16:50 2006 @@ -0,0 +1,46 @@ +;;;; +;;;; misc-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(define-test primary-display-test + (let ((display (gfw:obtain-primary-display))) + (assert-true display) + (assert-true (gfw:primary-p display)) + (let ((size (gfw:size display))) + (assert-true (> (gfs:size-width size) 0)) + (assert-true (> (gfs:size-height size) 0))) + (let ((size (gfw:client-size display))) + (assert-true (> (gfs:size-width size)) 0) + (assert-true (> (gfs:size-height size)) 0)) + (assert-true (> (length (gfw:text display)) 0))))
Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Fri Jun 2 16:16:50 2006 @@ -54,6 +54,30 @@ (call-display-visitor-func (thread-context) hmonitor data) 1)
+(defun query-display-info (hmonitor) + (let ((info nil)) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor gfs::work + gfs::flags gfs::device) + mi-ptr gfs::monitorinfoex) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::monitorinfoex)) + (if (zerop (gfs::get-monitor-info hmonitor mi-ptr)) + (error 'gfs:win32-warning :detail "get-monitor-info failed")) + (push (= (logand gfs::flags gfs::+monitorinfoof-primary+) gfs::+monitorinfoof-primary+) info) + (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device))) + (push (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)) info)) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (push (gfs:make-size :width (- gfs::right gfs::left) :height (- gfs::bottom gfs::top)) + info))) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::work))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (push (gfs:make-size :width (- gfs::right gfs::left) :height (- gfs::bottom gfs::top)) + info))))) + (reverse info))) + (defun mapdisplays (func) ;; ;; func should expect two parameters: @@ -65,8 +89,7 @@ (unwind-protect #+lispworks (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (gfs::enum-display-monitors ptr ptr #'display_visitor 0)) +#+clisp (gfs::enum-display-monitors nil nil #'display_visitor nil) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -74,11 +97,9 @@
(defun obtain-displays () (mapdisplays (lambda (hmonitor data) - (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) - gfs::+monitorinfoof-primary+)) - (display (make-instance 'display :handle hmonitor))) - (setf (slot-value display 'primary) pflag) - (push display (display-visitor-results (thread-context))))))) + (declare (ignore data)) + (push (make-instance 'display :handle hmonitor) + (display-visitor-results (thread-context))))))
(defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) @@ -129,44 +150,30 @@ (defmethod client-size ((self display)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((size (gfs::make-size))) - (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::work) - mi-ptr gfs::monitorinfoex) - (gfs::get-monitor-info (gfs:handle self) mi-ptr) - (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::work))) - (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) - rect-ptr gfs::rect) - (setf (gfs:size-width size) (- gfs::right gfs::left)) - (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) - size)) + (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self)) + (declare (ignore primary name size)) + client-size))
(defmethod gfs:dispose ((self display)) (setf (slot-value self 'gfs:handle) nil))
+(defun primary-p (self) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self)) + (declare (ignore name size client-size)) + primary)) + (defmethod size ((self display)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((size (gfs::make-size))) - (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor) - mi-ptr gfs::monitorinfoex) - (gfs::get-monitor-info (gfs:handle self) mi-ptr) - (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor))) - (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) - rect-ptr gfs::rect) - (setf (gfs:size-width size) (- gfs::right gfs::left)) - (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) + (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self)) + (declare (ignore primary name client-size)) size))
(defmethod text ((self display)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((name "")) - (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::device) - mi-ptr gfs::monitorinfoex) - (gfs::get-monitor-info (gfs:handle self) mi-ptr) - (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device))) - (setf name (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)))))) + (destructuring-bind (primary name size client-size) (query-display-info (gfs:handle self)) + (declare (ignore primary size client-size)) name))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Jun 2 16:16:50 2006 @@ -33,10 +33,7 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defclass display (gfs:native-object) - ((primary - :reader primary-p - :initform nil)) +(defclass display (gfs:native-object) () (:documentation "Instances of this class describe characteristics of monitors attached to the system."))
(defclass event-dispatcher () ()