Author: junrue Date: Tue Sep 5 11:39:37 2006 New Revision: 248

Modified: trunk/docs/manual/widget-functions.texinfo trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: converted update-native-style to a generic function, added other convenience functions for querying style flags

Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Sep 5 11:39:37 2006 @@ -546,9 +546,17 @@ @anchor{update-from-items} @deffn GenericFunction update-from-items self Synchronizes @var{self}'s internal model (i.e., a native control's -data structures) with the list from the @var{items} slot -after that list has been sorted. Application code typically does not -need to call this function. +data structures) with data derived from the @var{items} slot. +If @var{self} has been assigned a sorting predicate, the array +of items will be sorted prior to the internal model update. +@end deffn + +@anchor{update-native-style} +@deffn GenericFunction update-native-style self integer => integer +This function replaces the native style flags of @var{self} with +@var{integer} and calls any additional API needed to ensure that +@var{self}'s visual representation is refreshed. The supplied +@var{integer} is returned. @end deffn

@anchor{vertical-scrollbar-p}

Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Tue Sep 5 11:39:37 2006 @@ -93,8 +93,8 @@ :style '(:multiple-select) :items (subseq *list-box-test-data* 4))) (gfw:pack lb1-panel) - (make-instance 'gfw:button :parent btn-panel :text " ==> ") - (make-instance 'gfw:button :parent btn-panel :text " <== ") + (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " ==> ") nil) + (gfw:enable (make-instance 'gfw:button :parent btn-panel :text " <== ") nil) (gfw:pack btn-panel) (make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel) (setf lb2 (make-instance 'gfw:list-box :parent lb2-panel

Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Tue Sep 5 11:39:37 2006 @@ -140,3 +140,7 @@

(defmethod text-baseline ((self button)) (widget-text-baseline self +vertical-button-text-margin+)) + +(defmethod update-native-style ((self button) flags) + (gfs::send-message (gfs:handle self) gfs::+bm-setstyle+ flags 1) + flags)

Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Tue Sep 5 11:39:37 2006 @@ -195,3 +195,12 @@

(defmethod text-baseline ((self control)) (gfs:size-height (size self))) + +(defmethod update-native-style ((self control) flags) + (let ((hwnd (gfs:handle self))) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))) + flags)

Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Tue Sep 5 11:39:37 2006 @@ -106,16 +106,16 @@ (let ((old-widget (cancel-widget self))) (if old-widget (let* ((hwnd (gfs:handle old-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style old-widget))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (update-native-style old-widget style)))) (let* ((hwnd (gfs:handle cancel-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style cancel-widget))) (setf style (logior style gfs::+bs-pushbutton+)) (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + (update-native-style cancel-widget style)))

(defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -144,18 +144,18 @@ (let ((old-widget (default-widget self))) (if old-widget (let* ((hwnd (gfs:handle old-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style old-widget))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (update-native-style old-widget style)))) (let* ((hdlg (gfs:handle self)) (hwnd (gfs:handle def-widget)) - (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (style (get-native-style def-widget))) (setf style (logior style gfs::+bs-defpushbutton+)) (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idok+) (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0) - (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))) + (update-native-style def-widget style)))

(defmethod gfs:dispose ((self dialog)) (reenable-top-levels)

Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Tue Sep 5 11:39:37 2006 @@ -41,12 +41,10 @@ ;;;

(defmethod auto-hscroll-p ((self edit)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+es-autohscroll+) gfs::+es-autohscroll+))) + (test-native-style self gfs::+es-autohscroll+))

(defmethod auto-vscroll-p ((self edit)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+))) + (test-native-style self gfs::+es-autovscroll+))

(defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) @@ -84,7 +82,7 @@ (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0))

