July 2006 - graphic-forms-cvs@common-lisp.net

[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

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

[graphic-forms-cvs] r197 - in trunk: docs/manual etc src src/uitoolkit/system src/uitoolkit/widgets
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

[graphic-forms-cvs] r196 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 13 Jul '06

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

[graphic-forms-cvs] r195 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
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

[graphic-forms-cvs] r194 - in trunk/src: demos/textedit uitoolkit/widgets
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

[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

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

[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

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

[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

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

[graphic-forms-cvs] r190 - in trunk: docs/manual src src/demos/textedit src/uitoolkit/widgets
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

[graphic-forms-cvs] r189 - in trunk: docs/manual src/uitoolkit/widgets
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