~alcinnz/harfbuzz-pure: Throw out-of-memory errors instead of segfaulting.

3 files changed, 101 insertions(+), 22 deletions(-)

M Data/Text/Glyphize/Buffer.hs
M Data/Text/Glyphize/Font.hs
M harfbuzz-pure.cabal

M Data/Text/Glyphize/Buffer.hs => Data/Text/Glyphize/Buffer.hs +7 -4

@@ 8,8 8,7 @@ import Data.Char (toUpper, toLower)
 import Control.Monad (forM)
 import Control.Exception (bracket)
 
---- To fill computed text property.
-import Data.Text.Encoding (decodeUtf8Lenient)
+import Data.Text.Glyphize.Oom (throwFalse, throwNull)
 
 import qualified Data.Text.Array as A
 import GHC.Exts (ByteArray#, sizeofByteArray#, Int#)


@@ 324,6 323,8 @@ withBuffer buf cb = withNewBuffer $ \buf' -> bufferWithText buf' (text buf) $ do
         (Just ContentTypeUnicode, Nothing, _, _) -> hb_buffer_guess_segment_properties buf'
         (Just ContentTypeUnicode, _, Nothing, _) -> hb_buffer_guess_segment_properties buf'
         (Just ContentTypeUnicode, _, _, Nothing) -> hb_buffer_guess_segment_properties buf'
+
+    throwFalse $ hb_buffer_allocation_successful buf'
     cb buf'
 foreign import ccall "hb_buffer_set_content_type" hb_buffer_set_content_type
     :: Buffer' -> Int -> IO ()


@@ 342,6 343,8 @@ foreign import ccall "hb_buffer_set_replacement_codepoint" hb_buffer_set_replace
 --    :: Buffer' -> Word32 -> IO ()
 foreign import ccall "hb_buffer_guess_segment_properties" hb_buffer_guess_segment_properties
     :: Buffer' -> IO ()
+foreign import ccall "hb_buffer_allocation_successful" hb_buffer_allocation_successful
+    :: Buffer' -> IO Bool
 
 ------
 --- C-to-Haskell conversion


@@ 412,7 415,7 @@ instance Storable GlyphInfo where
         pokeElemOff ptr' 4 0
 -- | Decodes `Buffer'`'s glyph information array.'
 glyphInfos buf' = do
-    arr <- hb_buffer_get_glyph_infos buf' nullPtr
+    arr <- throwNull $ hb_buffer_get_glyph_infos buf' nullPtr
     length <- hb_buffer_get_length buf'
     if length == 0 || arr == nullPtr
     then return []


@@ 458,7 461,7 @@ instance Storable GlyphPos where
 -- | Decodes `Buffer'`'s glyph position array.
 -- If buffer did not have positions before, they will be initialized to zeros.'
 glyphsPos buf' = do
-    arr <- hb_buffer_get_glyph_positions buf' nullPtr
+    arr <- throwNull $ hb_buffer_get_glyph_positions buf' nullPtr
     length <- hb_buffer_get_length buf'
     if length == 0 || arr == nullPtr
     then return []

M Data/Text/Glyphize/Font.hs => Data/Text/Glyphize/Font.hs +93 -17

@@ 8,6 8,7 @@ import Data.Int (Int32)
 import FreeType.Core.Base (FT_Face)
 import Data.Text.Glyphize.Buffer (tag_to_string, tag_from_string, Direction, dir2int,
                                 c2w, w2c)
+import Data.Text.Glyphize.Oom (throwNull, throwFalse)
 
 import Control.Monad (forM, unless)
 import Data.Maybe (fromMaybe)


@@ 57,6 58,9 @@ parseFeature :: String -> Maybe Feature
 parseFeature str = unsafePerformIO $ withCStringLen str $ \(str', len) -> alloca $ \ret' -> do
     success <- hb_feature_from_string str' len ret'
     if success then Just <$> peek ret' else return Nothing
+parseFeature' str = unsafePerformIO $ withCStringLen str $ \(str', len) -> alloca $ \ret' -> do
+    throwFalse $ hb_feature_from_string str' len ret'
+    peek ret'
 foreign import ccall "hb_feature_from_string" hb_feature_from_string
     :: CString -> Int -> Ptr Feature -> IO Bool
 -- | Converts a `Feature` into a `String` in the format understood by `parseFeature`.


@@ 88,6 92,9 @@ parseVariation :: String -> Maybe Variation
 parseVariation str = unsafePerformIO $ withCStringLen str $ \(str', len) -> alloca $ \ret' -> do
     success <- hb_variation_from_string str' len ret'
     if success then Just <$> peek ret' else return Nothing
+parseVariation' str = unsafePerformIO $ withCStringLen str $ \(str', len) -> alloca $ \ret' -> do
+    throwFalse $ hb_variation_from_string str' len ret'
+    peek ret'
 foreign import ccall "hb_variation_from_string" hb_variation_from_string
     :: CString -> Int -> Ptr Variation -> IO Bool
 -- | Converts a `Variation` into a `String` in the format understood by `parseVariation`.


@@ 134,7 141,7 @@ data Face'
 createFace :: ByteString -> Word -> Face
 createFace bytes index = unsafePerformIO $ do
     blob <- bs2blob bytes
-    face <- withForeignPtr blob $ flip hb_face_create index
+    face <- withForeignPtr blob $ throwNull . flip hb_face_create index
     hb_face_make_immutable face
     newForeignPtr hb_face_destroy face
 foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Word -> IO Face_


@@ 144,9 151,11 @@ foreign import ccall "&hb_face_destroy" hb_face_destroy :: FunPtr (Face_ -> IO (
 -- | Creates a`Face` object from the specified `FT_Face`.
 -- Not thread-safe due to FreeType dependency.
 ftCreateFace :: FT_Face -> IO Face
-ftCreateFace = newForeignPtr hb_face_destroy . hb_ft_face_create_referenced
+ftCreateFace ft = do
+    ret <- throwNull $ hb_ft_face_create_referenced ft
+    newForeignPtr hb_face_destroy ret
 foreign import ccall "hb_ft_face_create_referenced" hb_ft_face_create_referenced
-    :: FT_Face -> Face_
+    :: FT_Face -> IO Face_
 
 -- | Fetches the singleton empty `Face` object.
 emptyFace :: Face


@@ 252,14 261,14 @@ foreign import ccall "hb_face_set_upem" hb_face_set_upem :: Face_ -> Word -> IO 
 createFaceWithOpts  :: FaceOptions -> ByteString -> Word -> Face
 createFaceWithOpts opts bytes index = unsafePerformIO $ do
     blob <- bs2blob bytes
-    face <- withForeignPtr blob $ flip hb_face_create index
+    face <- withForeignPtr blob $ throwNull . flip hb_face_create index
     _setFaceOptions face opts
     hb_face_make_immutable face
     newForeignPtr hb_face_destroy face
 -- | Variant of `ftCreateFace` which applies given options.
 ftCreateFaceWithOpts :: FaceOptions -> FT_Face -> IO Face
 ftCreateFaceWithOpts opts ftFace = do
-    let face = hb_ft_face_create_referenced ftFace
+    face <- throwNull $ hb_ft_face_create_referenced ftFace
     _setFaceOptions face opts
     hb_face_make_immutable face
     newForeignPtr hb_face_destroy face


@@ 269,10 278,11 @@ ftCreateFaceWithOpts opts ftFace = do
 -- with tables sorted by size then tag.
 buildFace :: [(String, ByteString)] -> FaceOptions -> Face
 buildFace tables opts = unsafePerformIO $ do
-    builder <- hb_face_builder_create
+    builder <- throwNull hb_face_builder_create
     forM tables $ \(tag, bytes) -> do
         blob <- bs2blob bytes
-        withForeignPtr blob $ hb_face_builder_add_table builder $ tag_from_string tag
+        throwFalse $ withForeignPtr blob $
+            hb_face_builder_add_table builder $ tag_from_string tag
     _setFaceOptions builder opts
     hb_face_make_immutable builder
     newForeignPtr hb_face_destroy builder


@@ 313,7 323,7 @@ data Font'
 -- This allows specifying which named-instance to load by default when creating the face.
 createFont :: Face -> Font
 createFont fce = unsafePerformIO $ do
-    font <- withForeignPtr fce $ hb_font_create
+    font <- throwNull $ withForeignPtr fce $ hb_font_create
     hb_font_make_immutable font
     newForeignPtr hb_font_destroy font
 foreign import ccall "hb_font_create" hb_font_create :: Face_ -> IO Font_


@@ 326,7 336,7 @@ foreign import ccall "&hb_font_destroy" hb_font_destroy :: FunPtr (Font_ -> IO (
 -- and will access `frSize`` member of `FT_Face` unconditionally.
 ftCreateFont :: FT_Face -> IO Font
 ftCreateFont fce = do
-    font <- hb_ft_font_create_referenced fce
+    font <- throwNull $ hb_ft_font_create_referenced fce
     hb_font_make_immutable font
     newForeignPtr hb_font_destroy font
 foreign import ccall "hb_ft_font_create_referenced" hb_ft_font_create_referenced


@@ 336,7 346,7 @@ foreign import ccall "hb_ft_font_create_referenced" hb_ft_font_create_referenced
 -- replicating the parent's properties.
 createSubFont :: Font -> Font
 createSubFont parent = unsafePerformIO $ do
-    font <- withForeignPtr parent $ hb_font_create_sub_font
+    font <- throwNull $ withForeignPtr parent $ hb_font_create_sub_font
     hb_font_make_immutable font
     newForeignPtr hb_font_destroy font
 foreign import ccall "hb_font_create_sub_font" hb_font_create_sub_font :: Font_ -> IO Font_


@@ 349,7 359,7 @@ foreign import ccall "hb_font_get_empty" hb_font_get_empty :: Font_
 -- | Fetches the `Face` associated with the specified `Font` object.
 fontFace :: Font -> Face
 fontFace font = unsafePerformIO $ withForeignPtr font $ \font' -> do
-    face' <- hb_font_get_face font'
+    face' <- throwNull $ hb_font_get_face font'
     newForeignPtr_ face' -- FIXME: Keep the font alive...
 foreign import ccall "hb_font_get_face" hb_font_get_face :: Font_ -> IO Face_
  


@@ 360,6 370,10 @@ fontGlyph font char var =
     unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do
         success <- hb_font_get_glyph font' (c2w char) (c2w $ fromMaybe '\0' var) ret
         if success then return . Just =<< peek ret else return Nothing
+fontGlyph' font char var =
+    unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do
+        throwFalse $ hb_font_get_glyph font' (c2w char) (c2w $ fromMaybe '\0' var) ret
+        peek ret
 foreign import ccall "hb_font_get_glyph" hb_font_get_glyph
     :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
 


@@ 390,6 404,12 @@ fontGlyphContourPoint font glyph index = unsafePerformIO $
             y <- peek y'
             return $ Just (x, y)
         else return Nothing
+fontGlyphContourPoint' font glyph index = unsafePerformIO $
+    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
+        throwFalse $ hb_font_get_glyph_contour_point font' glyph index x' y'
+        x <- peek x'
+        y <- peek y'
+        return (x, y)
 foreign import ccall "hb_font_get_glyph_contour_point" hb_font_get_glyph_contour_point
     :: Font_ -> Word32 -> Int -> Ptr Int32 -> Ptr Int32 -> IO Bool
 


@@ 409,6 429,13 @@ fontGlyphContourPointForOrigin font glyph index dir = unsafePerformIO $
             y <- peek y'
             return $ Just (x, y)
         else return Nothing
+fontGlyphContourPointForOrigin' font glyph index dir = unsafePerformIO $
+    withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do
+        throwFalse $ hb_font_get_glyph_contour_point_for_origin font' glyph index
+                (dir2int dir) x' y'
+        x <- peek x'
+        y <- peek y'
+        return (x, y)
 foreign import ccall "hb_font_get_glyph_contour_point_for_origin"
     hb_font_get_glyph_contour_point_for_origin
         :: Font_ -> Word32 -> Int -> Int -> Ptr Int32 -> Ptr Int32 -> IO Bool


@@ 434,6 461,10 @@ fontGlyphExtents font glyph = unsafePerformIO $
         if success
         then return . Just =<< peek ret
         else return Nothing
+fontGlyphExtents' font glyph = unsafePerformIO $
+    withForeignPtr font $ \font' -> alloca $ \ret -> do
+        throwFalse $ hb_font_get_glyph_extents font' glyph ret
+        peek ret
 foreign import ccall "hb_font_get_glyph_extents" hb_font_get_glyph_extents
     :: Font_ -> Word32 -> Ptr GlyphExtents -> IO Bool
 


@@ 448,6 479,10 @@ fontGlyphExtentsForOrigin font glyph dir = unsafePerformIO $
         if ok
         then return . Just =<< peek ret
         else return Nothing
+fontGlyphExtentsForOrigin' font glyph dir = unsafePerformIO $
+    withForeignPtr font $ \font' -> alloca $ \ret -> do
+        throwFalse $ hb_font_get_glyph_extents_for_origin font' glyph (dir2int dir) ret
+        peek ret
 foreign import ccall "hb_font_get_glyph_extents_for_origin"
     hb_font_get_glyph_extents_for_origin
         :: Font_ -> Word32 -> Int -> Ptr GlyphExtents -> IO Bool


@@ 461,6 496,11 @@ fontGlyphFromName font name = unsafePerformIO $
         if success
         then return . Just =<< peek ret
         else return Nothing
+fontGlyphFromName' font name = unsafePerformIO $
+    withForeignPtr font $ \font' -> alloca $ \ret -> do
+        throwFalse $ withCStringLen name $ \(name', len) ->
+            hb_font_get_glyph_from_name font' name' len ret
+        peek ret
 foreign import ccall "hb_font_get_glyph_from_name" hb_font_get_glyph_from_name
     :: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool
 


@@ 497,6 537,12 @@ fontGlyphHOrigin font glyph = unsafePerformIO $ withForeignPtr font $ \font' ->
             y <- peek y'
             return $ Just (x, y)
         else return Nothing
+fontGlyphHOrigin' font glyph = unsafePerformIO $ withForeignPtr font $ \font' ->
+    alloca $ \x' -> alloca $ \y' -> do
+        throwFalse $ hb_font_get_glyph_h_origin font' glyph x' y'
+        x <- peek x'
+        y <- peek y'
+        return (x, y)
 foreign import ccall "hb_font_get_glyph_h_origin" hb_font_get_glyph_h_origin ::
     Font_ -> Word32 -> Ptr Int32 -> Ptr Int32 -> IO Bool
 


@@ 512,6 558,12 @@ fontGlyphVOrigin font glyph = unsafePerformIO $ withForeignPtr font $ \font' ->
             y <- peek y'
             return $ Just (x, y)
         else return Nothing
+fontGlyphVOrigin' font glyph = unsafePerformIO $ withForeignPtr font $ \font' ->
+    alloca $ \x' -> alloca $ \y' -> do
+        throwFalse $ hb_font_get_glyph_v_origin font' glyph x' y'
+        x <- peek x'
+        y <- peek y'
+        return (x, y)
 foreign import ccall "hb_font_get_glyph_v_origin" hb_font_get_glyph_v_origin ::
     Font_ -> Word32 -> Ptr Int32 -> Ptr Int32 -> IO Bool
 


@@ 532,6 584,7 @@ foreign import ccall "hb_font_get_glyph_kerning_for_direction"
 -- | Fetches the glyph-name string for a glyph ID in the specified `Font`.
 fontGlyphName :: Font -> Word32 -> Maybe String
 fontGlyphName a b = fontGlyphName_ a b 32
+fontGlyphName' a b = fontGlyphName_' a b 32
 -- | Variant of `fontGlyphName` which lets you specify the maximum of the return value.
 -- Defaults to 32.
 fontGlyphName_ :: Font -> Word32 -> Int -> Maybe String


@@ 541,6 594,10 @@ fontGlyphName_ font glyph size = unsafePerformIO $ withForeignPtr font $ \font' 
         if success
         then Just <$> peekCStringLen (name', size)
         else return Nothing
+fontGlyphName_' font glyph size = unsafePerformIO $ withForeignPtr font $ \font' ->
+    allocaBytes size $ \name' -> do
+        throwFalse $ hb_font_get_glyph_name font' glyph name' (toEnum size)
+        peekCStringLen (name', size)
 foreign import ccall "hb_font_get_glyph_name" hb_font_get_glyph_name ::
     Font_ -> Word32 -> CString -> Word32 -> IO Bool
 


@@ 569,6 626,10 @@ fontNominalGlyph font c =
     unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do
         success <- hb_font_get_nominal_glyph font' (c2w c) glyph'
         if success then Just <$> peek glyph' else return Nothing
+fontNominalGlyph' font c =
+    unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do
+        throwFalse $ hb_font_get_nominal_glyph font' (c2w c) glyph'
+        peek glyph'
 foreign import ccall "hb_font_get_nominal_glyph" hb_font_get_nominal_glyph ::
     Font_ -> Word32 -> Ptr Word32 -> IO Bool
 


@@ 621,6 682,10 @@ fontVarGlyph font unicode varSel = unsafePerformIO $
         if success
         then return . Just =<< peek glyph'
         else return Nothing
+fontVarGlyph' font unicode varSel = unsafePerformIO $
+    withForeignPtr font $ \font' -> alloca $ \glyph' -> do
+        throwFalse $ hb_font_get_variation_glyph font' unicode varSel glyph'
+        peek glyph'
 foreign import ccall "hb_font_get_variation_glyph" hb_font_get_variation_glyph
     :: Font_ -> Word32 -> Word32 -> Ptr Word32 -> IO Bool
 


@@ 644,7 709,7 @@ foreign import ccall "hb_font_get_var_coords_design"
 fontVarCoordsNormalized :: Font -> [Int]
 fontVarCoordsNormalized font = unsafePerformIO $
     withForeignPtr font $ \font' -> alloca $ \length' -> do
-        arr <- hb_font_get_var_coords_normalized font' length'
+        arr <- throwNull $ hb_font_get_var_coords_normalized font' length'
         length <- peek length'
         forM [0..fromEnum length-1] $ peekElemOff arr
 foreign import ccall "hb_font_get_var_coords_normalized"


@@ 660,6 725,11 @@ fontTxt2Glyph font str = unsafePerformIO $
         if ok
         then return . Just =<< peek ret
         else return Nothing
+fontTxt2Glyph' font str = unsafePerformIO $
+    withForeignPtr font $ \font' -> alloca $ \ret -> do
+        throwFalse $ withCStringLen str $ \(str', len) ->
+            hb_font_glyph_from_string font' str' len ret
+        peek ret
 foreign import ccall "hb_font_glyph_from_string" hb_font_glyph_from_string
     :: Font_ -> CString -> Int -> Ptr Word32 -> IO Bool
 


@@ 705,6 775,9 @@ fontHExtents font = unsafePerformIO $ alloca $ \ret -> do
     if ok
     then return . Just =<< peek ret
     else return Nothing
+fontHExtents' font = unsafePerformIO $ alloca $ \ret -> do
+    throwFalse $ withForeignPtr font $ \font' -> hb_font_get_h_extents font' ret
+    peek ret
 foreign import ccall "hb_font_get_h_extents" hb_font_get_h_extents
     :: Font_ -> Ptr FontExtents -> IO Bool
 


@@ 714,6 787,9 @@ fontVExtents font = unsafePerformIO $ alloca $ \ret -> do
     if ok
     then return . Just =<< peek ret
     else return Nothing
+fontVExtents' font = unsafePerformIO $ alloca $ \ret -> do
+    throwFalse $ withForeignPtr font $ \font' -> hb_font_get_v_extents font' ret
+    peek ret
 foreign import ccall "hb_font_get_v_extents" hb_font_get_v_extents
     :: Font_ -> Ptr FontExtents -> IO Bool
 


@@ 817,7 893,7 @@ foreign import ccall "hb_font_set_var_named_instance" hb_font_set_var_named_inst
 -- | Variant of `createFont` which applies the given `FontOptions`.
 createFontWithOptions :: FontOptions -> Face -> Font
 createFontWithOptions opts fce = unsafePerformIO $ do
-    font <- withForeignPtr fce $ hb_font_create
+    font <- throwNull $ withForeignPtr fce $ hb_font_create
     _setFontOptions font opts
     hb_font_make_immutable font
     newForeignPtr hb_font_destroy font


@@ 825,7 901,7 @@ createFontWithOptions opts fce = unsafePerformIO $ do
 -- | Variant of `ftCreateFont` which applies the given `FontOptions`.
 ftCreateFontWithOptions :: FontOptions -> FT_Face -> Font
 ftCreateFontWithOptions opts fce = unsafePerformIO $ do
-    font <- hb_ft_font_create_referenced fce
+    font <- throwNull $ hb_ft_font_create_referenced fce
     _setFontOptions font opts
     hb_font_make_immutable font
     newForeignPtr hb_font_destroy font


@@ 833,7 909,7 @@ ftCreateFontWithOptions opts fce = unsafePerformIO $ do
 -- | Variant of createSubFont which applies the given `FontOptions`.
 createSubFontWithOptions :: FontOptions -> Font -> Font
 createSubFontWithOptions opts font = unsafePerformIO $ do
-    font <- withForeignPtr font $ hb_font_create_sub_font
+    font <- throwNull $ withForeignPtr font $ hb_font_create_sub_font
     _setFontOptions font opts
     hb_font_make_immutable font
     newForeignPtr hb_font_destroy font


@@ 849,7 925,7 @@ type Blob_ = Ptr Blob'
 -- | Convert from a ByteString to Harfbuzz's equivalent.
 bs2blob :: ByteString -> IO Blob
 bs2blob (BS bytes len) = do
-    blob <- withForeignPtr bytes $ \bytes' ->
+    blob <- throwNull $ withForeignPtr bytes $ \bytes' ->
         hb_blob_create bytes' len hb_MEMORY_MODE_DUPLICATE nullPtr nullFunPtr
     newForeignPtr hb_blob_destroy blob
 foreign import ccall "hb_blob_create" hb_blob_create ::


@@ 891,7 967,7 @@ type Set_ = Ptr Set'
 -- | Creates a Harfbuzz bitset wrapping it in a foreignpointer.
 createSet :: IO Set
 createSet = do
-    ret <- hb_set_create
+    ret <- throwNull hb_set_create
     newForeignPtr hb_set_destroy ret
 foreign import ccall "hb_set_create" hb_set_create :: IO Set_
 foreign import ccall "&hb_set_destroy" hb_set_destroy :: FunPtr (Set_ -> IO ())

M harfbuzz-pure.cabal => harfbuzz-pure.cabal +1 -1

@@ 54,7 54,7 @@ library
   exposed-modules:     Data.Text.Glyphize
   
   -- Modules included in this library but not exported.
-  other-modules:       Data.Text.Glyphize.Buffer, Data.Text.Glyphize.Font
+  other-modules:       Data.Text.Glyphize.Buffer, Data.Text.Glyphize.Font, Data.Text.Glyphize.Oom
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions: