[graphic-forms-cvs] r244 - in trunk: . docs/manual src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Aug 30 04:57:26 UTC 2006
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
- at macro begin-control-subclass{classname,descr,callbackname}
- at anchor{\classname\}
- at deftp Class \classname\ callback-event-name
-\descr\
- at table @var
+ at 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.
+ at end macro
+
+ at macro begin-control-subclass{classname,descr,callbackname}
+ at anchor{\classname\}
+ at deftp Class \classname\ callback-event-name
+\descr\
+ at table @var
+ at 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
+ at 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
+ at anchor{list-item}
+ at deftp Class list-item index
+A subclass of @ref{item} representing an element of a @ref{list-box}.
+ at table @var
+ at item index
+This is an internal value representing the position of the item
+within the list-box control.
+ at end table
+ at 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
More information about the Graphic-forms-cvs
mailing list