[graphic-forms-cvs] r184 - in trunk: . docs/manual src src/demos/textedit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Jul 7 22:37:46 UTC 2006
Author: junrue
Date: Fri Jul 7 18:37:45 2006
New Revision: 184
Added:
trunk/src/demos/textedit/textedit-document.lisp
Modified:
trunk/docs/manual/api.texinfo
trunk/graphic-forms-tests.asd
trunk/src/demos/textedit/textedit-window.lisp
trunk/src/packages.lisp
trunk/src/uitoolkit/widgets/edit.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
defined text-modified-p generic function and implemented it for edit controls; added initial model definition for textedit demo
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Fri Jul 7 18:37:45 2006
@@ -1316,6 +1316,15 @@
the custom control will be managed by a @ref{layout-manager}.
@end deffn
+ at anchor{text-modified-p}
+ at deffn GenericFunction text-modified-p self
+Returns T if the text component of @code{self} has been modified by
+the user; @sc{nil} otherwise. The corresponding @sc{setf} function
+updates the dirty state flag. This function is not implemented for all
+widgets, since in some cases there are multiple text components and in
+other cases there is no text component at all.
+ at end deffn
+
@deffn GenericFunction update self
Forces all outstanding paint requests for the object to be processed
before this function returns.
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Fri Jul 7 18:37:45 2006
@@ -61,7 +61,8 @@
:components
((:module "textedit"
:components
- ((:file "textedit-window")))
+ ((:file "textedit-document")
+ (:file "textedit-window")))
(:module "unblocked"
:components
((:file "tiles")
Added: trunk/src/demos/textedit/textedit-document.lisp
==============================================================================
--- (empty file)
+++ trunk/src/demos/textedit/textedit-document.lisp Fri Jul 7 18:37:45 2006
@@ -0,0 +1,44 @@
+;;;;
+;;;; textedit-document.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)
+
+(cells:defmodel textedit-document ()
+ ((content-replaced
+ :cell :ephemeral
+ :accessor content-replaced
+ :initform (cells:c-in nil))
+ (content-modified
+ :cell :ephemeral
+ :accessor content-modified
+ :initform (cells:c-in nil))))
Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp (original)
+++ trunk/src/demos/textedit/textedit-window.lisp Fri Jul 7 18:37:45 2006
@@ -37,10 +37,35 @@
(defvar *textedit-win* nil)
(defvar *textedit-startup-dir* nil)
+(defun manage-textedit-file-menu (disp menu time)
+ (declare (ignore disp time))
+ (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)))
+
(defun new-textedit-doc (disp item time rect)
(declare (ignore disp item time rect))
- (if *textedit-control*
- (setf (gfw:text *textedit-control*) "")))
+ (when *textedit-control*
+ (setf (gfw:text *textedit-control*) "")
+ (setf (gfw:text-modified-p *textedit-control*) nil)))
+
+(defun open-textedit-doc (disp item time rect)
+ (declare (ignore disp item time rect))
+ (gfw:with-file-dialog (*textedit-win*
+ '(:open :add-to-recent :path-must-exist)
+ paths
+ :filters '(("Text Files (*.txt)" . "*.txt")
+ ("All Files (*.*)" . "*.*")))))
+
+(defun save-textedit-doc (disp item time rect)
+ (declare (ignore disp item time rect)))
+
+(defun save-as-textedit-doc (disp item time rect)
+ (declare (ignore disp item time rect))
+ (gfw:with-file-dialog (*textedit-win*
+ '(:save :add-to-recent)
+ paths
+ :filters '(("Text Files (*.txt)" . "*.txt")
+ ("All Files (*.*)" . "*.*"))
+ :text "Save As")))
(defun quit-textedit (disp item time rect)
(declare (ignore disp item time rect))
@@ -131,16 +156,22 @@
(gfw:center-on-owner dlg)
(gfw:show dlg t)))
+(cells:defobserver content-replaced ((self textedit-document))
+ (if *textedit-control*
+ (setf (gfw:text *textedit-control*) (content-replaced self))))
+
+(cells:defobserver content-modified ((self textedit-document)))
+
(defun textedit-startup ()
#+clisp
(setf *textedit-startup-dir* (ext:cd))
#+lispworks
(setf *textedit-startup-dir* (hcl:get-working-directory))
- (let ((menubar (gfw:defmenu ((:item "&File"
+ (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu
:submenu ((:item "&New" :callback #'new-textedit-doc)
- (:item "&Open...")
- (:item "&Save")
- (:item "Save &As...")
+ (:item "&Open..." :callback #'open-textedit-doc)
+ (:item "&Save" :callback #'save-textedit-doc :disabled)
+ (:item "Save &As..." :callback #'save-as-textedit-doc)
(:item "" :separator)
(:item "E&xit" :callback #'quit-textedit)))
(:item "&Edit"
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Fri Jul 7 18:37:45 2006
@@ -486,6 +486,7 @@
#:text-baseline
#:text-height
#:text-limit
+ #:text-modified-p
#:thumb-size
#:tooltip-text
#:top-child-of
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Fri Jul 7 18:37:45 2006
@@ -126,3 +126,9 @@
(defmethod text-baseline ((self edit))
(widget-text-baseline self +vertical-edit-text-margin+))
+
+(defmethod text-modified-p ((self edit))
+ (/= (gfs::send-message (gfs:handle self) gfs::+em-getmodify+ 0 0) 0))
+
+(defmethod (setf text-modified-p) (flag (self edit))
+ (gfs::send-message (gfs:handle self) gfs::+em-setmodify+ (if flag 1 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 Fri Jul 7 18:37:45 2006
@@ -357,6 +357,9 @@
(defgeneric text-limit (self)
(:documentation "Returns the number of characters that the object's text field is capable of holding."))
+(defgeneric text-modified-p (self)
+ (:documentation "Returns true if the text component has been modified; nil otherwise."))
+
(defgeneric thumb-size (self)
(:documentation "Returns an integer representing the width (or height) of this object's thumb."))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Fri Jul 7 18:37:45 2006
@@ -319,18 +319,27 @@
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
+(defmethod (setf text-modified-p) :before (flag (self widget))
+ (declare (ignore flag))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod text-modified-p :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
(defmethod update :before ((w widget))
(if (gfs:disposed-p w)
(error 'gfs:disposed-error)))
-(defmethod update ((w widget))
- (let ((hwnd (gfs:handle w)))
+(defmethod update ((self widget))
+ (let ((hwnd (gfs:handle self)))
(unless (gfs:null-handle-p hwnd)
(gfs::update-window hwnd))))
-(defmethod visible-p :before ((w widget))
- (if (gfs:disposed-p w)
+(defmethod visible-p :before ((self widget))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod visible-p ((w widget))
- (not (zerop (gfs::is-window-visible (gfs:handle w)))))
+(defmethod visible-p ((self widget))
+ (not (zerop (gfs::is-window-visible (gfs:handle self)))))
More information about the Graphic-forms-cvs
mailing list