[graphic-forms-cvs] r144 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Jun 2 20:16:51 UTC 2006
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}.
- at deffn Reader primary-p
-Returns T if the system regards this display as the primary
-display; nil otherwise.
- at end deffn
@end deftp
@anchor{event-dispatcher}
@@ -965,6 +961,11 @@
must determine how tall it would be given that width.
@end deffn
+ at deffn Function primary-p display
+Returns T if the system regards the specified display as the primary
+display; nil otherwise.
+ at 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 () ()
More information about the Graphic-forms-cvs
mailing list