Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Appling patches from Steffen Siering

Expose functions to read/write an image to/from a ByteString.
Use of ForeignPtr to takes care of memory space leaks.
  • Loading branch information...
commit f725c92f620a5558586184635c4648de444dae0b 1 parent 587da90
@vincentg authored
View
164 Graphics/Transform/Magick/FFIHelpers.hsc
@@ -3,6 +3,12 @@ module Graphics.Transform.Magick.FFIHelpers(withExceptions,
withExceptions_,
setField,
(-->),
+ mkImage,
+ setImage,
+ applyImageFn,
+ applyImageFn',
+ applyImageFn1,
+ applyImageFn1',
setFilename,
getFilename,
setPage,
@@ -13,7 +19,13 @@ module Graphics.Transform.Magick.FFIHelpers(withExceptions,
sideEffectingOp,
linkImagesTogether,
mkNewExceptionInfo,
+ nonFinalizedExceptionInfo,
+ destroyExceptionInfo,
+ withTmpExceptionInfo,
mkNewImageInfo,
+ mkFinalizedImageInfo,
+ destroyImageInfo,
+ withTmpImageInfo,
toCEnum,
hImageRows,
hImageColumns,
@@ -27,11 +39,23 @@ import Graphics.Transform.Magick.Magick
import Graphics.Transform.Magick.Errors
import Graphics.Transform.Magick.Util
+import qualified Foreign.Concurrent as FC (newForeignPtr)
+
import Control.Exception
import Prelude hiding (maximum, minimum)
-- functions to help with doing FFI
+setImage :: HImage -> Ptr HImage_ -> HImage
+setImage hIm imPtr = unsafePerformIO $ do
+ i <- newForeignPtr finalize_image imPtr
+ return hIm{ image = i }
+
+mkImage :: Ptr HImage_ -> ImageNotLoaded -> HImage
+mkImage p info = unsafePerformIO $ do
+ i <- newForeignPtr finalize_image p
+ return $ HImage { image=i, otherInfo=info }
+
-------------- Strings/char arrays
-- This is really terrible. How to avoid these casts?
pokeStringIntoCharArray :: Ptr CharArray -> String -> IO ()
@@ -62,10 +86,25 @@ nullChar :: CChar
nullChar = castCharToCChar '\0'
-------- sets a field in something Storable --------
-setField :: Storable a => (a -> a) -> Ptr a -> IO ()
-setField modify p = peek p >>= ((poke p).modify)
-(-->) :: Storable a => Ptr a -> (a -> b) -> b
-(-->) p sel = unsafePerformIO $ peek p >>= (return.sel)
+
+class PtrAccessors ptr where
+ setField :: Storable a => (a -> a) -> ptr a -> IO ()
+ (-->) :: Storable a => ptr a -> (a -> b) -> b
+
+instance PtrAccessors Ptr where
+ setField modify p = peek p >>= ((poke p).modify)
+ p --> sel = unsafePerformIO $ peek p >>= (return.sel)
+
+instance PtrAccessors ForeignPtr where
+ setField modify p = withForeignPtr p (setField modify)
+ p --> sel = unsafePerformIO $ withForeignPtr p (\fp ->
+ peek fp >>= (return.sel))
+
+-- setField :: Storable a => (a -> a) -> Ptr a -> IO ()
+-- setField modify p = peek p >>= ((poke p).modify)
+-- (-->) :: Storable a => Ptr a -> (a -> b) -> b
+-- (-->) p sel = unsafePerformIO $ peek p >>= (return.sel)
+
---------------------------------
-- Function for handling exceptions from GraphicsMagick calls.
@@ -74,8 +113,8 @@ setField modify p = peek p >>= ((poke p).modify)
-- determine whether the result of the call was erroneous, as well as a pointer
-- to the exception info that the action will set.
-- The checker function is assumed to return True if there was an error.
-withExceptions :: IO a -> String -> (a -> Bool) -> (Ptr ExceptionInfo) -> IO a
-withExceptions action errMsg checker excPtr = do
+withExceptions :: IO a -> String -> (a -> Bool) -> (ForeignPtr ExceptionInfo) -> IO a
+withExceptions action errMsg checker excPtr_ = withForeignPtr excPtr_ $ \excPtr -> do
result <- action
if (checker result)
then do
@@ -85,7 +124,7 @@ withExceptions action errMsg checker excPtr = do
signalException errMsg
else return result
-- Same as withExceptions, but throws away the result
-withExceptions_ :: IO a -> String -> (a -> Bool) -> Ptr ExceptionInfo -> IO ()
+withExceptions_ :: IO a -> String -> (a -> Bool) -> ForeignPtr ExceptionInfo -> IO ()
withExceptions_ action errMsg checker excPtr =
withExceptions action errMsg checker excPtr >> return ()
@@ -93,6 +132,22 @@ withExceptions_ action errMsg checker excPtr =
-- call doTransform. For transformations that take extra arguments,
-- we use doTransformIO.
+applyImageFn :: HImage -> (Ptr HImage_ -> a) -> (a -> IO b) -> IO b
+applyImageFn hImage fn run = withForeignPtr (getImage hImage) $ \i_ptr ->
+ run $ fn i_ptr
+
+applyImageFn' :: HImage -> (Ptr HImage_ -> t) -> (t -> Ptr ExceptionInfo -> IO b) -> IO b
+applyImageFn' hImage fn run = withForeignPtr (getImage hImage) $ \i_ptr ->
+ withForeignPtr (getExceptionInfo hImage) $ \e_ptr ->
+ run (fn i_ptr) e_ptr
+
+applyImageFn1 :: HImage -> (Ptr HImage_ -> t -> IO b) -> t -> IO b
+applyImageFn1 hImage fn v = applyImageFn hImage fn $ \f -> f v
+
+
+applyImageFn1' :: HImage -> (Ptr HImage_ -> t -> Ptr ExceptionInfo -> IO b) -> t -> IO b
+applyImageFn1' hImage fn v = applyImageFn' hImage fn $ \f -> f v
+
-- doTransform takes an image transformation that takes an
-- image pointer and an exception pointer as arguments, and applies it
-- to the given HImage.
@@ -101,7 +156,8 @@ withExceptions_ action errMsg checker excPtr =
doTransform :: (Ptr HImage_ -> Ptr ExceptionInfo
-> IO (Ptr HImage_)) -> HImage -> HImage
doTransform transform hImage =
- doTransformIO (transform (getImage hImage) excInfo) hImage
+ doTransformIO (applyImageFn hImage transform $ withForeignPtr excInfo)
+ hImage
where excInfo = getExceptionInfo hImage
-- doTransformIO takes an arbitrary IO action that returns an HImage_
@@ -123,8 +179,8 @@ doTransformIO_XY :: (Integral a, Integral b) =>
(Ptr HImage_ -> a -> a -> Ptr ExceptionInfo -> IO (Ptr HImage_)) ->
HImage -> b -> b -> HImage
doTransformIO_XY transform hImage x_ y_ =
- doTransformIO (transform (getImage hImage) (fromIntegral x_) (fromIntegral y_)
- (getExceptionInfo hImage))
+ doTransformIO (applyImageFn' hImage transform $ \f ->
+ f (fromIntegral x_) (fromIntegral y_))
hImage
-- Ugh.
@@ -132,8 +188,7 @@ doTransformIO_XY_real :: (Real b, Fractional a) =>
(Ptr HImage_ -> a -> a -> Ptr ExceptionInfo -> IO (Ptr HImage_)) ->
HImage -> b -> b -> HImage
doTransformIO_XY_real transform hImage x_ y_ =
- doTransformIO (transform (getImage hImage) (realToFrac x_) (realToFrac y_)
- (getExceptionInfo hImage))
+ doTransformIO (applyImageFn' hImage transform $ \f -> f (realToFrac x_) (realToFrac y_))
hImage
------------------ creating image sequences -----------
@@ -141,10 +196,11 @@ linkImagesTogether :: [HImage] -> IO ()
linkImagesTogether [] = signalException $ "internal error: linkImagesTogether:"
++ " empty list"
linkImagesTogether (img:images) = do
- _ <- foldM (\ bigImage smallImage -> do
- (#poke Image, next) (getImage bigImage)
- (getImage smallImage)
- return smallImage)
+ _ <- foldM (\ bigImage smallImage ->
+ withForeignPtr (getImage bigImage) $ \bi ->
+ withForeignPtr (getImage smallImage) $ \si -> do
+ (#poke Image, next) bi si
+ return smallImage)
img
images
debug 3 $ "Checking assertion..."
@@ -155,8 +211,8 @@ linkImagesTogether (img:images) = do
assertM (allGood && lastNull)
"flattenImage: internal error: couldn't create sequence"
where nextImageNotNull hImage = do
- debug 3 $ "peeking: " ++ show (getImage hImage)
- nextIm <- (#peek Image, next) (getImage hImage)
+ -- debug 3 $ "peeking: " ++ show (getImage hImage)
+ nextIm <- withForeignPtr (getImage hImage) $ (#peek Image, next)
debug 3 $ "peeked! " ++ show nextIm
return $ nextIm /= nullPtr
@@ -687,8 +743,8 @@ maxTextExtent :: Int
maxTextExtent = 2053
hImageRows, hImageColumns :: HImage -> Word
-hImageRows = fromIntegral.columns.unsafePerformIO.peek.getImage
-hImageColumns = fromIntegral.rows.unsafePerformIO.peek.getImage
+hImageRows i = unsafePerformIO $ withForeignPtr (getImage i) $ return.fromIntegral.columns.unsafePerformIO.peek
+hImageColumns i = unsafePerformIO $ withForeignPtr (getImage i) $ return.fromIntegral.rows.unsafePerformIO.peek
--------------- Filename handling
@@ -712,7 +768,7 @@ instance HasFilename HImage where
------------- Page setting
setPage :: HImage -> Rectangle -> IO ()
-setPage hImage rect = (#poke Image, page) (getImage hImage) rect
+setPage hImage rect = applyImageFn hImage (#poke Image, page) $ \f -> f rect
------------- Dealing with side-effecting GraphicsMagick functions
sideEffectingOp :: (HImage -> IO CUInt) -> HImage -> HImage
@@ -725,28 +781,79 @@ sideEffectingOp impureFun = (\ hImage -> unsafePerformIO $ do
--------- Utils
-- The type emphasizes that we're doing something wantonly
-- non-referentially-transparent
+
+
+cloneImageInfo :: ForeignPtr HImageInfo -> IO (ForeignPtr HImageInfo)
+cloneImageInfo fp = withForeignPtr fp $ \p ->
+ mkFinalizedImageInfo =<< clone_image_info p
+
cloneImage :: HImage -> IO HImage
cloneImage hImage = do
- clonedImagePtr <- cloneImagePtr (getImage hImage)
- clonedImageInfo <- clone_image_info (getImageInfo hImage)
+ clonedImagePtr <- withForeignPtr (getImage hImage) cloneImagePtr
+ clonedImageInfo <- cloneImageInfo (getImageInfo hImage)
clonedExceptionInfo <- mkNewExceptionInfo
return $ mkImage clonedImagePtr (mkUnloadedImage clonedImageInfo clonedExceptionInfo)
-- 0 and 0 say that the cloned image should have the same
-- size as the original. 1 says this should be an orphan
-- image (not part of a list.)
- where cloneImagePtr p = withExceptions (clone_image p 0 0 1 (getExceptionInfo hImage))
+ where cloneImagePtr p = withExceptions (withForeignPtr (getExceptionInfo hImage) $
+ clone_image p 0 0 1)
"cloneImagePtr: error cloning image"
(== nullPtr)
(getExceptionInfo hImage)
----------- Exceptions
-mkNewExceptionInfo :: IO (Ptr ExceptionInfo)
-mkNewExceptionInfo = do
+
+mkNewExceptionInfo :: IO (ForeignPtr ExceptionInfo)
+mkNewExceptionInfo = mkFinalizedExceptionInfo =<< mkNewExceptionInfo_
+
+mkFinalizedExceptionInfo :: Ptr ExceptionInfo -> IO (ForeignPtr ExceptionInfo)
+mkFinalizedExceptionInfo p = FC.newForeignPtr p (destroyExceptionInfo p)
+
+nonFinalizedExceptionInfo :: Ptr ExceptionInfo -> IO (ForeignPtr ExceptionInfo)
+nonFinalizedExceptionInfo = newForeignPtr_
+
+mkNewExceptionInfo_ :: IO (Ptr ExceptionInfo)
+mkNewExceptionInfo_ = do
infoPtr <- malloc
get_exception_info infoPtr
return infoPtr
+
+destroyExceptionInfo :: Ptr ExceptionInfo -> IO ()
+destroyExceptionInfo infoPtr = do
+ destroy_exception_info infoPtr
+ free infoPtr
+
+withTmpExceptionInfo :: (Ptr ExceptionInfo -> IO a) -> IO a
+withTmpExceptionInfo action = do
+ infoPtr <- mkNewExceptionInfo_
+ result <- action infoPtr
+ result `seq` destroyExceptionInfo infoPtr
+ return result
+
----------- Image info
-mkNewImageInfo :: IO (Ptr HImageInfo)
-mkNewImageInfo = clone_image_info nullPtr
+
+mkNewImageInfo :: IO (ForeignPtr HImageInfo)
+mkNewImageInfo = mkFinalizedImageInfo =<< mkNewImageInfo_
+
+mkFinalizedImageInfo :: Ptr HImageInfo -> IO (ForeignPtr HImageInfo)
+mkFinalizedImageInfo = newForeignPtr imageInfoFinalizer
+
+mkNewImageInfo_ :: IO (Ptr HImageInfo)
+mkNewImageInfo_ = clone_image_info nullPtr
+
+destroyImageInfo :: Ptr HImageInfo -> IO ()
+destroyImageInfo = destroy_image_info
+
+foreign import ccall "static magick/api.h &DestroyImageInfo"
+ imageInfoFinalizer :: FunPtr (Ptr HImageInfo -> IO ())
+
+withTmpImageInfo :: (Ptr HImageInfo -> IO a) -> IO a
+withTmpImageInfo action = do
+ imgInfo <- mkNewImageInfo_
+ result <- action imgInfo
+ result `seq` destroy_image_info imgInfo
+ return result
+
----------- Both
mkNewUnloadedImage :: ImageNotLoaded
mkNewUnloadedImage = unsafePerformIO $ do
@@ -761,3 +868,4 @@ toCEnum = fromIntegral.fromEnum
maybeToPtr :: Storable a => Maybe a -> Ptr a -> IO (Ptr a)
maybeToPtr Nothing _ = return nullPtr
maybeToPtr (Just stuff) p = poke p stuff >> return p
+
View
154 Graphics/Transform/Magick/Images.hsc
@@ -1,6 +1,8 @@
module Graphics.Transform.Magick.Images(initializeMagick, readImage, writeImage, pingImage,
readInlineImage,
getFilename,
+ blobToImage,
+ imageToBlob,
-- transformations
flipImage,
flopImage,
@@ -38,6 +40,7 @@ module Graphics.Transform.Magick.Images(initializeMagick, readImage, writeImage,
compositeImage,
-- image methods
allocateImage,
+ destroyImage,
setImageColormap,
newImageColormap,
appendImages,
@@ -50,6 +53,9 @@ module Graphics.Transform.Magick.Images(initializeMagick, readImage, writeImage,
#include <magick/api.h>
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Unsafe as BS
+
import Graphics.Transform.Magick.Magick
import Graphics.Transform.Magick.Types
import Graphics.Transform.Magick.FFIHelpers
@@ -138,15 +144,16 @@ readImage = genericReadImage read_image
-- TODO: has the side effect that it writes the filepath into the image filename
-- fields. is this the right thing?
-writeImage fp hImage = do
+writeImage fp hImage = withForeignPtr (getImage hImage) $ \img_ptr -> do
-- hmm, side-effect the image info or make a copy of it?
setFilename hImage fp
debug 2 $ "About to write image..."
+ excInfo <- nonFinalizedExceptionInfo ((#ptr Image, exception) img_ptr)
-- write_image signals an exception by returning 0
- withExceptions_ (write_image (getImageInfo hImage) (getImage hImage))
+ withExceptions_ (withForeignPtr (getImageInfo hImage) (\ii ->
+ (write_image ii img_ptr)))
"writeImage: error writing image"
- (== 0)
- ((#ptr Image, exception) (getImage hImage))
+ (== 0) excInfo
debug 2 $ "Wrote the image!"
ex <- doesFileExist fp
debug 3 $ fp ++ (if ex then " exists " else " doesn't exist")
@@ -158,34 +165,44 @@ pingImage = genericReadImage ping_image
------------- composition ---------------------
compositeImage op x_offset y_offset canvas_image comp_image = sideEffectingOp
- (\ canvasIm -> withExceptions (composite_image (getImage canvasIm) (toCEnum op)
- (getImage comp_image)
- (fromIntegral x_offset) (fromIntegral y_offset))
+ (\ canvasIm -> withExceptions (
+ withForeignPtr (getImage canvasIm) $ \canvasImPtr ->
+ withForeignPtr (getImage comp_image) $ \comp_image_ptr ->
+ composite_image canvasImPtr (toCEnum op) comp_image_ptr
+ (fromIntegral x_offset) (fromIntegral y_offset))
"compositeImage: error compositing image" (== 0)
(getExceptionInfo canvasIm)) canvas_image
------------- image methods -------------------
allocateImage imgNotLoaded = unsafePerformIO $ do
- imagePtr <- allocate_image $ imageInfo imgNotLoaded
+ imagePtr <- withForeignPtr (imageInfo imgNotLoaded) allocate_image
if(imagePtr == nullPtr)
then (signalException "allocateImage returned null")
else return $ mkImage imagePtr imgNotLoaded
+-- optionaly let user destroy image and free memory immediately
+destroyImage :: HImage -> IO ()
+destroyImage (HImage img (ImageNotLoaded info exc)) = do
+ finalizeForeignPtr img
+ finalizeForeignPtr info
+ finalizeForeignPtr exc
+
setImageColormap clrs hImage = sideEffectingOp
- (\ im -> allocate_image_colormap (getImage im) (fromIntegral clrs))
+ (\ im -> applyImageFn1 im allocate_image_colormap (fromIntegral clrs))
hImage
newImageColormap clrs = unsafePerformIO $ do
let hImage = allocateImage mkNewUnloadedImage
- withExceptions_ (allocate_image_colormap (getImage hImage)
- (fromIntegral clrs)) "setImageColormap: error setting colormap" (== 0)
+ withExceptions_ (applyImageFn1 hImage allocate_image_colormap (fromIntegral clrs))
+ "setImageColormap: error setting colormap" (== 0)
(getExceptionInfo hImage)
return hImage
-- should require list to be nonempty
appendImages order images@(img:_) = unsafePerformIO $ do
linkImagesTogether images
- iPtr <- withExceptions (append_images (getImage img) (toCEnum order) (getExceptionInfo img)) "appendImage: error appending"
+ iPtr <- withExceptions (applyImageFn1' img append_images (toCEnum order))
+ "appendImage: error appending"
(== nullPtr) (getExceptionInfo img)
return $ setImage img iPtr
appendImages _ [] = unsafePerformIO $ signalException "appendImages: empty list"
@@ -196,7 +213,7 @@ appendImages _ [] = unsafePerformIO $ signalException "appendImages: empty list"
-- hmm, appendImages and averageImages look a lot alike...
averageImages images@(img:_) = unsafePerformIO $ do
linkImagesTogether images
- iPtr <- withExceptions (average_images (getImage img) (getExceptionInfo img))
+ iPtr <- withExceptions (applyImageFn' img average_images id)
"averageImages: error averaging" (== nullPtr) (getExceptionInfo img)
return $ setImage img iPtr
averageImages [] = unsafePerformIO $ signalException "averageImages: empty list"
@@ -204,7 +221,7 @@ averageImages [] = unsafePerformIO $ signalException "averageImages: empty list
-- TODO: should really abstract the patterns of "returns boolean" and
-- "may return null pointer"
cycleColormapImage amount img = sideEffectingOp
- (\ im -> cycle_colormap_image (getImage im) (fromIntegral amount))
+ (\ im -> applyImageFn1 im cycle_colormap_image (fromIntegral amount))
img
destroyImage img = destroy_image $ getImage img
@@ -227,7 +244,8 @@ describeImage verbosity img = unsafePerformIO $ do
------------- Stuff what displays stuff
animateImages images@(img:_) = do
linkImagesTogether images
- withExceptions_ (animate_images (getImageInfo img) (getImage img))
+ withExceptions_ (withForeignPtr (getImageInfo img) (\ii ->
+ (applyImageFn img (animate_images ii) id)))
"animateImages: error animating" (== 0) (getExceptionInfo img)
animateImages [] = return ()
------------- genericReadImage - not exported
@@ -242,11 +260,13 @@ genericReadOp :: (ImageNotLoaded -> IO ()) ->
String -> IO HImage
genericReadOp prepareImageInfo theAction errStr = do
infoPtr <- mkNewExceptionInfo
- image_info <- clone_image_info nullPtr
+ image_info <- mkNewImageInfo
let theImage = mkUnloadedImage image_info infoPtr
prepareImageInfo theImage
- iPtr <- withExceptions (theAction image_info infoPtr)
- errStr (== nullPtr) infoPtr
+ iPtr <- withForeignPtr image_info $ \ii_ptr ->
+ withForeignPtr infoPtr $ \exc_ptr ->
+ withExceptions (theAction ii_ptr exc_ptr)
+ errStr (== nullPtr) infoPtr
return $ mkImage iPtr theImage
----------------------------------------------
@@ -273,8 +293,7 @@ minifyImage = doTransform minify_image
-- rotates an image by an arbitrary number of degrees
rotateImage degrees hImage = doTransformIO
- (rotate_image (getImage hImage) (realToFrac degrees)
- (getExceptionInfo hImage))
+ (applyImageFn1' hImage rotate_image (realToFrac degrees))
hImage
affineTransform affineMatrix hImage = unsafePerformIO $ do
@@ -283,8 +302,7 @@ affineTransform affineMatrix hImage = unsafePerformIO $ do
(\ matrixP -> do
poke matrixP affineMatrix
return $ doTransformIO
- (affine_transform (getImage hImage) matrixP
- (getExceptionInfo hImage))
+ (applyImageFn1' hImage affine_transform matrixP)
hImage)
-- cuts the specified rectangle out of the image,
@@ -341,16 +359,17 @@ shearImage xFactor yFactor hImage = doTransformIO_XY_real shear_image
-- the stupid argument names are due to these names being already taken
-- as record fields.
resizeImage cols rws fltr blr hImage =
- doTransformIO (resize_image (getImage hImage) (fromIntegral cols)
- (fromIntegral rws) (toCEnum fltr)
- (realToFrac blr) (getExceptionInfo hImage))
+ doTransformIO (applyImageFn' hImage resize_image $ \f -> f
+ (fromIntegral cols)
+ (fromIntegral rws) (toCEnum fltr)
+ (realToFrac blr))
hImage
------------ enhancements
-- TODO: the contrastImage call only increases or decreases by a
-- given increment. perhaps want to change our API to specify
-- an amount of contrast
contrastImage increaseOrDecrease hImage = sideEffectingOp
- (\ im -> contrast_image (getImage im) sharpen) hImage
+ (\ im -> applyImageFn1 im contrast_image sharpen) hImage
where sharpen = case increaseOrDecrease of
IncreaseContrast -> 1
DecreaseContrast -> 0
@@ -359,27 +378,29 @@ equalizeImage = simpleOp equalize_image
normalizeImage = simpleOp normalize_image
gammaImage (PixelPacket { red=gRed, green=gGreen, blue=gBlue }) hImage =
- sideEffectingOp (\ im -> withCString levelStr (gamma_image (getImage im)))
+ sideEffectingOp (\ im -> applyImageFn im gamma_image $ withCString levelStr)
hImage
where levelStr = commaSep [gRed, gGreen, gBlue]
levelImage (Level { black=lBlack, mid=lMid, white=lWhite }) hImage =
- sideEffectingOp (\ im -> withCString levelStr (level_image (getImage im)))
+ sideEffectingOp (\ im ->
+ applyImageFn im level_image $ withCString levelStr)
hImage
where levelStr = commaSep [lBlack, lMid, lWhite]
levelImageChannel chanTy (Level { black=lBlack, mid=lMid, white=lWhite })
hImage = sideEffectingOp (\ im ->
- level_image_channel (getImage im) (toCEnum chanTy)
- (realToFrac lBlack) (realToFrac lMid) (realToFrac lWhite)) hImage
+ applyImageFn im level_image_channel $ \ f ->
+ f (toCEnum chanTy) (realToFrac lBlack)
+ (realToFrac lMid) (realToFrac lWhite)) hImage
modulateImage (Modulation{ brightness=b, saturation=s, hue=h }) hImage =
sideEffectingOp (\ im ->
- withCString modStr (modulate_image (getImage im))) hImage
+ applyImageFn im modulate_image $ withCString modStr) hImage
where modStr = commaSep [b, s, h]
negateImage whatToNegate hImage =
- (sideEffectingOp (\ im -> negate_image (getImage im) whatToDo) hImage)
+ (sideEffectingOp (\ im -> applyImageFn1 im negate_image whatToDo) hImage)
where whatToDo = case whatToNegate of
AllPixels -> 0
GrayscalePixels -> 1
@@ -399,15 +420,16 @@ constituteImage pixMap pixels = unsafePerformIO $ do
debug 3 $ "width = " ++ show wdth ++ " height = " ++ show hght ++ " sz = " ++ (show (pixelSize pixMap) ++ " len = " ++ show (length aScanline))
iPtr <- withExceptions (withArray (map marshalPixel (concat pixels)) (\ pixelArray ->
withCString (show pixMap) $
- (\ mapStr -> constitute_image
- wdth
- -- this is kind of weak... the pixmap
- -- says how many numbers represent each pixel. seems bad.
- -- we should have a better type system for this.
- hght
- mapStr
- (toCEnum (storageType (head aScanline)))
- pixelArray eInfo))) "constituteImage: error" (== nullPtr) eInfo
+ (\ mapStr -> withForeignPtr eInfo $
+ constitute_image
+ wdth
+ -- this is kind of weak... the pixmap
+ -- says how many numbers represent each pixel. seems bad.
+ -- we should have a better type system for this.
+ hght
+ mapStr
+ (toCEnum (storageType (head aScanline)))
+ pixelArray))) "constituteImage: error" (== nullPtr) eInfo
iInfo <- mkNewImageInfo
return $ mkImage iPtr (mkUnloadedImage iInfo eInfo)
-- TODO: freeing pixelArray and other memory?
@@ -424,10 +446,11 @@ dispatchImage pixMap storType (Rectangle{ width=cols, height=rws,
(allocaArray len (\ pixelArray ->
withCString (show pixMap) $
(\ mapStr -> do
- withExceptions_ (dispatch_image (getImage hImage) (fromIntegral x_offset)
- (fromIntegral y_offset) (fromIntegral cols)
- (fromIntegral rws) mapStr (toCEnum storType) pixelArray
- (getExceptionInfo hImage)) "dispatchImage: error" (== 0)
+ withExceptions_ (applyImageFn' hImage dispatch_image $ \f ->
+ f (fromIntegral x_offset) (fromIntegral y_offset)
+ (fromIntegral cols) (fromIntegral rws) mapStr
+ (toCEnum storType) pixelArray)
+ "dispatchImage: error" (== 0)
(getExceptionInfo hImage)
pixelList <- peekArray (fromIntegral len) pixelArray
let blobs = map unmarshalPixel pixelList
@@ -465,8 +488,8 @@ importPixelImageArea quantumType quantumSize pixels options hImage =
(\ pixelArray -> (alloca (\ importInfo -> (alloca (\ optionsPtr -> do
optsPtr <- maybeToPtr options optionsPtr
-- this side-effects the image, so we need to make a copy
- res <- (import_image_pixel_area (getImage theImage)
- (toCEnum quantumType) (fromIntegral quantumSize) pixelArray optsPtr
+ res <- (applyImageFn theImage import_image_pixel_area $ \f ->
+ f (toCEnum quantumType) (fromIntegral quantumSize) pixelArray optsPtr
importInfo)
bytes_imported <- (#peek ImportPixelAreaInfo, bytes_imported) importInfo
assertM (bytes_imported == length pixels)
@@ -478,7 +501,7 @@ readInlineImage base64content = unsafePerformIO $ do
genericReadOp (const (return ()))
(\ image_info exception_info ->
(withCString cleanedUpString (\ content_str ->
- read_inline_image image_info content_str exception_info)))
+ read_inline_image image_info content_str exception_info)))
"readInlineImage: error reading inline content"
where cleanedUpString = insertComma (deleteNewlines
(deleteEqualsSignLine base64content))
@@ -496,23 +519,50 @@ readInlineImage base64content = unsafePerformIO $ do
(firstLine:secondLine:restLines) ->
unlines (firstLine:((',':secondLine):restLines))
_ -> s
+
+blobToImage :: BS.ByteString -> HImage
+blobToImage bs = unsafePerformIO $ do
+ genericReadOp (const (return ()))
+ (\image_info exception_info ->
+ BS.unsafeUseAsCStringLen bs (\(ptr, len) ->
+ blob_to_image image_info (castPtr ptr) (fromIntegral len)
+ exception_info))
+ "blobToImage: error loading image from blob"
+
+imageToBlob :: HImage -> BS.ByteString
+imageToBlob img = unsafePerformIO $
+ withTmpImageInfo $ \imgInfo ->
+ alloca $ \sizePtr -> do
+ excInfo <- mkNewExceptionInfo
+ dat <- withExceptions (applyImageFn1' img (image_to_blob imgInfo) sizePtr)
+ "imageToBlob: unable to encode image"
+ (==nullPtr)
+ excInfo
+ len <- fromIntegral `fmap` peek sizePtr
+ BS.unsafePackCStringFinalizer (castPtr dat) len (free dat)
+
--------- helpers (private) ------------
simpleOp :: (Ptr HImage_ -> IO CUInt) -> HImage -> HImage
-simpleOp op im = sideEffectingOp (op.getImage) im
+simpleOp op im = sideEffectingOp
+ (\hImage ->
+ withForeignPtr (getImage hImage) $ \ii_ptr ->
+ op ii_ptr) im
withRectangle :: Rectangle ->
(Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo -> IO (Ptr HImage_)) ->
HImage -> IO HImage
withRectangle rect transform hImage = do
- -- Does this actually free the memory?
+ -- Does this actually free the memory?
+ -- Steffen: Yes, this will free the memory
(rectPtr::ForeignPtr Rectangle) <- mallocForeignPtr
-- This was causing a segfault so it\'s temporarily commented out.
-- TODO: Worry about memory freeing.
+ -- Steffen: this is not needed, mallocForeignPtr already installs a
+ -- correct finalizer
--addForeignPtrFinalizer p_free rectPtr
withForeignPtr rectPtr $
(\ rectP -> do
poke rectP rect
return $ doTransformIO
- (transform (getImage hImage) rectP
- (getExceptionInfo hImage))
+ (applyImageFn1' hImage transform rectP)
hImage)
View
18 Graphics/Transform/Magick/Magick.hs
@@ -4,6 +4,7 @@ module Graphics.Transform.Magick.Magick(module Foreign.C.Types,
module Control.Monad,
initialize_magick,
get_exception_info,
+ destroy_exception_info,
clone_image_info,
read_image,
write_image,
@@ -39,6 +40,9 @@ module Graphics.Transform.Magick.Magick(module Foreign.C.Types,
-- constitution
constitute_image,
dispatch_image,
+ -- blob
+ blob_to_image,
+ image_to_blob,
--export_image_pixel_area,
export_pixel_area_options_init,
import_image_pixel_area,
@@ -58,6 +62,7 @@ module Graphics.Transform.Magick.Magick(module Foreign.C.Types,
cycle_colormap_image,
describe_image,
destroy_image,
+ finalize_image,
destroy_image_info,
get_image_clip_mask,
get_image_depth,
@@ -106,6 +111,9 @@ foreign import ccall "static magick/api.h InitializeMagick"
foreign import ccall "static magick/api.h GetExceptionInfo"
get_exception_info :: Ptr ExceptionInfo -> IO ()
+foreign import ccall "static magick/api.h DestroyExceptionInfo"
+ destroy_exception_info :: Ptr ExceptionInfo -> IO ()
+
foreign import ccall "static magick/api.h CloneImageInfo"
clone_image_info :: Ptr HImageInfo -> IO (Ptr HImageInfo)
@@ -148,6 +156,13 @@ foreign import ccall "static magick/api.h PingImage"
foreign import ccall "static magick/api.h ReadInlineImage"
read_inline_image :: Ptr HImageInfo -> CString -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+----------------- Blob
+foreign import ccall "static magick/api.h BlobToImage"
+ blob_to_image :: Ptr HImageInfo -> Ptr CUChar -> CSize -> Ptr ExceptionInfo -> IO (Ptr HImage_)
+
+foreign import ccall "static magick/api.h ImageToBlob"
+ image_to_blob :: Ptr HImageInfo -> Ptr HImage_ -> Ptr CSize -> Ptr ExceptionInfo -> IO (Ptr CUChar)
+
----------------- Transformations
foreign import ccall "static magick/api.h FlipImage"
@@ -279,6 +294,9 @@ foreign import ccall "static magick/api.h DescribeImage"
foreign import ccall "static magick/api.h DestroyImage"
destroy_image :: Ptr HImage_ -> IO ()
+foreign import ccall "static magick/api.h &DestroyImage"
+ finalize_image :: FunPtr(Ptr HImage_ -> IO ())
+
foreign import ccall "static magick/api.h DestroyImageInfo"
destroy_image_info :: Ptr HImageInfo -> IO ()
View
19 Graphics/Transform/Magick/Types.hs
@@ -20,10 +20,10 @@ import Foreign.C.String
-- the filename in both the image *and* the info.
-- TODO: don't export the selectors for this.
-data HImage = HImage {image::Ptr HImage_,
+data HImage = HImage {image::ForeignPtr HImage_,
otherInfo::ImageNotLoaded}
-data ImageNotLoaded = ImageNotLoaded { imageInfo::Ptr HImageInfo,
- exceptionInfo::Ptr ExceptionInfo }
+data ImageNotLoaded = ImageNotLoaded { imageInfo::ForeignPtr HImageInfo,
+ exceptionInfo::ForeignPtr ExceptionInfo }
-- A rectangle is represented as a width, height, horizontal offset, and
-- vertical offset
@@ -73,23 +73,18 @@ data ChannelType =
MatteChannel
deriving Enum
-getImage :: HImage -> Ptr HImage_
-getImageInfo :: HImage -> Ptr HImageInfo
-getExceptionInfo :: HImage -> Ptr ExceptionInfo
-setImage :: HImage -> Ptr HImage_ -> HImage
+getImage :: HImage -> ForeignPtr HImage_
+getImageInfo :: HImage -> ForeignPtr HImageInfo
+getExceptionInfo :: HImage -> ForeignPtr ExceptionInfo
getImage = image
getImageInfo = imageInfo.otherInfo
getExceptionInfo = exceptionInfo.otherInfo
-setImage hIm imPtr = hIm{ image = imPtr }
-
-mkUnloadedImage :: Ptr HImageInfo -> Ptr ExceptionInfo -> ImageNotLoaded
+mkUnloadedImage :: ForeignPtr HImageInfo -> ForeignPtr ExceptionInfo -> ImageNotLoaded
mkUnloadedImage iInfo exInfo =
ImageNotLoaded{ imageInfo = iInfo, exceptionInfo = exInfo }
-mkImage :: Ptr HImage_ -> ImageNotLoaded -> HImage
-mkImage p info = HImage { image=p, otherInfo=info }
data FilterTypes =
UndefinedFilter
View
2  README
@@ -43,5 +43,5 @@ for their encouragement.
=== Contributors ===
-Thanks to "nonowarn" for contributing patches.
+Thanks to "nonowarn", "Steffen Siering" for contributing patches.
View
2  hsmagick.cabal
@@ -17,7 +17,7 @@ build-type: Simple
data-files: README
Library {
-build-depends: base < 5, directory, filepath, pretty, process
+build-depends: base < 5, directory, filepath, pretty, process, bytestring
exposed-modules: Graphics.Transform.Magick.Images, Graphics.Transform.Magick.Types, Graphics.Transform.Magick.Test
other-modules: Graphics.Transform.Magick.FFIHelpers, Graphics.Transform.Magick.Util, Graphics.Transform.Magick.Errors, Graphics.Transform.Magick.Magick
ghc-options: -Wall
Please sign in to comment.
Something went wrong with that request. Please try again.