[graphic-forms-cvs] r191 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Jul 11 05:24:43 UTC 2006
Author: junrue
Date: Tue Jul 11 01:24:41 2006
New Revision: 191
Modified:
trunk/docs/manual/api.texinfo
trunk/src/demos/textedit/textedit-window.lisp
trunk/src/packages.lisp
trunk/src/uitoolkit/system/datastructs.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/edit.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/widget.lisp
Log:
defined and implemented sufficient new methods to implement edit control cut/copy/paste/delete functionality for a window Edit menu; full-blown general clipboard support is still down the road a bit
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Tue Jul 11 01:24:41 2006
@@ -117,13 +117,18 @@
@deffn GenericFunction disposed-p self
Returns T if @ref{dispose} has been called on @var{self} and the
-object has not since been re-initialized; returns nil otherwise.
-This function also returns T if @var{self} has been instantiated
-but secondary initialization code has not yet executed.
+object has not since been re-initialized; returns @sc{nil} otherwise.
+This function also returns T if @var{self} has been instantiated but
+secondary initialization code has not yet executed.
@end deffn
+ at defun empty-span-p span
+Returns T if the @var{start} and @var{end} of @code{span} are the same;
+ at sc{nil} otherwise.
+ at end defun
+
@deffn Macro location rect
-This macro returns the @code{location} slot of a @ref{rectangle}.
+This macro returns the @var{location} slot of a @ref{rectangle}.
@end deffn
@deffn Function make-point :x :y :z
@@ -1276,12 +1281,24 @@
Returns T if the object is in the checked state; nil otherwise.
@end deffn
+ at deffn GenericFunction clear-all self
+Clears all content from @code{self}.
+ at end deffn
+
@deffn GenericFunction clear-item self index
-Clears the item at the zero-based index.
+Clears the @ref{item} at the zero-based @var{index}.
+ at end deffn
+
+ at deffn GenericFunction clear-selection self
+Sets the selection status of @code{self} to @samp{not selected} or
+ at samp{empty}. For a @ref{control} with a text field component,
+such as an @ref{edit} control, this function deletes selected
+text.
@end deffn
- at deffn GenericFunction clear-span self sp
-Clears the items whose zero-based indices lie within the specified span.
+ at deffn GenericFunction clear-span self @ref{span}
+Clears the items from @var{self} whose zero-based indices lie within
+the specified @var{span}.
@end deffn
@deffn GenericFunction client-size self
@@ -1300,6 +1317,32 @@
enclose the specified desired client area and this object's trim.
@end deffn
+ at anchor{copy-text}
+ at deffn GenericFunction copy-text self
+This function is a shortcut for a common clipboard transfer operation,
+namely the transfer of text from @code{self} to the system clipboard.
+The existing content of @code{self} remains in place. Some @ref{control}s
+like the @ref{edit} control have built-in clipboard functionality, and
+in such cases, the implementation of this function delegates directly.
+See @ref{cut-text}, @ref{paste-text}, and @ref{text-for-pasting-p}.@*@*
+ at strong{Note:} an upcoming release will include more general
+infrastructure for clipboard operations.
+ at end deffn
+
+ at anchor{cut-text}
+ at deffn GenericFunction cut-text self
+This function is a shortcut for a common clipboard transfer operation,
+namely the transfer of text from @code{self} to the system clipboard
+and removal of content from @code{self}. Some @ref{control}s like the
+ at ref{edit} control have built-in clipboard functionality, and in such
+cases, the implementation of this function delegates directly. For
+other @ref{widget}s, this operation is a wrapper around a copy/delete
+sequence. See @ref{copy-text}, @ref{paste-text}, and
+ at ref{text-for-pasting-p}.@*@*
+ at strong{Note:} an upcoming release will
+include more general infrastructure for clipboard operations.
+ at end deffn
+
@deffn GenericFunction default-widget self
Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil}
if none has been set. If @sc{nil} is passed to the corresponding
@@ -1509,6 +1552,19 @@
@end quotation
@end deffn
+ at anchor{paste-text}
+ at deffn GenericFunction paste-text self
+This function is a shortcut for a common clipboard transfer operation,
+namely the transfer of text from the system clipboard to @code{self}.
+Depending on the current selection within @code{self}, the text either
+gets inserted or existing content is replaced. Some @ref{control}s like the
+ at ref{edit} control have built-in clipboard functionality, and in such
+cases, the implementation of this function delegates directly. See
+ at ref{copy-text}, @ref{cut-text}, and @ref{text-for-pasting-p}.@*@*
+ at strong{Note:} an upcoming release will include more
+general infrastructure for clipboard operations.
+ at end deffn
+
@anchor{preferred-size}
@deffn GenericFunction preferred-size self width-hint height-hint
Implement this function to return @code{self}'s preferred @ref{size};
@@ -1550,6 +1606,12 @@
decorations are modified appropriately.
@end deffn
+ at deffn GenericFunction selection-span self => @ref{span}
+Returns a span object describing the start and end of the selection
+within @var{self}. If there is no selection, this function returns
+ at sc{nil}.
+ at end deffn
+
@anchor{show}
@deffn GenericFunction show self flag
Causes the object to be visible or hidden on the screen, but not
@@ -1579,6 +1641,16 @@
the custom control will be managed by a @ref{layout-manager}.
@end deffn
+ at anchor{text-for-pasting-p}
+ at deffn GenericFunction text-for-pasting-p self
+This function is a shortcut means of checking the clipboard for existence
+of data of a specific type (text). This status information is typically
+used to enable or disable a @samp{Paste} menu item. See @ref{copy-text},
+ at ref{cut-text}, and @ref{paste-text}.@*@*
+ at strong{Note:} an upcoming release will include more general
+infrastructure for clipboard operations.
+ at end deffn
+
@anchor{text-modified-p}
@deffn GenericFunction text-modified-p self
Returns T if the text component of @code{self} has been modified by
Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp (original)
+++ trunk/src/demos/textedit/textedit-window.lisp Tue Jul 11 01:24:41 2006
@@ -90,8 +90,32 @@
(declare (ignore disp))
(unless *textedit-control*
(return-from manage-textedit-edit-menu nil))
- (let ((items (gfw:items menu)))
- (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*))))
+ (let ((items (gfw:items menu))
+ (text-sel (gfw:selection-span *textedit-control*)))
+ (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*))
+ (gfw:enable (elt items 2) text-sel)
+ (gfw:enable (elt items 3) text-sel)
+ (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*))
+ (gfw:enable (elt items 5) text-sel)))
+
+(defun textedit-edit-copy (disp item)
+ (declare (ignore disp item))
+ (gfw:copy-text *textedit-control*))
+
+(defun textedit-edit-cut (disp item)
+ (declare (ignore disp item))
+ (gfw:cut-text *textedit-control*))
+
+(defun textedit-edit-delete (disp item)
+ (declare (ignore disp item))
+ (gfw:clear-selection *textedit-control*))
+
+(defun textedit-edit-paste (disp item)
+ (declare (ignore disp item))
+ (gfw:paste-text *textedit-control*))
+
+(defun textedit-edit-undo (disp item)
+ (declare (ignore disp item)))
(defun textedit-font (disp item)
(declare (ignore disp item))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Tue Jul 11 01:24:41 2006
@@ -65,6 +65,7 @@
#:detail
#:dispose
#:disposed-p
+ #:empty-span-p
#:equal-size-p
#:flatten
#:handle
@@ -343,11 +344,11 @@
#:column-order
#:columns
#:compute-outer-size
- #:copy
#:copy-area
+ #:copy-text
+ #:cut-text
#:current-font
#:cursor
- #:cut
#:default-message-filter
#:default-widget
#:defmenu
@@ -447,7 +448,7 @@
#:pack
#:page-increment
#:parent
- #:paste
+ #:paste-text
#:peer
#:preferred-size
#:primary-p
@@ -485,6 +486,7 @@
#:sub-menu
#:text
#:text-baseline
+ #:text-for-pasting-p
#:text-height
#:text-limit
#:text-modified-p
Modified: trunk/src/uitoolkit/system/datastructs.lisp
==============================================================================
--- trunk/src/uitoolkit/system/datastructs.lisp (original)
+++ trunk/src/uitoolkit/system/datastructs.lisp Tue Jul 11 01:24:41 2006
@@ -47,6 +47,9 @@
(defmacro size (rect)
`(rectangle-size ,rect))
+(defun empty-span-p (span)
+ (= (span-start span) (span-end span)))
+
(defun equal-size-p (size1 size2)
(and (= (size-width size1) (size-width size2))
(= (size-height size1) (size-height size2))))
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Tue Jul 11 01:24:41 2006
@@ -142,6 +142,30 @@
(defconstant +cderr-nohook+ #x000B)
(defconstant +cderr-registermsgfail+ #x000C)
+;;;
+;;; clipboard-related constants
+;;;
+(defconstant +cf-text+ 1)
+(defconstant +cf-bitmap+ 2)
+(defconstant +cf-metafilepict+ 3)
+(defconstant +cf-sylk+ 4)
+(defconstant +cf-dif+ 5)
+(defconstant +cf-tiff+ 6)
+(defconstant +cf-oemtext+ 7)
+(defconstant +cf-dib+ 8)
+(defconstant +cf-palette+ 9)
+(defconstant +cf-pendata+ 10)
+(defconstant +cf-riff+ 11)
+(defconstant +cf-wave+ 12)
+(defconstant +cf-unicodetext+ 13)
+(defconstant +cf-enhmetafile+ 14)
+(defconstant +cf-hdrop+ 15)
+(defconstant +cf-locale+ 16)
+(defconstant +cf-dibv5+ 17)
+
+;;;
+;;; font-related constants
+;;;
(defconstant +cf-screenfonts+ #x00000001)
(defconstant +cf-printerfonts+ #x00000002)
(defconstant +cf-both+ #x00000003)
@@ -985,6 +1009,29 @@
(defconstant +wm-mousehover+ #x02A1)
(defconstant +wm-ncmouseleave+ #x02A2)
(defconstant +wm-mouseleave+ #x02A3)
+(defconstant +wm-cut+ #x0300)
+(defconstant +wm-copy+ #x0301)
+(defconstant +wm-paste+ #x0302)
+(defconstant +wm-clear+ #x0303)
+(defconstant +wm-undo+ #x0304)
+(defconstant +wm-renderformat+ #x0305)
+(defconstant +wm-renderallformats+ #x0306)
+(defconstant +wm-destroyclipboard+ #x0307)
+(defconstant +wm-drawclipboard+ #x0308)
+(defconstant +wm-paintclipboard+ #x0309)
+(defconstant +wm-vscrollclipboard+ #x030A)
+(defconstant +wm-sizeclipboard+ #x030B)
+(defconstant +wm-askcbformatname+ #x030C)
+(defconstant +wm-changecbchain+ #x030D)
+(defconstant +wm-hscrollclipboard+ #x030E)
+(defconstant +wm-querynewpalette+ #x030F)
+(defconstant +wm-paletteischanging+ #x0310)
+(defconstant +wm-palettechanged+ #x0311)
+(defconstant +wm-hotkey+ #x0312)
+(defconstant +wm-print+ #x0317)
+(defconstant +wm-printclient+ #x0318)
+(defconstant +wm-appcommand+ #x0319)
+(defconstant +wm-themechanged+ #x031A)
(defconstant +wm-user-base+ #x0400)
(defconstant +wm-app-base+ #x8000)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Tue Jul 11 01:24:41 2006
@@ -454,6 +454,11 @@
(erase BOOL))
(defcfun
+ ("IsClipboardFormatAvailable" is-clipboard-format-available)
+ BOOL
+ (format UINT))
+
+(defcfun
("IsDialogMessageA" is-dialog-message)
BOOL
(hwnd HANDLE)
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jul 11 01:24:41 2006
@@ -48,6 +48,9 @@
(let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
(= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+)))
+(defmethod clear-selection ((self edit))
+ (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0))
+
(defmethod compute-style-flags ((self edit) &rest extra-data)
(declare (ignore extra-data))
(let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+))
@@ -74,6 +77,12 @@
(setf std-flags (logior std-flags gfs::+es-autohscroll+)))
(values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+))))
+(defmethod copy-text ((self edit))
+ (gfs::send-message (gfs:handle self) gfs::+wm-copy+ 0 0))
+
+(defmethod cut-text ((self edit))
+ (gfs::send-message (gfs:handle self) gfs::+wm-cut+ 0 0))
+
(defmethod enable-scrollbars ((self edit) horizontal vertical)
(let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
(if horizontal
@@ -102,6 +111,9 @@
(error 'gfs:disposed-error))
(gfs::send-message (gfs:handle self) gfs::+em-getlinecount+ 0 0))
+(defmethod paste-text ((self edit))
+ (gfs::send-message (gfs:handle self) gfs::+wm-paste+ 0 0))
+
(defmethod preferred-size ((self edit) width-hint height-hint)
(let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+)))
(size (gfs:make-size))
@@ -118,6 +130,17 @@
(* +vertical-edit-text-margin+ 2))))
size))
+(defmethod selection-span ((self edit))
+ (cffi:with-foreign-object (start-ptr :unsigned-long)
+ (cffi:with-foreign-object (end-ptr :unsigned-long)
+ (gfs::send-message (gfs:handle self)
+ gfs::+em-getsel+
+ (cffi:pointer-address start-ptr)
+ (cffi:pointer-address end-ptr))
+ (let ((start (cffi:mem-ref start-ptr :unsigned-long))
+ (end (cffi:mem-ref end-ptr :unsigned-long)))
+ (if (= start end) nil (gfs:make-span :start start :end end))))))
+
(defmethod text ((self edit))
(get-widget-text self))
@@ -127,6 +150,9 @@
(defmethod text-baseline ((self edit))
(widget-text-baseline self +vertical-edit-text-margin+))
+(defmethod text-for-pasting-p ((self edit))
+ (/= (gfs::is-clipboard-format-available gfs::+cf-text+) 0))
+
(defmethod text-modified-p ((self edit))
(/= (gfs::send-message (gfs:handle self) gfs::+em-getmodify+ 0 0) 0))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Jul 11 01:24:41 2006
@@ -84,6 +84,9 @@
(defgeneric checked-p (self)
(:documentation "Returns T if the object is in the checked state; nil otherwise."))
+(defgeneric clear-all (self)
+ (:documentation "Clears all content from self."))
+
(defgeneric clear-item (self index)
(:documentation "Clears the item at the zero-based index."))
@@ -117,14 +120,14 @@
(defgeneric compute-outer-size (self desired-client-size)
(:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim."))
-(defgeneric copy (self)
- (:documentation "Copies the current selection to the clipboard."))
+(defgeneric copy-text (self)
+ (:documentation "Copies the current text selection to the clipboard."))
(defgeneric cursor (self)
(:documentation "Returns the cursor object associated with this object."))
-(defgeneric cut (self)
- (:documentation "Copies the current selection to the clipboard and removes it from the object."))
+(defgeneric cut-text (self)
+ (:documentation "Copies the current text selection to the clipboard and removes it from self."))
(defgeneric default-widget (self)
(:documentation "Returns the child widget or item that has the default emphasis."))
@@ -261,8 +264,8 @@
(defgeneric parent (self)
(:documentation "Returns the object's parent."))
-(defgeneric paste (self)
- (:documentation "Copies content from the clipboard into the object."))
+(defgeneric paste-text (self)
+ (:documentation "Copies text from the clipboard into self"))
(defgeneric peer (self)
(:documentation "Returns the visual object associated with this object (not the underlying window system handle)."))
@@ -322,7 +325,7 @@
(:documentation "Returns a list of zero-based indices identifying the selected items within this object."))
(defgeneric selection-span (self)
- (:documentation "Returns a span object describing the start and end indices of the object selection."))
+ (:documentation "Returns a span object describing the start and end indices of the selection within self."))
(defgeneric show (self flag)
(:documentation "Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order."))
@@ -354,6 +357,9 @@
(defgeneric text-baseline (self)
(:documentation "Returns the y coordinate of the object's text component, if any."))
+(defgeneric text-for-pasting-p (self)
+ (:documentation "Returns T if the clipboard has data in text format; nil otherwise."))
+
(defgeneric text-height (self)
(:documentation "Returns the height of the object's text field."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Tue Jul 11 01:24:41 2006
@@ -91,11 +91,6 @@
(gfg::destroy-magick)
(gfs::post-quit-message exit-code))
-(defun clear-all (w)
- (let ((count (length (items w))))
- (unless (zerop count)
- (gfw:clear-span w (gfs:make-span :start 0 :end (1- count))))))
-
(defun initialize-comctl-classes (icc-flags)
(cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex)
(cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex)
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 Tue Jul 11 01:24:41 2006
@@ -33,40 +33,45 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled)
+(defmethod append-item :before ((self widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled)
(declare (ignore text image disp checked disabled))
- (if (gfs:disposed-p w)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod clear-item :before ((w widget-with-items) index)
+(defmethod clear-all ((self widget-with-items))
+ (let ((count (length (items self))))
+ (unless (zerop count)
+ (clear-span self (gfs:make-span :start 0 :end (1- count))))))
+
+(defmethod clear-item :before ((self widget-with-items) index)
(declare (ignore index))
- (if (gfs:disposed-p w)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod clear-item ((w widget-with-items) index)
- (let* ((items (items w))
+(defmethod clear-item ((self widget-with-items) index)
+ (let* ((items (items self))
(it (elt items index)))
- (delete it (items w) :test #'items-equal-p)
+ (delete it (items self) :test #'items-equal-p)
(if (gfs:disposed-p it)
(error 'gfs:disposed-error))
(gfs:dispose it)))
-(defmethod clear-span :before ((w widget-with-items) (sp gfs:span))
+(defmethod clear-span :before ((self widget-with-items) (sp gfs:span))
(declare (ignore sp))
- (if (gfs:disposed-p w)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod clear-span ((w widget-with-items) (sp gfs:span))
+(defmethod clear-span ((self widget-with-items) (sp gfs:span))
(dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp))))
- (clear-item w (gfs:span-start sp))))
+ (clear-item self (gfs:span-start sp))))
-(defmethod item-index :before ((w widget-with-items) (it item))
+(defmethod item-index :before ((self widget-with-items) (it item))
(declare (ignore it))
- (if (gfs:disposed-p w)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod item-index ((w widget-with-items) (it item))
- (let ((pos (position it (items w) :test #'items-equal-p)))
+(defmethod item-index ((self widget-with-items) (it item))
+ (let ((pos (position it (items self) :test #'items-equal-p)))
(if (null pos)
(return-from item-index 0))
0))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Tue Jul 11 01:24:41 2006
@@ -125,19 +125,27 @@
(defmethod center-on-parent ((self widget))
(center-object (parent self) self))
-(defmethod checked-p :before ((w widget))
- (if (gfs:disposed-p w)
+(defmethod checked-p :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod checked-p ((w widget))
- (declare (ignore w))
+(defmethod checked-p ((self widget))
+ (declare (ignore self))
nil)
-(defmethod client-size :before ((w widget))
- (if (gfs:disposed-p w)
+(defmethod clear-all :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod clear-selection :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod client-size ((w widget))
+(defmethod client-size :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod client-size ((self widget))
(cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
(cffi:with-foreign-slots ((gfs::cbsize
gfs::clientleft
@@ -146,19 +154,27 @@
gfs::clientbottom)
wi-ptr gfs::windowinfo)
(setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
- (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr))
+ (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr))
(error 'gfs:win32-error :detail "get-window-info failed"))
(gfs:make-size :width (- gfs::clientright gfs::clientleft)
:height (- gfs::clientbottom gfs::clienttop)))))
-(defmethod gfs:dispose ((w widget))
- (unless (null (dispatcher w))
- (event-dispose (dispatcher w) w))
- (let ((hwnd (gfs:handle w)))
+(defmethod copy-text :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod cut-text :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod gfs:dispose ((self widget))
+ (unless (null (dispatcher self))
+ (event-dispose (dispatcher self) self))
+ (let ((hwnd (gfs:handle self)))
(if (not (gfs:null-handle-p hwnd))
(if (zerop (gfs::destroy-window hwnd))
(error 'gfs:win32-error :detail "destroy-window failed"))))
- (setf (slot-value w 'gfs:handle) nil))
+ (setf (slot-value self 'gfs:handle) nil))
(defmethod enable :before ((self widget) flag)
(declare (ignore flag))
@@ -254,6 +270,10 @@
(error 'gfs:toolkit-error :detail "no widget for hwnd")))
widget))
+(defmethod paste-text :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
(defmethod print-object ((self widget) stream)
(print-unreadable-object (self stream :type t)
(format stream "handle: ~x " (gfs:handle self))
@@ -290,6 +310,10 @@
(declare (ignore self))
nil)
+(defmethod selection-span :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
(defmethod size :before ((self widget))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
@@ -326,6 +350,13 @@
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
+(defmethod text-for-pasting-p :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod text-for-pasting-p ((self widget))
+ nil)
+
(defmethod (setf text-modified-p) :before (flag (self widget))
(declare (ignore flag))
(if (gfs:disposed-p self)
More information about the Graphic-forms-cvs
mailing list