[graphic-forms-cvs] r117 - in trunk/src: . tests/uitoolkit uitoolkit/system uitoolkit/widgets

Author: junrue Date: Thu May 4 16:22:47 2006 New Revision: 117

Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented background-color/foreground-color/font customization for labels, infrastructure is in place for other controls too

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu May 4 16:22:47 2006 @@ -59,6 +59,9 @@ ;; constants

;; methods, functions, macros + #:copy-point + #:copy-size + #:copy-span #:detail #:dispose #:disposed-p @@ -98,6 +101,7 @@ (:export

;; classes and structs + #:color #:font #:font-data #:font-metrics @@ -132,6 +136,9 @@ #:color-red #:color-table #:copy-area + #:copy-color + #:copy-font-data + #:copy-font-metrics #:data-obj #:depth #:descent

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu May 4 16:22:47 2006 @@ -104,6 +104,7 @@ ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here + (setf (gfg:background-color w) (gfg:background-color *layout-tester-win*)) (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))))

Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu May 4 16:22:47 2006 @@ -152,6 +152,11 @@ (path :string))

(defcfun + ("CreateSolidBrush" create-solid-brush) + HANDLE + (color COLORREF)) + +(defcfun ("DeleteDC" delete-dc) BOOL (hdc HANDLE))

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu May 4 16:22:47 2006 @@ -800,6 +800,13 @@ (defconstant +wm-initmenupopup+ #x0117) (defconstant +wm-menuselect+ #x011F) (defconstant +wm-menuchar+ #x0120) +(defconstant +wm-ctlcolormsgbox+ #x0132) +(defconstant +wm-ctlcoloredit+ #x0133) +(defconstant +wm-ctlcolorlistbox+ #x0134) +(defconstant +wm-ctlcolorbtn+ #x0135) +(defconstant +wm-ctlcolordlg+ #x0136) +(defconstant +wm-ctlcolorscrollbar+ #x0137) +(defconstant +wm-ctlcolorstatic+ #x0138) (defconstant +wm-mousefirst+ #x0200) ; for use with peek-message (defconstant +wm-mousemove+ #x0200) (defconstant +wm-lbuttondown+ #x0201)

Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu May 4 16:22:47 2006 @@ -259,6 +259,13 @@ (index INT))

