[graphic-forms-cvs] r425 - in trunk/src: demos/textedit uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Jan 7 07:16:31 UTC 2007
Author: junrue
Date: Sun Jan 7 02:16:30 2007
New Revision: 425
Modified:
trunk/src/demos/textedit/textedit-window.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/status-bar.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
text now displays in simple status bars; related refactoring
Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp (original)
+++ trunk/src/demos/textedit/textedit-window.lisp Sun Jan 7 02:16:30 2007
@@ -200,6 +200,7 @@
(gfw:text *textedit-win*) *textedit-new-title*)
(let ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)))
(setf (gfw:image *textedit-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "textedit.ico"))))
+ (gfw::stb-set-text (gfw:status-bar-of *textedit-win*) "Testing...1, 2, 3")
(gfw:show *textedit-win* t)))
(defun textedit ()
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jan 7 02:16:30 2007
@@ -951,6 +951,11 @@
;;; statusbar constants
;;;
+(defconstant +sb-simpleid+ #x00FF)
+
+(defconstant +sb-settext+ #x0401) ; (WM_USER+1) SB_SETTEXTA
+(defconstant +sb-gettext+ #x0402) ; (WM_USER+2) SB_GETTEXTA
+(defconstant +sb-gettextlength+ #x0403) ; (WM_USER+3) SB_GETTEXTLENGTHA
(defconstant +sb-setparts+ #x0404) ; (WM_USER+4)
(defconstant +sb-getparts+ #x0406) ; (WM_USER+6)
(defconstant +sb-getborders+ #x0407) ; (WM_USER+7)
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Sun Jan 7 02:16:30 2007
@@ -65,7 +65,8 @@
;; it won't work if virtual containers like group are implemented.
;;
(when (and parent (layout-of parent))
- (append-layout-item (layout-of parent) ctrl)))))
+ (append-layout-item (layout-of parent) ctrl))
+ hwnd)))
;;;
;;; methods
Modified: trunk/src/uitoolkit/widgets/status-bar.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/status-bar.lisp (original)
+++ trunk/src/uitoolkit/widgets/status-bar.lisp Sun Jan 7 02:16:30 2007
@@ -34,12 +34,92 @@
(in-package :graphic-forms.uitoolkit.widgets)
;;;
+;;; helper functions
+;;;
+
+(declaim (inline stb-is-simple))
+(defun stb-is-simple (status-bar)
+ (/= (gfs::send-message (gfs:handle status-bar) gfs::+sb-issimple+ 0 0) 0))
+
+(defun stb-get-border-widths (status-bar)
+ "Returns a list of integer widths (0: horz border, 1: vert border, 2: internal)"
+ (cffi:with-foreign-pointer (array (* (cffi:foreign-type-size :int) 3))
+ (when (zerop (gfs::send-message (gfs:handle status-bar)
+ gfs::+sb-getborders+
+ 0
+ (cffi:pointer-address array)))
+ (warn 'gfs:win32-warning :detail "SB_GETBORDERS message failed")
+ (return-from stb-get-border-widths (list 0 0 0)))
+ (loop for index from 0 to 2
+ collect (cffi:mem-aref array :int index))))
+
+(defun stb-set-min-height (status-bar height)
+ (let ((widths (stb-get-border-widths status-bar))
+ (hstatus (gfs:handle status-bar)))
+ (when (zerop (gfs::send-message hstatus
+ gfs::+sb-setminheight+
+ (+ height (* (second widths) 2))
+ 0))
+ (warn 'gfs:win32-warning :detail "SB_SETMINHEIGHT message failed")
+ (return-from stb-set-min-height nil))
+ (gfs::send-message hstatus gfs::+wm-size+ 0 0))
+ height)
+
+(defun stb-set-text (status-bar str &optional item-index)
+ (let ((part-id (if (stb-is-simple status-bar) gfs::+sb-simpleid+ item-index)))
+ (cffi:with-foreign-string (str-ptr str)
+ (if (zerop (gfs::send-message (gfs:handle status-bar)
+ gfs::+sb-settext+
+ part-id
+ (cffi:pointer-address str-ptr)))
+ (warn 'gfs:win32-warning :detail "SB_SETTEXT message failed"))))
+ str)
+
+(defun stb-get-text-properties (status-bar item-index)
+ "Returns the text length and operation type of the status bar part at item-index."
+ (let ((hresult (gfs::send-message (gfs:handle status-bar)
+ gfs::+sb-gettextlength+
+ item-index
+ 0)))
+ (values (gfs::lparam-low-word hresult) (gfs::lparam-high-word hresult))))
+
+(defun stb-get-text (status-bar item-index)
+ (multiple-value-bind (length op-type)
+ (stb-get-text-properties status-bar item-index)
+ (declare (ignore op-type))
+ (if (zerop length)
+ ""
+ (cffi:with-foreign-pointer-as-string (str-ptr (1+ length))
+ (gfs::send-message (gfs:handle status-bar)
+ gfs::+sb-gettext+
+ item-index
+ (cffi:pointer-address str-ptr))))))
+
+;;;
;;; methods
;;;
+(defmethod border-width ((self status-bar))
+ (let ((widths (stb-get-border-widths self)))
+ (max (first widths) (second widths))))
+
(defmethod compute-style-flags ((self status-bar) &rest extra-data)
(declare (ignore extra-data))
(values (logior gfs::+ws-child+ gfs::+ws-visible+ gfs::+sbars-sizegrip+) 0))
(defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys)
- (create-control self parent "" gfs::+icc-win95-classes+))
+ (let ((hctl (create-control self parent "" gfs::+icc-win95-classes+)))
+ (gfs::send-message hctl gfs::+sb-simple+ 1 0))
+ (let ((widths (stb-get-border-widths self)))
+ (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths)))))
+
+(defmethod preferred-size ((self status-bar) width-hint height-hint)
+ (declare (ignore width-hint height-hint))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (let ((client-area (client-size (parent self)))
+ (tmp-size (compute-size (layout-of self) self width-hint height-hint))
+ (widths (stb-get-border-widths self)))
+ (gfs:make-size :width (gfs:size-width client-area))
+ :height (+ (gfs:size-height tmp-size) (* (first widths) 2))))
+
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jan 7 02:16:30 2007
@@ -1,7 +1,7 @@
;;;;
;;;; widget-utils.lisp
;;;;
-;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; Copyright (C) 2006-2007, Jack D. Unrue
;;;; All rights reserved.
;;;;
;;;; Redistribution and use in source and binary forms, with or without
@@ -162,20 +162,16 @@
(error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func))))
retval))
-(defun get-widget-text (w)
- (if (gfs:disposed-p w)
+(defun get-widget-text (widget)
+ (if (gfs:disposed-p widget)
(error 'gfs:disposed-error))
(let* ((text "")
- (hwnd (gfs:handle w))
- (len (gfs::get-window-text-length hwnd)))
- (unless (zerop len)
- (incf len)
- (let ((str-ptr (cffi:foreign-alloc :char :count len)))
- (unwind-protect
- (unless (zerop (gfs::get-window-text hwnd str-ptr len))
- (setf text (cffi:foreign-string-to-lisp str-ptr)))
- (cffi:foreign-free str-ptr))))
- text))
+ (hwnd (gfs:handle widget))
+ (length (gfs::get-window-text-length hwnd)))
+ (if (zerop length)
+ ""
+ (cffi:with-foreign-pointer-as-string (str-ptr (1+ length))
+ (gfs::get-window-text hwnd str-ptr (1+ length))))))
(defun outer-location (w pnt)
(cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
More information about the Graphic-forms-cvs
mailing list