From dfb515ef6cc5a645e2d96120d34514ca146dcb57 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 13 Oct 2023 13:35:59 +1300 Subject: [PATCH] Segfault fixes. --- Graphics/Text/Font/Choose/CharSet.hs | 3 +++ Graphics/Text/Font/Choose/Config.hs | 20 ++++++++++---------- Graphics/Text/Font/Choose/FontSet.hs | 4 ++-- Graphics/Text/Font/Choose/FontSet/API.hs | 24 +++++++++++++++--------- fontconfig-pure.cabal | 2 +- 5 files changed, 31 insertions(+), 22 deletions(-) diff --git a/Graphics/Text/Font/Choose/CharSet.hs b/Graphics/Text/Font/Choose/CharSet.hs index 1b08a79..03e76bb 100644 --- a/Graphics/Text/Font/Choose/CharSet.hs +++ b/Graphics/Text/Font/Choose/CharSet.hs @@ -9,6 +9,7 @@ import Data.Word (Word32) import Foreign.Ptr import Foreign.ForeignPtr (newForeignPtr, withForeignPtr) import Control.Exception (bracket) +import Foreign.Storable (peek) import Control.Monad (forM) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Array (allocaArray) @@ -93,3 +94,5 @@ foreign import ccall "my_FcCharSetIterDone" fcCharSetIterDone :: Word32 -> Bool thawCharSet_ :: IO CharSet_ -> IO CharSet thawCharSet_ cb = bracket (throwNull <$> cb) fcCharSetDestroy thawCharSet +thawCharSet' :: Ptr CharSet_ -> IO CharSet +thawCharSet' = thawCharSet_ . peek diff --git a/Graphics/Text/Font/Choose/Config.hs b/Graphics/Text/Font/Choose/Config.hs index 084112b..c3d2afb 100644 --- a/Graphics/Text/Font/Choose/Config.hs +++ b/Graphics/Text/Font/Choose/Config.hs @@ -243,23 +243,23 @@ foreign import ccall "FcFontMatch" fcFontMatch :: -- otherwise the results will not be correct. fontSort :: Config -> Pattern -> Bool -> Maybe (FontSet, CharSet) fontSort config pattern trim = unsafePerformIO $ withForeignPtr config $ \config' -> - withPattern pattern $ \pattern' -> withNewCharSet $ \csp' -> alloca $ \res' -> do - ret <- fcFontSort config' pattern' trim csp' res' - throwPtr res' $ do - x <- thawFontSet_ $ pure $ throwNull ret - y <- thawCharSet $ throwNull csp' - return (x, y) + withPattern pattern $ \pattern' -> alloca $ \csp' -> alloca $ \res' -> do + ret <- fcFontSort config' pattern' trim csp' res' + throwPtr res' $ do + x <- thawFontSet_ $ pure ret + y <- thawCharSet' csp' + return (x, y) -- | Variant of `fontSort` which operates upon current configuration. fontSort' :: Pattern -> Bool -> Maybe (FontSet, CharSet) fontSort' pattern trim = unsafePerformIO $ withPattern pattern $ \pattern' -> - withNewCharSet $ \csp' -> alloca $ \res' -> do + alloca $ \csp' -> alloca $ \res' -> do ret <- fcFontSort nullPtr pattern' trim csp' res' throwPtr res' $ do - x <- thawFontSet_ $ pure $ throwNull ret - y <- thawCharSet $ throwNull csp' + x <- thawFontSet_ $ pure ret + y <- thawCharSet' csp' return (x, y) foreign import ccall "FcFontSort" fcFontSort :: - Config_ -> Pattern_ -> Bool -> CharSet_ -> Ptr Word8 -> IO FontSet_ + Config_ -> Pattern_ -> Bool -> Ptr CharSet_ -> Ptr Word8 -> IO FontSet_ -- | Creates a new pattern consisting of elements of font not appearing in pat, -- elements of pat not appearing in font and the best matching value from pat diff --git a/Graphics/Text/Font/Choose/FontSet.hs b/Graphics/Text/Font/Choose/FontSet.hs index 91ea7a9..05c0713 100644 --- a/Graphics/Text/Font/Choose/FontSet.hs +++ b/Graphics/Text/Font/Choose/FontSet.hs @@ -7,7 +7,7 @@ import Graphics.Text.Font.Choose.Result (throwFalse, throwNull) import Foreign.Ptr (Ptr, castPtr, nullPtr) import Foreign.Storable (pokeElemOff, sizeOf) import Foreign.Marshal.Alloc (allocaBytes) -import Foreign.Marshal.Array (peekArray) +import Foreign.Marshal.Array (peekArray, allocaArray) import Control.Monad (forM) import Control.Exception (bracket) import System.IO.Unsafe (unsafeInterleaveIO) @@ -46,7 +46,7 @@ foreign import ccall "FcFontSetAdd" fcFontSetAdd :: FontSet_ -> Pattern_ -> IO B withFontSets :: [FontSet] -> (Ptr FontSet_ -> Int -> IO a) -> IO a withFontSets fontss cb = let n = length fontss in - allocaBytes (sizeOf (undefined :: FontSet_) * n) $ \fontss' -> + allocaArray n $ \fontss' -> withFontSets' fontss 0 fontss' $ cb fontss' n withFontSets' :: [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a withFontSets' [] _ _ cb = cb diff --git a/Graphics/Text/Font/Choose/FontSet/API.hs b/Graphics/Text/Font/Choose/FontSet/API.hs index cf107d4..8383ee8 100644 --- a/Graphics/Text/Font/Choose/FontSet/API.hs +++ b/Graphics/Text/Font/Choose/FontSet/API.hs @@ -60,18 +60,24 @@ foreign import ccall "FcFontSetMatch" fcFontSetMatch :: -- the return value from multiple `fontSort` calls, applications cannot modify -- these patterns. Instead, they should be passed, along with pattern to -- `fontRenderPrepare` which combines them into a complete pattern. -fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet -fontSetSort config fontss pattern trim csp = unsafePerformIO $ +fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> Maybe (FontSet, CharSet) +fontSetSort config fontss pattern trim = unsafePerformIO $ withForeignPtr config $ \config' -> withFontSets fontss $ \fontss' n -> - withPattern pattern $ \pattern' -> withCharSet csp $ \csp' -> alloca $ \res' -> do + withPattern pattern $ \pattern' -> alloca $ \csp' -> alloca $ \res' -> do ret' <- fcFontSetSort config' fontss' n pattern' trim csp' res' - throwPtr res' $ thawFontSet_ $ pure ret' + throwPtr res' $ do + x <- thawFontSet_ $ pure ret' + y <- thawCharSet' csp' + return (x, y) -- | Variant of `fontSetSort` operating upon registered default `Config`. -fontSetSort' :: [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet -fontSetSort' fontss pattern trim csp = unsafePerformIO $ +fontSetSort' :: [FontSet] -> Pattern -> Bool -> Maybe (FontSet, CharSet) +fontSetSort' fontss pattern trim = unsafePerformIO $ withFontSets fontss $ \fontss' n -> withPattern pattern $ \pattern' -> - withCharSet csp $ \csp' -> alloca $ \res' -> do + alloca $ \csp' -> alloca $ \res' -> do ret' <- fcFontSetSort nullPtr fontss' n pattern' trim csp' res' - throwPtr res' $ thawFontSet_ $ pure ret' + throwPtr res' $ do + x <- thawFontSet_ $ pure ret' + y <- thawCharSet' csp' + return (x, y) foreign import ccall "FcFontSetSort" fcFontSetSort :: Config_ -> Ptr FontSet_ - -> Int -> Pattern_ -> Bool -> CharSet_ -> Ptr Word8 -> IO FontSet_ + -> Int -> Pattern_ -> Bool -> Ptr CharSet_ -> Ptr Word8 -> IO FontSet_ diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal index 1892d27..52f150a 100644 --- a/fontconfig-pure.cabal +++ b/fontconfig-pure.cabal @@ -10,7 +10,7 @@ name: fontconfig-pure -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.3.0.1 +version: 0.4.0.0 -- A short (one-line) description of the package. synopsis: Pure-functional language bindings to FontConfig -- 2.30.2