Author: junrue Date: Wed Aug 30 00:57:25 2006 New Revision: 244

Added: trunk/src/uitoolkit/widgets/list-item.lisp Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/widgets/item-manager.lisp trunk/src/uitoolkit/widgets/item.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: refactored more of menu-item, implemented new list-item class

Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Wed Aug 30 00:57:25 2006 @@ -104,17 +104,21 @@ @end deffn @end macro

-@macro begin-control-subclass{classname,descr,callbackname} -@anchor{\classname} -@deftp Class \classname\ callback-event-name -\descr\ -@table @var +@macro callback-event-name-slot{callbackname} @item callback-event-name This is an @code{(:allocation :class)} slot that holds the symbol @sc{@ref{\callbackname}} identifying the event generic function to be implemented on behalf of the application when a function is supplied for the @code{:callback} initarg. See @ref{event-source} for more details on this slot. +@end macro + +@macro begin-control-subclass{classname,descr,callbackname} +@anchor{\classname} +@deftp Class \classname\ callback-event-name +\descr\ +@table @var +@callback-event-name-slot{\callbackname} @end table @end macro

Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Wed Aug 30 00:57:25 2006 @@ -65,6 +65,7 @@ interface objects serving as subcomponents of an @ref{item-manager}. It derives from @ref{event-source}. @table @var +@callback-event-name-slot{event-select} @item data A reference to the application-defined object to be wrapped by the item. @@ -120,6 +121,16 @@ @end deffn @end deftp

+@anchor{list-item} +@deftp Class list-item index +A subclass of @ref{item} representing an element of a @ref{list-box}. +@table @var +@item index +This is an internal value representing the position of the item +within the list-box control. +@end table +@end deftp + @anchor{menu} @deftp Class menu This class represents a container for menu items and submenus. It

Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Aug 30 00:57:25 2006 @@ -132,6 +132,7 @@ (:file "label") (:file "button") (:file "item-manager") + (:file "list-item") (:file "list-box") (:file "menu") (:file "menu-item")

Modified: trunk/src/uitoolkit/widgets/item-manager.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item-manager.lisp (original) +++ trunk/src/uitoolkit/widgets/item-manager.lisp Wed Aug 30 00:57:25 2006 @@ -85,6 +85,12 @@ (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp)))) (delete-item self (gfs:span-start sp))))

