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)