graphic-forms-cvs
Threads by month
- ----- 2025 -----
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
July 2006
- 1 participants
- 31 discussions
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r198 - in trunk: . src src/uitoolkit/graphics src/uitoolkit/graphics/plugins src/uitoolkit/graphics/plugins/imagemagick src/uitoolkit/widgets
by junrue@common-lisp.net 17 Jul '06
by junrue@common-lisp.net 17 Jul '06
17 Jul '06
Author: junrue
Date: Mon Jul 17 00:48:13 2006
New Revision: 198
Added:
trunk/src/uitoolkit/graphics/plugins/
trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp
trunk/src/uitoolkit/graphics/plugins/imagemagick/
trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp
- copied, changed from r153, trunk/src/uitoolkit/graphics/magick-core-api.lisp
trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp
- copied, changed from r58, trunk/src/uitoolkit/graphics/magick-core-types.lisp
trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
Removed:
trunk/src/uitoolkit/graphics/magick-core-api.lisp
trunk/src/uitoolkit/graphics/magick-core-types.lisp
Modified:
trunk/graphic-forms-uitoolkit.asd
trunk/src/packages.lisp
trunk/src/uitoolkit/graphics/graphics-classes.lisp
trunk/src/uitoolkit/graphics/graphics-generics.lisp
trunk/src/uitoolkit/graphics/image-data.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
created a plugin system for choosing what library code to load for image data processing, moved existing ImageMagick support into such a plugin
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Mon Jul 17 00:48:13 2006
@@ -69,9 +69,7 @@
(:module "graphics"
:depends-on ("system")
:components
- ((:file "magick-core-types")
- (:file "magick-core-api")
- (:file "graphics-constants")
+ ((:file "graphics-constants")
(:file "graphics-classes")
(:file "graphics-generics")
(:file "color")
@@ -80,7 +78,18 @@
(:file "image")
(:file "font-data")
(:file "font")
- (:file "graphics-context")))
+ (:file "graphics-context")
+ (:module "plugins"
+ :components
+ ((:file "graphics-plugin-packages")
+#+load-imagemagick-plugin
+ (:module "imagemagick"
+ ; :depends-on ("graphics")
+ :components
+ ((:file "magick-core-types")
+ (:file "magick-core-api")
+ (:file "magick-data-plugin"
+ :depends-on ("magick-core-types" "magick-core-api"))))))))
(:module "widgets"
:depends-on ("graphics")
:components
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Jul 17 00:48:13 2006
@@ -111,6 +111,7 @@
#:graphics-context
#:image
#:image-data
+ #:image-data-plugin
#:palette
#:pattern
#:transform
@@ -121,8 +122,10 @@
#:*color-green*
#:*color-red*
#:*color-white*
+ #:*image-file-types*
;; methods, functions, macros
+ #:accepts-file-p
#:alpha
#:anti-alias
#:ascent
@@ -142,6 +145,7 @@
#:copy-color
#:copy-font-data
#:copy-font-metrics
+ #:data->image
#:data-object
#:depth
#:descent
Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Jul 17 00:48:13 2006
@@ -81,7 +81,13 @@
(direct nil)
(table nil))) ; vector of COLOR structs
-(defclass image-data (gfs:native-object) ()
+(defclass image-data-plugin (gfs:native-object) ()
+ (:documentation "Graphics library plugin implementation objects."))
+
+(defclass image-data ()
+ ((data-plugin
+ :reader data-plugin-of
+ :initform nil))
(:documentation "This class maintains image attributes, color, and pixel data."))
(defclass font (gfs:native-object) ()
Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Jul 17 00:48:13 2006
@@ -36,6 +36,9 @@
(defgeneric background-color (self)
(:documentation "Returns a color object corresponding to the current background color."))
+(defgeneric data->image (self)
+ (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ."))
+
(defgeneric data-object (self &optional gc)
(:documentation "Returns the data structure representing the raw form of the object."))
Modified: trunk/src/uitoolkit/graphics/image-data.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image-data.lisp (original)
+++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Jul 17 00:48:13 2006
@@ -33,10 +33,54 @@
(in-package :graphic-forms.uitoolkit.graphics)
+(defvar *image-plugins* nil)
+
+;;
+;; list the superset of file extensions for formats that any
+;; plugin might support (clearly there are more formats than
+;; this extant in the world, so add more as needed)
+;;
+(defvar *image-file-types* (let ((table (make-hash-table :test #'equal)))
+ (loop for (key value) in '(("bmp" "Microsoft Windows bitmap")
+ ("cur" "Microsoft Windows cursor")
+ ("dib" "Microsoft Windows device-independent bitmap")
+ ("emf" "Microsoft Windows Enhanced Metafile")
+ ("eps" "Adobe Encapsulated PostScript")
+ ("fax" "Group 3 TIFF")
+ ("fig" "FIG graphics format")
+ ("gif" "CompuServe Graphics Interchange Format")
+ ("ico" "Microsoft Windows icon")
+ ("jpeg" "Joint Photographic Experts Group")
+ ("jpg" "Joint Photographic Experts Group")
+ ("pbm" "Portable bitmap format (b/w)")
+ ("pcd" "Photo CD")
+ ("pcl" "HP Page Control Language")
+ ("pcx" "ZSoft IBM PC Paintbrush")
+ ("pdf" "Portable Document Format")
+ ("pgm" "Portable graymap")
+ ("pix" "Alias/Wavefront RLE")
+ ("png" "Portable Network Graphics")
+ ("ppm" "Portable pixmap (color)")
+ ("ps" "Adobe PostScript")
+ ("svg" "Scalable Vector Graphics")
+ ("tga" "Truevision Targa")
+ ("tiff" "Tagged Image File")
+ ("wmf" "Microsoft Windows Metafile")
+ ("xbm" "X Window System bitmap (b/w)")
+ ("xpm" "X Window System pixmap (color)"))
+ do (setf (gethash key table) value))
+ table))
+
;;;
;;; helper functions
;;;
+(defun find-image-plugin (path)
+ (loop for acceptor in *image-plugins*
+ for plugin = (funcall acceptor path)
+ until plugin
+ finally (return plugin)))
+
(defun image->data (hbmp) (declare (ignore hbmp)))
#|
(defun image->data (hbmp)
@@ -124,147 +168,52 @@
data))
|#
-(defun data->image (data)
- "Convert the image-data object to a bitmap and return the native handle."
- (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo)
- (cffi:with-foreign-slots ((gfs::bisize
- gfs::biwidth
- gfs::biheight
- gfs::biplanes
- gfs::bibitcount
- gfs::bicompression
- gfs::bisizeimage
- gfs::bixpels
- gfs::biypels
- gfs::biclrused
- gfs::biclrimp
- gfs::bmicolors)
- bi-ptr gfs::bitmapinfo)
- (let* ((handle (gfs:handle data))
- (sz (size data))
- (pix-count (* (gfs:size-width sz) (gfs:size-height sz)))
- (hbmp (cffi:null-pointer))
- (screen-dc (gfs::get-dc (cffi:null-pointer))))
- (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
- gfs::biwidth (gfs:size-width sz)
- gfs::biheight (- 0 (gfs:size-height sz))
- gfs::biplanes 1
- gfs::bibitcount 32 ;; 32bpp even if original image file is not
- gfs::bicompression gfs::+bi-rgb+
- gfs::bisizeimage 0
- gfs::bixpels 0
- gfs::biypels 0
- gfs::biclrused 0
- gfs::biclrimp 0)
-
- ;; create the bitmap
- ;;
- (cffi:with-foreign-object (pix-bits-ptr :pointer)
- (setf hbmp (gfs::create-dib-section screen-dc
- bi-ptr
- gfs::+dib-rgb-colors+
- pix-bits-ptr
- (cffi:null-pointer)
- 0))
- (if (gfs:null-handle-p hbmp)
- (error 'gfs:win32-error :detail "create-dib-section failed"))
-
- ;; update the RGBQUADs
- ;;
- (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz)))
- (ptr (cffi:mem-ref pix-bits-ptr :pointer)))
- (dotimes (i pix-count)
- (cffi:with-foreign-slots ((gfg::blue gfg::green gfg::red gfg::reserved)
- (cffi:mem-aref tmp 'gfg::pixel-packet i)
- gfg::pixel-packet)
- (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved)
- (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad)
- (setf gfs::rgbreserved 0)
- (setf gfs::rgbred (scale-quantum-to-byte red))
- (setf gfs::rgbgreen (scale-quantum-to-byte green))
- (setf gfs::rgbblue (scale-quantum-to-byte blue)))))))
- (unless (gfs:null-handle-p screen-dc)
- (gfs::release-dc (cffi:null-pointer) screen-dc))
- hbmp))))
-
;;;
;;; methods
;;;
-(defmethod depth ((data image-data))
- (let ((handle (gfs:handle data)))
- (if (null handle)
- (error 'gfs:disposed-error))
- (cffi:foreign-slot-value handle 'magick-image 'depth)))
-
-(defmethod gfs:dispose ((data image-data))
- (let ((victim (gfs:handle data)))
- (if (null victim)
- (error 'gfs:disposed-error))
- (destroy-image victim))
- (setf (slot-value data 'gfs:handle) nil))
+(defmethod data->image ((self image-data))
+ (data->image (data-plugin-of self)))
+
+(defmethod depth ((self image-data))
+ (depth (data-plugin-of self)))
-(defmethod load ((data image-data) path)
+(defmethod gfs:dispose ((self image-data))
+ (let ((victim (data-plugin-of self)))
+ (unless (null victim)
+ (gfs:dispose victim)))
+ (setf (slot-value self 'data-plugin) nil))
+
+(defmethod load ((self image-data) path)
(setf path (cond
((typep path 'pathname) (namestring (merge-pathnames path)))
((typep path 'string) (namestring (merge-pathnames path)))
(t
(error 'gfs:toolkit-error :detail "pathname or string required"))))
- (let ((handle (gfs:handle data)))
- (when (and handle (not (cffi:null-pointer-p handle)))
- (destroy-image handle)
- (setf (slot-value data 'gfs:handle) nil)
- (setf handle nil))
- (with-image-path (path info ex)
- (setf handle (read-image info ex))
- (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
- (error 'gfs:toolkit-error :detail (format nil
- "exception reason: ~s"
- (cffi:foreign-slot-value ex 'exception-info 'reason))))
- (if (cffi:null-pointer-p handle)
- (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path)))
- (setf (slot-value data 'gfs:handle) handle))))
-
-(defmethod size ((data image-data))
- (let ((handle (gfs:handle data))
- (size (gfs:make-size)))
- (if (or (null handle) (cffi:null-pointer-p handle))
- (error 'gfs:disposed-error))
- (cffi:with-foreign-slots ((rows columns) handle magick-image)
- (setf (gfs:size-height size) rows)
- (setf (gfs:size-width size) columns))
- size))
-
-(defmethod (setf size) (size (data image-data))
- (let ((handle (gfs:handle data))
- (new-handle (cffi:null-pointer))
- (ex (acquire-exception-info)))
- (if (or (null handle) (cffi:null-pointer-p handle))
- (error 'gfs:disposed-error))
- (unwind-protect
- (progn
- (setf new-handle (resize-image handle
- (gfs:size-width size)
- (gfs:size-height size)
- (cffi:foreign-enum-value 'filter-types :lanczos)
- 1.0 ex))
- (if (gfs:null-handle-p new-handle)
- (error 'gfs:toolkit-error :detail (format nil
- "could not resize: ~a"
- (cffi:foreign-slot-value ex
- 'exception-info
- 'reason))))
- (setf (slot-value data 'gfs:handle) new-handle)
- (destroy-image handle))
- (destroy-exception-info ex))))
-(defmethod print-object ((data image-data) stream)
- (if (or (null (gfs:handle data)) (cffi:null-pointer-p (gfs:handle data)))
+ (let ((plugin (data-plugin-of self)))
+ (when plugin
+ (gfs:dispose plugin)
+ (setf (slot-value self 'data-plugin) nil))
+ (setf plugin (find-image-plugin path))
+ (unless plugin
+ (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path)))
+ (load plugin path)
+ (setf (slot-value self 'data-plugin) plugin)))
+
+(defmethod size ((self image-data))
+ (size (data-plugin-of self)))
+
+(defmethod (setf size) (size (self image-data))
+ (setf (gfg:size (data-plugin-of self)) size))
+
+(defmethod print-object ((self image-data) stream)
+ (if (or (null (gfs:handle self)) (cffi:null-pointer-p (gfs:handle self)))
(error 'gfs:disposed-error))
- (let ((size (size data)))
- (print-unreadable-object (data stream :type t)
+ (let ((size (size self)))
+ (print-unreadable-object (self stream :type t)
;; FIXME: dump palette info, too
;;
(format stream "width: ~a " (gfs:size-width size))
(format stream "height: ~a " (gfs:size-height size))
- (format stream "bits per pixel: ~a " (depth data)))))
+ (format stream "bits per pixel: ~a " (depth self)))))
Added: trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp Mon Jul 17 00:48:13 2006
@@ -0,0 +1,70 @@
+;;;;
+;;;; packages.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 #:cl-user)
+
+;;;
+;;; package for base Win32 graphics plugin
+;;;
+(defpackage #:graphic-forms.uitoolkit.graphics.win32
+ (:nicknames #:gfgw32)
+ (:shadow #:load #:type)
+ (:use #:common-lisp)
+ (:export
+
+;; classes and structs
+
+;; constants
+
+;; methods, functions, macros
+
+;; conditions
+ ))
+
+;;;
+;;; package for ImageMagick graphics plugin
+;;;
+(defpackage #:graphic-forms.uitoolkit.graphics.imagemagick
+ (:nicknames #:gfgim)
+ (:shadow #:load #:type)
+ (:use #:common-lisp)
+ (:export
+
+;; classes and structs
+
+;; constants
+
+;; methods, functions, macros
+
+;; conditions
+ ))
Copied: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (from r153, trunk/src/uitoolkit/graphics/magick-core-api.lisp)
==============================================================================
--- trunk/src/uitoolkit/graphics/magick-core-api.lisp (original)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp Mon Jul 17 00:48:13 2006
@@ -31,12 +31,14 @@
;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;;
-(in-package :graphic-forms.uitoolkit.graphics)
+(in-package :graphic-forms.uitoolkit.graphics.imagemagick)
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cffi)
(pushnew cl-user::*magick-library-directory* cffi:*foreign-library-directories* :test #'equal))
+(defvar *magick-initialized* nil)
+
(load-foreign-library "wsock32.dll")
(load-foreign-library "msvcr71.dll")
(load-foreign-library "x11.dll")
Copied: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp (from r58, trunk/src/uitoolkit/graphics/magick-core-types.lisp)
==============================================================================
--- trunk/src/uitoolkit/graphics/magick-core-types.lisp (original)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp Mon Jul 17 00:48:13 2006
@@ -31,7 +31,7 @@
;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;;
-(in-package :graphic-forms.uitoolkit.graphics)
+(in-package :graphic-forms.uitoolkit.graphics.imagemagick)
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cffi))
@@ -55,11 +55,11 @@
(defconstant +yellow-channel+ #x00000004)
(defconstant +alpha-channel+ #x00000008)
(defconstant +opacity-channel+ #x00000008)
-(defconstant +matte-channel+ #x00000008) ;; deprecated
+(defconstant +matte-channel+ #x00000008) ; deprecated
(defconstant +black-channel+ #x00000020)
(defconstant +index-channel+ #x00000020)
(defconstant +all-channels+ #x000000FF)
-(defconstant +default-channels+ (logand +all-channels+ (lognot +opacity-channel+))) ;; (AllChannels &~ OpacityChannel)
+(defconstant +default-channels+ (logand +all-channels+ (lognot +opacity-channel+))) ; (AllChannels &~ OpacityChannel)
(defctype quantum :unsigned-short)
@@ -373,9 +373,9 @@
(error-number :int)
(reason :string)
(description :string)
- (exceptions :pointer) ;; void*
+ (exceptions :pointer) ; void*
(relinquish boolean-type)
- (semaphore :pointer) ;; Semaphore*
+ (semaphore :pointer) ; Semaphore*
(signature :unsigned-long))
(defcstruct primary-info
@@ -398,7 +398,7 @@
(defcstruct profile-info
(name :string)
(length :unsigned-long)
- (info :pointer) ;; char*
+ (info :pointer) ; char*
(signature :unsigned-long))
(defcstruct rectangle-info
@@ -430,24 +430,24 @@
(rows :unsigned-long)
(depth :unsigned-long)
(colors :unsigned-long)
- (colormap :pointer) ;; PixelPacket*
+ (colormap :pointer) ; PixelPacket*
(background-color pixel-packet)
(border-color pixel-packet)
(matte-color pixel-packet)
(gamma :double)
(chromaticity chromaticity-info)
(render-intent rendering-intent)
- (profiles :pointer) ;; void*
+ (profiles :pointer) ; void*
(units resolution-type)
- (montage :pointer) ;; char*
- (directory :pointer) ;; char*
- (geometry :pointer) ;; char*
+ (montage :pointer) ; char*
+ (directory :pointer) ; char*
+ (geometry :pointer) ; char*
(offset :long)
(x-resolution :double)
(y-resolution :double)
(page rectangle-info)
(extract-info rectangle-info)
- (tile-info rectangle-info) ;; deprecated
+ (tile-info rectangle-info) ; deprecated
(bias :double)
(blur :double)
(fuzz :double)
@@ -457,7 +457,7 @@
(gravity gravity-type)
(compose composite-operator)
(dispose dispose-type)
- (clip-mask :pointer) ;; Image*
+ (clip-mask :pointer) ; Image*
(scene :unsigned-long)
(delay :unsigned-long)
(ticks-per-second :unsigned-long)
@@ -466,27 +466,27 @@
(start-loop :long)
(error error-info)
(timer timer-info)
- (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args)
- (client-data :pointer) ;; void*
- (cache :pointer) ;; void*
- (attributes :pointer) ;; void*
- (ascii85 :pointer) ;; _Ascii85Info_*
- (blob :pointer) ;; _BlobInfo_*
+ (progress-monitor :pointer) ; MagickBooleanType (*MagickProgressMonitor)(args)
+ (client-data :pointer) ; void*
+ (cache :pointer) ; void*
+ (attributes :pointer) ; void*
+ (ascii85 :pointer) ; _Ascii85Info_*
+ (blob :pointer) ; _BlobInfo_*
(filename :char :count 4096)
(magick-filename :char :count 4096)
(magick :char :count 4096)
(exception exception-info)
(debug boolean-type)
(reference-count :long)
- (semaphore :pointer) ;; SemaphoreInfo*
+ (semaphore :pointer) ; SemaphoreInfo*
(color-profile profile-info)
(iptc-profile profile-info)
- (generic-profile :pointer) ;; ProfileInfo*
- (generic-profiles :unsigned-long) ;; deprecated (and ProfileInfo too?)
+ (generic-profile :pointer) ; ProfileInfo*
+ (generic-profiles :unsigned-long) ; deprecated (and ProfileInfo too?)
(signature :unsigned-long)
- (previous :pointer) ;; Image*
- (list :pointer) ;; Image*
- (next :pointer)) ;; Image*
+ (previous :pointer) ; Image*
+ (list :pointer) ; Image*
+ (next :pointer)) ; Image*
(defcstruct magick-image-info
(compression compression-type)
@@ -495,10 +495,10 @@
(adjoin boolean-type)
(affirm boolean-type)
(antialias boolean-type)
- (size :pointer) ;; char*
- (extract :pointer) ;; char*
- (page :pointer) ;; char*
- (scenes :pointer) ;; char*
+ (size :pointer) ; char*
+ (extract :pointer) ; char*
+ (page :pointer) ; char*
+ (scenes :pointer) ; char*
(scene :unsigned-long)
(number-scenes :unsigned-long)
(depth :unsigned-long)
@@ -506,11 +506,11 @@
(endian endian-type)
(units resolution-type)
(quality :unsigned-long)
- (sampling-factor :pointer) ;; char*
- (server-name :pointer) ;; char*
- (font :pointer) ;; char*
- (texture :pointer) ;; char*
- (density :pointer) ;; char*
+ (sampling-factor :pointer) ; char*
+ (server-name :pointer) ; char*
+ (font :pointer) ; char*
+ (texture :pointer) ; char*
+ (density :pointer) ; char*
(point-size :double)
(fuzz :double)
(background-color pixel-packet)
@@ -525,24 +525,24 @@
(group :long)
(ping boolean-type)
(verbose boolean-type)
- (view :pointer) ;; char*
- (authenticate :pointer) ;; char*
- (channel :unsigned-int) ;; ChannelType
- (attributes :pointer) ;; Image*
- (options :pointer) ;; void*
- (progress-monitor :pointer) ;; MagickBooleanType (*MagickProgressMonitor)(args)
- (client-data :pointer) ;; void*
- (cache :pointer) ;; void*
- (stream :pointer) ;; size_t (*StreamHandler)(args)
- (file :pointer) ;; FILE*
- (blob :pointer) ;; void*
+ (view :pointer) ; char*
+ (authenticate :pointer) ; char*
+ (channel :unsigned-int) ; ChannelType
+ (attributes :pointer) ; Image*
+ (options :pointer) ; void*
+ (progress-monitor :pointer) ; MagickBooleanType (*MagickProgressMonitor)(args)
+ (client-data :pointer) ; void*
+ (cache :pointer) ; void*
+ (stream :pointer) ; size_t (*StreamHandler)(args)
+ (file :pointer) ; FILE*
+ (blob :pointer) ; void*
(length :unsigned-int)
(magick :char :count 4096)
(unique :char :count 4096)
(zero :char :count 4096)
(filename :char :count 4906)
(debug boolean-type)
- (tile :pointer) ;; deprecated
+ (tile :pointer) ; deprecated
(subimage :unsigned-long)
(subrange :unsigned-long)
(pen pixel-packet)
Added: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp Mon Jul 17 00:48:13 2006
@@ -0,0 +1,179 @@
+;;;;
+;;;; magick-data-plugin.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.graphics.imagemagick)
+
+(defclass magick-data-plugin (gfg:image-data-plugin) ()
+ (:documentation "ImageMagick library plugin for the graphics package."))
+
+(defun accepts-file-p (path)
+ (unless *magick-initialized*
+ (initialize-magick (cffi:null-pointer))
+ (setf *magick-initialized* t))
+ (cond
+ ((parse-namestring path)) ; syntax check
+ ((typep path 'pathname)
+ (setf path (namestring path)))
+ (t
+ (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path))))
+ (if (gethash (pathname-type path) gfg:*image-file-types*)
+ (let ((plugin (make-instance 'magick-data-plugin)))
+ (gfg:load plugin path)
+ plugin)
+ nil))
+
+(push #'accepts-file-p gfg::*image-plugins*)
+
+(defmethod gfg:data->image ((self magick-data-plugin))
+ "Convert the image-data object to a bitmap and return the native handle."
+ (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo)
+ (cffi:with-foreign-slots ((gfs::bisize
+ gfs::biwidth
+ gfs::biheight
+ gfs::biplanes
+ gfs::bibitcount
+ gfs::bicompression
+ gfs::bisizeimage
+ gfs::bixpels
+ gfs::biypels
+ gfs::biclrused
+ gfs::biclrimp
+ gfs::bmicolors)
+ bi-ptr gfs::bitmapinfo)
+ (let* ((handle (gfs:handle self))
+ (sz (gfg:size self))
+ (pix-count (* (gfs:size-width sz) (gfs:size-height sz)))
+ (hbmp (cffi:null-pointer))
+ (screen-dc (gfs::get-dc (cffi:null-pointer))))
+ (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
+ gfs::biwidth (gfs:size-width sz)
+ gfs::biheight (- 0 (gfs:size-height sz))
+ gfs::biplanes 1
+ gfs::bibitcount 32 ;; 32bpp even if original image file is not
+ gfs::bicompression gfs::+bi-rgb+
+ gfs::bisizeimage 0
+ gfs::bixpels 0
+ gfs::biypels 0
+ gfs::biclrused 0
+ gfs::biclrimp 0)
+
+ ;; create the bitmap
+ ;;
+ (cffi:with-foreign-object (pix-bits-ptr :pointer)
+ (setf hbmp (gfs::create-dib-section screen-dc
+ bi-ptr
+ gfs::+dib-rgb-colors+
+ pix-bits-ptr
+ (cffi:null-pointer)
+ 0))
+ (if (gfs:null-handle-p hbmp)
+ (error 'gfs:win32-error :detail "create-dib-section failed"))
+
+ ;; update the RGBQUADs
+ ;;
+ (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz)))
+ (ptr (cffi:mem-ref pix-bits-ptr :pointer)))
+ (dotimes (i pix-count)
+ (cffi:with-foreign-slots ((blue green red reserved)
+ (cffi:mem-aref tmp 'pixel-packet i)
+ pixel-packet)
+ (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved)
+ (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad)
+ (setf gfs::rgbreserved 0)
+ (setf gfs::rgbred (scale-quantum-to-byte red))
+ (setf gfs::rgbgreen (scale-quantum-to-byte green))
+ (setf gfs::rgbblue (scale-quantum-to-byte blue)))))))
+ (unless (gfs:null-handle-p screen-dc)
+ (gfs::release-dc (cffi:null-pointer) screen-dc))
+ hbmp))))
+
+(defmethod gfg:depth ((self magick-data-plugin))
+ (let ((handle (gfs:handle self)))
+ (if (null handle)
+ (error 'gfs:disposed-error))
+ (cffi:foreign-slot-value handle 'magick-image 'depth)))
+
+(defmethod gfs:dispose ((self magick-data-plugin))
+ (let ((victim (gfs:handle self)))
+ (unless (or (null victim) (cffi:null-pointer-p victim))
+ (destroy-image victim)))
+ (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))
+
+(defmethod gfg:load ((self magick-data-plugin) path)
+ (let ((handle (gfs:handle self)))
+ (when (and handle (not (cffi:null-pointer-p handle)))
+ (destroy-image handle)
+ (setf (slot-value self 'gfs:handle) nil)
+ (setf handle nil))
+ (with-image-path (path info ex)
+ (setf handle (read-image info ex))
+ (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
+ (error 'gfs:toolkit-error :detail (format nil
+ "exception reason: ~s"
+ (cffi:foreign-slot-value ex 'exception-info 'reason))))
+ (if (cffi:null-pointer-p handle)
+ (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path)))
+ (setf (slot-value self 'gfs:handle) handle))))
+
+(defmethod gfg:size ((self magick-data-plugin))
+ (let ((handle (gfs:handle self))
+ (size (gfs:make-size)))
+ (if (or (null handle) (cffi:null-pointer-p handle))
+ (error 'gfs:disposed-error))
+ (cffi:with-foreign-slots ((rows columns) handle magick-image)
+ (setf (gfs:size-height size) rows)
+ (setf (gfs:size-width size) columns))
+ size))
+
+(defmethod (setf gfg:size) (size (self magick-data-plugin))
+ (let ((handle (gfs:handle self))
+ (new-handle (cffi:null-pointer))
+ (ex (acquire-exception-info)))
+ (if (or (null handle) (cffi:null-pointer-p handle))
+ (error 'gfs:disposed-error))
+ (unwind-protect
+ (progn
+ (setf new-handle (resize-image handle
+ (gfs:size-width size)
+ (gfs:size-height size)
+ (cffi:foreign-enum-value 'filter-types :lanczos)
+ 1.0 ex))
+ (if (gfs:null-handle-p new-handle)
+ (error 'gfs:toolkit-error :detail (format nil
+ "could not resize: ~a"
+ (cffi:foreign-slot-value ex
+ 'exception-info
+ 'reason))))
+ (setf (slot-value self 'gfs:handle) new-handle)
+ (destroy-image handle))
+ (destroy-exception-info ex))))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Jul 17 00:48:13 2006
@@ -38,7 +38,6 @@
(child-visitor-results :initform nil :accessor child-visitor-results)
(display-visitor-func :initform nil :accessor display-visitor-func)
(display-visitor-results :initform nil :accessor display-visitor-results)
- (image-loaders-by-type :initform (make-hash-table :test #'equal))
(job-table :initform (make-hash-table :test #'equal))
(job-table-lock :initform nil)
(event-time :initform 0 :accessor event-time)
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Jul 17 00:48:13 2006
@@ -81,13 +81,11 @@
#+clisp (defun startup (thread-name start-fn)
(declare (ignore thread-name))
- (gfg::initialize-magick (cffi:null-pointer))
(funcall start-fn)
(message-loop #'default-message-filter))
#+lispworks (defun startup (thread-name start-fn)
(hcl:add-special-free-action 'gfs::native-object-special-action)
- (gfg::initialize-magick (cffi:null-pointer))
(when (null (mp:list-all-processes))
(mp:initialize-multiprocessing))
(mp:process-run-function thread-name
@@ -97,7 +95,6 @@
(message-loop #'default-message-filter))))
(defun shutdown (exit-code)
- (gfg::destroy-magick)
(gfs::post-quit-message exit-code))
(defun initialize-comctl-classes (icc-flags)
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r197 - in trunk: docs/manual etc src src/uitoolkit/system src/uitoolkit/widgets
by junrue@common-lisp.net 14 Jul '06
by junrue@common-lisp.net 14 Jul '06
14 Jul '06
Author: junrue
Date: Thu Jul 13 20:20:12 2006
New Revision: 197
Modified:
trunk/docs/manual/api.texinfo
trunk/etc/lisp.exe.manifest
trunk/src/packages.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/widgets/event-generics.lisp
trunk/src/uitoolkit/widgets/event.lisp
Log:
implemented event-session function, currently untested
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Thu Jul 13 20:20:12 2006
@@ -1172,6 +1172,57 @@
@end table
@end deffn
+@anchor{event-session}
+@deffn GenericFunction event-session dispatcher window phase reason
+Implement this method to participate in the system's session shutdown
+protocol. When the user chooses to end the session (by logging out or
+by shutting down), or if an application calls one of the Win32
+shutdown functions, every application is given a veto option. This
+event function will be called at least once for each @ref{top-level}
+window in the application.@*
+
+The MSDN documentation makes the following recommendations for handling
+this event:
+@itemize @bullet
+@item Whenever possible, applications should respect the user's
+intentions by allowing the session to end.
+@item In the case of a critical operation, provide a @ref{dialog} or
+other feedback with information for the user as to consequences
+if the application is interrupted at this time.
+@item Respond to the @code{:query} event as quickly as possible, leaving
+time-consuming cleanup to be done in the session @code{:end} event.
+@end itemize
+
+@table @var
+@event-dispatcher-arg
+@item window
+The @ref{top-level} @ref{window} receiving this event.
+@item phase
+Identifies which of the two phases this event represents:
+@table @code
+@item :query
+This symbol means that the system is querying the application for
+permission to proceed. Return @sc{nil} if there is a reason to veto
+the process, or non-@sc{nil} otherwise.
+@item :end
+This symbol is specified in the subsequent call to @code{event-session}.
+It means that the system is going ahead with ending the
+session, therefore this is an opportunity for graceful cleanup.
+@end table
+@item reason
+Provides more detail to aid in choosing desired behavior:
+@table @code
+@item :logoff
+The user is logging off.
+@item :replacing-file
+The application must exit because a file it is using is being
+replaced.
+@item :shutdown
+The system is shutting down or restarting.
+@end table
+@end table
+@end deffn
+
@anchor{event-timer}
@deffn GenericFunction event-timer dispatcher timer
Implement this method to respond to expiration of the current
Modified: trunk/etc/lisp.exe.manifest
==============================================================================
--- trunk/etc/lisp.exe.manifest (original)
+++ trunk/etc/lisp.exe.manifest Thu Jul 13 20:20:12 2006
@@ -1,10 +1,10 @@
-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
- <assemblyIdentity version="1.0.0.0" processorArchitecture="X86" name="clisp" type="win32"/>
+ <assemblyIdentity processorArchitecture="x86" name="clisp" type="win32"/>
<description>GNU CLISP</description>
<dependency>
<dependentAssembly>
- <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*"/>
+ <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="x86" publicKeyToken="6595b64144ccf1df" language="*"/>
</dependentAssembly>
</dependency>
</assembly>
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Thu Jul 13 20:20:12 2006
@@ -395,7 +395,7 @@
#:event-pre-resize
#:event-resize
#:event-select
- #:event-show
+ #:event-session
#:event-timer
#:expand
#:expanded-p
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Thu Jul 13 20:20:12 2006
@@ -974,6 +974,24 @@
(defconstant +wm-gettextlength+ #x000E)
(defconstant +wm-paint+ #x000F)
(defconstant +wm-close+ #x0010)
+(defconstant +wm-queryendsession+ #x0011)
+(defconstant +wm-queryopen+ #x0013)
+(defconstant +wm-endsession+ #x0016)
+(defconstant +wm-quit+ #x0012)
+(defconstant +wm-erasebkgnd+ #x0014)
+(defconstant +wm-syscolorchange+ #x0015)
+(defconstant +wm-showwindow+ #x0018)
+(defconstant +wm-wininichange+ #x001A)
+(defconstant +wm-settingchange+ #x001A)
+(defconstant +wm-devmodechange+ #x001B)
+(defconstant +wm-activateapp+ #x001C)
+(defconstant +wm-fontchange+ #x001D)
+(defconstant +wm-timechange+ #x001E)
+(defconstant +wm-cancelmode+ #x001F)
+(defconstant +wm-setcursor+ #x0020)
+(defconstant +wm-mouseactivate+ #x0021)
+(defconstant +wm-childactivate+ #x0022)
+(defconstant +wm-queuesync+ #x0023)
(defconstant +wm-getminmaxinfo+ #x0024)
(defconstant +wm-painticon+ #x0026)
(defconstant +wm-iconerasebkgnd+ #x0027)
Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp Thu Jul 13 20:20:12 2006
@@ -178,10 +178,10 @@
(:method (dispatcher item)
(declare (ignorable dispatcher item))))
-(defgeneric event-show (dispatcher widget)
- (:documentation "Implement this to respond to an object being shown.")
- (:method (dispatcher widget)
- (declare (ignorable dispatcher widget))))
+(defgeneric event-session (dispatcher window phase reason)
+ (:documentation "Implement this to participate in the session shutdown protocol.")
+ (:method (dispatcher window phase reason)
+ (declare (ignorable dispatcher window phase reason))))
(defgeneric event-timer (dispatcher timer)
(:documentation "Implement this to respond to a tick from a specific timer.")
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Thu Jul 13 20:20:12 2006
@@ -142,6 +142,18 @@
(defun obtain-event-time ()
(event-time (thread-context)))
+(defun option->reason (lparam)
+ ;; MSDN says the value is a bitmask, so must be tested bit-wise.
+ (cond
+ ((zerop lparam)
+ :shutdown)
+ ((oddp lparam)
+ :replacing-file)
+ ((= (logand lparam #x80000000) #x80000000)
+ :logoff)
+ (t
+ :shutdown)))
+
;;;
;;; process-message methods
;;;
@@ -214,6 +226,19 @@
(delete-widget (thread-context) hwnd)
0)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-queryendsession+)) wparam lparam)
+ (declare (ignore wparam))
+ (let ((widget (get-widget (thread-context) hwnd)))
+ (unless (null widget)
+ (if (event-session (dispatcher widget) widget :query (option->reason lparam)) 1 0))))
+
+(defmethod process-message (hwnd (msg (eql gfs::+wm-endsession+)) wparam lparam)
+ (declare (ignore wparam))
+ (let ((widget (get-widget (thread-context) hwnd)))
+ (unless (null widget)
+ (event-session (dispatcher widget) widget :end (option->reason lparam))))
+ 0)
+
(defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam)
(declare (ignore lparam))
(let* ((tc (thread-context))
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
13 Jul '06
Author: junrue
Date: Thu Jul 13 13:46:23 2006
New Revision: 196
Modified:
trunk/src/uitoolkit/system/comdlg32.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/system-types.lisp
trunk/src/uitoolkit/system/user32.lisp
Log:
preparation for implementing standard find/replace dialog
Modified: trunk/src/uitoolkit/system/comdlg32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/comdlg32.lisp (original)
+++ trunk/src/uitoolkit/system/comdlg32.lisp Thu Jul 13 13:46:23 2006
@@ -41,18 +41,28 @@
(defcfun
("ChooseFontA" choose-font)
BOOL
- (struct LPTR))
+ (struct LPTR)) ; choosefont struct
(defcfun
("CommDlgExtendedError" comm-dlg-extended-error)
DWORD)
(defcfun
+ ("FindTextA" find-text)
+ HANDLE
+ (fr LPTR)) ; findreplace struct
+
+(defcfun
("GetOpenFileNameA" get-open-filename)
BOOL
- (ofn LPTR))
+ (ofn LPTR)) ; openfilename struct
(defcfun
("GetSaveFileNameA" get-save-filename)
BOOL
- (ofn LPTR))
+ (ofn LPTR)) ; openfilename struct
+
+(defcfun
+ ("ReplaceTextA" replace-text)
+ HANDLE
+ (fr LPTR)) ; findreplace struct
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Thu Jul 13 13:46:23 2006
@@ -33,10 +33,24 @@
(in-package :graphic-forms.uitoolkit.system)
+;;;
+;;; control class names
+;;;
(defconstant +button-classname+ "button")
(defconstant +edit-classname+ "edit")
(defconstant +static-classname+ "static")
+;;;
+;;; registered message names
+;;;
+(defconstant +lbselchstringa+ "commdlg_LBSelChangedNotify")
+(defconstant +sharevistringa+ "commdlg_ShareViolation")
+(defconstant +fileokstringa+ "commdlg_FileNameOK")
+(defconstant +colorokstringa+ "commdlg_ColorOK")
+(defconstant +setrgbstringa+ "commdlg_SetRGBColor")
+(defconstant +helpmsgstringa+ "commdlg_help")
+(defconstant +findmsgstringa+ "commdlg_FindReplace")
+
(defconstant +ad-counterclockwise+ 1)
(defconstant +ad-clockwise+ 2)
@@ -374,6 +388,31 @@
(defconstant +fr-private+ #x10)
(defconstant +fr-not-enum+ #x20)
+;;;
+;;; find/replace dialog-related constants
+;;;
+(defconstant +fr-down+ #x00000001)
+(defconstant +fr-wholeword+ #x00000002)
+(defconstant +fr-matchcase+ #x00000004)
+(defconstant +fr-findnext+ #x00000008)
+(defconstant +fr-replace+ #x00000010)
+(defconstant +fr-replaceall+ #x00000020)
+(defconstant +fr-dialogterm+ #x00000040)
+(defconstant +fr-showhelp+ #x00000080)
+(defconstant +fr-enablehook+ #x00000100)
+(defconstant +fr-enabletemplate+ #x00000200)
+(defconstant +fr-noupdown+ #x00000400)
+(defconstant +fr-nomatchcase+ #x00000800)
+(defconstant +fr-nowholeword+ #x00001000)
+(defconstant +fr-enabletemplatehandle+ #x00002000)
+(defconstant +fr-hideupdown+ #x00004000)
+(defconstant +fr-hidematchcase+ #x00008000)
+(defconstant +fr-hidewholeword+ #x00010000)
+(defconstant +fr-raw+ #x00020000)
+(defconstant +fr-matchdiac+ #x20000000)
+(defconstant +fr-matchkashida+ #x40000000)
+(defconstant +fr-matchalefhamza+ #x80000000)
+
(defconstant +frerr-findreplacecodes+ #x4000)
(defconstant +frerr-bufferlengthzero+ #x4001)
Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp (original)
+++ trunk/src/uitoolkit/system/system-types.lisp Thu Jul 13 13:46:23 2006
@@ -151,6 +151,19 @@
(rightmargin INT)
(lengthdrawn UINT))
+(defcstruct findreplace
+ (structsize DWORD)
+ (howner HANDLE)
+ (hinst HANDLE)
+ (flags DWORD)
+ (whatstr :string)
+ (withstr :string)
+ (whatlen WORD)
+ (withlen WORD)
+ (data LPARAM)
+ (hookfn LPTR) ; FIXME: not yet used, but eventually should be FRHookProc
+ (templname :string))
+
(defcstruct initcommoncontrolsex
(size DWORD)
(icc DWORD))
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Thu Jul 13 13:46:23 2006
@@ -541,6 +541,11 @@
(wndclass LPTR))
(defcfun
+ ("RegisterWindowMessageA" register-window-message)
+ UINT
+ (str :string))
+
+(defcfun
("ReleaseCapture" release-capture)
BOOL)
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r195 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue@common-lisp.net 13 Jul '06
by junrue@common-lisp.net 13 Jul '06
13 Jul '06
Author: junrue
Date: Thu Jul 13 12:21:53 2006
New Revision: 195
Modified:
trunk/docs/manual/api.texinfo
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/item.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
documented select/selected-p methods and implemented them for buttons
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Thu Jul 13 12:21:53 2006
@@ -1607,6 +1607,11 @@
decorations are modified appropriately.
@end deffn
+@deffn GenericFunction select self flag
+Sets @var{self} to the selected state if @var{flag} is not @sc{nil}
+or to the unselected state if @sc{nil}.
+@end deffn
+
@deffn GenericFunction select-all self flag
Sets the entire content of @code{self} to the selected state if
@var{flag} is not @sc{nil} or to the unselected state if @sc{nil}.
@@ -1634,6 +1639,10 @@
returns @sc{nil}.
@end deffn
+@deffn GenericFunction selected-p self => boolean
+Returns T if @var{self} is in the selected state; @sc{nil} otherwise.
+@end deffn
+
@anchor{show}
@deffn GenericFunction show self flag
Causes the object to be visible or hidden on the screen, but not
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Jul 13 12:21:53 2006
@@ -112,7 +112,10 @@
:dispatcher be
:style (list subtype)))
(setf (toggle-fn be) (create-button-toggler be))
- (setf (gfw:text w) (funcall (toggle-fn be))))
+ (setf (gfw:text w) (funcall (toggle-fn be)))
+ (if (eql subtype :tri-state)
+ (gfw:check w t)
+ (gfw:check w t)))
((eql subtype :single-line-edit)
(setf w (make-instance widget-class
:parent *layout-tester-win*
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Thu Jul 13 12:21:53 2006
@@ -40,6 +40,17 @@
;;; methods
;;;
+(defmethod check ((self button) flag)
+ (let ((bits (if flag gfs::+bst-checked+ gfs::+bst-unchecked+)))
+ (gfs::send-message (gfs:handle self) gfs::+bm-setcheck+ bits 0)))
+
+(defmethod checked-p ((self button))
+ (let ((bits (gfs::send-message (gfs:handle self) gfs::+bm-getcheck+ 0 0)))
+ (case bits
+ (gfs::+bst-checked+ t)
+ (gfs::+bst-unchecked+ nil)
+ (otherwise nil))))
+
(defmethod compute-style-flags ((self button) &rest extra-data)
(declare (ignore extra-data))
(let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+))
@@ -115,6 +126,12 @@
(gfs:size-height text-size)))))
size))
+(defmethod select ((self button) flag)
+ (check self flag))
+
+(defmethod selected-p ((self button))
+ (checked-p self))
+
(defmethod text ((self button))
(get-widget-text self))
Modified: trunk/src/uitoolkit/widgets/item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item.lisp (original)
+++ trunk/src/uitoolkit/widgets/item.lisp Thu Jul 13 12:21:53 2006
@@ -36,7 +36,12 @@
(defun items-equal-p (item1 item2)
(= (item-id item1) (item-id item2)))
-(defmethod check :before ((it item) flag)
+(defmethod check :before ((self item) flag)
(declare (ignore flag))
- (if (gfs:null-handle-p (gfs:handle it))
+ (if (gfs:null-handle-p (gfs:handle self))
+ (error 'gfs:toolkit-error :detail "null owner handle")))
+
+(defmethod checked-p :before ((self item))
+ (declare (ignore flag))
+ (if (gfs:null-handle-p (gfs:handle self))
(error 'gfs:toolkit-error :detail "null owner handle")))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu Jul 13 12:21:53 2006
@@ -297,6 +297,9 @@
(defgeneric scroll (self dest-pnt src-rect children-too)
(:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
+(defgeneric select (self flag)
+ (:documentation "Set self into (or out of) the selected state."))
+
(defgeneric select-all (self flag)
(:documentation "Set all items of this object into (or out of) the selected state."))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Thu Jul 13 12:21:53 2006
@@ -125,12 +125,16 @@
(defmethod center-on-parent ((self widget))
(center-object (parent self) self))
+(defmethod check :before ((self widget) flag)
+ (declare (ignore flag))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
(defmethod checked-p :before ((self widget))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
(defmethod checked-p ((self widget))
- (declare (ignore self))
nil)
(defmethod client-size :before ((self widget))
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r194 - in trunk/src: demos/textedit uitoolkit/widgets
by junrue@common-lisp.net 13 Jul '06
by junrue@common-lisp.net 13 Jul '06
13 Jul '06
Author: junrue
Date: Thu Jul 13 10:15:32 2006
New Revision: 194
Modified:
trunk/src/demos/textedit/textedit-window.lisp
trunk/src/uitoolkit/widgets/event.lisp
Log:
WM_ACTIVATE seems to be getting additional notification values than documented so changed an ecase to case; fix select all item enabling in textedit when text is empty
Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp (original)
+++ trunk/src/demos/textedit/textedit-window.lisp Thu Jul 13 10:15:32 2006
@@ -91,16 +91,17 @@
(unless *textedit-control*
(return-from manage-textedit-edit-menu nil))
(let ((items (gfw:items menu))
+ (text (gfw:text *textedit-control*))
(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)
- (gfw:enable (elt items 12) (or (null text-sel)
- (> (gfs:span-start text-sel) 0)
- (< (gfs:span-end text-sel)
- (length (gfw:text *textedit-control*)))))))
+ (gfw:enable (elt items 12) (and (> (length text) 0)
+ (or (null text-sel)
+ (> (gfs:span-start text-sel) 0)
+ (< (gfs:span-end text-sel) (length text)))))))
(defun textedit-edit-copy (disp item)
(declare (ignore disp item))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Thu Jul 13 10:15:32 2006
@@ -353,7 +353,7 @@
(declare (ignore lparam))
(let ((widget (get-widget (thread-context) hwnd)))
(if widget
- (ecase wparam
+ (case wparam
(#.gfs::+wa-active+ (event-activate (dispatcher widget) widget))
(#.gfs::+wa-clickactive+ (event-activate (dispatcher widget) widget))
(#.gfs::+wa-inactive+ (event-deactivate (dispatcher widget) widget)))))
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r193 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/system src/uitoolkit/widgets
by junrue@common-lisp.net 13 Jul '06
by junrue@common-lisp.net 13 Jul '06
13 Jul '06
Author: junrue
Date: Thu Jul 13 02:38:01 2006
New Revision: 193
Modified:
trunk/docs/manual/api.texinfo
trunk/docs/manual/miscellaneous.texinfo
trunk/src/demos/textedit/textedit-window.lisp
trunk/src/packages.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.lisp
Log:
implemented select-all and select-span for edit controls
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Thu Jul 13 02:38:01 2006
@@ -128,9 +128,9 @@
@end defun
@anchor{location}
-@deffn Macro location rect
+@defmac location rect
This macro returns the @var{location} slot of a @ref{rectangle}.
-@end deffn
+@end defmac
@deffn Function make-point :x :y :z
This function creates a new @ref{point} object.
@@ -148,9 +148,9 @@
This function creates a new @ref{span} object.
@end deffn
-@deffn Macro size rect
+@defmac size rect
This macro returns the @code{size} slot of a @ref{rectangle}.
-@end deffn
+@end defmac
@node system conditions
@@ -1282,17 +1282,6 @@
Returns T if the object is in the checked state; nil otherwise.
@end deffn
-@deffn GenericFunction clear-selection self
-Sets the selection status of @code{self} (or @ref{item}s within
-@var{self}) to the @samp{unselected} state.
-@end deffn
-
-@deffn GenericFunction clear-selection-span self @ref{span}
-Sets the selection status of @ref{item}s within @var{self}, whose
-zero-based indices lie within @var{span}, to the @samp{unselected}
-state.
-@end deffn
-
@deffn GenericFunction client-size self
Returns a size object that describes the region of the object that can
be drawn within or can display data.
@@ -1618,10 +1607,31 @@
decorations are modified appropriately.
@end deffn
+@deffn GenericFunction select-all self flag
+Sets the entire content of @code{self} to the selected state if
+@var{flag} is not @sc{nil} or to the unselected state if @sc{nil}.
+@end deffn
+
+@anchor{select-items}
+@deffn GenericFunction select-items self indices flag
+Sets the @ref{item}s of @var{self}, each identified by a zero-based
+index from the @var{indices} @sc{list}, to the selected state if
+@var{flag} is not @sc{nil} or to the unselected state if @sc{nil}.
+This is the function to use when not all of the items in question
+are contiguous.
+@end deffn
+
+@anchor{select-span}
+@deffn GenericFunction select-span self span
+Sets the @ref{item}s of @var{self} that lie within @var{span} to
+the selected state. An existing selection's extent is modified
+to match the new @var{span}.
+@end deffn
+
@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
-@sc{nil}.
+Returns a span object describing the @var{start} and @var{end} of the
+selection within @var{self}. If there is no selection, this function
+returns @sc{nil}.
@end deffn
@anchor{show}
@@ -1701,30 +1711,37 @@
@end deffn
@end html
+@defmac with-drawing-disabled (widget) &body body
+This macro executes @var{body} while updates of @var{widget} are
+disabled. Drawing operations attempted while @var{body}
+is executing will be queued so that when the lock is lifted
+@var{widget} will be repainted.
+@end defmac
+
@anchor{with-file-dialog}
-@deffn Macro with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body
+@defmac with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body
This macro wraps the instantiation of a standard file open/save dialog
-and the subsequent retrieval of the user's file selections (supplied to @code{body}
-via @code{paths}). @xref{file-dialog}.
-@end deffn
+and the subsequent retrieval of the user's file selections (supplied to @var{body}
+via @var{paths}). @xref{file-dialog}.
+@end defmac
@anchor{with-font-dialog}
-@deffn Macro with-font-dialog (owner style font color &key gc initial-color initial-font) &body body
+@defmac with-font-dialog (owner style font color &key gc initial-color initial-font) &body body
This macro wraps the instantiation of a standard font dialog and binds
-@code{font} to a font object, and @code{color} to a @ref{color} object,
+@var{font} to a font object, and @var{color} to a @ref{color} object,
corresponding to the attributes selected by the user. If the user cancels
-the dialog, @code{font} will be @sc{nil}. In addition, @code{color} will also
+the dialog, @var{font} will be @sc{nil}. In addition, @var{color} will also
be @sc{nil} if the dialog was created with the @code{:no-effects} style
keyword. @xref{font-dialog}.
-@end deffn
+@end defmac
@anchor{with-graphics-context}
-@deffn Macro with-graphics-context (gc &optional thing) &body body
+@defmac with-graphics-context (gc &optional thing) &body body
This macro manages a @ref{graphics-context} representing the underlying
-device context of @code{thing}, which can be a @ref{widget} or an
-@ref{image}. If @code{thing} is not specified, then the macro creates
+device context of @var{thing}, which can be a @ref{widget} or an
+@ref{image}. If @var{thing} is not specified, then the macro creates
a graphics-context compatible with the @ref{display}.
-@end deffn
+@end defmac
@node layout functions
Modified: trunk/docs/manual/miscellaneous.texinfo
==============================================================================
--- trunk/docs/manual/miscellaneous.texinfo (original)
+++ trunk/docs/manual/miscellaneous.texinfo Thu Jul 13 02:38:01 2006
@@ -20,8 +20,8 @@
This chapter documents terminology conventions observed in
Graphic-Forms. These conventions should be interpreted with the
-traditional Common Lisp conventions in mind (such as
-@url{http://www.cliki.net/Naming%20conventions}).
+traditional Common Lisp conventions in mind (some of which are
+documented here: @url{http://www.cliki.net/Naming%20conventions}).
@table @option
@@ -29,6 +29,41 @@
For clearer identification of accessors, Graphic-Forms
uses the suffix @samp{-of} whenever possible.
+@item @samp{check} versus @samp{select}
+Admittedly, these two concepts are similar. They can be used as verbs
+and they both describe a state of being (@samp{checked} and
+@samp{selected}). Yet they need to remain separate due to the fact
+that certain @ref{widget}s can exist in both states simultaneously,
+like a tri-state @ref{button}, or a table or tree whose items are
+checkboxes. The choice of which best describes an action or state
+amounts to a judgement call. In Graphic-Forms, the author chooses to
+use @samp{select} when a user gesture causes a widget to issue its
+primary notification event, such as a menu item or button being
+clicked. Hence, the verb @samp{select} aligns with the
+@ref{event-select} function.@footnote{This topic gets muddier when
+edit controls come into the picture. Text in an edit control is
+selected despite there being no notification event; yet there is a
+notification (event-modify) then the user types text. I'm choosing to
+live with this inconsistency, partly because otherwise my
+categorization scheme seems to work well; and one can refer to the act
+of retrieving edit control selection, confident that developers will
+know this means obtaining highlighted text.} And so the
+@samp{selection} state is associated with highlighting of an
+@ref{item}. Graphic-Forms uses @samp{check} to identify an operation
+that flags or annotates a widget; the @samp{checked} state means being
+annotated.
+
+@c @item @samp{clear} versus @samp{delete}
+@c There is a distinction between @samp{clear} and @samp{delete} which
+@c hinges on the difference between the primary content of a @ref{widget}
+@c and secondary state information. An example of primary content is text
+@c within an @ref{edit} @ref{control}. An example of secondary state
+@c information (relevant to this topic at least) is the @ref{span} of
+@c selected text in an edit control. With that in mind, Graphic-Forms
+@c functions @samp{delete} content but @samp{clear} secondary state. This
+@c choice aligns with the semantics of @sc{CL:delete}, including the
+@c notion of that function being a destructive operation.
+
@item function and method names
Functions and methods should be named using a verb to suggest
action. It may be tempting (especially for former Java programmers) to
@@ -39,25 +74,14 @@
functions, the author suggests @samp{available-p}, such as
@ref{undo-available-p}.
-@item @samp{clear} versus @samp{delete}
-Related to the @samp{function and method names} issues, there is
-a distinction between @samp{clear} and @samp{delete} which hinges on
-the difference between the primary content of a @ref{widget} and
-secondary state information. An example of primary content is text
-within an @ref{edit} @ref{control}. An example of secondary state
-information (relevant to this topic at least) is the @ref{span} of
-selected text in an edit control. With that in mind, Graphic-Forms
-functions @samp{delete} content but @samp{clear} secondary state. This
-choice is intended in part to align with the semantics of
-@sc{CL:delete}, including the notion of that function being a
-destructive operation.
-
@item macro names
Macros should be named consistent with established Common Lisp
practice, with an exception being allowed for convenience wrappers
-around structure accessors (see @ref{location}). Otherwise, the
-temptation to define an unorthodox macro name is a symptom that maybe
-the code in question should not be a macro in the first place.
+around structure accessors (see for example
+@ref{location}). Otherwise, the temptation to define an unorthodox
+macro name is a symptom that maybe the code in question should not be
+a macro in the first place. The rule of thumb is: if something can
+be a function, then let it be a function; in general, think carefully
+before creating a new macro.
@end table
-
Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp (original)
+++ trunk/src/demos/textedit/textedit-window.lisp Thu Jul 13 02:38:01 2006
@@ -96,7 +96,11 @@
(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)))
+ (gfw:enable (elt items 5) text-sel)
+ (gfw:enable (elt items 12) (or (null text-sel)
+ (> (gfs:span-start text-sel) 0)
+ (< (gfs:span-end text-sel)
+ (length (gfw:text *textedit-control*)))))))
(defun textedit-edit-copy (disp item)
(declare (ignore disp item))
@@ -114,6 +118,10 @@
(declare (ignore disp item))
(gfw:paste-text *textedit-control*))
+(defun textedit-edit-selall (disp item)
+ (declare (ignore disp item))
+ (gfw:select-all *textedit-control* t))
+
(defun textedit-edit-undo (disp item)
(declare (ignore disp item)))
@@ -234,7 +242,7 @@
(:item "&Replace..." :disabled)
(:item "&Go To...")
(:item "" :separator)
- (:item "Select &All")))
+ (:item "Select &All" :callback #'textedit-edit-selall)))
(:item "F&ormat"
:submenu ((:item "&Font..." :callback #'textedit-font)))
(:item "&Help"
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Thu Jul 13 02:38:01 2006
@@ -465,6 +465,7 @@
#:scroll
#:select
#:select-all
+ #:select-items
#:selected-p
#:selection-count
#:selection-index
@@ -502,6 +503,7 @@
#:vertical-scrollbar
#:visible-item-count
#:visible-p
+ #:with-drawing-disabled
#:with-file-dialog
#:with-font-dialog
#:with-graphics-context
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Thu Jul 13 02:38:01 2006
@@ -497,6 +497,11 @@
(fu-load UINT))
(defcfun
+ ("LockWindowUpdate" lock-window-update)
+ BOOL
+ (hwnd HANDLE))
+
+(defcfun
("MapVirtualKeyA" map-virtual-key)
UINT
(code UINT)
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Thu Jul 13 02:38:01 2006
@@ -130,6 +130,17 @@
(* +vertical-edit-text-margin+ 2))))
size))
+(defmethod select-all ((self edit) flag)
+ (if flag
+ (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 (length (text self)))
+ (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 0)))
+
+(defmethod select-span ((self edit) (span gfs:span))
+ (with-drawing-disabled (self)
+ (let ((hwnd (gfs:handle self)))
+ (gfs::send-message hwnd gfs::+em-setsel+ 1 1)
+ (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span)))))
+
(defmethod selection-span ((self edit))
(cffi:with-foreign-object (start-ptr :unsigned-long)
(cffi:with-foreign-object (end-ptr :unsigned-long)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu Jul 13 02:38:01 2006
@@ -84,12 +84,6 @@
(defgeneric checked-p (self)
(:documentation "Returns T if the object is in the checked state; nil otherwise."))
-(defgeneric clear-selection (self)
- (:documentation "The set of selected items in self is made empty."))
-
-(defgeneric clear-selection-span (self span)
- (:documentation "Sets a subset of self's current selection to the unselected state."))
-
(defgeneric client-size (self)
(:documentation "Returns a size object that describes the region of the object that can be drawn within or can display data."))
@@ -303,11 +297,14 @@
(defgeneric scroll (self dest-pnt src-rect children-too)
(:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
-(defgeneric select (self flag)
- (:documentation "Set this object into (or take it out of) the selected state."))
-
(defgeneric select-all (self flag)
- (:documentation "Set all items of this object into (or take them out of) the selected state."))
+ (:documentation "Set all items of this object into (or out of) the selected state."))
+
+(defgeneric select-items (self indices flag)
+ (:documentation "Set items of self, each identified by a zero-based index, into (or out of) the selected state."))
+
+(defgeneric select-span (self span)
+ (:documentation "Set items of self that lie within span into the selected state."))
(defgeneric selected-p (self)
(:documentation "Returns T if the object is in the selected state; nil otherwise."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Jul 13 02:38:01 2006
@@ -50,7 +50,16 @@
(unwind-protect
(progn
,@body)
- (gfs:dispose ,gc)))))
+ (gfs:dispose ,gc))))
+
+ (defmacro with-drawing-disabled ((widget) &body body)
+ `(unwind-protect
+ (progn
+ (unless (gfs:disposed-p ,widget)
+ (error 'gfs:disposed-error))
+ (gfs::lock-window-update (gfs:handle ,widget))
+ ,@body)
+ (gfs::lock-window-update (cffi:null-pointer)))))
(defun translate-and-dispatch (msg-ptr)
(gfs::translate-message msg-ptr)
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Thu Jul 13 02:38:01 2006
@@ -133,15 +133,6 @@
(declare (ignore self))
nil)
-(defmethod clear-selection :before ((self widget))
- (if (gfs:disposed-p self)
- (error 'gfs:disposed-error)))
-
-(defmethod clear-selection-span :before ((self widget) span)
- (declare (ignore span))
- (if (gfs:disposed-p self)
- (error 'gfs:disposed-error)))
-
(defmethod client-size :before ((self widget))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
@@ -296,7 +287,7 @@
(defmethod print-object ((self widget) stream)
(print-unreadable-object (self stream :type t)
(format stream "handle: ~x " (gfs:handle self))
- (format stream "dispatcher: ~a " (dispatcher self))))
+ (format stream "dispatcher: ~a~%" (dispatcher self))))
(defmethod redo-available-p :before ((self widget))
(if (gfs:disposed-p self)
@@ -321,12 +312,31 @@
(defmethod resizable-p ((self widget))
nil)
+(defmethod select :before ((self widget) flag)
+ (declare (ignore flag))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod select-all :before ((self widget) flag)
+ (declare (ignore flag))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod select-items :before ((self widget) items flag)
+ (declare (ignore items flag))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod select-span :before ((self widget) span)
+ (declare (ignore span))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
(defmethod selected-p :before ((self widget))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
(defmethod selected-p ((self widget))
- (declare (ignore self))
nil)
(defmethod selection-span :before ((self widget))
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r192 - in trunk: docs/manual src src/demos/textedit src/tests/uitoolkit src/uitoolkit/widgets
by junrue@common-lisp.net 11 Jul '06
by junrue@common-lisp.net 11 Jul '06
11 Jul '06
Author: junrue
Date: Tue Jul 11 16:33:21 2006
New Revision: 192
Modified:
trunk/docs/manual/api.texinfo
trunk/docs/manual/miscellaneous.texinfo
trunk/src/demos/textedit/textedit-window.lisp
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/uitoolkit/widgets/edit.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/menu-item.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/timer.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-with-items.lisp
trunk/src/uitoolkit/widgets/widget.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
cleanup of clear vs. delete terminology, and got rid of remove-*
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Tue Jul 11 16:33:21 2006
@@ -127,6 +127,7 @@
@sc{nil} otherwise.
@end defun
+@anchor{location}
@deffn Macro location rect
This macro returns the @var{location} slot of a @ref{rectangle}.
@end deffn
@@ -1281,24 +1282,15 @@
Returns T if the object is in the checked state; nil otherwise.
@end deffn
-@deffn GenericFunction clear-all self
-Clears all content from @code{self}.
-@end deffn
-
-@deffn GenericFunction clear-item self index
-Clears the @ref{item} at the zero-based @var{index}.
-@end deffn
-
@deffn GenericFunction clear-selection self
-Sets the selection status of @code{self} to @samp{not selected} or
-@samp{empty}. For a @ref{control} with a text field component,
-such as an @ref{edit} control, this function deletes selected
-text.
+Sets the selection status of @code{self} (or @ref{item}s within
+@var{self}) to the @samp{unselected} state.
@end deffn
-@deffn GenericFunction clear-span self @ref{span}
-Clears the items from @var{self} whose zero-based indices lie within
-the specified @var{span}.
+@deffn GenericFunction clear-selection-span self @ref{span}
+Sets the selection status of @ref{item}s within @var{self}, whose
+zero-based indices lie within @var{span}, to the @samp{unselected}
+state.
@end deffn
@deffn GenericFunction client-size self
@@ -1351,6 +1343,26 @@
presses @sc{enter}.
@end deffn
+@deffn GenericFunction delete-all self
+Removes all content from @code{self}.
+@end deffn
+
+@deffn GenericFunction delete-item self index
+Removes the @ref{item} at the zero-based @var{index}.
+@end deffn
+
+@deffn GenericFunction delete-item-span self @ref{span}
+Removes the items from @var{self} whose zero-based indices lie within
+the specified @var{span}.
+@end deffn
+
+@deffn GenericFunction delete-selection self
+Removes the subset of items from @var{self} that are in the
+@samp{selected} state. For a @ref{control} with a text field
+component, such as an @ref{edit} control, this function deletes
+selected text.
+@end deffn
+
@deffn GenericFunction display-to-object self pnt
Return a point that is the result of transforming the specified point
from display-relative coordinates to this object's coordinate system.
@@ -1660,6 +1672,7 @@
other cases there is no text component at all.
@end deffn
+@anchor{undo-available-p}
@deffn GenericFunction undo-available-p self => boolean
Returns T if @code{self} has @sc{undo} capability and has an
operation that can be undone; @sc{nil} otherwise.
Modified: trunk/docs/manual/miscellaneous.texinfo
==============================================================================
--- trunk/docs/manual/miscellaneous.texinfo (original)
+++ trunk/docs/manual/miscellaneous.texinfo Tue Jul 11 16:33:21 2006
@@ -10,4 +10,54 @@
@node Miscellaneous Topics
@chapter Miscellaneous Topics
-@strong{TBD}
+@menu
+* terminology:: Some notes about terminology conventions.
+@end menu
+
+
+@node terminology
+@section terminology
+
+This chapter documents terminology conventions observed in
+Graphic-Forms. These conventions should be interpreted with the
+traditional Common Lisp conventions in mind (such as
+@url{http://www.cliki.net/Naming%20conventions}).
+
+@table @option
+
+@item accessor names
+For clearer identification of accessors, Graphic-Forms
+uses the suffix @samp{-of} whenever possible.
+
+@item function and method names
+Functions and methods should be named using a verb to suggest
+action. It may be tempting (especially for former Java programmers) to
+use the Java getter/setter naming conventions for accessor-like
+functions, but the author prefers @samp{obtain} rather than
+@samp{get}, and he prefers @sc{setf}'able places which therefore can
+have @sc{setf} functions defined for them. For status querying
+functions, the author suggests @samp{available-p}, such as
+@ref{undo-available-p}.
+
+@item @samp{clear} versus @samp{delete}
+Related to the @samp{function and method names} issues, there is
+a distinction between @samp{clear} and @samp{delete} which hinges on
+the difference between the primary content of a @ref{widget} and
+secondary state information. An example of primary content is text
+within an @ref{edit} @ref{control}. An example of secondary state
+information (relevant to this topic at least) is the @ref{span} of
+selected text in an edit control. With that in mind, Graphic-Forms
+functions @samp{delete} content but @samp{clear} secondary state. This
+choice is intended in part to align with the semantics of
+@sc{CL:delete}, including the notion of that function being a
+destructive operation.
+
+@item macro names
+Macros should be named consistent with established Common Lisp
+practice, with an exception being allowed for convenience wrappers
+around structure accessors (see @ref{location}). Otherwise, the
+temptation to define an unorthodox macro name is a symptom that maybe
+the code in question should not be a macro in the first place.
+
+@end table
+
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 16:33:21 2006
@@ -108,7 +108,7 @@
(defun textedit-edit-delete (disp item)
(declare (ignore disp item))
- (gfw:clear-selection *textedit-control*))
+ (gfw:delete-selection *textedit-control*))
(defun textedit-edit-paste (disp item)
(declare (ignore disp item))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Tue Jul 11 16:33:21 2006
@@ -331,10 +331,8 @@
#:check
#:check-all
#:checked-p
- #:clear-all
- #:clear-item
#:clear-selection
- #:clear-span
+ #:clear-selection-span
#:client-size
#:close-obj
#:code
@@ -353,6 +351,10 @@
#:default-widget
#:defmenu
#:delay-of
+ #:delete-all
+ #:delete-item
+ #:delete-selection
+ #:delete-span
#:disabled-image
#:dispatcher
#:display-to-object
@@ -455,9 +457,6 @@
#:redraw
#:redrawing-p
#:release-mouse
- #:remove-all
- #:remove-item
- #:remove-span
#:reparentable-p
#:replace-selection
#:resizable-p
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Tue Jul 11 16:33:21 2006
@@ -169,7 +169,7 @@
:initform nil)))
(defmethod gfw:event-activate ((d child-menu-dispatcher) menu)
- (gfw:clear-all menu)
+ (gfw:delete-all menu)
(gfw:mapchildren *layout-tester-win*
(lambda (parent child)
(declare (ignore parent))
@@ -336,7 +336,7 @@
(defun flow-mod-callback (disp menu)
(declare (ignore disp))
- (gfw:clear-all menu)
+ (gfw:delete-all menu)
(let ((it nil)
(margin-menu (gfw:defmenu ((:item "Left"
:callback #'enable-left-flow-margin-items
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Tue Jul 11 16:33:21 2006
@@ -48,9 +48,6 @@
(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+))
@@ -83,6 +80,9 @@
(defmethod cut-text ((self edit))
(gfs::send-message (gfs:handle self) gfs::+wm-cut+ 0 0))
+(defmethod delete-selection ((self edit))
+ (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0))
+
(defmethod enable-scrollbars ((self edit) horizontal vertical)
(let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
(if horizontal
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Tue Jul 11 16:33:21 2006
@@ -211,7 +211,7 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
(declare (ignore wparam lparam))
- (remove-widget (thread-context) hwnd)
+ (delete-widget (thread-context) hwnd)
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam)
@@ -454,7 +454,7 @@
(defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
(declare (ignore wparam lparam))
- (remove-widget (thread-context) hwnd)
+ (delete-widget (thread-context) hwnd)
(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 Tue Jul 11 16:33:21 2006
@@ -196,7 +196,7 @@
(defmethod gfs:dispose ((it menu-item))
(setf (dispatcher it) nil)
- (remove-menuitem (thread-context) it)
+ (delete-menuitem (thread-context) it)
(let ((id (item-id it))
(owner (owner it)))
(unless (null owner)
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Tue Jul 11 16:33:21 2006
@@ -142,13 +142,13 @@
(defun menu-cleanup-callback (menu item)
(let ((tc (thread-context)))
- (remove-widget tc (gfs:handle menu))
- (remove-menuitem tc item)))
+ (delete-widget tc (gfs:handle menu))
+ (delete-menuitem tc item)))
(defmethod gfs:dispose ((m menu))
(visit-menu-tree m #'menu-cleanup-callback)
(let ((hwnd (gfs:handle m)))
- (remove-widget (thread-context) hwnd)
+ (delete-widget (thread-context) hwnd)
(if (not (gfs:null-handle-p hwnd))
(if (zerop (gfs::destroy-menu hwnd))
(error 'gfs:win32-error :detail "destroy-menu failed"))))
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Jul 11 16:33:21 2006
@@ -133,7 +133,7 @@
"Add the specified widget to the widget table using its native handle as the key."
(setf (gethash (cffi:pointer-address (gfs:handle w)) (slot-value tc 'widgets-by-hwnd)) w))
-(defmethod remove-widget ((tc thread-context) hwnd)
+(defmethod delete-widget ((tc thread-context) hwnd)
"Remove the widget object corresponding to the specified native window handle."
(when (not (slot-value tc 'wip))
(remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd))))
@@ -154,7 +154,7 @@
(if (find :keyboard-navigation (style-of widget))
(setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc)))))
-(defmethod remove-kbdnav-widget ((tc thread-context) (widget widget))
+(defmethod delete-kbdnav-widget ((tc thread-context) (widget widget))
(setf (kbdnav-widgets tc)
(remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd))
(kbdnav-widgets tc)
@@ -170,7 +170,7 @@
(setf widget (find-if (lambda (w) (/= (gfs::is-dialog-message (gfs:handle w) msg-ptr)))
(rest widgets)))
(when (and widget (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0))
- (let ((tmp (remove-kbdnav-widget tc widget)))
+ (let ((tmp (delete-kbdnav-widget tc widget)))
(setf (kbdnav-widgets tc) (push widget tmp)))
(return-from intercept-kbdnav-message widget))))
nil)
@@ -183,7 +183,7 @@
"Stores a menu item using its id as the key."
(setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it))
-(defmethod remove-menuitem ((tc thread-context) (it menu-item))
+(defmethod delete-menuitem ((tc thread-context) (it menu-item))
"Removes the menu item using its id as the key."
(maphash
#'(lambda (k v)
@@ -206,7 +206,7 @@
"Stores a timer using its id as the key."
(setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer))
-(defmethod remove-timer ((tc thread-context) (timer timer))
+(defmethod delete-timer ((tc thread-context) (timer timer))
"Removes the timer using its id as the key."
(maphash
#'(lambda (k v)
Modified: trunk/src/uitoolkit/widgets/timer.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/timer.lisp (original)
+++ trunk/src/uitoolkit/widgets/timer.lisp Tue Jul 11 16:33:21 2006
@@ -78,7 +78,7 @@
(defmethod gfs:dispose ((self timer))
(let ((tc (thread-context)))
- (remove-timer tc self)
+ (delete-timer tc self)
(gfs::kill-timer (utility-hwnd tc) (id-of self))))
(defmethod initialize-instance :after ((self timer) &key)
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Jul 11 16:33:21 2006
@@ -130,7 +130,7 @@
(let ((m (menu-bar win)))
(unless (null m)
(visit-menu-tree m #'menu-cleanup-callback)
- (remove-widget (thread-context) (gfs:handle m))))
+ (delete-widget (thread-context) (gfs:handle m))))
(call-next-method))
(defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys)
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 16:33:21 2006
@@ -84,17 +84,11 @@
(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."))
-
(defgeneric clear-selection (self)
- (:documentation "Sets the object's selection status to empty or not selected."))
+ (:documentation "The set of selected items in self is made empty."))
-(defgeneric clear-span (self sp)
- (:documentation "Clears the items whose zero-based indices lie within the specified span."))
+(defgeneric clear-selection-span (self span)
+ (:documentation "Sets a subset of self's current selection to the unselected state."))
(defgeneric client-size (self)
(:documentation "Returns a size object that describes the region of the object that can be drawn within or can display data."))
@@ -132,6 +126,18 @@
(defgeneric default-widget (self)
(:documentation "Returns the child widget or item that has the default emphasis."))
+(defgeneric delete-all (self)
+ (:documentation "Removes all content from the object."))
+
+(defgeneric delete-item (self index)
+ (:documentation "Removes the item at the zero-based index from the object."))
+
+(defgeneric delete-item-span (self span)
+ (:documentation "Removes the sequence of items represented by the specified span object."))
+
+(defgeneric delete-selection (self)
+ (:documentation "Removes items from self that are in the selected state."))
+
(defgeneric disabled-image (self)
(:documentation "Returns the image used to render this item with a disabled look."))
@@ -282,15 +288,6 @@
(defgeneric redrawing-p (self)
(:documentation "Returns T if the object is set to allow processing of paint events."))
-(defgeneric remove-all (self)
- (:documentation "Removes all items from the object."))
-
-(defgeneric remove-item (self index)
- (:documentation "Removes the item at the zero-based index from the object."))
-
-(defgeneric remove-span (self sp)
- (:documentation "Removes the sequence of items represented by the specified span object."))
-
(defgeneric reparentable-p (self)
(:documentation "Returns T if the window system allows this object to be reparented; nil otherwise."))
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 16:33:21 2006
@@ -38,17 +38,17 @@
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod clear-all ((self widget-with-items))
+(defmethod delete-all ((self widget-with-items))
(let ((count (length (items self))))
(unless (zerop count)
- (clear-span self (gfs:make-span :start 0 :end (1- count))))))
+ (delete-item-span self (gfs:make-span :start 0 :end (1- count))))))
-(defmethod clear-item :before ((self widget-with-items) index)
+(defmethod delete-item :before ((self widget-with-items) index)
(declare (ignore index))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod clear-item ((self widget-with-items) index)
+(defmethod delete-item ((self widget-with-items) index)
(let* ((items (items self))
(it (elt items index)))
(delete it (items self) :test #'items-equal-p)
@@ -56,14 +56,14 @@
(error 'gfs:disposed-error))
(gfs:dispose it)))
-(defmethod clear-span :before ((self widget-with-items) (sp gfs:span))
+(defmethod delete-item-span :before ((self widget-with-items) (sp gfs:span))
(declare (ignore sp))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod clear-span ((self widget-with-items) (sp gfs:span))
+(defmethod delete-item-span ((self widget-with-items) (sp gfs:span))
(dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp))))
- (clear-item self (gfs:span-start sp))))
+ (delete-item self (gfs:span-start sp))))
(defmethod item-index :before ((self widget-with-items) (it item))
(declare (ignore it))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Tue Jul 11 16:33:21 2006
@@ -133,11 +133,12 @@
(declare (ignore self))
nil)
-(defmethod clear-all :before ((self widget))
+(defmethod clear-selection :before ((self widget))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod clear-selection :before ((self widget))
+(defmethod clear-selection-span :before ((self widget) span)
+ (declare (ignore span))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
@@ -167,6 +168,24 @@
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
+(defmethod delete-all :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod delete-item :before ((self widget) index)
+ (declare (ignore index))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod delete-item-span :before ((self widget) span)
+ (declare (ignore span))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod delete-selection :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))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Tue Jul 11 16:33:21 2006
@@ -166,7 +166,7 @@
new-size))
(defmethod gfs:dispose ((self window))
- (remove-kbdnav-widget (thread-context) self)
+ (delete-kbdnav-widget (thread-context) self)
(call-next-method))
(defmethod enable-layout :before ((win window) flag)
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r191 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/system src/uitoolkit/widgets
by junrue@common-lisp.net 11 Jul '06
by junrue@common-lisp.net 11 Jul '06
11 Jul '06
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
+@defun empty-span-p span
+Returns T if the @var{start} and @var{end} of @code{span} are the same;
+@sc{nil} otherwise.
+@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
+@deffn GenericFunction clear-all self
+Clears all content from @code{self}.
+@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}.
+@end deffn
+
+@deffn GenericFunction clear-selection self
+Sets the selection status of @code{self} to @samp{not selected} or
+@samp{empty}. For a @ref{control} with a text field component,
+such as an @ref{edit} control, this function deletes selected
+text.
@end deffn
-@deffn GenericFunction clear-span self sp
-Clears the items whose zero-based indices lie within the specified span.
+@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
+@anchor{copy-text}
+@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}.@*@*
+@strong{Note:} an upcoming release will include more general
+infrastructure for clipboard operations.
+@end deffn
+
+@anchor{cut-text}
+@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
+@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
+@ref{text-for-pasting-p}.@*@*
+@strong{Note:} an upcoming release will
+include more general infrastructure for clipboard operations.
+@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
+@anchor{paste-text}
+@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
+@ref{edit} control have built-in clipboard functionality, and in such
+cases, the implementation of this function delegates directly. See
+@ref{copy-text}, @ref{cut-text}, and @ref{text-for-pasting-p}.@*@*
+@strong{Note:} an upcoming release will include more
+general infrastructure for clipboard operations.
+@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
+@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
+@sc{nil}.
+@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
+@anchor{text-for-pasting-p}
+@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},
+@ref{cut-text}, and @ref{paste-text}.@*@*
+@strong{Note:} an upcoming release will include more general
+infrastructure for clipboard operations.
+@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)
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r190 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/widgets
by junrue@common-lisp.net 10 Jul '06
by junrue@common-lisp.net 10 Jul '06
10 Jul '06
Author: junrue
Date: Mon Jul 10 17:26:44 2006
New Revision: 190
Modified:
trunk/docs/manual/api.texinfo
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 widget functions for querying undo and redo state, and implemented them for edit controls
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Mon Jul 10 17:26:44 2006
@@ -1525,6 +1525,11 @@
display; nil otherwise.
@end deffn
+@deffn GenericFunction redo-available-p self => boolean
+Returns T if @code{self} has @sc{redo} capability and has an
+operation that can be redone; @sc{nil} otherwise.
+@end deffn
+
@deffn GenericFunction redraw self
Causes the entire bounds of the object to be marked as needing to be redrawn
@end deffn
@@ -1583,6 +1588,11 @@
other cases there is no text component at all.
@end deffn
+@deffn GenericFunction undo-available-p self => boolean
+Returns T if @code{self} has @sc{undo} capability and has an
+operation that can be undone; @sc{nil} otherwise.
+@end deffn
+
@deffn GenericFunction update self
Forces all outstanding paint requests for the object to be processed
before this function returns.
Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp (original)
+++ trunk/src/demos/textedit/textedit-window.lisp Mon Jul 10 17:26:44 2006
@@ -86,6 +86,13 @@
(setf *textedit-win* nil)
(gfw:shutdown 0))
+(defun manage-textedit-edit-menu (disp menu)
+ (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*))))
+
(defun textedit-font (disp item)
(declare (ignore disp item))
(gfw:with-graphics-context (gc *textedit-control*)
@@ -175,7 +182,7 @@
(cells:defobserver file-path ((self textedit-document))
(if *textedit-win*
- (setf (gfw:text *textedit-win*) (format nil "~s - GraphicForms TextEdit" (file-path self)))
+ (setf (gfw:text *textedit-win*) (format nil "~a - GraphicForms TextEdit" (file-path self)))
(setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit")))
(defun textedit-startup ()
@@ -186,21 +193,21 @@
(let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu
:submenu ((:item "&New" :callback #'textedit-file-new)
(:item "&Open..." :callback #'textedit-file-open)
- (:item "&Save" :callback #'textedit-file-save :disabled)
+ (:item "&Save" :callback #'textedit-file-save :disabled)
(:item "Save &As..." :callback #'textedit-file-save-as)
(:item "" :separator)
(:item "E&xit" :callback #'textedit-file-quit)))
- (:item "&Edit"
- :submenu ((:item "&Undo")
+ (:item "&Edit" :callback #'manage-textedit-edit-menu
+ :submenu ((:item "&Undo" :callback #'textedit-edit-undo :disabled)
(:item "" :separator)
- (:item "Cu&t")
- (:item "&Copy")
- (:item "&Paste")
- (:item "De&lete")
+ (:item "Cu&t" :callback #'textedit-edit-cut :disabled)
+ (:item "&Copy" :callback #'textedit-edit-copy :disabled)
+ (:item "&Paste" :callback #'textedit-edit-paste :disabled)
+ (:item "De&lete" :callback #'textedit-edit-delete :disabled)
(:item "" :separator)
(:item "&Find...")
- (:item "Find &Next")
- (:item "&Replace...")
+ (:item "Find &Next" :disabled)
+ (:item "&Replace..." :disabled)
(:item "&Go To...")
(:item "" :separator)
(:item "Select &All")))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Jul 10 17:26:44 2006
@@ -496,6 +496,7 @@
#:traverse
#:traverse-order
#:trim-sizes
+ #:undo-available-p
#:update
#:vertical-scrollbar
#:visible-item-count
Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp (original)
+++ trunk/src/uitoolkit/widgets/edit.lisp Mon Jul 10 17:26:44 2006
@@ -132,3 +132,6 @@
(defmethod (setf text-modified-p) (flag (self edit))
(gfs::send-message (gfs:handle self) gfs::+em-setmodify+ (if flag 1 0) 0))
+
+(defmethod undo-available-p ((self edit))
+ (/= (gfs::send-message (gfs:handle self) gfs::+em-canundo+ 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 Mon Jul 10 17:26:44 2006
@@ -270,6 +270,9 @@
(defgeneric preferred-size (self width-hint height-hint)
(:documentation "Returns a size object representing the object's 'preferred' size."))
+(defgeneric redo-available-p (self)
+ (:documentation "Returns T if self can redo an operation; nil otherwise."))
+
(defgeneric redraw (self)
(:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn"))
@@ -375,6 +378,9 @@
(defgeneric traverse-order (self)
(:documentation "Returns a list of this object's layout-managed children in the order in which tab traversal would visit them."))
+(defgeneric undo-available-p (self)
+ (:documentation "Returns T if self can undo an operation; nil otherwise."))
+
(defgeneric update (self)
(:documentation "Forces all outstanding paint requests for the object to be processed before this function returns."))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Mon Jul 10 17:26:44 2006
@@ -259,6 +259,13 @@
(format stream "handle: ~x " (gfs:handle self))
(format stream "dispatcher: ~a " (dispatcher self))))
+(defmethod redo-available-p :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod redo-available-p ((self widget))
+ nil)
+
(defmethod redraw :before ((self widget))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
@@ -328,6 +335,13 @@
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
+(defmethod undo-available-p :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod undo-available-p ((self widget))
+ nil)
+
(defmethod update :before ((w widget))
(if (gfs:disposed-p w)
(error 'gfs:disposed-error)))
1
0
![](https://secure.gravatar.com/avatar/fb2f3f4d70bc8fccbb82c23998e3a5b7.jpg?s=120&d=mm&r=g)
[graphic-forms-cvs] r189 - in trunk: docs/manual src/uitoolkit/widgets
by junrue@common-lisp.net 09 Jul '06
by junrue@common-lisp.net 09 Jul '06
09 Jul '06
Author: junrue
Date: Sun Jul 9 16:38:15 2006
New Revision: 189
Modified:
trunk/docs/manual/api.texinfo
trunk/docs/manual/reference.texinfo
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/event-source.lisp
trunk/src/uitoolkit/widgets/menu-item.lisp
trunk/src/uitoolkit/widgets/menu-language.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
Log:
abstracted :callback setup somewhat for controls; added related documentation
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Sun Jul 9 16:38:15 2006
@@ -178,12 +178,22 @@
classes.
@anchor{button}
-@deftp Class button
-This @ref{control} class represents selectable controls that invoke
-the @ref{event-select} method defined for an @ref{event-dispatcher}
-associated with the @code{button}.
+@deftp Class button callback-event-name
+This @ref{control} class represents selectable controls that generate
+an event when clicked.
+@table @var
+@item callback-event-name
+This is an (@code{:allocation :class}) slot that holds a symbol
+identifying an event function (e.g., @ref{event-select}). See
+@ref{event-source} for more details on this slot.
+@end table
+@deffn Initarg :callback
+The @sc{function} value supplied via this initarg will be
+used as the implementation of @ref{event-select} in an
+@ref{event-dispatcher} configured for the @code{button}.
+@end deffn
@deffn Initarg :image
-Supplies an image to be used as the @code{button} label.
+Supplies an image to be used as the @code{button}'s label.
@end deffn
@deffn Initarg :style
@table @code
@@ -229,7 +239,43 @@
@anchor{control}
@deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color
The base class for widgets having pre-defined native behavior. It derives from
-@ref{widget}.
+@ref{widget}.@*@*
+@strong{Note:} application code should not manipulate @code{control} slots
+directly, unless defining a new @code{control} type as an extension to
+Graphic-Forms.
+@table @var
+@item brush-color
+If set, this @ref{color} object is used as the @code{control}'s background color
+when the @code{control} needs to be redrawn.
+@item brush-handle
+This is a native handle for a Win32 @sc{brush} that is used when customizing
+the @code{control}'s background color.
+@item font
+This is a @ref{font} object for customizing the text of a @code{control}.
+@item pixel-point
+This is a @ref{point} object specifying a pixel in an @ref{image}
+associated with a @code{control}, for the purpose of determining what
+color to use for transparency.
+@item maximum-size
+This is a @ref{size} object that places a maximum constraint on the
+size that a @ref{layout-manager} may set for the @code{control}. It
+may be @sc{nil} if no such constraint has been set.
+@item minimum-size
+This is a @ref{size} object that places a minimum constraint on the
+size that a @ref{layout-manager} may set for the @code{control}. It
+may be @sc{nil} if no such constraint has been set.
+@item text-color
+If set, this color object is used as the @code{control}'s foreground text
+color when the @code{control} needs to be redrawn.
+@end table
+@deffn Initarg :callback
+This initarg associates a @sc{function} with an @ref{event-dispatcher}
+subclass that is generated behind the scenes and then instantiated to
+serve as the @code{control}'s event dispatcher. Each @code{control}
+subclass specifies the particular event function (e.g., @ref{event-select})
+that this callback will implement; see the documentation for specific
+@code{control} subclasses for more information on this initarg.
+@end deffn
@end deftp
@anchor{dialog}
@@ -281,13 +327,24 @@
@end deftp
@anchor{edit}
-@deftp Class edit
+@deftp Class edit callback-event-name
This subclass of @ref{control} represents a rectangular area that
permits the user to enter and edit text. The @ref{event-focus-gain}
and @ref{event-focus-loss} methods of each @code{edit control}'s
@ref{event-dispatcher} are invoked when focus is given or taken
away. The @ref{event-modify} method is invoked when the user edits
content.
+@table @var
+@item callback-event-name
+This is an (@code{:allocation :class}) slot that holds a symbol
+identifying an event function (e.g., @ref{event-modify}). See
+@ref{event-source} for more details on this slot.
+@end table
+@deffn Initarg :callback
+The @sc{function} value supplied via this initarg will be
+used as the implementation of @ref{event-modify} in an
+@ref{event-dispatcher} configured for the @code{edit control}.
+@end deffn
@deffn Initarg :style
@table @code
@item :auto-hscroll
@@ -346,15 +403,33 @@
behalf of @ref{widget}s. Applications define subclasses of
@code{event-dispatcher} and implement one or more of the @ref{event
functions} specializing on each such application-defined subclass in
-order to implement desired behavior.
+order to implement desired behavior. @xref{event-source}.
@end deftp
@anchor{event-source}
-@deftp Class event-source dispatcher
+@deftp Class event-source callback-event-name dispatcher
This is the base class for user interface objects that generate
-events. It derives from @ref{native-object}. The @code{dispatcher}
-slot holds an instance of @ref{event-dispatcher} that is responsible
-for processing events on behalf of an @code{event-source}.
+events@footnote{Actually, events are generated by underlying
+native window objects, which are represented in the class hierarchy by
+the event-source class}. It derives from @ref{native-object}.
+@table @var
+@item callback-event-name
+This is an (@code{:allocation :class}) slot that holds a symbol
+identifying an event function (e.g., @ref{event-select}), to be
+supplied along with a function pointer in calls to the internal
+@code{define-dispatcher} function. The purpose of this is to
+facilitate implementation of shortcuts for defining dispatchers where
+definition of a primary event function is sufficient, as is the case
+when a @ref{control} class wants to support a @code{:callback}
+initarg. The choice of event function is determined by each subclass,
+hence this slot is shadowed by each such subclass. Application code
+typically is not concerned with this slot, except when an application
+defines new kinds of event sources.
+@item dispatcher
+This slot holds a reference to an instance of @ref{event-dispatcher},
+which has responsibility for handling events on behalf of the event
+source object.
+@end table
@deffn Initarg :callbacks
The @code{:callbacks} initarg value specifies an association list
where the @code{CAR} of each entry is the symbol of an @code{event-*}
@@ -362,10 +437,6 @@
pointer. As such, this constitutes a specification for a new
@ref{event-dispatcher} class and associated methods.
@end deffn
-@deffn Initarg :dispatcher
-@end deffn
-@deffn Accessor dispatcher
-@end deffn
@end deftp
@anchor{file-dialog}
@@ -634,13 +705,13 @@
@end deftp
@deftp Class menu-item
-A subclass of @ref{item} representing a menu item.
+A subclass of @ref{item} representing a @ref{menu} item.
@end deftp
@anchor{panel}
@deftp Class panel
Base class for @ref{window}s that are children of @ref{top-level}
-@ref{window}s (or other panels).
+windows, @ref{dialog}s, or other @code{panel}s.
@end deftp
@anchor{root-window}
@@ -666,7 +737,7 @@
@end deftp
@anchor{timer}
-@deftp Class timer
+@deftp Class timer id initial-delay delay
A timer is a non-windowed object that generates events at a regular
(adjustable) frequency. Applications handle timer events by
implementing the @ref{event-timer} generic function. This class
Modified: trunk/docs/manual/reference.texinfo
==============================================================================
--- trunk/docs/manual/reference.texinfo (original)
+++ trunk/docs/manual/reference.texinfo Sun Jul 9 16:38:15 2006
@@ -149,6 +149,8 @@
@end copying
@c %**end of header
+@footnotestyle end
+
@titlepage
@title Graphic-Forms Programming Reference
@c @subtitle Version 0.5
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Sun Jul 9 16:38:15 2006
@@ -148,11 +148,11 @@
(defmethod give-focus ((self control))
(gfs::set-focus (gfs:handle self)))
-(defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys)
+(defmethod initialize-instance :after ((self control) &key callback callbacks dispatcher parent &allow-other-keys)
(if (gfs:disposed-p parent)
(error 'gfs:disposed-error))
- (unless (or disp callbacks (not (functionp callback)))
- (let ((class (define-dispatcher `((event-select . ,callback)))))
+ (unless (or dispatcher callbacks (not (functionp callback)))
+ (let ((class (define-dispatcher (class-name (class-of self)) callback)))
(setf (dispatcher self) (make-instance (class-name class))))))
(defmethod (setf maximum-size) :after (max-size (self control))
Modified: trunk/src/uitoolkit/widgets/event-source.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-source.lisp (original)
+++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 16:38:15 2006
@@ -35,6 +35,7 @@
(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source))
(gfw:event-arm . (gfw:event-source))
+ (gfw:event-modify . (gfw:event-source))
(gfw:event-select . (gfw:event-source))))
(defun make-specializer-list (disp-class arg-info)
@@ -42,10 +43,10 @@
(push disp-class tmp)
tmp))
-(defun define-dispatcher (callbacks)
- (let* ((*print-gensym* nil)
- (class (clos:ensure-class (gentemp "EDCLASS" :gfgen)
- :direct-superclasses '(event-dispatcher))))
+(defun define-dispatcher-for-callbacks (callbacks)
+ (let ((*print-gensym* nil)
+ (class (clos:ensure-class (gentemp "EDCLASS" :gfgen)
+ :direct-superclasses '(event-dispatcher))))
(loop for pair in callbacks
do (let* ((method-sym (car pair))
(fn (cdr pair))
@@ -65,13 +66,17 @@
:specializers (make-specializer-list class arg-info))))
class))
+(defun define-dispatcher (classname callback)
+ (let ((proto (c2mop:class-prototype (find-class classname))))
+ (define-dispatcher-for-callbacks `((,(callback-event-name-of proto) . ,callback)))))
+
;;;
;;; methods
;;;
-(defmethod initialize-instance :after ((self event-source) &key callbacks disp &allow-other-keys)
- (unless (or disp (null callbacks))
- (let ((class (define-dispatcher callbacks)))
+(defmethod initialize-instance :after ((self event-source) &key callbacks dispatcher &allow-other-keys)
+ (unless (or dispatcher (null callbacks))
+ (let ((class (define-dispatcher-for-callbacks callbacks)))
(setf (dispatcher self) (make-instance (class-name class))))))
(defmethod owner :before ((self event-source))
Modified: trunk/src/uitoolkit/widgets/menu-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-item.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-item.lisp Sun Jul 9 16:38:15 2006
@@ -172,7 +172,7 @@
((null disp)
(setf item (make-instance 'menu-item :handle hmenu)))
((functionp disp)
- (setf item (make-instance 'menu-item :handle hmenu :callbacks `((gfw:event-select . ,disp)))))
+ (setf item (make-instance 'menu-item :handle hmenu :callback disp)))
((typep disp 'gfw:event-dispatcher)
(setf item (make-instance 'menu-item :handle hmenu :dispatcher disp)))
(t
@@ -220,6 +220,12 @@
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)
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp Sun Jul 9 16:38:15 2006
@@ -150,8 +150,8 @@
(if (null callback)
(error 'gfs:toolkit-error :detail "missing callback argument"))
(if sub
- (setf disp `(make-instance (define-dispatcher `((gfw:event-activate . ,,callback)))))
- (setf disp `(make-instance (define-dispatcher `((gfw:event-select . ,,callback)))))))
+ (setf disp `(make-instance (define-dispatcher 'gfw:menu ,callback)))
+ (setf disp `(make-instance (define-dispatcher 'gfw:menu-item ,callback)))))
(when disp
(if sep
(error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators"))
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Sun Jul 9 16:38:15 2006
@@ -131,7 +131,7 @@
(cond
((null disp))
((functionp disp)
- (let ((class (define-dispatcher `((event-activate . ,disp)))))
+ (let ((class (define-dispatcher 'gfw:menu disp)))
(setf (dispatcher submenu) (make-instance (class-name class)))))
((typep disp 'gfw:event-dispatcher)
(setf (dispatcher submenu) disp))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Jul 9 16:38:15 2006
@@ -72,14 +72,22 @@
((dispatcher
:accessor dispatcher
:initarg :dispatcher
- :initform (make-instance 'event-dispatcher)))
+ :initform (make-instance 'event-dispatcher))
+ (callback-event-name
+ :accessor callback-event-name-of
+ :initform nil
+ :allocation :class)) ; subclasses will shadow this slot
(:documentation "This is the base class for user interface objects that generate events."))
(defclass item (event-source)
((item-id
:accessor item-id
:initarg :item-id
- :initform 0))
+ :initform 0)
+ (callback-event-name
+ :accessor callback-event-name-of
+ :initform 'event-select
+ :allocation :class)) ; shadowing same slot from event-source
(:documentation "The item class is the base class for all non-windowed user interface objects."))
(defclass menu-item (item) ()
@@ -121,10 +129,18 @@
:initform nil))
(:documentation "The base class for widgets having pre-defined native behavior."))
-(defclass button (control) ()
+(defclass button (control)
+ ((callback-event-name
+ :accessor callback-event-name-of
+ :initform 'event-select
+ :allocation :class)) ; shadowing same slot from event-source
(:documentation "This class represents selectable controls that issue notifications when clicked."))
-(defclass edit (control) ()
+(defclass edit (control)
+ ((callback-event-name
+ :accessor callback-event-name-of
+ :initform 'event-modify
+ :allocation :class)) ; shadowing same slot from event-source
(:documentation "This class represents a control in which the user may enter and edit text."))
(defclass label (control) ()
@@ -146,7 +162,11 @@
:initform (make-array 7 :fill-pointer 0 :adjustable t)))
(:documentation "The widget-with-items class is the base class for objects composed of sub-items."))
-(defclass menu (widget-with-items) ()
+(defclass menu (widget-with-items)
+ ((callback-event-name
+ :accessor callback-event-name-of
+ :initform 'event-activate
+ :allocation :class)) ; shadowing same slot from event-source
(:documentation "The menu class represents a container for menu items (and submenus)."))
(defclass window (widget layout-managed)
1
0