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)