[graphic-forms-cvs] r246 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Sep 4 20:01:48 UTC 2006
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.
+ at deffn Initarg :parent
+This initarg is used to specify the @ref{parent} window of the
+panel.
+ at 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)
More information about the Graphic-forms-cvs
mailing list