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)))))