hpdft 0.4.6.2 → 0.4.6.3

raw patch · 12 files changed

+531/−121 lines, 12 filesbinary-addedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• data/map/cp932.map binary
• data/map/jisx0208.map binary
• hpdft.cabal +5/−2
• src/PDF/Character.hs +9/−1
• src/PDF/ContentStream.hs +184/−51
• src/PDF/Definition.hs +6/−1
• src/PDF/DocumentStructure.hs +126/−31
• src/PDF/Encrypt.hs +44/−26
• src/PDF/Interpret.hs +78/−9
• src/PDF/Text.hs +2/−0
• test/Unit.hs +58/−0

@@ -1,5 +1,24 @@ # Changelog +## 0.4.6.3 (2026-07-06)++### Added++- Predefined CMap support for Japanese Type0 fonts without `/ToUnicode`:+  - Shift-JIS: `/90ms-RKSJ-H/V`, `/90msp-RKSJ-H/V`, `/RKSJ-H/V` (new `SJISmap` encoding backed by an embedded CP932→Unicode table, `data/map/cp932.map`)+  - Unicode: `/UniJIS-UCS2-H/V`, `/UniJIS-UCS2-HW-H/V`, `/UniJIS-UTF16-H/V`, `/UniJIS2004-UTF16-H/V` (new `UnicodeMap` encoding; UTF-16BE splitting with surrogate-pair support, no table needed)+  - JIS X 0208: `/H`, `/V` (new `JISmap` encoding backed by an embedded JIS→Unicode table, `data/map/jisx0208.map`)+  - Vertical variants set the writing mode; `/V` is matched exactly in addition to the `-V` suffix.+- Legacy extraction (and the TUI viewer) now descends into Form XObjects invoked with `Do`, so text drawn inside forms is no longer silently dropped.+- Golden fixtures `data/fixtures/cmap-unijis.pdf` and `data/fixtures/cmap-jis-h.pdf` plus unit tests for the new code splitting and table lookups.++### Fixed++- Object stream (ObjStm) parsing now splits header and body strictly at the `/First` offset instead of relying on the parser stop position; a 1-byte misalignment previously made every object in an affected stream unparseable (mojibake or missing text in PDFs from pdfTeX and similar producers).+- PDFs using CR-only line endings no longer fail trailer/xref discovery (which previously caused a long "broken cross-reference" scan before erroring out).+- RC4 decryption rewritten with a mutable unboxed array (`Data.Array.ST`), turning the previous quadratic key-stream generation linear; large encrypted objects (e.g. full-page images) now decrypt in milliseconds instead of tens of seconds.+- Hex strings in content streams may contain embedded whitespace (e.g. `<65E5 672C 8A9E>`), as allowed by the PDF spec.+ ## 0.4.6.2 (2026-07-06)  ### Fixed

binary file changed (absent → 50449 bytes)

binary file changed (absent → 37468 bytes)

@@ -1,6 +1,6 @@ cabal-version:       3.8 name:                hpdft-version:             0.4.6.2+version:             0.4.6.3 synopsis:            PDF parsing library and CLI for text, layout, diff, images, and forms description:     hpdft is a Haskell library and command-line tool for parsing PDF files.@@ -33,6 +33,8 @@ data-dir:            data/  data-files:          map/Adobe-Japan1-6.map+                     , map/cp932.map+                     , map/jisx0208.map  source-repository head   type:     git@@ -66,7 +68,8 @@                      , PDF.Structure   other-modules:       Paths_hpdft   other-extensions:    OverloadedStrings-  build-depends:       attoparsec >= 0.14.4 && < 0.15+  build-depends:       array >= 0.5 && < 0.6+                     , attoparsec >= 0.14.4 && < 0.15                      , base >= 4.18.0 && < 4.23                      , binary >= 0.8.9 && < 0.9                      , bytestring >= 0.11.4 && < 0.13

@@ -4,7 +4,9 @@ module PDF.Character        ( pdfcharmap        , extendedAscii-       , adobeJapanOneSixMap) where+       , adobeJapanOneSixMap+       , cp932Map+       , jisx0208Map) where  import qualified Data.Text as T import qualified Data.Map as Map@@ -20,6 +22,12 @@  adobeJapanOneSixMap :: Map.Map Int BSLU.ByteString adobeJapanOneSixMap = decode . decompress . BSL.fromChunks . (:[]) $ $(embedFile "data/map/Adobe-Japan1-6.map")++cp932Map :: Map.Map Int BSLU.ByteString+cp932Map = decode . decompress . BSL.fromChunks . (:[]) $ $(embedFile "data/map/cp932.map")++jisx0208Map :: Map.Map Int BSLU.ByteString+jisx0208Map = decode . decompress . BSL.fromChunks . (:[]) $ $(embedFile "data/map/jisx0208.map")  extendedasciidict :: [(Int, Char)] extendedasciidict =

