Author: junrue Date: Mon Sep 4 16:01:46 2006 New Revision: 246 Added: trunk/src/tests/uitoolkit/widget-tester.lisp Modified: trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/list-item.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: lots of list-box debugging, with new widget-tester test program Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Mon Sep 4 16:01:46 2006 @@ -387,8 +387,8 @@ case the control will re-allocate storage as necessary). @end deffn @deffn Initarg :items -This initarg accepts a list of objects for populating the -contents of the list-box. The list-box will hold references to the +This initarg accepts a list of @ref{list-item} objects for populating +the contents of the list-box. The list-box will hold references to the supplied objects. See also @ref{append-item}. @end deffn @control-parent-initarg{list-box} @@ -693,7 +693,11 @@ @anchor{panel} @deftp Class panel Base class for @ref{window}s that are children of @ref{top-level} -windows, @ref{dialog}s, or other @code{panel}s. +windows, @ref{dialog}s, or other panels. +@deffn Initarg :parent +This initarg is used to specify the @ref{parent} window of the +panel. +@end deffn @end deftp @anchor{root-window} Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Mon Sep 4 16:01:46 2006 @@ -42,6 +42,7 @@ #:hello-world #:image-tester #:layout-tester + #:widget-tester #:textedit #:unblocked #:windlg)) @@ -87,4 +88,5 @@ (:file "layout-tester") (:file "image-tester") (:file "drawing-tester") + (:file "widget-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Mon Sep 4 16:01:46 2006 @@ -0,0 +1,91 @@ +;;;; +;;;; widget-tester.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + + ;; drop cookies +(defvar *list-box-test-data* '("chocolate chip" "butterscotch crunch" "peanut butter" "oatmeal" + ;; molded cookies + "butterfinger chunkies" "jam thumbprints" "cappuccino flats" + ;; pressed cookies + "langues de chat" "macaroons" "shortbread" + ;; refrigerator cookies + "brysell" "caramel" "mosaic" "praline" "toffee")) + +(defvar *widget-tester-win* nil) + +(defun widget-tester-exit (disp item) + (declare (ignore disp item)) + (gfs:dispose *widget-tester-win*) + (setf *widget-tester-win* nil) + (gfw:shutdown 0)) + +(defclass widget-tester-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp widget-tester-events) window) + (declare (ignore window)) + (widget-tester-exit disp nil)) + +(defclass widget-tester-panel-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-paint ((disp widget-tester-panel-events) window gc rect) + (declare (ignore rect)) + (setf (gfg:background-color gc) gfg:*color-white* + (gfg:foreground-color gc) gfg:*color-white*) + (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) + +(defun populate-list-box-test-panel () + (let* ((disp (make-instance 'widget-tester-panel-events)) + (layout (make-instance 'gfw:flow-layout)) + (panel (make-instance 'gfw:panel :dispatcher disp + :parent *widget-tester-win* + :layout layout))) + (make-instance 'gfw:list-box :parent panel :items *list-box-test-data*) + (gfW:pack panel) + panel)) + +(defun widget-tester-internal () + (let ((disp (make-instance 'widget-tester-events)) + (layout (make-instance 'gfw:heap-layout)) + (menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'widget-tester-exit))))))) + (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher disp + :layout layout + :style '(:frame))) + (setf (gfw:menu-bar *widget-tester-win*) menubar) + (setf (gfw:top-child-of layout) (populate-list-box-test-panel)) + (gfw:pack *widget-tester-win*) + (gfw:show *widget-tester-win* t))) + +(defun widget-tester () + (gfw:startup "Widget Tester" #'widget-tester-internal)) Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Mon Sep 4 16:01:46 2006 @@ -48,6 +48,33 @@ (t (funcall func thing))))) +(defun copy-item-sequence (parent new-items item-class) + (let ((hwnd (gfs:handle parent)) + (tc (thread-context)) + (replacements (make-array 7 :fill-pointer 0 :adjustable t))) + (cond + ((null new-items) + replacements) + ((vectorp new-items) + (dotimes (i (length new-items)) + (let ((item (elt new-items i))) + (if (typep item item-class) + (vector-push-extend item replacements) + (let ((tmp (make-instance item-class :handle hwnd :data item))) + (put-item tc tmp) + (vector-push-extend tmp replacements))))) + replacements) + ((listp new-items) + (loop for item in new-items + do (if (typep item item-class) + (vector-push-extend item replacements) + (let ((tmp (make-instance item-class :handle hwnd :data item))) + (put-item tc tmp) + (vector-push-extend tmp replacements)))) + replacements) + (t + (error 'gfs:toolkit-error :detail (format nil "invalid data structure type: ~a" new-items)))))) + ;;; ;;; methods ;;; Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Mon Sep 4 16:01:46 2006 @@ -90,3 +90,10 @@ (if (null widget) (error 'gfs:toolkit-error :detail "no owner widget")) widget))) + +(defmethod print-object ((self item) stream) + (print-unreadable-object (self stream :type t) + (format stream "id: ~d " (item-id self)) + (format stream "data: ~a " (data-of self)) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Sep 4 16:01:46 2006 @@ -76,23 +76,22 @@ for rect = (cdr k) for size = (gfs:size rect) for pnt = (gfs:location rect) - do (progn - (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width size) - (gfs:size-height size) - (funcall flags-func (car k))) - (gfs::defer-window-pos hdwp - (gfs:handle (car k)) - (cffi:null-pointer) - (gfs:point-x pnt) - (gfs:point-y pnt) - (gfs:size-width size) - (gfs:size-height size) - (funcall flags-func (car k)))))) + do (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))) + (gfs::defer-window-pos hdwp + (gfs:handle (car k)) + (cffi:null-pointer) + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width size) + (gfs:size-height size) + (funcall flags-func (car k))))) (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp)))) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Mon Sep 4 16:01:46 2006 @@ -43,7 +43,7 @@ (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) (item (create-item-with-callback hcontrol 'list-item thing disp))) - (lb-insert-item hcontrol -1 text (cffi:null-pointer)) + (lb-insert-item hcontrol #xFFFFFFFF text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) item)) @@ -79,7 +79,7 @@ (:want-scrollbar (setf std-flags (logior std-flags gfs::+lbs-disablenoscroll+))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self list-box) &key estimated-count parent &allow-other-keys) +(defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys) (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) @@ -93,10 +93,17 @@ (init-control self) (if (and estimated-count (> estimated-count 0)) (lb-init-storage (gfs:handle self) estimated-count (* estimated-count +estimated-text-size+))) + (if items + (setf (slot-value self 'items) (copy-item-sequence self items 'list-item))) (update-from-items self)) (defmethod (setf items-of) :after (new-items (self list-box)) - (declare (ignore new-items)) + (let ((old-items (items-of self))) + (dotimes (i (length old-items)) + (let ((victim (elt old-items i))) + (setf (slot-value victim 'gfs:handle) nil) + (gfs:dispose victim)))) + (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item)) (update-from-items self)) (defmethod preferred-size ((self list-box) width-hint height-hint) @@ -109,14 +116,16 @@ (setf (gfs:size-width size) (loop for index to (1- (lb-item-count hwnd)) with dt-flags = (logior gfs::+dt-singleline+ gfs::+dt-noprefix+) - maximizing (widget-text-size self - (lambda () (item-text index)) - dt-flags) + maximizing (gfs:size-width (widget-text-size self + (lambda (unused) + (declare (ignore unused)) + (item-text index)) + dt-flags)) into max-width - finally (return max-width))))) + finally (return (or max-width 0)))))) (if (zerop (gfs:size-width size)) (setf (gfs:size-width size) +default-widget-width+) - (incf (gfs:size-width size) b-width)) + (incf (gfs:size-width size) (+ b-width 4))) (when (< height-hint 0) (setf (gfs:size-height size) (* (lb-item-count hwnd) (lb-item-height hwnd)))) (if (zerop (gfs:size-height size)) @@ -131,16 +140,18 @@ (let ((sort-func (sort-predicate-of self)) (items (items-of self)) (hwnd (gfs:handle self))) +#| (when sort-func (setf items (gfs::indexed-sort items sort-func (lambda (it) (data-of it))) (items-of self) items)) +|# (enable-redraw self nil) (unwind-protect (progn (lb-clear-content hwnd) - (loop for item in items - for index = 0 then (1+ index) - do (progn - (setf (index-of item) index) - (append-item self item (dispatcher self))))) + (dotimes (index (length items)) + (let* ((item (elt items index)) + (text (call-text-provider self (data-of item)))) + (setf (index-of item) index) + (lb-insert-item hwnd #xFFFFFFFF text (cffi:null-pointer))))) (enable-redraw self t)))) Modified: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-item.lisp (original) +++ trunk/src/uitoolkit/widgets/list-item.lisp Mon Sep 4 16:01:46 2006 @@ -47,8 +47,9 @@ (declare (ignore hbmp)) ; FIXME: re-enable when we support images in list-box (let ((text (or label ""))) (cffi:with-foreign-string (str-ptr text) - (if (< (gfs::send-message hwnd gfs::+lb-insertstring+ index str-ptr) 0) - (error 'gfs:win32-error :detail "LB_INSERTSTRING failed"))))) + (let ((retval (gfs::send-message hwnd gfs::+lb-insertstring+ index (cffi:pointer-address str-ptr)))) + (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))) @@ -88,8 +89,16 @@ (defmethod gfs:dispose ((self list-item)) (let ((index (index-of self)) - (owner (owner self))) - (if owner - (gfs::send-message (gfs:handle owner) gfs::+lb-deletestring+ index 0)) + (howner (gfs:handle self))) + (if howner + (gfs::send-message howner gfs::+lb-deletestring+ index 0)) (setf (index-of self) 0)) (call-next-method)) + +(defmethod print-object ((self list-item) stream) + (print-unreadable-object (self stream :type t) + (format stream "id: ~d " (item-id self)) + (format stream "index: ~d " (index-of self)) + (format stream "data: ~a " (data-of self)) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Sep 4 16:01:46 2006 @@ -183,7 +183,7 @@ :initform nil)) (:documentation "A mix-in for objects composed of sub-elements.")) -(defclass list-box (widget item-manager) +(defclass list-box (control item-manager) ((callback-event-name :accessor callback-event-name-of :initform 'event-select Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Sep 4 16:01:46 2006 @@ -310,7 +310,7 @@ (defmethod print-object ((self widget) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a~%" (dispatcher self)))) + (format stream "dispatcher: ~a" (dispatcher self)))) (defmethod redo-available-p :before ((self widget)) (if (gfs:disposed-p self)