[graphic-forms-cvs] r87 - trunk/src/uitoolkit/graphics
junrue at common-lisp.net
junrue at common-lisp.net
Mon Apr 3 06:42:39 UTC 2006
Author: junrue
Date: Mon Apr 3 02:42:38 2006
New Revision: 87
Modified:
trunk/src/uitoolkit/graphics/graphics-classes.lisp
trunk/src/uitoolkit/graphics/graphics-context.lisp
trunk/src/uitoolkit/graphics/image-data.lisp
trunk/src/uitoolkit/graphics/image.lisp
Log:
fixed more GDI handle leaks
Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Mon Apr 3 02:42:38 2006
@@ -114,9 +114,6 @@
:initform 1)
(pen-handle
:accessor pen-handle-of
- :initform (cffi:null-pointer))
- (orig-pen-handle
- :accessor orig-pen-handle-of
:initform (cffi:null-pointer)))
(:documentation "This class represents the context associated with drawing primitives."))
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Apr 3 02:42:38 2006
@@ -91,10 +91,8 @@
(setf (pen-handle-of gc) new-hpen)
(setf old-hpen (gfs::select-object (gfs:handle gc) new-hpen))
(gfs::set-miter-limit (gfs:handle gc) (miter-limit gc) (cffi:null-pointer))
- (if (gfs:null-handle-p (orig-pen-handle-of gc))
- (setf (orig-pen-handle-of gc) old-hpen)
- (unless (gfs:null-handle-p old-hpen)
- (gfs::delete-object old-hpen)))))))
+ (unless (gfs:null-handle-p old-hpen)
+ (gfs::delete-object old-hpen))))))
(defun call-rect-function (fn name hdc rect)
(let ((pnt (gfs:location rect))
@@ -227,9 +225,7 @@
(gfs::set-bk-color hdc rgb)))
(defmethod gfs:dispose ((self graphics-context))
- (unless (gfs:null-handle-p (orig-pen-handle-of self))
- (gfs::select-object (gfs:handle self) (orig-pen-handle-of self)))
- (setf (orig-pen-handle-of self) nil)
+ (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+))
(gfs::delete-object (pen-handle-of self))
(setf (pen-handle-of self) nil)
(let ((fn (dc-destructor-of self)))
@@ -369,7 +365,9 @@
gfs::width
gfs::height
memdc2
- 0 0 gfs::+blt-srcpaint+))
+ 0 0 gfs::+blt-srcpaint+)
+ (gfs::delete-dc memdc2)
+ (gfs::delete-object hcopy))
(gfs:dispose tr-mask))
(progn
(gfs::select-object memdc himage)
Modified: trunk/src/uitoolkit/graphics/image-data.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image-data.lisp (original)
+++ trunk/src/uitoolkit/graphics/image-data.lisp Mon Apr 3 02:42:38 2006
@@ -182,8 +182,10 @@
(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))))))
- hbmp)))))
+ (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
Modified: trunk/src/uitoolkit/graphics/image.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image.lisp (original)
+++ trunk/src/uitoolkit/graphics/image.lisp Mon Apr 3 02:42:38 2006
@@ -48,17 +48,18 @@
(defun clone-bitmap (horig)
(let ((hclone (cffi:null-pointer))
+ (screen-dc (gfs::get-dc (cffi:null-pointer)))
(nptr (cffi:null-pointer)))
(gfs::with-compatible-dcs (nptr memdc-src memdc-dest)
(cffi:with-foreign-object (bmp-ptr 'gfs::bitmap)
(cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap)
(gfs::get-object horig (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr)
- (setf hclone (gfs::create-compatible-bitmap (gfs::get-dc (cffi:null-pointer))
- gfs::width
- gfs::height))
+ (setf hclone (gfs::create-compatible-bitmap screen-dc gfs::width gfs::height))
(gfs::select-object memdc-dest hclone)
(gfs::select-object memdc-src horig)
(gfs::bit-blt memdc-dest 0 0 gfs::width gfs::height memdc-src 0 0 gfs::+blt-srccopy+))))
+ (unless (gfs:null-handle-p screen-dc)
+ (gfs::release-dc (cffi:null-pointer) screen-dc))
hclone))
;;;
@@ -88,12 +89,12 @@
(cffi:with-foreign-slots ((gfs::bisize gfs::biwidth gfs::biheight gfs::biplanes
gfs::bibitcount gfs::bicompression)
bih-ptr gfs::bitmapinfoheader)
- (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
- gfs::biwidth (gfs:size-width size)
- gfs::biheight (- (gfs:size-height size))
- gfs::biplanes 1
- gfs::bibitcount 32
- gfs::bicompression gfs::+bi-rgb+)
+ (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
+ gfs::biwidth (gfs:size-width size)
+ gfs::biheight (- (gfs:size-height size))
+ gfs::biplanes 1
+ gfs::bibitcount 32
+ gfs::bicompression gfs::+bi-rgb+)
(let ((nptr (cffi:null-pointer))
(hbmp (cffi:null-pointer)))
(cffi:with-foreign-object (buffer :pointer)
@@ -125,8 +126,7 @@
(let ((pixel-pnt (transparency-pixel-of im))
(hbmp (gfs:handle im))
(hmask (cffi:null-pointer))
- (nptr (cffi:null-pointer))
- (old-bg 0))
+ (nptr (cffi:null-pointer)))
(unless (null pixel-pnt)
(cffi:with-foreign-object (bmp-ptr 'gfs::bitmap)
(gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr)
@@ -136,9 +136,9 @@
(error 'gfs:win32-error :detail "create-bitmap failed"))
(gfs::with-compatible-dcs (nptr memdc1 memdc2)
(gfs::select-object memdc1 hbmp)
- (setf old-bg (gfs::set-bk-color memdc1
- (gfs::get-pixel memdc1 (gfs:point-x pixel-pnt) (gfs:point-y pixel-pnt))))
+ (gfs::set-bk-color memdc1 (gfs::get-pixel memdc1
+ (gfs:point-x pixel-pnt)
+ (gfs:point-y pixel-pnt)))
(gfs::select-object memdc2 hmask)
- (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+)
- (gfs::set-bk-color memdc1 old-bg))))
- (make-instance 'image :handle hmask))))
+ (gfs::bit-blt memdc2 0 0 gfs::width gfs::height memdc1 0 0 gfs::+blt-srccopy+)))
+ (make-instance 'image :handle hmask)))))
More information about the Graphic-forms-cvs
mailing list