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*)))