[graphic-forms-cvs] r4 - in trunk: . src src/intrinsics/system src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Feb 10 07:37:08 UTC 2006
Author: junrue
Date: Fri Feb 10 01:37:07 2006
New Revision: 4
Added:
trunk/src/intrinsics/system/native-classes.lisp
- copied, changed from r1, trunk/src/intrinsics/system/system-classes.lisp
trunk/src/intrinsics/system/native-conditions.lisp
- copied, changed from r1, trunk/src/intrinsics/system/system-conditions.lisp
Removed:
trunk/src/intrinsics/system/system-classes.lisp
trunk/src/intrinsics/system/system-conditions.lisp
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/item.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/widget-with-items.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
fixed filename conflict; overhauled menu cleanup; implemented more menu mgmnt
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Fri Feb 10 01:37:07 2006
@@ -54,8 +54,8 @@
((:file "datastruct-classes")))
(:module "system"
:components
- ((:file "system-classes")
- (:file "system-conditions")
+ ((:file "native-classes")
+ (:file "native-conditions")
(:file "native-object-generics")
(:file "native-object")))))
(:module "uitoolkit"
Copied: trunk/src/intrinsics/system/native-classes.lisp (from r1, trunk/src/intrinsics/system/system-classes.lisp)
==============================================================================
--- trunk/src/intrinsics/system/system-classes.lisp (original)
+++ trunk/src/intrinsics/system/native-classes.lisp Fri Feb 10 01:37:07 2006
@@ -1,5 +1,5 @@
;;;;
-;;;; classes.lisp
+;;;; native-classes.lisp
;;;;
;;;; Copyright (C) 2006, Jack D. Unrue
;;;; All rights reserved.
Copied: trunk/src/intrinsics/system/native-conditions.lisp (from r1, trunk/src/intrinsics/system/system-conditions.lisp)
==============================================================================
--- trunk/src/intrinsics/system/system-conditions.lisp (original)
+++ trunk/src/intrinsics/system/native-conditions.lisp Fri Feb 10 01:37:07 2006
@@ -1,5 +1,5 @@
;;;;
-;;;; conditions.lisp
+;;;; native-conditions.lisp
;;;;
;;;; Copyright (C) 2006, Jack D. Unrue
;;;; All rights reserved.
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Fri Feb 10 01:37:07 2006
@@ -310,6 +310,7 @@
#:border-width
#:caret
#:checked-p
+ #:clear-all
#:clear-item
#:clear-selection
#:clear-span
@@ -387,15 +388,16 @@
#:header-visible-p
#:iconify
#:iconified-p
- #:image
- #:item-id
#:hide
#:hide-header
#:hide-lines
#:horizontal-scrollbar
+ #:image
+ #:item-append
#:item-at
#:item-count
#:item-height
+ #:item-id
#:item-index
#:item-owner
#:items
@@ -455,6 +457,7 @@
#:startup
#:step-increment
#:style
+ #:sub-menu
#:text
#:text-height
#:text-limit
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Fri Feb 10 01:37:07 2006
@@ -36,21 +36,21 @@
(defconstant +btn-text-1+ "Push Me")
(defconstant +btn-text-2+ "Again!")
-(defparameter *layout-win* nil)
+(defparameter *layout-tester-win* nil)
(defun exit-layout-tester ()
- (let ((w *layout-win*))
- (setf *layout-win* nil)
+ (let ((w *layout-tester-win*))
+ (setf *layout-tester-win* nil)
(gfis:dispose w))
(gfuw:shutdown 0))
-(defclass fill-events (gfuw:event-dispatcher) ())
+(defclass layout-tester-events (gfuw:event-dispatcher) ())
-(defmethod gfuw:event-close ((d fill-events) time)
+(defmethod gfuw:event-close ((d layout-tester-events) time)
(declare (ignore time))
(exit-layout-tester))
-(defclass fill-btn-events (gfuw:event-dispatcher)
+(defclass layout-tester-btn-events (gfuw:event-dispatcher)
((button
:accessor button
:initarg :button
@@ -59,24 +59,40 @@
:accessor toggle-fn
:initform nil)))
-(defmethod gfuw:event-select ((d fill-btn-events) time item rect)
+(defmethod gfuw:event-select ((d layout-tester-btn-events) time item rect)
(declare (ignorable time rect))
(let ((btn (button d)))
(setf (gfuw:text btn) (funcall (toggle-fn d)))))
-(defclass fill-exit-dispatcher (gfuw:event-dispatcher) ())
+(defclass layout-tester-child-menu-dispatcher (gfuw:event-dispatcher) ())
-(defmethod gfuw:event-select ((d fill-exit-dispatcher) time item rect)
+(defmethod gfuw:event-activate ((d layout-tester-child-menu-dispatcher) time)
+ (declare (ignore time))
+ (let* ((mb (gfuw:menu-bar *layout-tester-win*))
+ (menu (gfuw:sub-menu mb 1)))
+ (gfuw:clear-all menu)
+ (gfuw::visit-child-widgets *layout-tester-win*
+ #'(lambda (child val)
+ (declare (ignore val))
+ (let ((it (make-instance 'gfuw:menu-item)))
+ (gfuw:item-append menu it)
+ (setf (gfuw:text it) (gfuw:text child))))
+ 0)))
+
+(defclass layout-tester-exit-dispatcher (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-select ((d layout-tester-exit-dispatcher) time item rect)
(declare (ignorable time item rect))
(exit-layout-tester))
(defun run-layout-tester-internal ()
(let* ((menubar nil)
- (md (make-instance 'fill-exit-dispatcher))
- (bd (make-instance 'fill-btn-events))
- (btn (make-instance 'gfuw:button :dispatcher bd)))
- (setf (button bd) btn)
- (setf (toggle-fn bd) (let ((flag nil))
+ (fed (make-instance 'layout-tester-exit-dispatcher))
+ (be (make-instance 'layout-tester-btn-events))
+ (cmd (make-instance 'layout-tester-child-menu-dispatcher))
+ (btn (make-instance 'gfuw:button :dispatcher be)))
+ (setf (button be) btn)
+ (setf (toggle-fn be) (let ((flag nil))
#'(lambda ()
(if (null flag)
(progn
@@ -85,18 +101,19 @@
(progn
(setf flag nil)
+btn-text-2+)))))
- (setf *layout-win* (make-instance 'gfuw:window :dispatcher (make-instance 'fill-events)))
- (gfuw:realize *layout-win* nil :style-workspace)
- (setf (gfuw:size *layout-win*) (gfid:make-size :width 200 :height 150))
+ (setf *layout-tester-win* (make-instance 'gfuw:window :dispatcher (make-instance 'layout-tester-events)))
+ (gfuw:realize *layout-tester-win* nil :style-workspace)
+ (setf (gfuw:size *layout-tester-win*) (gfid:make-size :width 200 :height 150))
(setf menubar (gfuw:defmenusystem `(((:menu "&File")
- (:menuitem "E&xit" :dispatcher ,md))
- ((:menu "&Children")))))
- (setf (gfuw:menu-bar *layout-win*) menubar)
- (gfuw:realize btn *layout-win* :push-button)
- (setf (gfuw:text btn) (funcall (toggle-fn bd)))
+ (:menuitem "E&xit" :dispatcher ,fed))
+ ((:menu "&Children" :dispatcher ,cmd)
+ (:menuitem :separator)))))
+ (setf (gfuw:menu-bar *layout-tester-win*) menubar)
+ (gfuw:realize btn *layout-tester-win* :push-button)
+ (setf (gfuw:text btn) (funcall (toggle-fn be)))
(setf (gfuw:location btn) (gfid:make-point))
(setf (gfuw:size btn) (gfuw:preferred-size btn -1 -1))
- (gfuw:show *layout-win*)
+ (gfuw:show *layout-tester-win*)
(gfuw:run-default-message-loop)))
(defun run-layout-tester ()
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Fri Feb 10 01:37:07 2006
@@ -211,6 +211,9 @@
(defconstant +lr-copyfromresource+ #x4000)
(defconstant +lr-shared+ #x8000)
+(defconstant +mf-bycommand+ #x00000000)
+(defconstant +mf-byposition+ #x00000400)
+
(defconstant +mfs-grayed+ #x00000003)
(defconstant +mfs-disabled+ #x00000003)
(defconstant +mfs-checked+ #x00000008)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Fri Feb 10 01:37:07 2006
@@ -288,6 +288,13 @@
(hdc HANDLE))
(defcfun
+ ("RemoveMenu" remove-menu)
+ BOOL
+ (hmenu HANDLE)
+ (pos UINT)
+ (flags UINT))
+
+(defcfun
("SendMessageA" send-message)
LRESULT
(hwnd HANDLE)
Modified: trunk/src/uitoolkit/widgets/item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item.lisp (original)
+++ trunk/src/uitoolkit/widgets/item.lisp Fri Feb 10 01:37:07 2006
@@ -34,4 +34,4 @@
(in-package :graphic-forms.uitoolkit.widgets)
(defun items-equal-p (item1 item2)
- (string= (text item1) (text item2)))
+ (= (item-id item1) (item-id item2)))
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Fri Feb 10 01:37:07 2006
@@ -75,7 +75,31 @@
(cffi:foreign-free str-ptr)))
result))))
-(defun insert-menuitem (hparent mid label hbmp)
+(defun set-menuitem-text (hmenu mid label)
+ (cffi:with-foreign-string (str-ptr label)
+ (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
+ (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
+ gfus::state gfus::id gfus::hsubmenu
+ gfus::hbmpchecked gfus::hbmpunchecked
+ gfus::idata gfus::tdata gfus::cch
+ gfus::hbmpitem)
+ mii-ptr gfus::menuiteminfo)
+ (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo))
+ (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+))
+ (setf gfus::type 0)
+ (setf gfus::state 0)
+ (setf gfus::id mid)
+ (setf gfus::hsubmenu (cffi:null-pointer))
+ (setf gfus::hbmpchecked (cffi:null-pointer))
+ (setf gfus::hbmpunchecked (cffi:null-pointer))
+ (setf gfus::idata 0)
+ (setf gfus::tdata str-ptr)
+ (setf gfus::cch (length label))
+ (setf gfus::hbmpitem (cffi:null-pointer)))
+ (if (zerop (gfus::set-menu-item-info hmenu mid 0 mii-ptr))
+ (error 'gfus:win32-error :detail "set-menu-item-info failed")))))
+
+(defun insert-menuitem (howner mid label hbmp)
(cffi:with-foreign-string (str-ptr label)
(cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
(cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
@@ -96,7 +120,7 @@
(setf gfus::tdata str-ptr)
(setf gfus::cch (length label))
(setf gfus::hbmpitem hbmp))
- (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
+ (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
(error 'gfus::win32-error :detail "insert-menu-item failed")))))
(defun insert-submenu (hparent mid label hbmp hchildmenu)
@@ -125,7 +149,7 @@
(if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
(error 'gfus::win32-error :detail "insert-menu-item failed")))))
-(defun insert-separator (hparent)
+(defun insert-separator (howner)
(cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
(cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
gfus::state gfus::id gfus::hsubmenu
@@ -145,26 +169,35 @@
(setf gfus::tdata (cffi:null-pointer))
(setf gfus::cch 0)
(setf gfus::hbmpitem (cffi:null-pointer)))
- (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
+ (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
(error 'gfus::win32-error :detail "insert-menu-item failed"))))
+(defun sub-menu (m index)
+ (if (gfis:disposed-p m)
+ (error 'gfis:disposed-error))
+ (let ((hwnd (gfus::get-submenu (gfis:handle m) index)))
+ (if (not (gfus:null-handle-p hwnd))
+ (get-widget hwnd)
+ nil)))
+
+(defun visit-menu-tree (menu fn)
+ (dotimes (index (item-count menu))
+ (let ((it (item-at menu index))
+ (child (sub-menu menu index)))
+ (unless (null child)
+ (visit-menu-tree child fn))
+ (funcall fn menu it))))
+
;;;
;;; menu methods
;;;
-(defun recursively-dispose-menuitem (it)
- (let ((hsubmenu (gfis:handle it)))
- (unless (gfus:null-handle-p hsubmenu)
- (let ((m (get-widget hsubmenu)))
- (if (null m)
- (error 'gfus:toolkit-error :detail "no object for hmenu"))
- (gfis:dispose m))))
- (gfis:dispose it))
+(defun menu-cleanup-callback (menu item)
+ (remove-widget (gfis:handle menu))
+ (remove-menuitem item))
(defmethod gfis:dispose ((m menu))
- (let ((tmp (items m)))
- (dotimes (i (length tmp))
- (recursively-dispose-menuitem (elt tmp i))))
+ (visit-menu-tree m #'menu-cleanup-callback)
(let ((hwnd (gfis:handle m)))
(remove-widget hwnd)
(if (not (gfus:null-handle-p hwnd))
@@ -172,6 +205,18 @@
(error 'gfus:win32-error :detail "destroy-menu failed"))))
(setf (slot-value m 'gfis:handle) nil))
+(defmethod item-append ((m menu) (it menu-item))
+ (let ((id *next-menuitem-id*)
+ (hmenu (gfis:handle m)))
+ (if (gfus:null-handle-p hmenu)
+ (error 'gfis:disposed-error))
+ (setf *next-menuitem-id* (1+ id))
+ (insert-menuitem (gfis:handle m) id " " (cffi:null-pointer))
+ (setf (item-id it) id)
+ (setf (slot-value it 'gfis:handle) hmenu)
+ (put-menuitem it)
+ (call-next-method)))
+
;;;
;;; item methods
;;;
@@ -179,14 +224,40 @@
(defmethod gfis:dispose ((it menu-item))
(setf (dispatcher it) nil)
(remove-menuitem it)
- (setf (item-id it) 0)
- (setf (slot-value it 'gfis:handle) nil)) ; menu-item slot is for parent menu
-
-(defmethod text ((i menu-item))
- (get-menuitem-text (gfis:handle (item-owner i)) (item-id i)))
+ (let ((id (item-id it))
+ (owner (item-owner it)))
+ (unless (null owner)
+ (gfus::remove-menu (gfis:handle owner) id gfus::+mf-bycommand+)
+ (let* ((index (item-index owner it))
+ (child-menu (sub-menu owner index)))
+ (unless (null child-menu)
+ (gfis:dispose child-menu))))
+ (setf (item-id it) 0)
+ (setf (slot-value it 'gfis:handle) nil)))
+
+(defmethod item-owner ((it menu-item))
+ (let ((hmenu (gfis:handle it)))
+ (if (gfus:null-handle-p hmenu)
+ (error 'gfus:toolkit-error :detail "null owner menu handle"))
+ (let ((m (get-widget hmenu)))
+ (if (null m)
+ (error 'gfus:toolkit-error :detail "no owner menu"))
+ m)))
+
+(defmethod text ((it menu-item))
+ (let ((hmenu (gfis:handle it)))
+ (if (gfus:null-handle-p hmenu)
+ (error 'gfus:toolkit-error :detail "null owner menu handle"))
+ (get-menuitem-text hmenu (item-id it))))
+
+(defmethod (setf text) (str (it menu-item))
+ (let ((hmenu (gfis:handle it)))
+ (if (gfus:null-handle-p hmenu)
+ (error 'gfus:toolkit-error :detail "null owner menu handle"))
+ (set-menuitem-text hmenu (item-id it) str)))
;;;
-;;; DSL implementation
+;;; menu language compiler
;;;
;;; an example menubar definition:
;;;
@@ -268,7 +339,7 @@
(when dispatcher
(setf dispatcher (nth (1+ dispatcher) options))
(if (null dispatcher)
- (error 'toolkit-error :detail "missing dispatcher function")))
+ (error 'gfus:toolkit-error :detail "missing dispatcher function")))
(values dispatcher)))
(defun parse-menuitem-options (options)
@@ -280,23 +351,23 @@
(sub (position-if #'submenu-option-p options)))
(when sep
(if (or disabled checked image sub)
- (error 'toolkit-error :detail "invalid menu item options"))
+ (error 'gfus:toolkit-error :detail "invalid menu item options"))
(return-from parse-menuitem-options (values nil nil nil nil t nil)))
(when image
(if sep
- (error 'toolkit-error :detail "invalid menu item options"))
+ (error 'gfus:toolkit-error :detail "invalid menu item options"))
(setf image (nth (1+ image) options))
(if (null image)
- (error 'toolkit-error :detail "missing image filename")))
+ (error 'gfus:toolkit-error :detail "missing image filename")))
(when dispatcher
(if sep
- (error 'toolkit-error :detail "invalid menu item options"))
+ (error 'gfus:toolkit-error :detail "invalid menu item options"))
(setf dispatcher (nth (1+ dispatcher) options))
(if (null dispatcher)
- (error 'toolkit-error :detail "missing dispatcher function")))
+ (error 'gfus:toolkit-error :detail "missing dispatcher function")))
(when sub
(if (or checked sep)
- (error 'toolkit-error :detail "invalid menu item options"))
+ (error 'gfus:toolkit-error :detail "invalid menu item options"))
(return-from parse-menuitem-options (values dispatcher disabled nil image nil t)))
(values dispatcher disabled checked image nil nil)))
@@ -377,35 +448,39 @@
(setf (menu-stack gen) (list m))))
(defmethod define-menuitem ((gen menu-generator) label dispatcher enabled checked image)
- (let* ((parent (first (menu-stack gen)))
+ (let* ((owner (first (menu-stack gen)))
(it (make-instance 'menu-item :dispatcher dispatcher))
- (id *next-menuitem-id*))
+ (id *next-menuitem-id*)
+ (hmenu (gfis:handle owner)))
(setf *next-menuitem-id* (1+ id))
+ (insert-menuitem hmenu id label (cffi:null-pointer))
(setf (item-id it) id)
+ (setf (slot-value it 'gfis:handle) hmenu)
(put-menuitem it)
- (item-append parent it)
- (insert-menuitem (gfis:handle parent) id label (cffi:null-pointer))))
+ (vector-push-extend it (items owner))))
(defmethod define-submenu ((gen menu-generator) submenu dispatcher enabled image)
(declare (ignore dispatcher) (ignore enabled) (ignore image))
(process-menu gen submenu))
(defmethod define-separator ((gen menu-generator))
- (let* ((parent (first (menu-stack gen)))
- (it (make-instance 'menu-item)))
+ (let* ((owner (first (menu-stack gen)))
+ (it (make-instance 'menu-item))
+ (hmenu (gfis:handle owner)))
(put-menuitem it)
- (item-append parent it)
- (insert-separator (gfis:handle parent))))
+ (insert-separator hmenu)
+ (setf (slot-value it 'gfis:handle) hmenu)
+ (vector-push-extend it (items owner))))
(defmethod define-menu ((gen menu-generator) label dispatcher)
(let* ((m (make-instance 'menu :handle (gfus::create-popup-menu) :dispatcher dispatcher))
(parent (first (menu-stack gen)))
- (it (make-instance 'menu-item :handle (gfis:handle m) :dispatcher dispatcher))
+ (it (make-instance 'menu-item :handle (gfis:handle parent) :dispatcher dispatcher))
(id *next-menuitem-id*))
(setf *next-menuitem-id* (1+ id))
- (setf (item-id it) id)
- (item-append parent it)
(insert-submenu (gfis:handle parent) id label (cffi:null-pointer) (gfis:handle m))
+ (setf (item-id it) id)
+ (vector-push-extend it (items parent))
(push m (menu-stack gen))
(put-widget m)
m))
@@ -414,11 +489,10 @@
(setf (menu-stack gen) (cdr (menu-stack gen))))
(defmacro defmenusystem (sexp)
- `(let ((gen (gensym))
- (var (gensym)))
- (setf gen (make-instance 'menu-generator))
- (mapcar #'(lambda (var) (process-menu gen var)) ,sexp)
- (first (menu-stack gen))))
+ (let ((gen (gensym)))
+ `(let ((,gen (make-instance 'menu-generator)))
+ (mapcar #'(lambda (var) (process-menu ,gen var)) ,sexp)
+ (first (menu-stack ,gen)))))
;;;
;;; menuitems table management
@@ -437,18 +511,3 @@
(if (eql k (item-id it))
(remhash k *menuitems-by-id*)))
*menuitems-by-id*))
-
-(defun recursively-cleanup-menuitem (it)
- (let ((hsubmenu (gfis:handle it)))
- (unless (gfus:null-handle-p hsubmenu)
- (let ((m (get-widget hsubmenu)))
- (if (null m)
- (error 'gfus:toolkit-error :detail "no object for hmenu"))
- (cleanup-menu-tables m))))
- (remove-menuitem it))
-
-(defun cleanup-menu-tables (m)
- (let ((tmp (items m)))
- (dotimes (i (length tmp))
- (recursively-cleanup-menuitem (elt tmp i))))
- (remove-widget (gfis:handle m)))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Feb 10 01:37:07 2006
@@ -47,11 +47,7 @@
((item-id
:accessor item-id
:initarg :item-id
- :initform 0)
- (item-owner
- :accessor item-owner
- :initarg :item-owner
- :initform nil))
+ :initform 0))
(:documentation "The item class is the base class for all non-windowed user interface objects."))
(defclass menu-item (item) ()
@@ -72,7 +68,8 @@
(defclass widget-with-items (widget)
((items
:accessor items
- :initform (make-array 7 :fill-pointer 0 :adjustable t))) ; allow subclasses to set size?
+ ;; FIXME: allow subclasses to set initial size?
+ :initform (make-array 7 :fill-pointer 0 :adjustable t)))
(:documentation "The widget-with-items class is the base class for objects composed of fine-grained items."))
(defclass menu (widget-with-items) ()
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Feb 10 01:37:07 2006
@@ -213,6 +213,9 @@
(defgeneric item-index (object other)
(:documentation "Return the zero-based index of the location of the other object in this object."))
+(defgeneric item-owner (object)
+ (:documentation "Return the widget containing this item."))
+
(defgeneric layout (object)
(:documentation "Set the size and location of this object's children."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Feb 10 01:37:07 2006
@@ -45,6 +45,11 @@
(defun shutdown (exit-code)
(gfus::post-quit-message exit-code))
+(defun clear-all (w)
+ (let ((count (gfuw:item-count w)))
+ (unless (zerop count)
+ (gfuw:clear-span w (gfid:make-span :start 0 :end (1- count))))))
+
(defun create-window (class-name title parent-hwnd std-style ex-style)
(cffi:with-foreign-string (cname-ptr class-name)
(cffi:with-foreign-string (title-ptr title)
Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Fri Feb 10 01:37:07 2006
@@ -33,9 +33,19 @@
(in-package :graphic-forms.uitoolkit.widgets)
+(defmethod clear-item ((w widget-with-items) index)
+ (let ((it (item-at w index)))
+ (delete it (items w) :test #'items-equal-p)
+ (if (gfis:disposed-p it)
+ (error 'gfis:disposed-error))
+ (gfis:dispose it)))
+
+(defmethod clear-span ((w widget-with-items) (sp gfid:span))
+ (loop for index from (gfid:span-start sp) to (gfid:span-end sp)
+ collect (clear-item w index)))
+
(defmethod item-append ((w widget-with-items) (i item))
- (vector-push-extend i (items w))
- (setf (item-owner i) w))
+ (vector-push-extend i (items w)))
(defmethod item-at ((w widget-with-items) index)
(elt (items w) index))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Fri Feb 10 01:37:07 2006
@@ -33,7 +33,7 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defconstant +workspace-window-classname+ "JCLUIT_WorkspaceWindow")
+(defconstant +workspace-window-classname+ "GraphicForms_WorkspaceWindow")
(defconstant +default-window-title+ "New Window")
@@ -43,19 +43,22 @@
;;; helper functions
;;;
+;; FIXME: causes GPF
+;;
(cffi:defcallback child_hwnd_collector
gfus::BOOL
((hwnd gfus::HANDLE)
(lparam gfus::LPARAM))
(let ((w (get-widget hwnd)))
(unless (or (null w) (null *child-visiting-functions*))
- (funcall (car *child-visiting-functions*) w lparam))))
+ (funcall (car *child-visiting-functions*) w lparam)))
+ 1)
-(defun visit-child-windows (win func val)
+(defun visit-child-widgets (win func val)
;;
;; supplied closure should accept two parameters:
- ;; current child window
- ;; long value passed to map-child-windows
+ ;; current child widget
+ ;; long value passed to visit-child-windows
;;
(push func *child-visiting-functions*)
(unwind-protect
@@ -163,7 +166,8 @@
(defmethod gfis:dispose ((win window))
(let ((m (menu-bar win)))
(unless (null m)
- (cleanup-menu-tables m)))
+ (visit-menu-tree m #'menu-cleanup-callback)
+ (remove-widget (gfis:handle m))))
(call-next-method))
(defmethod hide ((win window))
@@ -175,7 +179,7 @@
(return-from menu-bar nil))
(let ((m (get-widget hmenu)))
(if (null m)
- (error 'gfus:toolkit-error :detail "no object for hmenu"))
+ (error 'gfus:toolkit-error :detail "no object for menu handle"))
m)))
(defmethod (setf menu-bar) ((m menu) (win window))
More information about the Graphic-forms-cvs
mailing list