+(defmethod gfs:dispose ((self item-manager)) + (let ((items (items-of self)) + (tc (thread-context))) + (dotimes (i (length items)) + (delete-tc-item tc (elt items i))))) + (defmethod item-index :before ((self item-manager) (it item)) (declare (ignore it)) (if (gfs:disposed-p self)

Modified: trunk/src/uitoolkit/widgets/item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/item.lisp (original) +++ trunk/src/uitoolkit/widgets/item.lisp Wed Aug 30 00:57:25 2006 @@ -33,16 +33,20 @@

(in-package :graphic-forms.uitoolkit.widgets)

-(defun create-item-with-callback (howner thing disp) +;;; +;;; helper functions +;;; + +(defun create-item-with-callback (howner class-symbol thing disp) (let ((item nil) (id (increment-item-id (thread-context)))) (cond ((null disp) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner))) ((functionp disp) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :callback disp))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner :callback disp))) ((typep disp 'gfw:event-dispatcher) - (setf item (make-instance 'menu-item :item-id id :data thing :handle howner :dispatcher disp))) + (setf item (make-instance class-symbol :item-id id :data thing :handle howner :dispatcher disp))) (t (error 'gfs:toolkit-error :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) @@ -51,6 +55,10 @@ (defun items-equal-p (item1 item2) (= (item-id item1) (item-id item2)))

+;;; +;;; methods +;;; + (defmethod check :before ((self item) flag) (declare (ignore flag)) (if (gfs:null-handle-p (gfs:handle self)) @@ -59,3 +67,26 @@ (defmethod checked-p :before ((self item)) (if (gfs:null-handle-p (gfs:handle self)) (error 'gfs:toolkit-error :detail "null owner handle"))) + +(defmethod gfs:dispose ((self item)) + (setf (dispatcher self) nil) + (delete-tc-item (thread-context) self) + (setf (data-of self) nil) + (setf (item-id self) 0) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod initialize-instance :after ((self item) &key callback &allow-other-keys) + (when callback + (unless (typep callback 'function) + (error 'gfs:toolkit-error :detail ":callback value must be a function")) + (setf (dispatcher self) + (make-instance (define-dispatcher (class-name (class-of self)) callback))))) + +(defmethod owner ((self item)) + (let ((hwnd (gfs:handle self))) + (if (gfs:null-handle-p hwnd) + (error 'gfs:toolkit-error :detail "null owner widget handle")) + (let ((widget (get-widget (thread-context) hwnd))) + (if (null widget) + (error 'gfs:toolkit-error :detail "no owner widget")) + widget)))

Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Wed Aug 30 00:57:25 2006 @@ -53,7 +53,7 @@ (let* ((tc (thread-context)) (hcontrol (gfs:handle self)) (text (call-text-provider self thing)) - (item (create-item-with-callback hcontrol thing disp))) + (item (create-item-with-callback hcontrol 'list-item thing disp))) (insert-list-item hcontrol -1 text (cffi:null-pointer)) (put-item tc item) (vector-push-extend item (items-of self)) @@ -125,5 +125,8 @@ (progn (gfs::send-message hwnd gfs::+lb-resetcontent+ 0 0) (loop for item in items - do (append-item self item (dispatcher self)))) + for index = 0 then (1+ index) + do (progn + (setf (index-of item) index) + (append-item self item (dispatcher self))))) (enable-redraw self t))))

Added: trunk/src/uitoolkit/widgets/list-item.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/list-item.lisp Wed Aug 30 00:57:25 2006 @@ -0,0 +1,46 @@ +;;;; +;;;; list-item.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.widgets) + +;;; +;;; methods +;;; + +(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)) + (setf (index-of self) 0)) + (call-next-method))

Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Wed Aug 30 00:57:25 2006 @@ -170,65 +170,47 @@ ;;; methods ;;;

-(defmethod check ((it menu-item) flag) - (let ((hmenu (gfs:handle it))) - (check-menuitem hmenu (item-id it) flag))) +(defmethod check ((self menu-item) flag) + (let ((hmenu (gfs:handle self))) + (check-menuitem hmenu (item-id self) flag)))

-(defmethod checked-p ((it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod checked-p ((self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (is-menuitem-checked hmenu (item-id it)))) + (is-menuitem-checked hmenu (item-id self))))

-(defmethod gfs:dispose ((it menu-item)) - (setf (dispatcher it) nil) - (delete-tc-item (thread-context) it) - (let ((id (item-id it)) - (owner (owner it))) +(defmethod gfs:dispose ((self menu-item)) + (let ((id (item-id self)) + (owner (owner self))) (unless (null owner) (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) - (let* ((index (item-index owner it)) + (let* ((index (item-index owner self)) (child-menu (sub-menu owner index))) (unless (null child-menu) - (gfs:dispose child-menu)))) - (setf (item-id it) 0) - (setf (slot-value it 'gfs:handle) nil))) + (gfs:dispose child-menu))))) + (call-next-method))

-(defmethod enable ((it menu-item) flag) +(defmethod enable ((self menu-item) flag) (let ((bits 0)) (if flag (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-enabled+)) (setf bits (logior gfs::+mf-bycommand+ gfs::+mfs-grayed+))) - (gfs::enable-menu-item (gfs:handle it) (item-id it) bits))) + (gfs::enable-menu-item (gfs:handle self) (item-id self) bits)))

-(defmethod enabled-p ((it menu-item)) - (= (logand (get-menuitem-state (gfs:handle it) (item-id it)) +(defmethod enabled-p ((self menu-item)) + (= (logand (get-menuitem-state (gfs:handle self) (item-id self)) gfs::+mfs-enabled+) gfs::+mfs-enabled+))

-(defmethod initialize-instance :after ((self menu-item) &key callback &allow-other-keys) - (when callback - (unless (typep callback 'function) - (error 'gfs:toolkit-error :detail ":callback value must be a function")) - (setf (dispatcher self) (make-instance (define-dispatcher 'menu-item callback))))) - -(defmethod owner ((it menu-item)) - (let ((hmenu (gfs:handle it))) - (if (gfs:null-handle-p hmenu) - (error 'gfs:toolkit-error :detail "null owner menu handle")) - (let ((m (get-widget (thread-context) hmenu))) - (if (null m) - (error 'gfs:toolkit-error :detail "no owner menu")) - m))) - -(defmethod text ((it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod text ((self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (get-menuitem-text hmenu (item-id it)))) + (get-menuitem-text hmenu (item-id self))))

-(defmethod (setf text) (str (it menu-item)) - (let ((hmenu (gfs:handle it))) +(defmethod (setf text) (str (self menu-item)) + (let ((hmenu (gfs:handle self))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) - (set-menuitem-text hmenu (item-id it) str))) + (set-menuitem-text hmenu (item-id self) str)))

Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Wed Aug 30 00:57:25 2006 @@ -93,7 +93,7 @@ (defmethod append-item ((self menu) thing disp &optional disabled checked) (let* ((tc (thread-context)) (hmenu (gfs:handle self)) - (item (create-item-with-callback hmenu thing disp)) + (item (create-item-with-callback hmenu 'menu-item thing disp)) (text (call-text-provider self thing))) (append-menuitem hmenu (item-id item) text (cffi:null-pointer) (cffi:null-pointer) disabled checked) (put-item tc item) @@ -141,11 +141,13 @@ (delete-widget tc (gfs:handle menu)) (delete-tc-item tc item)))

-(defmethod gfs:dispose ((m menu)) - (visit-menu-tree m #'menu-cleanup-callback) - (let ((hwnd (gfs:handle m))) - (delete-widget (thread-context) hwnd) - (if (not (gfs:null-handle-p hwnd)) +(defmethod gfs:dispose ((self menu)) + (unless (null (dispatcher self)) + (event-dispose (dispatcher self) self)) + (visit-menu-tree self #'menu-cleanup-callback) + (let ((hwnd (gfs:handle self))) + (when (not (gfs:null-handle-p hwnd)) + (delete-widget (thread-context) hwnd) (if (zerop (gfs::destroy-menu hwnd)) (error 'gfs:win32-error :detail "destroy-menu failed")))) - (setf (slot-value m 'gfs:handle) nil)) + (setf (slot-value self 'gfs:handle) nil))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Aug 30 00:57:25 2006 @@ -90,8 +90,14 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects."))

+(defclass list-item (item) + ((index + :accessor index-of + :initform 0)) + (:documentation "A subclass of item representing an element of a list-box.")) + (defclass menu-item (item) () - (:documentation "A subtype of item representing a menu item.")) + (:documentation "A subclass of item representing a menu item."))

(defclass widget (event-source) ((style