diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/data/map/cp932.map b/data/map/cp932.map new file mode 100644 Binary files /dev/null and b/data/map/cp932.map differ diff --git a/data/map/jisx0208.map b/data/map/jisx0208.map new file mode 100644 Binary files /dev/null and b/data/map/jisx0208.map differ diff --git a/hpdft.cabal b/hpdft.cabal --- a/hpdft.cabal +++ b/hpdft.cabal @@ -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 diff --git a/src/PDF/Character.hs b/src/PDF/Character.hs --- a/src/PDF/Character.hs +++ b/src/PDF/Character.hs @@ -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 = diff --git a/src/PDF/ContentStream.hs b/src/PDF/ContentStream.hs --- a/src/PDF/ContentStream.hs +++ b/src/PDF/ContentStream.hs @@ -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 diff --git a/src/PDF/Definition.hs b/src/PDF/Definition.hs --- a/src/PDF/Definition.hs +++ b/src/PDF/Definition.hs @@ -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) diff --git a/src/PDF/DocumentStructure.hs b/src/PDF/DocumentStructure.hs --- a/src/PDF/DocumentStructure.hs +++ b/src/PDF/DocumentStructure.hs @@ -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 diff --git a/src/PDF/Encrypt.hs b/src/PDF/Encrypt.hs --- a/src/PDF/Encrypt.hs +++ b/src/PDF/Encrypt.hs @@ -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 diff --git a/src/PDF/Interpret.hs b/src/PDF/Interpret.hs --- a/src/PDF/Interpret.hs +++ b/src/PDF/Interpret.hs @@ -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) [] diff --git a/src/PDF/Text.hs b/src/PDF/Text.hs --- a/src/PDF/Text.hs +++ b/src/PDF/Text.hs @@ -87,6 +87,8 @@ , colorspace=T.empty , xcolorspaces=[] , warnings=[] + , psResDict=Nothing + , psFormDepth=0 } pdfToTextBS :: FilePath -> Maybe String -> IO (PdfResult BSL.ByteString) diff --git a/test/Unit.hs b/test/Unit.hs --- a/test/Unit.hs +++ b/test/Unit.hs @@ -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]) ]