(defcfun + ("GetClassNameA" get-class-name) + INT + (hwnd HANDLE) + (classname LPTSTR) + (maxcount INT)) + +(defcfun ("GetClientRect" get-client-rect) BOOL (hwnd HANDLE)

Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Thu May 4 16:22:47 2006 @@ -53,13 +53,40 @@ ;;; methods ;;;

-(defmethod background-color :before ((ctrl control)) +(defmethod gfg: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 gfg:background-color ((ctrl control)) + (or (brush-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + +(defmethod (setf gfg:background-color) :before (color (ctrl control)) + (declare (ignore color)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:background-color) (color (ctrl control)) + (let ((hbrush (brush-handle-of ctrl))) + (when (not (gfs:null-handle-p hbrush)) + (gfs::delete-object hbrush) + (setf (brush-handle-of ctrl) (cffi:null-pointer))) + (setf hbrush (gfs::create-solid-brush (gfg:color->rgb color))) + (if (gfs:null-handle-p hbrush) + (error 'gfs:win32-error :detail "create-solid-brush failed")) + (setf (brush-color-of ctrl) (gfg:copy-color color)) + (setf (brush-handle-of ctrl) hbrush)) + (redraw ctrl)) + +(defmethod gfs:dispose ((ctrl control)) + (let ((hbrush (brush-handle-of ctrl)) + (font (font-of ctrl))) + (if font + (gfs:dispose font)) + (setf (font-of ctrl) nil) + (if (not (gfs:null-handle-p hbrush)) + (gfs::delete-object hbrush)) + (setf (brush-handle-of ctrl) (cffi:null-pointer))) + (call-next-method))

(defmethod focus-p :before ((ctrl control)) (if (gfs:disposed-p ctrl) @@ -69,6 +96,38 @@ (let ((focus-hwnd (gfs::get-focus))) (and (not (gfs:null-handle-p focus-hwnd)) (cffi:pointer-eq focus-hwnd (gfs:handle ctrl)))))

+(defmethod gfg:font :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod gfg:font ((ctrl control)) + (font-of ctrl)) + +(defmethod (setf gfg:font) :before (font (ctrl control)) + (declare (ignore color)) + (if (or (gfs:disposed-p ctrl) (gfs:disposed-p font)) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:font) (font (ctrl control)) + (setf (font-of ctrl) font) + (redraw ctrl)) + +(defmethod gfg:foreground-color :before ((ctrl control)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod gfg:foreground-color ((ctrl control)) + (or (text-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btntext+)))) + +(defmethod (setf gfg:foreground-color) :before (color (ctrl control)) + (declare (ignore color)) + (if (gfs:disposed-p ctrl) + (error 'gfs:disposed-error))) + +(defmethod (setf gfg:foreground-color) (color (ctrl control)) + (setf (text-color-of ctrl) (gfg:copy-color color)) + (redraw ctrl)) + (defmethod give-focus :before ((ctrl control)) (if (gfs:disposed-p ctrl) (error 'gfs:disposed-error)))

Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu May 4 16:22:47 2006 @@ -306,6 +306,27 @@ (error 'gfs:toolkit-error :detail "no object for hwnd"))) 0)

+(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam) + (declare (ignore hwnd)) + (let* ((tc (thread-context)) + (widget (get-widget tc (cffi:make-pointer lparam))) + (hdc (cffi:make-pointer wparam)) + (bkgdcolor (brush-color-of widget)) + (textcolor (text-color-of widget)) + (ret-val 0)) + (when widget + (if (not (typep widget 'label)) + (error 'gfs:toolkit-error :detail "incorrect widget type received WM_CTLCOLORSTATIC")) + (let ((font (font-of widget))) + (if font + (gfs::select-object hdc (gfs:handle font)))) + (if bkgdcolor + (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) + (if textcolor + (gfs::set-text-color hdc (gfg:color->rgb textcolor))) + (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) + ret-val)) + (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam) (declare (ignore wparam)) (process-mouse-message #'event-mouse-double hwnd lparam :right-button))

Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu May 4 16:22:47 2006 @@ -34,7 +34,7 @@ (in-package :graphic-forms.uitoolkit.widgets)

;;; -;;; methods +;;; helper functions ;;;

(defun compute-image-style-flags (style) @@ -77,6 +77,20 @@ (setf flags (logior flags gfs::+ss-left+))))) flags))

+;;; +;;; methods +;;; + +(defmethod (setf gfg:background-color) (color (label label)) + (declare (ignorable color)) + (call-next-method) + (let ((image (image label)) + (pnt (pixel-point-of label))) + (when image + (if pnt + (setf (gfg:transparency-pixel-of image) pnt)) + (setf (image label) image)))) + (defmethod compute-style-flags ((label label) style &rest extra-data) (declare (ignore label)) (if (> (count-if-not #'null extra-data) 1) @@ -113,7 +127,7 @@ gfs::+ws-visible+)) (tr-pnt (gfg:transparency-pixel-of image))) (if tr-pnt - (let* ((color (background-color label)) + (let* ((color (gfg:background-color label)) (size (gfg:size image)) (bounds (make-instance 'gfs:rectangle :size size)) (tmp-image (make-instance 'gfg:image :size size)) @@ -125,7 +139,8 @@ (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))) + (gfg:draw-image gc image (gfs:location bounds)) + (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (gfs:dispose gc)) (setf image tmp-image))) (if (/= orig-flags flags)

Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu May 4 16:22:47 2006 @@ -33,9 +33,6 @@

(in-package :graphic-forms.uitoolkit.widgets)

-(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") -(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") - (defconstant +default-window-title+ "New Window")

;;;

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu May 4 16:22:47 2006 @@ -65,7 +65,22 @@ (defclass caret (widget) () (:documentation "The caret class provides an i-beam typically representing an insertion point."))

-(defclass control (widget) () +(defclass control (widget) + ((brush-color + :accessor brush-color-of + :initform nil) + (brush-handle + :accessor brush-handle-of + :initform (cffi:null-pointer)) + (font + :accessor font-of + :initform nil) + (text-color + :accessor text-color-of + :initform nil) + (pixel-point + :accessor pixel-point-of + :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior."))

(defclass button (control) ()

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu May 4 16:22:47 2006 @@ -51,9 +51,6 @@ (defgeneric append-submenu (self text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))

-(defgeneric background-color (self) - (:documentation "Returns a color object corresponding to the current background color.")) - (defgeneric border-width (self) (:documentation "Returns the object's border width."))

@@ -156,9 +153,6 @@ (defgeneric focus-p (self) (:documentation "Returns T if this object has the keyboard focus; nil otherwise."))

-(defgeneric foreground-color (self) - (:documentation "Returns a color object corresponding to the current foreground color.")) - (defgeneric give-focus (self) (:documentation "Causes this object to have the keyboard focus."))

Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu May 4 16:22:47 2006 @@ -33,6 +33,9 @@

(in-package :graphic-forms.uitoolkit.widgets)

+(defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") +(defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd") + ;;; ;;; helper functions ;;; @@ -151,8 +154,15 @@ ;;; methods ;;;

-(defmethod background-color ((win window)) - (gfg:rgb->color (gfs::get-class-long (gfs:handle win) gfs::+gclp-hbrbackground+))) +(defmethod gfg:background-color ((win window)) + (let ((hwnd (gfs:handle win)) + (color nil)) + (cffi:with-foreign-pointer-as-string (str-ptr 64) + (gfs::get-class-name hwnd str-ptr 64) + (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+) + (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) + (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) + color))

(defmethod compute-outer-size ((win window) desired-client-size) ;; TODO: consider reimplementing this with AdjustWindowRect