[graphic-forms-cvs] r277 - in trunk: . src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Sep 29 19:56:34 UTC 2006
Author: junrue
Date: Fri Sep 29 15:56:34 2006
New Revision: 277
Modified:
trunk/src/tests/uitoolkit/widget-unit-tests.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/edit.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/list-box.lisp
trunk/src/uitoolkit/widgets/slider.lisp
trunk/tests.lisp
Log:
refactored control initialization
Modified: trunk/src/tests/uitoolkit/widget-unit-tests.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/widget-unit-tests.lisp (original)
+++ trunk/src/tests/uitoolkit/widget-unit-tests.lisp Fri Sep 29 15:56:34 2006
@@ -37,9 +37,10 @@
(assert-true (> (gfw::register-panel-window-class) 0) 'gfw::register-panel-class)
(assert-true (> (gfw::register-toplevel-erasebkgnd-window-class) 0) 'gfw::register-toplevel-erasebkgnd-window-class)
(assert-true (> (gfw::register-toplevel-noerasebkgnd-window-class) 0) 'gfw::register-toplevel-noerasebkgnd-window-class)
- (assert-true (> (gfw::register-dialog-class) 0) 'gfw::register-dialog-class))
+ (assert-true (> (gfw::register-dialog-class) 0) 'gfw::register-dialog-class)
-(define-test repeat-class-registration-test
+ ;; test registering them again
+ ;;
(assert-true (> (gfw::register-panel-window-class) 0) 'gfw::register-panel-class)
(assert-true (> (gfw::register-toplevel-erasebkgnd-window-class) 0) 'gfw::register-toplevel-erasebkgnd-window-class)
(assert-true (> (gfw::register-toplevel-noerasebkgnd-window-class) 0) 'gfw::register-toplevel-noerasebkgnd-window-class)
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Fri Sep 29 15:56:34 2006
@@ -73,25 +73,19 @@
(values std-flags 0)))
(defmethod initialize-instance :after ((self button) &key parent text &allow-other-keys)
- (initialize-comctl-classes gfs::+icc-standard-classes+)
- (multiple-value-bind (std-style ex-style)
- (compute-style-flags self)
- (let ((hwnd (create-window (system-classname-of self)
- (or text " ")
- (gfs:handle parent)
- std-style
- ex-style
- (cond
- ((find :default-button (style-of self))
- gfs::+idok+)
- ((find :cancel-button (style-of self))
- gfs::+idcancel+)
- (t
- (increment-widget-id (thread-context)))))))
- (unless (zerop (logand std-style gfs::+bs-defpushbutton+))
- (gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0))
- (setf (slot-value self 'gfs:handle) hwnd)))
- (init-control self))
+ (let ((id (cond
+ ((find :default-button (style-of self))
+ gfs::+idok+)
+ ((find :cancel-button (style-of self))
+ gfs::+idcancel+)
+ (t
+ (increment-widget-id (thread-context))))))
+ (create-control self parent text gfs::+icc-standard-classes+ id)
+ (if (test-native-style self gfs::+bs-defpushbutton+)
+ (gfs::send-message (gfs:handle parent)
+ gfs::+dm-setdefid+
+ (cffi:pointer-address (gfs:handle self))
+ 0))))
(defmethod preferred-size ((self button) width-hint height-hint)
(let ((text-size (widget-text-size self #'text gfs::+dt-singleline+))
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Fri Sep 29 15:56:34 2006
@@ -43,21 +43,27 @@
(setf gfs::size (cffi:foreign-type-size 'gfs::initcommoncontrolsex)
gfs::icc icc-flags))
(if (and (zerop (gfs::init-common-controls ic-ptr)) (/= (gfs::get-last-error) 0))
- ;; returns false when called on SBCL with ICC_STANDARD_CLASSES, so
- ;; this warning gets triggered a lot; need to investigate further
(warn 'gfs:win32-warning :detail "init-common-controls failed"))))
-(defun init-control (ctrl)
- (let ((hwnd (gfs:handle ctrl)))
- (subclass-wndproc hwnd)
- (put-widget (thread-context) ctrl)
- (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+)))
- (unless (gfs:null-handle-p hfont)
- (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0)))
- ;; FIXME: this is a temporary hack to allow layout management testing;
- ;; it breaks in the presence of virtual containers like group
- ;;
- (let ((parent (parent ctrl)))
+(defun create-control (ctrl parent text icc-flags &optional id)
+ (initialize-comctl-classes icc-flags)
+ (multiple-value-bind (std-style ex-style)
+ (compute-style-flags ctrl)
+ (let ((hwnd (create-window (system-classname-of ctrl)
+ (or text " ")
+ (gfs:handle parent)
+ std-style
+ ex-style
+ (or id (increment-widget-id (thread-context))))))
+ (setf (slot-value ctrl 'gfs:handle) hwnd)
+ (subclass-wndproc hwnd)
+ (put-widget (thread-context) ctrl)
+ (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+)))
+ (unless (gfs:null-handle-p hfont)
+ (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0)))
+ ;; FIXME: this is a temporary hack to allow layout management testing;
+ ;; it won't work if virtual containers like group are implemented.
+ ;;
(when (and parent (layout-of parent))
(append-layout-item (layout-of parent) ctrl)))))
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Fri Sep 29 15:56:34 2006
@@ -92,17 +92,7 @@
(update-native-style self bits)))
(defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys)
- (initialize-comctl-classes gfs::+icc-standard-classes+)
- (multiple-value-bind (std-style ex-style)
- (compute-style-flags self)
- (let ((hwnd (create-window (system-classname-of self)
- (or text "")
- (gfs:handle parent)
- std-style
- ex-style
- (increment-widget-id (thread-context)))))
- (setf (slot-value self 'gfs:handle) hwnd)))
- (init-control self))
+ (create-control self parent text gfs::+icc-standard-classes+))
(defmethod line-count ((self edit))
(if (gfs:disposed-p self)
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Fri Sep 29 15:56:34 2006
@@ -147,20 +147,10 @@
gfs::+image-bitmap+
(cffi:pointer-address (gfs:handle image)))))
-(defmethod initialize-instance :after ((self label) &key image parent separator text &allow-other-keys)
- (initialize-comctl-classes gfs::+icc-standard-classes+)
- (multiple-value-bind (std-style ex-style)
- (compute-style-flags self image separator text)
- (let ((hwnd (create-window (system-classname-of self)
- (or text " ")
- (gfs:handle parent)
- (logior std-style)
- ex-style
- (increment-widget-id (thread-context)))))
- (setf (slot-value self 'gfs:handle) hwnd)
- (if image
- (setf (image self) image))))
- (init-control self))
+(defmethod initialize-instance :after ((self label) &key image parent text &allow-other-keys)
+ (create-control self parent text gfs::+icc-standard-classes+)
+ (if image
+ (setf (image self) image)))
(defmethod preferred-size ((self label) width-hint height-hint)
(let ((bits (get-native-style self))
Modified: trunk/src/uitoolkit/widgets/list-box.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/list-box.lisp (original)
+++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 29 15:56:34 2006
@@ -220,22 +220,12 @@
(enable-redraw self t)))
(defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys)
- (initialize-comctl-classes gfs::+icc-standard-classes+)
- (multiple-value-bind (std-style ex-style)
- (compute-style-flags self)
- (let ((hwnd (create-window (system-classname-of self)
- ""
- (gfs:handle parent)
- std-style
- ex-style
- (increment-widget-id (thread-context)))))
- (setf (slot-value self 'gfs:handle) hwnd)
- (init-control self)
- (if (and estimated-count (> estimated-count 0))
- (gfs::send-message hwnd
- gfs::+lb-initstorage+
- estimated-count
- (* estimated-count +estimated-text-size+)))))
+ (create-control self parent "" gfs::+icc-standard-classes+)
+ (if (and estimated-count (> estimated-count 0))
+ (gfs::send-message (gfs:handle self)
+ gfs::+lb-initstorage+
+ estimated-count
+ (* estimated-count +estimated-text-size+)))
(if items
(setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) items 'list-item)))
(update-from-items self))
Modified: trunk/src/uitoolkit/widgets/slider.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/slider.lisp (original)
+++ trunk/src/uitoolkit/widgets/slider.lisp Fri Sep 29 15:56:34 2006
@@ -98,14 +98,4 @@
(values std-flags 0)))
(defmethod initialize-instance :after ((self slider) &key parent &allow-other-keys)
- (initialize-comctl-classes gfs::+icc-win95-classes+)
- (multiple-value-bind (std-style ex-style)
- (compute-style-flags self)
- (let ((hwnd (create-window (system-classname-of self)
- ""
- (gfs:handle parent)
- std-style
- ex-style
- (increment-widget-id (thread-context)))))
- (setf (slot-value self 'gfs:handle) hwnd)
- (init-control self))))
+ (create-control self parent "" gfs::+icc-win95-classes+))
Modified: trunk/tests.lisp
==============================================================================
--- trunk/tests.lisp (original)
+++ trunk/tests.lisp Fri Sep 29 15:56:34 2006
@@ -36,14 +36,14 @@
(defun load-tests ()
(setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
(asdf:operate 'asdf:load-op :graphic-forms-tests)
- (load (concatenate 'string *gf-tests-dir* "test-utils"))
- (load (concatenate 'string *gf-tests-dir* "mock-objects"))
- (load (concatenate 'string *gf-tests-dir* "color-unit-tests"))
- (load (concatenate 'string *gf-tests-dir* "graphics-context-unit-tests"))
- (load (concatenate 'string *gf-tests-dir* "image-unit-tests"))
- (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests"))
- (load (concatenate 'string *gf-tests-dir* "layout-unit-tests"))
- (load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests"))
- (load (concatenate 'string *gf-tests-dir* "widget-unit-tests"))
- (load (concatenate 'string *gf-tests-dir* "item-manager-unit-tests"))
- (load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))
+ (load (merge-pathnames "test-utils.lisp" *gf-tests-dir*))
+ (load (merge-pathnames "mock-objects" *gf-tests-dir*))
+ (load (merge-pathnames "color-unit-tests" *gf-tests-dir*))
+ (load (merge-pathnames "graphics-context-unit-tests" *gf-tests-dir*))
+ (load (merge-pathnames "image-unit-tests" *gf-tests-dir*))
+ (load (merge-pathnames "icon-bundle-unit-tests" *gf-tests-dir*))
+ (load (merge-pathnames "layout-unit-tests" *gf-tests-dir*))
+ (load (merge-pathnames "flow-layout-unit-tests" *gf-tests-dir*))
+ (load (merge-pathnames "widget-unit-tests" *gf-tests-dir*))
+ (load (merge-pathnames "item-manager-unit-tests" *gf-tests-dir*))
+ (load (merge-pathnames "misc-unit-tests" *gf-tests-dir*)))
More information about the Graphic-forms-cvs
mailing list