@@ -6,6 +6,7 @@        ) where  import Data.Char (chr, ord)+import Data.Bits (shiftL) import Data.String (fromString) import Data.List (isPrefixOf, dropWhileEnd) import Numeric (readOct, readHex)@@ -27,21 +28,26 @@  import PDF.Definition import PDF.Object-import PDF.Character (pdfcharmap, extendedAscii, adobeJapanOneSixMap)+import PDF.Character (pdfcharmap, extendedAscii, adobeJapanOneSixMap, cp932Map, jisx0208Map) import PDF.Error (PdfError(..), PdfResult, PdfWarning(..))  type PSParser a = GenParser Char PSR a  parseContentStream p st = runParser p st "" -parseStream :: PSR -> PDFStream -> PdfResult (PDFStream, [PdfWarning])-parseStream psr pdfstream =-  case parseContentStream contentParser psr pdfstream of+type FormRunner = T.Text -> PSR -> T.Text++noFormRunner :: FormRunner+noFormRunner _ _ = T.empty++parseStream :: FormRunner -> PSR -> PDFStream -> PdfResult (PDFStream, [PdfWarning])+parseStream formRunner psr pdfstream =+  case parseContentStream (contentParser formRunner) psr pdfstream of     Left err -> Left (ParseError ("content stream: " ++ show err) BS.empty)     Right (str, ws) -> Right (BSLC.pack $ BSSC.unpack $ encodeUtf8 str, reverse ws)   where-    contentParser = do-      str <- T.concat <$> (spaces >> many (try elems <|> skipOther))+    contentParser runner = do+      str <- T.concat <$> (spaces >> many (try (elems runner) <|> skipOther))       st <- getState       return (str, warnings st) @@ -49,7 +55,7 @@ parseColorSpace psr pdfstream =    case parseContentStream (many (choice [ try colorSpace                                         , try $ T.concat <$> xObject-                                        , (T.empty <$ elems)+                                        , (T.empty <$ elems noFormRunner)                                         ])) psr pdfstream of     Left  err -> Left (ParseError ("color space: " ++ show err) BS.empty)     Right str -> Right str@@ -57,8 +63,8 @@  -- | Parsers for Content Stream -elems :: PSParser T.Text-elems = choice [ try pdfopBT +elems :: FormRunner -> PSParser T.Text+elems formRunner = choice [ try (pdfopBT formRunner)                , try pdfopTf                , try pdfopTD                , try pdfopTd@@ -79,17 +85,26 @@                , try array <* spaces                , try pdfopGraphics                , try dashPattern-               , try $ T.empty <$ xObject+               , try (formDoOp formRunner)                , try graphicState                , try pdfopcm                , try $ T.empty <$ colorSpace                , try $ T.empty <$ renderingIntent-               , try pdfopBDC-               , try pdfopBMC+               , try (pdfopBDC formRunner)+               , try (pdfopBMC formRunner)                , try pdfopEMC                , unknowns                ] +formDoOp :: FormRunner -> PSParser T.Text+formDoOp runner = do+  n <- (++) <$> string "/" <*> manyTill anyChar (try space)+  spaces+  string "Do"+  spaces+  st <- getState+  return $ runner (T.pack n) st+ pdfopGraphics :: PSParser T.Text pdfopGraphics = do   spaces@@ -152,30 +167,30 @@ --  updateState (\s -> s {colorspace = xobjcs})   return xobjcs -pdfopBT :: PSParser T.Text-pdfopBT = do+pdfopBT :: FormRunner -> PSParser T.Text+pdfopBT formRunner = do   st <- getState   updateState (\s -> s{text_m = (1,0,0,1,0,0), text_break = False})   string "BT"   spaces-  t <- manyTill elems (try $ string "ET")+  t <- manyTill (elems formRunner) (try $ string "ET")   spaces   return $ T.concat t  -- should have refined according to the section 10.5 of PDF reference -pdfopBMC :: PSParser T.Text-pdfopBMC = do+pdfopBMC :: FormRunner -> PSParser T.Text+pdfopBMC formRunner = do   tag <- (++) <$> string "/" <*> manyTill anyChar (try space)   spaces   string "BMC"   spaces-  manyTill elems (try $ string "EMC")+  manyTill (elems formRunner) (try $ string "EMC")   spaces   return T.empty -pdfopBDC :: PSParser T.Text-pdfopBDC = do+pdfopBDC :: FormRunner -> PSParser T.Text+pdfopBDC formRunner = do   tag <- name   prop <- propertyList   spaces@@ -184,7 +199,7 @@   case tag of     "/Span"        | "/ActualText" == (fst prop)-        -> do {spaces >> manyTill elems (try $ string "EMC") >> return (snd prop)}+        -> do {spaces >> manyTill (elems formRunner) (try $ string "EMC") >> return (snd prop)}       | otherwise  -> return $ T.empty     _ -> return $ T.empty @@ -263,9 +278,9 @@ unknowns = do   ps <- manyTill anyChar (try $ oneOf "\r\n")   st <- getState-  case runParser elems st "" $ BSLC.pack ((Data.List.dropWhileEnd (=='\\') ps)++")Tj") of+  case runParser (elems noFormRunner) st "" $ BSLC.pack ((Data.List.dropWhileEnd (=='\\') ps)++")Tj") of     Right xs -> return xs-    Left _ -> case runParser elems st "" $ BSLC.pack ("("++ps) of+    Left _ -> case runParser (elems noFormRunner) st "" $ BSLC.pack ("("++ps) of       Right xs -> return xs       Left _ -> case ps of         "" -> return T.empty@@ -298,6 +313,9 @@       letterParser = case Map.lookup (curfont st) (fontmaps st) of         Just (Encoding m) -> psletter m         Just (CIDmap s) -> cidletter s+        Just SJISmap -> sjisletters+        Just UnicodeMap -> unicodeletters+        Just JISmap -> jisletters         Just (WithCharSet s) -> try $ bytesletter cmap <|> cidletters         Just NullMap -> psletter Map.empty         Nothing -> (T.pack) <$> (many1 $ choice [ try $ ')' <$ (string "\\)")@@ -326,7 +344,7 @@   byteStringToText cmap txt   where     byteStringToText cmap' str = do-      parts <- mapM (lookupUcs cmap') $ asInt16 $ map ord str+      parts <- mapM (lookupUcs Nothing cmap') $ asInt16 $ map ord str       return $ T.concat parts      asInt16 :: [Int] -> [Int]@@ -338,31 +356,141 @@ hexletters = do   st <- getState   char '<'-  hexChars <- many (oneOf "0123456789ABCDEFabcdef")+  hexChars <- many (oneOf "0123456789ABCDEFabcdef \t\r\n")   char '>'   spaces-  let cmap = Map.findWithDefault Map.empty (curfont st) (cmaps st)-      codes = hexStringToCodes (fontBytesPerCode st) hexChars-  parts <- mapM (lookupUcs cmap) codes+  let enc = Map.lookup (curfont st) (fontmaps st)+      cmap = Map.findWithDefault Map.empty (curfont st) (cmaps st)+      codes = hexStringToCodes enc (filter (\c -> c `notElem` (" \t\r\n" :: String)) hexChars)+  parts <- mapM (lookupUcs enc cmap) codes   return $ T.concat parts --- | Split a hex string into character codes (matches 'PDF.Interpret.hexPairs'--- and 'bytesToCodes' for 1- vs 2-byte fonts).-fontBytesPerCode :: PSR -> Int-fontBytesPerCode st =-  case Map.lookup (curfont st) (fontmaps st) of-    Just (CIDmap _) -> 2-    _ -> 1--hexStringToCodes :: Int -> String -> [Int]-hexStringToCodes bpc hex =+-- | Split a hex string into character codes (matches 'PDF.Interpret.bytesToCodes').+hexStringToCodes :: Maybe Encoding -> String -> [Int]+hexStringToCodes enc hex =   let bytes = hexPairs hex-  in if bpc == 2 then pairBytes bytes else bytes+  in case enc of+    Just SJISmap -> sjisBytesToCodes bytes+    Just UnicodeMap -> unicodeBytesToCodes bytes+    Just JISmap -> pairBytes bytes+    Just (CIDmap _) -> pairBytes bytes+    _ -> bytes   where     pairBytes [] = []     pairBytes [_] = []     pairBytes (a:b:rest) = (a * 256 + b) : pairBytes rest +isUtf16HighSurrogate :: Int -> Bool+isUtf16HighSurrogate u = u >= 0xD800 && u <= 0xDBFF++isUtf16LowSurrogate :: Int -> Bool+isUtf16LowSurrogate u = u >= 0xDC00 && u <= 0xDFFF++surrogatePairToCode :: Int -> Int -> Int+surrogatePairToCode hi lo = 0x10000 + ((hi - 0xD800) `shiftL` 10) + (lo - 0xDC00)++unicodeBytesToCodes :: [Int] -> [Int]+unicodeBytesToCodes [] = []+unicodeBytesToCodes [_] = []+unicodeBytesToCodes (a:b:rest) =+  let unit = a * 256 + b+  in if isUtf16HighSurrogate unit+     then case rest of+       (c:d:rs) ->+         let unit2 = c * 256 + d+         in if isUtf16LowSurrogate unit2+            then surrogatePairToCode unit unit2 : unicodeBytesToCodes rs+            else unit : unicodeBytesToCodes rest+       _ -> [unit]+     else unit : unicodeBytesToCodes rest++isSjisLead :: Int -> Bool+isSjisLead b = (b >= 0x81 && b <= 0x9F) || (b >= 0xE0 && b <= 0xFC)++sjisBytesToCodes :: [Int] -> [Int]+sjisBytesToCodes [] = []+sjisBytesToCodes (b:rest)+  | isSjisLead b = case rest of+      (t:rs) -> (b * 256 + t) : sjisBytesToCodes rs+      _ -> [b]+  | otherwise = b : sjisBytesToCodes rest++sjisCodeToText :: Int -> T.Text+sjisCodeToText code =+  case Map.lookup code cp932Map of+    Just bs -> T.pack $ BSLU.toString bs+    Nothing ->+      if code >= 0 && code <= 0x7F+      then T.singleton (chr code)+      else "\xFFFD"++unicodeCodeToText :: Int -> T.Text+unicodeCodeToText code =+  if code >= 0 && code <= 0x10FFFF+  then T.singleton (chr code)+  else "\xFFFD"++jisCodeToText :: Int -> T.Text+jisCodeToText code =+  case Map.lookup code jisx0208Map of+    Just bs -> T.pack $ BSLU.toString bs+    Nothing ->+      if code >= 0 && code <= 0x7F+      then T.singleton (chr code)+      else "\xFFFD"++sjisletters :: PSParser T.Text+sjisletters = do+  txt <- (many1 $ choice [ try $ ')' <$ (string "\\)")+                         , try $ '(' <$ (string "\\(")+                         , try $ (chr 10) <$ (string "\\n")+                         , try $ (chr 13) <$ (string "\\r")+                         , try $ (chr 8) <$ (string "\\b")+                         , try $ (chr 9) <$ (string "\\t")+                         , try $ (chr 12) <$ (string "\\f")+                         , try $ (chr 92) <$ (string "\\\\")+                         , try $ chr <$> ((string "\\") *> octnum)+                         , try $ noneOf ")"+                         ])+  let codes = sjisBytesToCodes $ map ord txt+  return $ T.concat $ map sjisCodeToText codes++unicodeletters :: PSParser T.Text+unicodeletters = do+  txt <- (many1 $ choice [ try $ ')' <$ (string "\\)")+                         , try $ '(' <$ (string "\\(")+                         , try $ (chr 10) <$ (string "\\n")+                         , try $ (chr 13) <$ (string "\\r")+                         , try $ (chr 8) <$ (string "\\b")+                         , try $ (chr 9) <$ (string "\\t")+                         , try $ (chr 12) <$ (string "\\f")+                         , try $ (chr 92) <$ (string "\\\\")+                         , try $ chr <$> ((string "\\") *> octnum)+                         , try $ noneOf ")"+                         ])+  let codes = unicodeBytesToCodes $ map ord txt+  return $ T.concat $ map unicodeCodeToText codes++jisletters :: PSParser T.Text+jisletters = do+  txt <- (many1 $ choice [ try $ ')' <$ (string "\\)")+                         , try $ '(' <$ (string "\\(")+                         , try $ (chr 10) <$ (string "\\n")+                         , try $ (chr 13) <$ (string "\\r")+                         , try $ (chr 8) <$ (string "\\b")+                         , try $ (chr 9) <$ (string "\\t")+                         , try $ (chr 12) <$ (string "\\f")+                         , try $ (chr 92) <$ (string "\\\\")+                         , try $ chr <$> ((string "\\") *> octnum)+                         , try $ noneOf ")"+                         ])+  let codes = pairBytes $ map ord txt+  return $ T.concat $ map jisCodeToText codes+  where+    pairBytes [] = []+    pairBytes [_] = []+    pairBytes (a:b:rest) = (a * 256 + b) : pairBytes rest+ hexPairs :: String -> [Int] hexPairs [] = [] hexPairs [x] =@@ -391,16 +519,21 @@   Just cs -> T.pack $ BSLU.toString cs   Nothing -> T.pack $ "[" ++ show a ++ "]" -lookupUcs :: CMap -> Int -> PSParser T.Text-lookupUcs m h = case Map.lookup h m of+lookupUcs :: Maybe Encoding -> CMap -> Int -> PSParser T.Text+lookupUcs enc m h = case Map.lookup h m of   Just ucs -> return ucs-  Nothing-    | Map.null m -> case Map.lookup h adobeJapanOneSixMap of-        Just cs -> return $ T.pack $ BSLU.toString cs-        Nothing -> do-          updateState (\s -> s {warnings = UnmappedCid h : warnings s})-          return $ adobeOneSix h-    | otherwise -> return $ T.singleton (chr h)+  Nothing ->+    case enc of+      Just SJISmap -> return $ sjisCodeToText h+      Just UnicodeMap -> return $ unicodeCodeToText h+      Just JISmap -> return $ jisCodeToText h+      _ | Map.null m ->+          case Map.lookup h adobeJapanOneSixMap of+            Just cs -> return $ T.pack $ BSLU.toString cs+            Nothing -> do+              updateState (\s -> s {warnings = UnmappedCid h : warnings s})+              return $ adobeOneSix h+      _ -> return $ T.singleton (chr h)  cidletters = choice [try hexletter, try octletter] @@ -413,7 +546,7 @@                       , try $ (:"0") <$> (oneOf "0123456789ABCDEFabcdef")                       ]   case readHex hexDigits of-    [(h, "")] -> lookupUcs cmap h+    [(h, "")] -> lookupUcs (Map.lookup (curfont st) (fontmaps st)) cmap h     _ -> return "????"  octletter :: PSParser T.Text@@ -421,7 +554,7 @@   st <- getState   let cmap = Map.findWithDefault Map.empty (curfont st) (cmaps st)   o <- octnum-  lookupUcs cmap o+  lookupUcs (Map.lookup (curfont st) (fontmaps st)) cmap o  psletter :: Map.Map Char T.Text -> PSParser T.Text psletter fontmap = do@@ -453,7 +586,7 @@   o1 <- octnum   o2 <- octnum   let d = 256 * o1 + o2-  lookupUcs Map.empty d+  lookupUcs Nothing Map.empty d  octnum :: PSParser Int octnum = do

@@ -67,12 +67,15 @@ ppObjAt _ PdfNull = ""  -data Encoding = CIDmap T.Text | Encoding (Map Char T.Text) | WithCharSet T.Text | NullMap+data Encoding = CIDmap T.Text | Encoding (Map Char T.Text) | WithCharSet T.Text | SJISmap | UnicodeMap | JISmap | NullMap  instance Show Encoding where   show (CIDmap s) = "CIDmap" ++ T.unpack s   show (Encoding a) = "Encoding" ++ show a   show (WithCharSet s) = "WithCharSet" ++ T.unpack s+  show SJISmap = "SJISmap"+  show UnicodeMap = "UnicodeMap"+  show JISmap = "JISmap"   show NullMap = []  type CMap = Map Int T.Text@@ -104,5 +107,7 @@                , colorspace :: T.Text                , xcolorspaces :: [T.Text]                , warnings     :: [PdfWarning]+               , psResDict    :: Maybe Dict+               , psFormDepth  :: Int                }          deriving (Show)

@@ -45,6 +45,7 @@ import Data.Bits ((.&.), shiftR) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.ByteString.Lazy.UTF8 as BSLU import qualified Data.ByteString.Builder as B import qualified Data.Text as T import Data.Maybe (fromMaybe, listToMaybe)@@ -129,9 +130,10 @@           in maybe [PdfNull] (parseObjStmObject body) off         Nothing -> [PdfNull]     objStmBody cnum =-      case rawStream msec cnum (M.findWithDefault [PdfNull] cnum objs) of+      let containerObjs = M.findWithDefault [PdfNull] cnum objs+      in case rawStream msec cnum containerObjs of         Right streamBytes ->-          case parseObjStmHeader (BSL.toStrict streamBytes) of+          case parseObjStmHeader (objStmFirst containerObjs) (BSL.toStrict streamBytes) of             Right cache -> cache             Left _ -> ([], BS.empty)         Left _ -> ([], BS.empty)@@ -203,10 +205,51 @@  parseContentStream :: Dict -> PSR -> Maybe Security -> PDFObjIndex -> BSL.ByteString -> PdfResult (PDFStream, [PdfWarning]) parseContentStream dict st sec objs s =-  parseStream (st {fontmaps=fontdict, cmaps=cmap}) s+  parseStream (formTextRunner sec objs) (st {fontmaps=fontdict, cmaps=cmap, psResDict=Just dict}) s   where fontdict = findFontEncoding dict sec objs         cmap = findCMap dict sec objs +maxLegacyFormDepth :: Int+maxLegacyFormDepth = 12++formTextRunner :: Maybe Security -> PDFObjIndex -> T.Text -> PSR -> T.Text+formTextRunner sec objs name st+  | psFormDepth st >= maxLegacyFormDepth = T.empty+  | otherwise =+      case formStream sec objs (psResDict st) name of+        Nothing -> T.empty+        Just (formDict, stream) ->+          let runner = formTextRunner sec objs+              st' = st { fontmaps = M.union (findFontEncoding formDict sec objs) (fontmaps st)+                       , cmaps = M.union (findCMap formDict sec objs) (cmaps st)+                       , psResDict = Just formDict+                       , psFormDepth = psFormDepth st + 1+                       }+          in case parseStream runner st' stream of+               Right (txt, _) -> T.pack (BSLU.toString txt)+               Left _ -> T.empty++formStream :: Maybe Security -> PDFObjIndex -> Maybe Dict -> T.Text -> Maybe (Dict, PDFStream)+formStream sec objs resDict name =+  case resDict >>= xobjectDict objs >>= M.lookup name of+    Just (ObjRef r) ->+      case findDictByRef r objs of+        Just d | M.lookup "/Subtype" d == Just (PdfName "/Form") ->+          case rawStreamByRef sec objs r of+            Right stream -> Just (d, stream)+            Left _ -> Nothing+        _ -> Nothing+    _ -> Nothing++xobjectDict :: PDFObjIndex -> Dict -> Maybe (M.Map T.Text Obj)+xobjectDict objs d =+  case findResourcesDict d objs of+    Just rd -> case findObjFromDict rd "/XObject" of+      Just (PdfDict xd) -> Just xd+      Just (ObjRef xr) -> findDictByRef xr objs+      _ -> Nothing+    Nothing -> Nothing+ rawStreamByRef :: Maybe Security -> PDFObjIndex -> Int -> PdfResult BSL.ByteString rawStreamByRef sec pdfobjs x = case findObjsByRef x pdfobjs of   Just objs -> rawStream sec x objs@@ -384,13 +427,23 @@       BS.all isSpaceChar (BS.drop 5 rest)     _ -> False +isEol :: Char -> Bool+isEol c = c == '\n' || c == '\r'++splitLastLine :: BS.ByteString -> (BS.ByteString, BS.ByteString)+splitLastLine bs =+  let trimmed = BS.dropWhileEnd isEol bs+      rev = BS.reverse trimmed+      (lineRev, restRev) = BS.break isEol rev+  in ( BS.reverse restRev+     , BS.reverse lineRev+     )+ getStartxrefOffset :: BS.ByteString -> PdfResult Int getStartxrefOffset source =   let trimmed = BS.dropWhileEnd isSpaceChar source-      numLine = case BS.breakEnd (== '\n') trimmed of-        (_, n) | not (BS.null n) -> BS.dropWhile isSpaceChar n-        _ -> trimmed-  in readDec' $ BS.takeWhile (\c -> c >= '0' && c <= '9') numLine+      (_, numLine) = splitLastLine trimmed+  in readDec' $ BS.takeWhile (\c -> c >= '0' && c <= '9') (BS.dropWhile isSpaceChar numLine)  isSpaceChar :: Char -> Bool isSpaceChar c = c `elem` (" \t\r\n" :: String)@@ -404,17 +457,17 @@   _ -> Right xref  findTrailer :: BS.ByteString -> PdfResult Dict-findTrailer bs = case BS.breakEnd (== '\n') bs of+findTrailer bs = case splitLastLine bs of   (source, eofLine)     | isPdfEofLine eofLine -> do         offset <- getStartxrefOffset source         (dict, _) <- findTrailerDictXREF $ BS.drop offset bs         return dict     | source == "" -> Left (BrokenXref "no %%EOF or startxref found")-    | otherwise -> findTrailer (BS.init bs)+    | otherwise -> findTrailer source  findTrailer' :: BS.ByteString -> PdfResult (Dict, XREF)-findTrailer' bs = case BS.breakEnd (== '\n') bs of+findTrailer' bs = case splitLastLine bs of   (source, eofLine)     | isPdfEofLine eofLine -> do         offset <- getStartxrefOffset source@@ -424,7 +477,7 @@           Just (PdfNumber x) -> xrefs (truncate x) bs (dict, xref')           _ -> Right (dict, xref')     | source == "" -> Left (BrokenXref "no %%EOF or startxref found")-    | otherwise -> findTrailer' (BS.init bs)+    | otherwise -> findTrailer' source   where     xrefs n all (dict, sofar) = do       (dict', xref) <- findTrailerDictXREF $ BS.drop n all@@ -653,33 +706,52 @@ objStm :: Maybe Security -> PDFObj -> PdfResult [PDFObj] objStm sec (n, obj) = case findDictOfType "/ObjStm" obj of   Nothing -> Right [(n,obj)]-  Just _  -> do+  Just d  -> do     streamBytes <- rawStream sec n obj-    pdfObjStm n (BSL.toStrict streamBytes)-  -refOffset :: Parser ([(Int, Int)], String)-refOffset = spaces *> ((,) -                       <$> many1 refPair-                       <*> many1 anyChar)-  where-    refPair = do-      rStr <- many1 digit <* spaces-      oStr <- many1 digit <* spaces-      case (readDec rStr, readDec oStr) of-        ([(r, "")], [(o, "")]) -> return (r, o)-        _ -> fail "invalid object stream reference"+    pdfObjStm n (objStmFirstFromDict d) (BSL.toStrict streamBytes) -pdfObjStm n s =-  case parseObjStmHeader s of+objStmFirstFromDict :: Dict -> Maybe Int+objStmFirstFromDict d = case findObjFromDict d "/First" of+  Just (PdfNumber n) -> Just (truncate n)+  _ -> Nothing++objStmFirst :: [Obj] -> Maybe Int+objStmFirst objs = findDict objs >>= objStmFirstFromDict++refPair :: Parser (Int, Int)+refPair = do+  rStr <- many1 digit <* spaces+  oStr <- many1 digit <* spaces+  case (readDec rStr, readDec oStr) of+    ([(r, "")], [(o, "")]) -> return (r, o)+    _ -> fail "invalid object stream reference"++refPairs :: Parser [(Int, Int)]+refPairs = spaces *> many1 refPair++refOffset :: Parser ([(Int, Int)], BS.ByteString)+refOffset = do+  location <- refPairs+  rest <- BS.pack <$> many1 anyChar+  return (location, rest)++pdfObjStm :: Int -> Maybe Int -> BS.ByteString -> PdfResult [PDFObj]+pdfObjStm n mFirst s =+  case parseObjStmHeader mFirst s of     Right (location, body) ->       Right [ (r, parseObjStmObject body o) | (r, o) <- location ]     Left err ->       Left (ParseError ("Failed to parse Object Stream: " ++ show err) (BS.take 80 s)) -parseObjStmHeader :: BS.ByteString -> Either String ([(Int, Int)], BS.ByteString)-parseObjStmHeader s =+parseObjStmHeader :: Maybe Int -> BS.ByteString -> Either String ([(Int, Int)], BS.ByteString)+parseObjStmHeader (Just first) s+  | first >= 0 && first <= BS.length s =+      case parseOnly refPairs (BS.take first s) of+        Right location -> Right (location, BS.drop first s)+        Left err -> Left (show err)+parseObjStmHeader _ s =   case parseOnly refOffset s of-    Right (location, objstr) -> Right (location, BS.pack objstr)+    Right (location, body) -> Right (location, body)     Left err -> Left (show err)  parseObjStmObject :: BS.ByteString -> Int -> [Obj]@@ -735,6 +807,10 @@     Just (PdfName "/Identity-H") -> case cidSysInfo descendantFonts of       (e:_) -> e       []    -> NullMap+    Just (PdfName n) | n `elem` sjisEncodings -> SJISmap+    Just (PdfName n) | n `elem` unijisEncodings -> UnicodeMap+    Just (PdfName "/H") -> JISmap+    Just (PdfName "/V") -> JISmap     Just (PdfName _) -> NullMap     _ -> NullMap   Just (PdfName "/Type1") -> case encField of@@ -768,6 +844,21 @@     subtype = M.lookup "/Subtype" d     encField = M.lookup "/Encoding" d +    sjisEncodings :: [T.Text]+    sjisEncodings =+      [ "/90ms-RKSJ-H", "/90ms-RKSJ-V"+      , "/90msp-RKSJ-H", "/90msp-RKSJ-V"+      , "/RKSJ-H", "/RKSJ-V"+      ]++    unijisEncodings :: [T.Text]+    unijisEncodings =+      [ "/UniJIS-UCS2-H", "/UniJIS-UCS2-V"+      , "/UniJIS-UCS2-HW-H", "/UniJIS-UCS2-HW-V"+      , "/UniJIS-UTF16-H", "/UniJIS-UTF16-V"+      , "/UniJIS2004-UTF16-H", "/UniJIS2004-UTF16-V"+      ]+     descendantFonts :: [Obj]     descendantFonts = descendantFontObjsFromDict d objs @@ -898,13 +989,16 @@       wmode = wmodeFromEncoding (findObjFromDict d "/Encoding")       widthFn cid = M.findWithDefault defaultW cid widthMap       widthVFn cid = M.findWithDefault w1Default cid widthVMap+      bpc = case enc of+        SJISmap -> 1+        _ -> 2   in FontInfo     { fiEncoding = enc     , fiToUnicode = tuc     , fiWidth = widthFn     , fiWidthV = widthVFn     , fiWMode = wmode-    , fiBytesPerCode = 2+    , fiBytesPerCode = bpc     , fiDefaultWidth = defaultW     } @@ -988,6 +1082,7 @@   _ -> (880, defaultVerticalW1)  wmodeFromEncoding :: Maybe Obj -> Int+wmodeFromEncoding (Just (PdfName "/V")) = 1 wmodeFromEncoding (Just (PdfName n)) | "-V" `T.isSuffixOf` n = 1 wmodeFromEncoding _ = 0 

@@ -17,6 +17,10 @@ import Data.List (foldl') import qualified Data.Map as M import Control.Applicative ((<|>))+import Control.Monad (forM_, forM)+import Control.Monad.ST (ST, runST)+import Data.Array.ST (STUArray, newArray, readArray, writeArray)+import Data.STRef (newSTRef, readSTRef, writeSTRef) import Data.Word (Word8, Word32) import Numeric (readHex) @@ -225,7 +229,7 @@ rc4Decrypt :: BS.ByteString -> BS.ByteString -> BS.ByteString rc4Decrypt key ciphertext =   let ks = rc4KeyStream key (BS.length ciphertext)-  in BS.pack $ zipWith xor (BS.unpack ciphertext) ks+  in BS.pack $ zipWith xor (BS.unpack ciphertext) (BS.unpack ks)  rc4DecryptRev3 :: Int -> BS.ByteString -> BS.ByteString -> BS.ByteString rc4DecryptRev3 keyLen key ciphertext =@@ -233,31 +237,45 @@          ciphertext          [19,18..0] -rc4KeyStream :: BS.ByteString -> Int -> [Word8]-rc4KeyStream key nbytes =-  let keyInts = map fromIntegral (BS.unpack key) :: [Int]-      state = ksaInit keyInts-  in map fromIntegral $ take nbytes $ prga state-  where-    ksaInit k' =-      let len = length k'-          step (st, j) i =-            let j' = (j + st !! i + k' !! (i `mod` len)) `mod` 256-                st' = swap st i j'-            in (st', j')-      in fst $ foldl' step ([0..255], 0) [0..255]-    prga st = reverse $ go st 0 0 []-      where go sbox i j out-              | length out >= nbytes = out-              | otherwise =-                  let i' = (i + 1) `mod` 256-                      j' = (j + sbox !! i') `mod` 256-                      s' = swap sbox i' j'-                      byte = s' !! ((s' !! i' + s' !! j') `mod` 256)-                  in go s' i' j' (byte:out)-    swap s i j =-      [ if x == i then s !! j else if x == j then s !! i else v-      | (x, v) <- zip [0..] s ]+rc4KeyStream :: BS.ByteString -> Int -> BS.ByteString+rc4KeyStream _ nbytes | nbytes <= 0 = BS.empty+rc4KeyStream key nbytes = runST $ do+  let keyLen = BS.length key+  sbox <- newArray (0, 255) 0 :: ST s (STUArray s Int Word8)+  forM_ [0..255] $ \i -> writeArray sbox i (fromIntegral i :: Word8)+  jRef <- newSTRef (0 :: Int)+  forM_ [0..255] $ \i -> do+    j <- readSTRef jRef+    si <- fmap fromIntegral (readArray sbox i)+    kj <- return $ fromIntegral (BS.index key (i `mod` keyLen))+    let j' = (j + si + kj) `mod` 256+    rc4Swap sbox i j'+    writeSTRef jRef j'+  out <- (newArray (0, nbytes - 1) (0 :: Word8) :: ST s (STUArray s Int Word8))+  iRef <- newSTRef 0+  jRef2 <- newSTRef 0+  forM_ [0..nbytes - 1] $ \n -> do+    i <- readSTRef iRef+    j <- readSTRef jRef2+    let i' = (i + 1) `mod` 256+    si <- fmap fromIntegral (readArray sbox i')+    let j' = (j + si) `mod` 256+    rc4Swap sbox i' j'+    a <- fmap fromIntegral (readArray sbox i')+    b <- fmap fromIntegral (readArray sbox j')+    byte <- readArray sbox ((a + b) `mod` 256)+    writeArray out n byte+    writeSTRef iRef i'+    writeSTRef jRef2 j'+  arr <- forM [0..nbytes - 1] (readArray out)+  return (BS.pack arr)++rc4Swap :: STUArray s Int Word8 -> Int -> Int -> ST s ()+rc4Swap arr i j = do+  a <- readArray arr i+  b <- readArray arr j+  writeArray arr i b+  writeArray arr j a  decryptString :: Maybe Security -> Int -> Int -> BS.ByteString -> BS.ByteString decryptString Nothing _ _ bs = bs

@@ -14,6 +14,9 @@   , interpretContentItems   , interpretContentWithFonts   , interpretContentWithFontsItems+  , bytesToCodes+  , encodingUnicode+  , unicodeBytesToCodes   ) where  import PDF.Definition@@ -30,13 +33,14 @@   , rawStreamByRef   ) import PDF.Matrix-import PDF.Character (pdfcharmap, adobeJapanOneSixMap)+import PDF.Character (pdfcharmap, adobeJapanOneSixMap, cp932Map, jisx0208Map) import PDF.Encrypt (Security) import PDF.Error (PdfError(..), PdfResult) import PDF.Object (parseRefsArray)  import Data.Char (chr, isDigit, ord) import Data.List (find, foldl', isPrefixOf)+import Data.Bits (shiftL) import Data.Maybe (fromMaybe, isJust) import Data.Word (Word8) import qualified Numeric as Num@@ -577,6 +581,9 @@   | not (isCidFontName name) = fi   | fiBytesPerCode fi == 2, CIDmap{} <- fiEncoding fi = fi   | fiBytesPerCode fi == 2, Encoding{} <- fiEncoding fi = fi+  | SJISmap <- fiEncoding fi = fi+  | UnicodeMap <- fiEncoding fi = fi+  | JISmap <- fiEncoding fi = fi   | otherwise = defaultAdobeJapanFontInfo fi  isCidFontName :: T.Text -> Bool@@ -674,14 +681,57 @@  bytesToCodes :: FontInfo -> [Int] -> [Int] bytesToCodes fi bytes =-  if fiBytesPerCode fi == 2-  then pairs bytes-  else bytes+  case fiEncoding fi of+    SJISmap -> sjisBytesToCodes bytes+    UnicodeMap -> unicodeBytesToCodes bytes+    JISmap -> jisBytesToCodes bytes+    _ | fiBytesPerCode fi == 2 -> pairs bytes+    _ -> bytes   where     pairs [] = []     pairs [_] = []     pairs (a:b:rest) = (a * 256 + b) : pairs rest +isUtf16HighSurrogate :: Int -> Bool+isUtf16HighSurrogate u = u >= 0xD800 && u <= 0xDBFF++isUtf16LowSurrogate :: Int -> Bool+isUtf16LowSurrogate u = u >= 0xDC00 && u <= 0xDFFF++surrogatePairToCode :: Int -> Int -> Int+surrogatePairToCode hi lo = 0x10000 + ((hi - 0xD800) `shiftL` 10) + (lo - 0xDC00)++unicodeBytesToCodes :: [Int] -> [Int]+unicodeBytesToCodes [] = []+unicodeBytesToCodes [_] = []+unicodeBytesToCodes (a:b:rest) =+  let unit = a * 256 + b+  in if isUtf16HighSurrogate unit+     then case rest of+       (c:d:rs) ->+         let unit2 = c * 256 + d+         in if isUtf16LowSurrogate unit2+            then surrogatePairToCode unit unit2 : unicodeBytesToCodes rs+            else unit : unicodeBytesToCodes rest+       _ -> [unit]+     else unit : unicodeBytesToCodes rest++jisBytesToCodes :: [Int] -> [Int]+jisBytesToCodes [] = []+jisBytesToCodes [_] = []+jisBytesToCodes (a:b:rest) = (a * 256 + b) : jisBytesToCodes rest++isSjisLead :: Int -> Bool+isSjisLead b = (b >= 0x81 && b <= 0x9F) || (b >= 0xE0 && b <= 0xFC)++sjisBytesToCodes :: [Int] -> [Int]+sjisBytesToCodes [] = []+sjisBytesToCodes (b:rest)+  | isSjisLead b = case rest of+      (t:rs) -> (b * 256 + t) : sjisBytesToCodes rs+      _ -> [b]+  | otherwise = b : sjisBytesToCodes rest+ codeToUnicode :: FontInfo -> Int -> T.Text codeToUnicode fi code =   case M.lookup code (fiToUnicode fi) of@@ -710,6 +760,21 @@     Just bs -> T.pack (BSLU.toString bs)     Nothing -> T.singleton (safeChr code) encodingUnicode (CIDmap _) code = T.singleton (safeChr code)+encodingUnicode SJISmap code =+  case M.lookup code cp932Map of+    Just bs -> T.pack (BSLU.toString bs)+    Nothing ->+      if code >= 0 && code <= 0x7F+      then T.singleton (safeChr code)+      else "\xFFFD"+encodingUnicode UnicodeMap code = T.singleton (safeChr code)+encodingUnicode JISmap code =+  case M.lookup code jisx0208Map of+    Just bs -> T.pack (BSLU.toString bs)+    Nothing ->+      if code >= 0 && code <= 0x7F+      then T.singleton (safeChr code)+      else "\xFFFD" encodingUnicode (WithCharSet "ZapfDingbats") code =   fromMaybe (T.singleton (safeChr code)) (dingbatCodeUnicode code) encodingUnicode (WithCharSet _) code = T.singleton (safeChr code)@@ -1012,11 +1077,15 @@  readHexString :: BSL.ByteString -> Maybe (Token, BSL.ByteString) readHexString bs =-  let hex = BSL.takeWhile hexDigit8 (BSL.tail bs)-      rest = BSL.drop (1 + BSL.length hex) bs-  in case BSL.uncons rest of-       Just (62, r) -> Just (TokOperand (PdfHex (T.pack (map w2c (BSL.unpack hex)))), r)-       _ -> Nothing+  case BSL.break ((== 62) . fromIntegral) (BSL.tail bs) of+    (hexBody, rest) ->+      case BSL.uncons rest of+        Just (_, r) ->+          let hex = BSL.filter hexDigit8 hexBody+          in if BSL.null hex+             then Nothing+             else Just (TokOperand (PdfHex (T.pack (map w2c (BSL.unpack hex)))), r)+        _ -> Nothing  readArray :: BSL.ByteString -> Maybe (Token, BSL.ByteString) readArray bs = parseArrayElems (BSL.tail bs) []

@@ -87,6 +87,8 @@                 , colorspace=T.empty                 , xcolorspaces=[]                 , warnings=[]+                , psResDict=Nothing+                , psFormDepth=0                 }  pdfToTextBS :: FilePath -> Maybe String -> IO (PdfResult BSL.ByteString)

@@ -8,6 +8,9 @@   , interpretContentWithFonts   , interpretContentWithFontsItems   , interpretPageImageHits+  , bytesToCodes+  , encodingUnicode+  , unicodeBytesToCodes   ) import PDF.Layout (LayoutOptions(..), defaultLayoutOptions, needsAozoraBar, aozoraRuby, layoutParagraphs, layoutParagraphsWith, layoutPageText, layoutDocument, sortLinesByReadingOrder, linesFromGlyphs, Line(..)) import PDF.Structure (StructElem(..), StructKid(..), structTree, logicalOrder)@@ -15,6 +18,7 @@ import PDF.Page (pageCount, pageRefAt, pageParagraphs) import PDF.Diff (TextChange(..), compareDocuments, diffParagraphs) import PDF.DocumentStructure (parseCIDWidths, simpleWidthAt, decodeStreamBytes)+import PDF.Character (jisx0208Map) import PDF.Image   ( ImageFormat(..)   , PageImage(..)@@ -182,6 +186,7 @@           ++ formExtractResults           ++ taggedEndToEndResults           ++ textStreamResults+          ++ cmapEncodingResults           ++ tuiScrollResults   let failures = [msg | Fail msg <- results]       passed = length results - length failures@@ -1317,5 +1322,58 @@           (padToDisplayWidth 6 "あ" == "あ    ")       , assertBool "tuiScroll pad straddling wide char"           (stringDisplayWidth (padToDisplayWidth 4 "あい") == 4)+      ]++cmapTestFontInfo :: Encoding -> FontInfo+cmapTestFontInfo enc =+  FontInfo+    { fiEncoding = enc+    , fiToUnicode = M.empty+    , fiWidth = const 1000+    , fiWidthV = const 1000+    , fiWMode = 0+    , fiBytesPerCode = 2+    , fiDefaultWidth = 1000+    }++cmapEncodingResults :: [Result]+cmapEncodingResults =+  let ufi = cmapTestFontInfo UnicodeMap+      jfi = cmapTestFontInfo JISmap+      bmp = [0x65, 0xE5, 0x67, 0x2C]+      mixed = [0x65, 0xE5, 0xD8, 0x3D, 0xDE, 0x00, 0x67, 0x2C]+      odd = [0x65, 0xE5, 0x67]+   in [ assertBool "unicodeBytesToCodes BMP"+          (unicodeBytesToCodes bmp == [0x65E5, 0x672C])+      , assertBool "unicodeBytesToCodes surrogate pair"+          (unicodeBytesToCodes [0xD8, 0x3D, 0xDE, 0x00] == [0x1F600])+      , assertBool "unicodeBytesToCodes BMP and surrogate mixed"+          (unicodeBytesToCodes mixed == [0x65E5, 0x1F600, 0x672C])+      , assertBool "unicodeBytesToCodes odd trailing byte"+          (unicodeBytesToCodes odd == [0x65E5])+      , assertBool "bytesToCodes UnicodeMap via FontInfo"+          (bytesToCodes ufi bmp == [0x65E5, 0x672C])+      , assertTextEq "encodingUnicode UnicodeMap BMP"+          "\x65E5"+          (encodingUnicode UnicodeMap 0x65E5)+      , assertTextEq "encodingUnicode UnicodeMap invalid"+          "\xFFFD"+          (encodingUnicode UnicodeMap 0x110000)+      , assertTextEq "encodingUnicode JISmap 0x3021"+          "\x4E9C"+          (encodingUnicode JISmap 0x3021)+      , assertTextEq "encodingUnicode JISmap 0x2422"+          "\x3042"+          (encodingUnicode JISmap 0x2422)+      , assertTextEq "encodingUnicode JISmap ASCII"+          "A"+          (encodingUnicode JISmap 0x41)+      , assertTextEq "encodingUnicode JISmap missing"+          "\xFFFD"+          (encodingUnicode JISmap 0x2021)+      , assertBool "jisx0208Map has 日本語 codes"+          (M.member 0x467C jisx0208Map && M.member 0x4B5C jisx0208Map)+      , assertBool "bytesToCodes JISmap 2-byte fixed"+          (bytesToCodes jfi [0x46, 0x7C, 0x4B, 0x5C] == [0x467C, 0x4B5C])       ]