Fix a crash reported by Michael Snoyman.
authorBryan O'Sullivan <bos@serpentine.com>
Fri, 12 Mar 2010 05:30:12 +0000 (05:30 +0000)
committerBryan O'Sullivan <bos@serpentine.com>
Fri, 12 Mar 2010 05:30:12 +0000 (05:30 +0000)
--HG--
extra : convert_revision : 57b826873d42656a950945fb118ffe6ac4d9e767

Data/Text/Lazy/Encoding/Fusion.hs
tests/Makefile
tests/Regressions.hs [new file with mode: 0644]

index d4494a6..d5047f9 100644 (file)
@@ -100,19 +100,17 @@ streamUtf8 onErr bs0 = Stream next (T bs0 S0 0) unknownSize
 unstreamChunks :: Int -> Stream Word8 -> ByteString
 unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
   where chunk s1 len1 = unsafePerformIO $ do
-          let len = min len1 chunkSize
+          let len = max 4 (min len1 chunkSize)
           mallocByteString len >>= loop len 0 s1
           where
             loop !n !off !s fp = case next s of
                 Done | off == 0 -> return Empty
-                     | otherwise -> do
-                      bs <- trimUp fp off
-                      return $! Chunk bs Empty
+                     | otherwise -> return $! Chunk (trimUp fp off) Empty
                 Skip s' -> loop n off s' fp
                 Yield x s'
                     | off == chunkSize -> do
-                      bs <- trimUp fp off
-                      return (Chunk bs (chunk s (n - B.length bs)))
+                      let !newLen = n - off
+                      return $! Chunk (trimUp fp off) (chunk s newLen)
                     | off == n -> realloc fp n off s' x
                     | otherwise -> do
                       withForeignPtr fp $ \p -> pokeByteOff p off x
@@ -123,8 +121,7 @@ unstreamChunks chunkSize (Stream next s0 len0) = chunk s0 (upperBound 4 len0)
               fp' <- copy0 fp n n'
               withForeignPtr fp' $ \p -> pokeByteOff p off x
               loop n' (off+1) s fp'
-            {-# NOINLINE trimUp #-}
-            trimUp fp off = return $! B.PS fp 0 off
+            trimUp fp off = B.PS fp 0 off
             copy0 :: ForeignPtr Word8 -> Int -> Int -> IO (ForeignPtr Word8)
             copy0 !src !srcLen !destLen = assert (srcLen <= destLen) $ do
                 dest <- mallocByteString destLen
index 84ae99a..789a45a 100644 (file)
@@ -5,7 +5,8 @@ ghc-base-flags := -funbox-strict-fields -package criterion \
        -package bytestring -ignore-package text \
        -fno-ignore-asserts
 ghc-test-flags := -package QuickCheck -package test-framework \
-       -package test-framework-quickcheck
+       -package test-framework-quickcheck -package test-framework-hunit \
+       -package HUnit
 ghc-base-flags += -Wall -fno-warn-orphans -fno-warn-missing-signatures
 ghc-flags := $(ghc-base-flags) -i../dist/build -package-name text-$(version)
 ghc-hpc-flags := $(ghc-base-flags) -fhpc -fno-ignore-asserts -odir hpcdir \
@@ -16,7 +17,7 @@ lib-srcs := $(shell grep '^  *Data' ../text.cabal | \
 
 cabal := $(shell which cabal 2>/dev/null)
 
-all: bm qc coverage
+all: bm qc coverage regressions
 
 lib: $(lib)
 
@@ -46,6 +47,9 @@ qc-hpc: Properties.hs QuickCheckUtils.hs $(lib-srcs:%=../%)
        $(ghc) $(ghc-hpc-flags) $(ghc-opt-flags) -ihpcdir \
          --make -threaded -o $@ $<
 
+regressions: Regressions.o
+       $(ghc) $(ghc-test-flags) -o $@ $^ $(lib)
+
 coverage: qc-hpc-html/hpc_index.html
 
 qc-hpc-html/hpc_index.html: qc-hpc
diff --git a/tests/Regressions.hs b/tests/Regressions.hs
new file mode 100644 (file)
index 0000000..570201d
--- /dev/null
@@ -0,0 +1,26 @@
+-- Regression tests for specific bugs.
+
+import Control.Exception (bracket)
+import System.Directory (removeFile)
+import System.IO (hClose, openTempFile)
+import Test.HUnit (Assertion)
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LE
+import qualified Test.Framework as F
+import qualified Test.Framework.Providers.HUnit as F
+
+-- Reported by Michael Snoyman: UTF-8 encoding a large lazy bytestring
+-- caused either a segfault or attempt to allocate a negative number
+-- of bytes.
+lazy_encode_crash =
+  bracket (openTempFile "." "crashy.txt")
+          (\(path,h) -> hClose h >> removeFile path) $
+  \(_,h) -> LB.hPut h . LE.encodeUtf8 . LT.pack . replicate 100000 $ 'a'
+
+tests :: F.Test
+tests = F.testGroup "crashers" [
+          F.testCase "lazy_encode_crash" lazy_encode_crash
+        ]
+
+main = F.defaultMain [tests]