From cd20a1cfb768f928047decc5be4a594e52b948b5 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 5 Jan 2023 16:31:38 +1300 Subject: [PATCH] Throw out-of-memory errors instead of segfaulting. --- Data/Text/Glyphize/Buffer.hs | 11 ++-- Data/Text/Glyphize/Font.hs | 110 +++++++++++++++++++++++++++++------ harfbuzz-pure.cabal | 2 +- 3 files changed, 101 insertions(+), 22 deletions(-) diff --git a/Data/Text/Glyphize/Buffer.hs b/Data/Text/Glyphize/Buffer.hs index 9dc2c3c..caa63ac 100644 --- a/Data/Text/Glyphize/Buffer.hs +++ b/Data/Text/Glyphize/Buffer.hs @@ -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 [] diff --git a/Data/Text/Glyphize/Font.hs b/Data/Text/Glyphize/Font.hs index f22ae4c..6c04532 100644 --- a/Data/Text/Glyphize/Font.hs +++ b/Data/Text/Glyphize/Font.hs @@ -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 ()) diff --git a/harfbuzz-pure.cabal b/harfbuzz-pure.cabal index 7bdd483..09c6863 100644 --- a/harfbuzz-pure.cabal +++ b/harfbuzz-pure.cabal @@ -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: -- 2.30.2