[graphic-forms-cvs] r98 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Apr 16 06:14:04 UTC 2006
Author: junrue
Date: Sun Apr 16 02:14:03 2006
New Revision: 98
Modified:
trunk/docs/manual/api.texinfo
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/graphics/image.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/panel.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
revised label control to support both text and image content
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Sun Apr 16 02:14:03 2006
@@ -238,9 +238,46 @@
@end deffn
@end deftp
+ at anchor{label}
@deftp Class label
-This @ref{control} class represents non-selectable controls that
-display a string or image.
+This @ref{control} subclass represents non-selectable controls that
+display a string, image, or etched line.
+ at deffn Initarg :image
+Supply an @ref{image} object as the value of this initarg to configure
+the label to display the image rather than text.
+ at end deffn
+ at deffn Initarg :separator
+Supply @sc{t} for the value of this initarg to configure the label to
+render itself as an etched horizontal (or vertical) divider. The
+ at code{:style} initarg is used to select the desired orientation.
+ at end deffn
+ at deffn Initarg :style
+When configured as a @code{text} label, the following keyword symbols
+are relevant:
+ at itemize bullet
+ at item @code{:beginning}
+ at item @code{:center}
+ at item @code{:ellipsis}
+ at item @code{:end}
+ at item @code{:wrap}
+ at end itemize
+The following style style keywords apply for both @code{text} and
+ at code{image} modes:
+ at itemize bullet
+ at item @code{:raised}
+ at item @code{:sunken}
+ at end itemize
+Finally, the following style keywords apply when a label is
+configured as a @code{separator}:
+ at itemize bullet
+ at item @code{:horizontal}
+ at item @code{:vertical}
+ at end itemize
+ at end deffn
+ at deffn Initarg :text
+Supply a string as the value of this initarg to configure the label to
+act as a text label. This mode is also the default.
+ at end deffn
@end deftp
@anchor{menu}
@@ -893,9 +930,22 @@
@end deffn
@end deftp
+ at anchor{image}
+ at deftp Class image
+This subclass of @ref{native-object} wraps a native image object.
+Instances may be drawn directly via a graphics-context (see
+ at ref{draw-image}) or set as the content of a @ref{label} control.
+ at deffn Initarg :size
+Supply a @ref{size} object via this initarg to create a new image
+object with the desired width and height.
+ at end deffn
+ at xref{image-data}.
+ at end deftp
+
+ at anchor{image-data}
@deftp Class image-data
This subclass of @ref{native-object} maintains image attributes,
-color, and pixel data.
+color, and pixel data. @xref{image}.
@end deftp
@node graphics functions
@@ -1020,6 +1070,7 @@
determined by @code{arc-size}.
@end deffn
+ at anchor{draw-image}
@deffn GenericFunction draw-image self image point
Draws @code{image} in the receiver where @code{point} identifies the
position of the upper-left corner of the image.
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sun Apr 16 02:14:03 2006
@@ -184,6 +184,7 @@
#:multiply
#:pen-style
#:pen-width
+ #:rgb->color
#:red-mask
#:red-shift
#:rotate
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Apr 16 02:14:03 2006
@@ -103,6 +103,12 @@
(setf flag nil)
(format nil "~d ~a" (id be) +btn-text-after+))))))
(setf (gfw:text w) (funcall (toggle-fn be))))
+ ((eql subtype :image-label)
+ ;; NOTE: we are leaking a bitmap handle by not tracking the
+ ;; image being created here
+ (let ((tmp-image (make-instance 'gfg:image :file "happy.bmp")))
+ (gfg:with-image-transparency (tmp-image (gfs:make-point))
+ (setf (gfw:image w) tmp-image))))
((eql subtype :text-label)
(setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+))))
(incf *widget-counter*)))
@@ -350,6 +356,8 @@
(add-btn-disp (make-instance 'add-child-dispatcher))
(add-panel-disp (make-instance 'add-child-dispatcher :widget-class 'test-panel
:subtype :panel))
+ (add-image-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label
+ :subtype :image-label))
(add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw:label
:subtype :text-label))
(rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher))
@@ -366,7 +374,8 @@
(:item "&Children"
:submenu ((:item "Add"
:submenu ((:item "Button" :dispatcher add-btn-disp)
- (:item "Label" :dispatcher add-text-label-disp)
+ (:item "Label - Image" :dispatcher add-image-label-disp)
+ (:item "Label - Text" :dispatcher add-text-label-disp)
(:item "Panel" :dispatcher add-panel-disp)))
(:item "Remove" :dispatcher rem-menu-disp
:submenu ((:item "")))
Modified: trunk/src/uitoolkit/graphics/image.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image.lisp (original)
+++ trunk/src/uitoolkit/graphics/image.lisp Sun Apr 16 02:14:03 2006
@@ -82,25 +82,28 @@
(gfs:dispose im))
(setf (slot-value im 'gfs:handle) (data->image id)))
-(defmethod initialize-instance :after ((image image) &key size &allow-other-keys)
- (unless (null size)
- (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader)
- (gfs::zero-mem bih-ptr gfs::bitmapinfoheader)
- (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes
- gfs::bibitcount gfs::bicompression)
- bih-ptr gfs::bitmapinfoheader)
- (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
- gfs::biwidth (gfs:size-width size)
- gfs::biheight (- (gfs:size-height size))
- gfs::biplanes 1
- gfs::bibitcount 32
- gfs::bicompression gfs::+bi-rgb+)
- (let ((nptr (cffi:null-pointer))
- (hbmp (cffi:null-pointer)))
- (cffi:with-foreign-object (buffer :pointer)
- (gfs::with-compatible-dcs (nptr memdc)
- (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0))))
- (setf (slot-value image 'gfs:handle) hbmp))))))
+(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys)
+ (cond
+ (file
+ (load image file))
+ (size
+ (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader)
+ (gfs::zero-mem bih-ptr gfs::bitmapinfoheader)
+ (cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes
+ gfs::bibitcount gfs::bicompression)
+ bih-ptr gfs::bitmapinfoheader)
+ (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
+ gfs::biwidth (gfs:size-width size)
+ gfs::biheight (- (gfs:size-height size))
+ gfs::biplanes 1
+ gfs::bibitcount 32
+ gfs::bicompression gfs::+bi-rgb+)
+ (let ((nptr (cffi:null-pointer))
+ (hbmp (cffi:null-pointer)))
+ (cffi:with-foreign-object (buffer :pointer)
+ (gfs::with-compatible-dcs (nptr memdc)
+ (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0))))
+ (setf (slot-value image 'gfs:handle) hbmp)))))))
(defmethod load ((im image) path)
(let ((data (make-instance 'image-data)))
@@ -127,18 +130,20 @@
(hbmp (gfs:handle im))
(hmask (cffi:null-pointer))
(nptr (cffi:null-pointer)))
- (unless (null pixel-pnt)
- (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap)
- (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr)
- (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap)
- (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer)))
- (if (gfs:null-handle-p hmask)
- (error 'gfs:win32-error :detail "create-bitmap failed"))
- (gfs::with-compatible-dcs (nptr memdc1 memdc2)
- (gfs::select-object memdc1 hbmp)
- (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1
- (gfs:point-x pixel-pnt)
- (gfs:point-y pixel-pnt)))
- (gfs::select-object memdc2 hmask)
- (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+)))
- (make-instance 'image :handle hmask)))))
+ (if pixel-pnt
+ (progn
+ (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap)
+ (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr)
+ (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap)
+ (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer)))
+ (if (gfs:null-handle-p hmask)
+ (error 'gfs:win32-error :detail "create-bitmap failed"))
+ (gfs::with-compatible-dcs (nptr memdc1 memdc2)
+ (gfs::select-object memdc1 hbmp)
+ (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1
+ (gfs:point-x pixel-pnt)
+ (gfs:point-y pixel-pnt)))
+ (gfs::select-object memdc2 hmask)
+ (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+))))
+ (make-instance 'image :handle hmask))
+ nil)))
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Sun Apr 16 02:14:03 2006
@@ -602,6 +602,17 @@
(defconstant +ss-wordellipsis+ #x0000C000)
(defconstant +ss-ellipsismask+ #x0000C000)
+(defconstant +stm-seticon+ #x0170)
+(defconstant +stm-geticon+ #x0171)
+(defconstant +stm-setimage+ #x0172)
+(defconstant +stm-getimage+ #x0173)
+(defconstant +stm-msgmax+ #x0174)
+
+(defconstant +stn-clicked+ 0)
+(defconstant +stn-dblclk+ 1)
+(defconstant +stn-enable+ 2)
+(defconstant +stn-disable+ 3)
+
(defconstant +sw-hide+ 0)
(defconstant +sw-shownormal+ 1)
(defconstant +sw-normal+ 1)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sun Apr 16 02:14:03 2006
@@ -323,6 +323,11 @@
(pos INT))
(defcfun
+ ("GetSysColor" get-sys-color)
+ DWORD
+ (index INT))
+
+(defcfun
("GetSystemMetrics" get-system-metrics)
INT
(index INT))
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Sun Apr 16 02:14:03 2006
@@ -37,8 +37,8 @@
;;; methods
;;;
-(defmethod compute-style-flags ((btn button) style)
- (declare (ignore btn))
+(defmethod compute-style-flags ((btn button) style &rest extra-data)
+ (declare (ignore btn extra-data))
(let ((std-flags 0)
(ex-flags 0))
(setf style (gfs:flatten style))
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Sun Apr 16 02:14:03 2006
@@ -53,6 +53,14 @@
;;; methods
;;;
+(defmethod background-color :before ((ctrl control))
+ (if (gfs:disposed-p ctrl)
+ (error 'gfs:disposed-error)))
+
+(defmethod background-color ((ctrl control))
+ (declare (ignore ctrl))
+ (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))
+
(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys)
(if (gfs:disposed-p parent)
(error 'gfs:disposed-error)))
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Sun Apr 16 02:14:03 2006
@@ -37,77 +37,157 @@
;;; methods
;;;
-(defmethod compute-style-flags ((label label) style)
- (declare (ignore label))
- (let ((std-flags 0)
- (ex-flags 0))
- (setf style (gfs:flatten style))
- (unless (or (find :beginning style)
- (find :center style)
- (find :end style))
- (setf std-flags gfs::+ss-leftnowordwrap+))
+(defun compute-image-style-flags (style)
+ (let ((flags (logior gfs::+ss-bitmap+ gfs::+ss-realsizeimage+ gfs::+ss-centerimage+)))
+ (when (find :raised style)
+ (setf flags (logand (lognot gfs::+ss-sunken+) flags))
+ (setf flags (logior flags gfs::+ss-etchedframe+)))
+ (when (find :sunken style)
+ (setf flags (logand (lognot gfs::+ss-etchedframe+) flags))
+ (setf flags (logior flags gfs::+ss-sunken+)))
+ flags))
+
+(defun compute-text-style-flags (style)
+ (let ((flags 0))
+ (unless (intersection style (list :beginning :center :end))
+ (setf flags gfs::+ss-leftnowordwrap+))
(loop for sym in style
do (cond
- ;; primary static styles
+ ;; primary text static styles
;;
((eq sym :beginning)
- (setf std-flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n
+ (setf flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n
((eq sym :center)
- (setf std-flags gfs::+ss-center+))
+ (setf flags gfs::+ss-center+))
((eq sym :end)
- (setf std-flags gfs::+ss-right+)) ; FIXME: i18n
+ (setf flags gfs::+ss-right+)) ; FIXME: i18n
;; styles that can be combined
;;
((eq sym :ellipsis)
- (setf std-flags (logior std-flags gfs::+ss-endellipsis+)))
+ (setf flags (logior flags gfs::+ss-endellipsis+)))
((eq sym :raised)
- (setf std-flags (logand (lognot gfs::+ss-sunken+) std-flags))
- (setf std-flags (logior std-flags gfs::+ss-etchedframe+)))
+ (setf flags (logand (lognot gfs::+ss-sunken+) flags))
+ (setf flags (logior flags gfs::+ss-etchedframe+)))
((eq sym :sunken)
- (setf std-flags (logand (lognot gfs::+ss-etchedframe+) std-flags))
- (setf std-flags (logior std-flags gfs::+ss-sunken+)))
+ (setf flags (logand (lognot gfs::+ss-etchedframe+) flags))
+ (setf flags (logior flags gfs::+ss-sunken+)))
((eq sym :wrap)
- (setf std-flags (logand (lognot gfs::+ss-leftnowordwrap+) std-flags))
- (setf std-flags (logior std-flags gfs::+ss-left+)))))
- (values std-flags ex-flags)))
+ (setf flags (logand (lognot gfs::+ss-leftnowordwrap+) flags))
+ (setf flags (logior flags gfs::+ss-left+)))))
+ flags))
+
+(defmethod compute-style-flags ((label label) style &rest extra-data)
+ (declare (ignore label))
+ (if (> (count-if-not #'null extra-data) 1)
+ (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed"))
+ (values (cond
+ ((first extra-data)
+ (compute-image-style-flags (gfs:flatten style)))
+ ((second extra-data)
+ (if (find :vertical style) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+))
+ (t
+ (compute-text-style-flags (gfs:flatten style))))
+ 0))
+
+(defmethod image ((label label))
+ (if (gfs:disposed-p label)
+ (error 'gfs:disposed-error))
+ (let ((addr (gfs::send-message (gfs:handle label) gfs::+stm-getimage+ gfs::+image-bitmap+ 0)))
+ (if (zerop addr)
+ nil
+ (make-instance 'gfg:image :handle (cffi:make-pointer addr)))))
+
+(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+))
+ (etch-flags (logior (logand orig-flags gfs::+ss-etchedframe+)
+ (logand orig-flags gfs::+ss-sunken+)))
+ (flags (logior etch-flags
+ gfs::+ss-bitmap+
+ gfs::+ss-realsizeimage+
+ gfs::+ss-centerimage+
+ gfs::+ws-child+
+ gfs::+ws-visible+))
+ (tr-pnt (gfg:transparency-pixel-of image)))
+ (if tr-pnt
+ (let* ((color (background-color label))
+ (size (gfg:size image))
+ (bounds (make-instance 'gfs:rectangle :size size))
+ (tmp-image (make-instance 'gfg:image :size size))
+ (gc (make-instance 'gfg:graphics-context :image tmp-image)))
+ (unwind-protect
+ (progn
+ (setf (gfg:background-color gc) color)
+ (let ((orig-color (gfg:foreground-color gc)))
+ (setf (gfg:foreground-color gc) color)
+ (gfg:draw-filled-rectangle gc bounds)
+ (setf (gfg:foreground-color gc) orig-color))
+ (gfg:draw-image gc image (gfs:location bounds)))
+ (gfs:dispose gc))
+ (setf image tmp-image)))
+ (if (/= orig-flags flags)
+ (gfs::set-window-long hwnd gfs::+gwl-style+ flags))
+ (gfs::send-message hwnd
+ gfs::+stm-setimage+
+ gfs::+image-bitmap+
+ (cffi:pointer-address (gfs:handle image)))))
-(defmethod initialize-instance :after ((label label) &key parent style &allow-other-keys)
+(defmethod initialize-instance :after ((label label) &key image parent separator style text &allow-other-keys)
(if (not (listp style))
(setf style (list style)))
(multiple-value-bind (std-style ex-style)
- (compute-style-flags label style)
+ (compute-style-flags label style image separator text)
(let ((hwnd (create-window gfs::+static-classname+
- " "
+ (or text " ")
(gfs:handle parent)
(logior std-style gfs::+ws-child+ gfs::+ws-visible+)
ex-style)))
(if (not hwnd)
(error 'gfs:win32-error :detail "create-window failed"))
- (setf (slot-value label 'gfs:handle) hwnd)))
+ (setf (slot-value label 'gfs:handle) hwnd)
+ (if image
+ (setf (image label) image))))
(init-control label))
-
(defmethod preferred-size ((label label) width-hint height-hint)
+ (declare (ignorable width-hint height-hint))
(let* ((hwnd (gfs:handle label))
(bits (gfs::get-window-long hwnd gfs::+gwl-style+))
(b-width (border-width label))
- (sz nil)
- (flags (logior gfs::+dt-editcontrol+
- gfs::+dt-expandtabs+)))
- (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0))
- (setf flags (logior flags gfs::+dt-wordbreak+)))
- (setf sz (widget-text-size label flags))
- (if (>= width-hint 0)
- (setf (gfs:size-width sz) width-hint))
- (if (>= height-hint 0)
- (setf (gfs:size-height sz) height-hint))
- (incf (gfs:size-width sz) (* b-width 2))
- (incf (gfs:size-height sz) (* b-width 2))
- sz))
+ (sz nil))
+ (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) ; SS_BITMAP is not a single bit
+ (let ((image (image label)))
+ (if image
+ (gfg:size image)
+ (gfs:make-size)))
+ (let ((flags (logior gfs::+dt-editcontrol+ gfs::+dt-expandtabs+)))
+ (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0))
+ (setf flags (logior flags gfs::+dt-wordbreak+)))
+ (setf sz (widget-text-size label flags))
+ (if (>= width-hint 0)
+ (setf (gfs:size-width sz) width-hint))
+ (if (>= height-hint 0)
+ (setf (gfs:size-height sz) height-hint))
+ (incf (gfs:size-width sz) (* b-width 2))
+ (incf (gfs:size-height sz) (* b-width 2))
+ sz))))
(defmethod text ((label label))
(get-widget-text label))
(defmethod (setf text) (str (label label))
+ (let* ((hwnd (gfs:handle label))
+ (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+))
+ (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 label nil nil nil str)
+ (declare (ignore ex-flags))
+ (gfs::set-window-long hwnd gfs::+gwl-style+ (logior etch-flags
+ std-flags
+ gfs::+ws-child+
+ gfs::+ws-visible+))))
(set-widget-text label str))
Modified: trunk/src/uitoolkit/widgets/panel.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/panel.lisp (original)
+++ trunk/src/uitoolkit/widgets/panel.lisp Sun Apr 16 02:14:03 2006
@@ -49,7 +49,8 @@
;;; methods
;;;
-(defmethod compute-style-flags ((self panel) style)
+(defmethod compute-style-flags ((self panel) style &rest extra-data)
+ (declare (ignore extra-data))
(let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))
(ex-flags 0))
(mapc #'(lambda (sym)
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 16 02:14:03 2006
@@ -63,8 +63,8 @@
;;; methods
;;;
-(defmethod compute-style-flags ((win top-level) style)
- (declare (ignore win))
+(defmethod compute-style-flags ((win top-level) style &rest extra-data)
+ (declare (ignore win extra-data))
(let ((std-flags 0)
(ex-flags 0))
(mapc #'(lambda (sym)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Apr 16 02:14:03 2006
@@ -105,7 +105,7 @@
(defgeneric columns (self)
(:documentation "Returns the column objects displayed by the object."))
-(defgeneric compute-style-flags (self style)
+(defgeneric compute-style-flags (self style &rest extra-data)
(:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports."))
(defgeneric compute-outer-size (self desired-client-size)
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 16 02:14:03 2006
@@ -149,6 +149,9 @@
;;; methods
;;;
+(defmethod background-color ((win window))
+ (gfg:rgb->color (gfs::get-class-long (gfs:handle win) gfs::+gclp-hbrbackground+)))
+
(defmethod compute-outer-size ((win window) desired-client-size)
;; TODO: consider reimplementing this with AdjustWindowRect
;;
More information about the Graphic-forms-cvs
mailing list