diff --git a/Graphics/Transform/Magick/FFIHelpers.hsc b/Graphics/Transform/Magick/FFIHelpers.hsc --- a/Graphics/Transform/Magick/FFIHelpers.hsc +++ b/Graphics/Transform/Magick/FFIHelpers.hsc @@ -3,6 +3,12 @@ withExceptions_, setField, (-->), + mkImage, + setImage, + applyImageFn, + applyImageFn', + applyImageFn1, + applyImageFn1', setFilename, getFilename, setPage, @@ -13,7 +19,13 @@ sideEffectingOp, linkImagesTogether, mkNewExceptionInfo, + nonFinalizedExceptionInfo, + destroyExceptionInfo, + withTmpExceptionInfo, mkNewImageInfo, + mkFinalizedImageInfo, + destroyImageInfo, + withTmpImageInfo, toCEnum, hImageRows, hImageColumns, @@ -27,11 +39,24 @@ 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) +import Control.Monad -- 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 +87,25 @@ 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 +114,8 @@ -- 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 +125,7 @@ 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 +133,22 @@ -- 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 +157,8 @@ 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 +180,8 @@ (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 +189,7 @@ (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 +197,11 @@ 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 +212,8 @@ 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 +744,8 @@ 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 +769,7 @@ ------------- 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 +782,79 @@ --------- 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 +869,4 @@ maybeToPtr :: Storable a => Maybe a -> Ptr a -> IO (Ptr a) maybeToPtr Nothing _ = return nullPtr maybeToPtr (Just stuff) p = poke p stuff >> return p + diff --git a/Graphics/Transform/Magick/Images.hsc b/Graphics/Transform/Magick/Images.hsc --- a/Graphics/Transform/Magick/Images.hsc +++ b/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, @@ -43,12 +45,16 @@ appendImages, averageImages, cycleColormapImage, + destroyImage, -- describeImage, -- Stuff what displays stuff animateImages) where #include +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 @@ -66,6 +72,8 @@ readImage :: FilePath -> IO HImage writeImage :: FilePath -> HImage -> IO () pingImage :: FilePath -> IO HImage +-- | initializeMagick must be invoked by the user program before making use +-- of the library functions. initializeMagick :: IO () --------- Transformations flipImage, flopImage :: HImage -> HImage @@ -118,6 +126,7 @@ appendImages :: ImageOrder -> [HImage] -> HImage averageImages :: [HImage] -> HImage cycleColormapImage :: Int -> HImage -> HImage +destroyImage :: HImage -> IO () -- TODO. -- describeImage :: Verbosity -> HImage -> String ------------- Stuff what displays stuff @@ -136,15 +145,16 @@ -- 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") @@ -156,34 +166,43 @@ ------------- 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 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" @@ -194,7 +213,7 @@ -- 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" @@ -202,7 +221,7 @@ -- 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 {- @@ -223,7 +242,8 @@ ------------- 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 @@ -238,11 +258,13 @@ 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 ---------------------------------------------- @@ -269,8 +291,7 @@ -- 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 @@ -279,8 +300,7 @@ (\ 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, @@ -337,16 +357,17 @@ -- 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 @@ -355,27 +376,29 @@ 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 @@ -395,15 +418,16 @@ 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? @@ -420,10 +444,11 @@ (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 @@ -461,8 +486,8 @@ (\ 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) @@ -474,7 +499,7 @@ 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)) @@ -492,23 +517,50 @@ (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) diff --git a/Graphics/Transform/Magick/Magick.hs b/Graphics/Transform/Magick/Magick.hs --- a/Graphics/Transform/Magick/Magick.hs +++ b/Graphics/Transform/Magick/Magick.hs @@ -1,9 +1,9 @@ module Graphics.Transform.Magick.Magick(module Foreign.C.Types, module Foreign, module Foreign.C.String, - module Control.Monad, initialize_magick, get_exception_info, + destroy_exception_info, clone_image_info, read_image, write_image, @@ -39,6 +39,9 @@ -- 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 +61,7 @@ cycle_colormap_image, describe_image, destroy_image, + finalize_image, destroy_image_info, get_image_clip_mask, get_image_depth, @@ -91,7 +95,6 @@ import Foreign import Foreign.C.Types import Foreign.C.String -import Control.Monad -- The internal interface to the GraphicsMagick library. This -- module should mostly (if not entirely) contain import declarations @@ -106,6 +109,9 @@ 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 +154,13 @@ 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" @@ -278,6 +291,9 @@ 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 () diff --git a/Graphics/Transform/Magick/Types.hs b/Graphics/Transform/Magick/Types.hs --- a/Graphics/Transform/Magick/Types.hs +++ b/Graphics/Transform/Magick/Types.hs @@ -20,10 +20,10 @@ -- 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 @@ 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 diff --git a/README b/README --- a/README +++ b/README @@ -25,9 +25,10 @@ be better yet. Please submit bug reports, questions, feedback, complaints, praise, -and especially patches (including documentation patches) to me at: +and especially patches (including documentation patches) to the +maintainer at: - chevalier@alum.wellesley.edu + vincent_AT_xenbox.fr I did a lot of this work during the second Haskell Hackathon (Hac II '07) in Freiburg in September 2007. I'd like to thank all the @@ -42,5 +43,5 @@ === Contributors === -Thanks to "nonowarn" for contributing patches. +Thanks to "nonowarn", "Steffen Siering" for contributing patches. diff --git a/hsmagick.cabal b/hsmagick.cabal --- a/hsmagick.cabal +++ b/hsmagick.cabal @@ -1,27 +1,27 @@ name: hsmagick -version: 0.4 +version: 0.5 synopsis: FFI bindings for the GraphicsMagick library description: FFI bindings for the GraphicsMagick library category: Graphics license: BSD3 license-file: LICENSE author: Tim Chevalier -maintainer: chevalier@alum.wellesley.edu +maintainer: Vincent Gerard, vincent@xenbox.fr copyright: (c) Tim Chevalier, 2008 stability: alpha -homepage: http://community.haskell.org/~tim +homepage: https://github.com/vincentg/hsmagick Cabal-Version: >= 1.2.3 -tested-with: GHC==6.10.4, GHC==6.12.2 +tested-with: GHC==6.10.4, GHC==6.12.2, GHC==7.0.2 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 -extra-libraries: tiff jasper jpeg png wmflite bz2 z m pthread +extra-libraries: tiff jasper jpeg png wmflite bz2 z m pkgconfig-depends: GraphicsMagick >= 1.3.3 , lcms , freetype2