(defmethod enable-scrollbars ((self edit) horizontal vertical) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) + (let ((bits (get-native-style self))) (if horizontal (setf bits (logior bits gfs::+ws-hscroll+)) (setf bits (logand bits (lognot gfs::+ws-hscroll+))))

Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Tue Sep 5 11:39:37 2006 @@ -117,8 +117,7 @@ (defmethod (setf image) ((image gfg:image) (label label)) (if (or (gfs:disposed-p label) (gfs:disposed-p image)) (error 'gfs:disposed-error)) - (let* ((hwnd (gfs:handle label)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (let* ((orig-flags (get-native-style label)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+))) (flags (logior etch-flags @@ -142,8 +141,8 @@ (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (setf image tmp-image))) (if (/= orig-flags flags) - (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) - (gfs::send-message hwnd + (update-native-style label flags)) + (gfs::send-message (gfs:handle label) gfs::+stm-setimage+ gfs::+image-bitmap+ (cffi:pointer-address (gfs:handle image))))) @@ -164,9 +163,8 @@ (init-control label))

(defmethod preferred-size ((self label) width-hint height-hint) - (let* ((hwnd (gfs:handle self)) - (bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (b-width (* (border-width self) 2))) + (let ((bits (get-native-style self)) + (b-width (* (border-width self) 2))) (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) (let ((image (image self))) (if image @@ -191,23 +189,18 @@ (get-widget-text self))

(defmethod (setf text) (str (self label)) - (let* ((hwnd (gfs:handle self)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) + (let* ((orig-flags (get-native-style self)) (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+) (logand orig-flags gfs::+ss-sunken+)))) (multiple-value-bind (std-flags ex-flags) (compute-style-flags self nil nil str) (declare (ignore ex-flags)) - (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags - std-flags - +default-child-style+)))) + (update-native-style self (logior etch-flags std-flags +default-child-style+)))) (set-widget-text self str))

(defmethod text-baseline ((self label)) (let ((b-width (border-width self))) - (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+) - gfs::+ss-bitmap+) - gfs::+ss-bitmap+) + (if (test-native-style self gfs::+ss-bitmap+) (let ((image (image self))) (if image (+ (gfs:size-height (gfg:size image)) b-width)

Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Tue Sep 5 11:39:37 2006 @@ -52,6 +52,24 @@ (lognot (logior gfs::+lbs-multiplesel+ gfs::+lbs-extendedsel+)))) (logior orig-flags gfs::+lbs-nosel+))

+(defun lb-init-storage (hwnd item-count total-bytes) + (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) + +(defun lb-clear-content (hwnd) + (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) + +(defun lb-width (hwnd) + (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) + (if (< width 0) + (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) + width)) + +(defun lb-item-count (hwnd) + (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) + (if (< count 0) + (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) + count)) + ;;; ;;; methods ;;; @@ -151,15 +169,14 @@ ((>= height-hint 0) (setf (gfs:size-height size) height-hint)) (t - (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd))))) + (setf (gfs:size-height size) (* (lb-item-count hwnd) (1+ (lb-item-height hwnd)))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) (incf (gfs:size-width size) (+ b-width 4))) (if (zerop (gfs:size-height size)) (setf (gfs:size-height size) +default-widget-height+) (incf (gfs:size-height size) b-width)) - (if (= (logand (gfs::get-window-long hwnd gfs::+gwl-style+) gfs::+ws-vscroll+) - gfs::+ws-vscroll+) + (if (test-native-style self gfs::+ws-vscroll+) (incf (gfs:size-width size) (vertical-scrollbar-width))) size))

Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Tue Sep 5 11:39:37 2006 @@ -37,12 +37,6 @@ ;;; helper functions ;;;

-(defun lb-init-storage (hwnd item-count total-bytes) - (gfs::send-message hwnd gfs::+lb-initstorage+ item-count total-bytes)) - -(defun lb-clear-content (hwnd) - (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0)) - (defun lb-insert-item (hwnd index label hbmp) (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box (let ((text (or label ""))) @@ -51,18 +45,6 @@ (if (< retval 0) (error 'gfs:toolkit-error :detail (format nil "LB_INSERTSTRING failed: ~d" retval)))))))

-(defun lb-width (hwnd) - (let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0))) - (if (< width 0) - (error 'gfs:win32-error :detail "LB_GETHORIZONTALEXTENT failed")) - width)) - -(defun lb-item-count (hwnd) - (let ((count (gfs::send-message hwnd gfs::+lb-getcount+ 0 0))) - (if (< count 0) - (error 'gfs:win32-error :detail "LB_GETCOUNT failed")) - count)) - (defun lb-item-height (hwnd) (let ((height (gfs::send-message hwnd gfs::+lb-getitemheight+ 0 0))) (if (< height 0)

Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Sep 5 11:39:37 2006 @@ -52,9 +52,8 @@ -1))

(defun update-top-level-resizability (win same-size-flag) - (let* ((hwnd (gfs:handle win)) - (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+)) - (new-flags 0)) + (let ((orig-flags (get-native-style win)) + (new-flags 0)) (cond (same-size-flag (setf new-flags (logand orig-flags (lognot gfs::+ws-maximizebox+))) @@ -192,8 +191,7 @@ (format stream "max size: ~a" (maximum-size self))))

(defmethod resizable-p ((self top-level)) - (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+))) - (= (logand bits gfs::+ws-thickframe+) gfs::+ws-thickframe+))) + (test-native-style self gfs::+ws-thickframe+))

(defmethod (setf resizable-p) (flag (self top-level)) (let ((style (style-of self)))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Sep 5 11:39:37 2006 @@ -423,6 +423,9 @@ (defgeneric update-from-items (self) (:documentation "Rebuilds the native control's model of self from self's item list."))

+(defgeneric update-native-style (self flags) + (:documentation "Modifies self's native style flags and refreshes self's visual appearance.")) + (defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise."))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Sep 5 11:39:37 2006 @@ -141,14 +141,6 @@ (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval))

-(defun update-native-style (widget bits) - (let ((hwnd (gfs:handle widget))) - (gfs::set-window-long hwnd gfs::+gwl-style+ bits) - (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ - gfs::+swp-nomove+ - gfs::+swp-nosize+ - gfs::+swp-nozorder+)))) - (defun get-widget-text (w) (if (gfs:disposed-p w) (error 'gfs:disposed-error)) @@ -282,3 +274,15 @@ (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size))) (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size)))) (gfs:make-size :width new-width :height new-height))) + +(defun get-native-style (widget) + (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+)) + +(defun get-native-exstyle (widget) + (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+)) + +(defun test-native-style (widget bits) + (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) bits)) + +(defun test-native-exstyle (widget bits) + (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) bits))

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Sep 5 11:39:37 2006 @@ -92,8 +92,7 @@ (error 'gfs:disposed-error)))

(defmethod border-width ((self widget)) - (let* ((hwnd (gfs:handle self)) - (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (let ((bits (get-native-exstyle self))) (cond ((/= (logand bits gfs::+ws-ex-clientedge+) 0) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxedge+))) @@ -103,8 +102,7 @@ (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) ((/= (logand bits gfs::+ws-ex-windowedge+) 0) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxdlgframe+)))) - (setf bits (gfs::get-window-long hwnd gfs::+gwl-style+)) - (when (logand bits gfs::+ws-border+) + (when (test-native-style self gfs::+ws-border+) (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) 0))

@@ -434,6 +432,11 @@ (unless (gfs:null-handle-p hwnd) (gfs::update-window hwnd))))

+(defmethod update-native-style :before ((self widget) bits) + (declare (ignore bits)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod visible-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Sep 5 11:39:37 2006 @@ -152,16 +152,16 @@ (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) color))

-(defmethod compute-outer-size ((win window) desired-client-size) - (let ((hwnd (gfs:handle win)) +(defmethod compute-outer-size ((self window) desired-client-size) + (let ((hwnd (gfs:handle self)) (new-size (gfs:make-size))) (gfs::with-rect (setf gfs::right (gfs:size-width desired-client-size) gfs::bottom (gfs:size-height desired-client-size)) (if (zerop (gfs::adjust-window-rect gfs::rect-ptr - (gfs::get-window-long hwnd gfs::+gwl-style+) + (get-native-style self) (if (cffi:null-pointer-p (gfs::get-menu hwnd)) 0 1) - (gfs::get-window-long hwnd gfs::+gwl-exstyle+))) + (get-native-exstyle self))) (error 'gfs:win32-error :detail "adjust-window-rect failed")) (setf (gfs:size-width new-size) (- gfs::right gfs::left) (gfs:size-height new-size) (- gfs::bottom gfs::top))) @@ -314,6 +314,15 @@ (outer-size self sz) sz))

+(defmethod update-native-style ((self window) flags) + (let ((hwnd (gfs:handle self))) + (gfs::set-window-long hwnd gfs::+gwl-style+ flags) + (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+ + gfs::+swp-nomove+ + gfs::+swp-nosize+ + gfs::+swp-nozorder+))) + flags) + (defmethod window->display :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))