[graphic-forms-cvs] r248 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Sep 5 15:39:38 UTC 2006
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.
+ at end deffn
+
+ at anchor{update-native-style}
+ at deffn GenericFunction update-native-style self integer => integer
+This function replaces the native style flags of @var{self} with
+ at var{integer} and calls any additional API needed to ensure that
+ at var{self}'s visual representation is refreshed. The supplied
+ at 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)))
More information about the Graphic-forms-cvs
mailing list