diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,6 +6,6 @@ Example ------- -`Sample.hs` has some functions showing how to use hpdft. +[`Sample.hs`](https://github.com/k16shikano/hpdft/blob/master/data/sample/Sample.hs) has some functions showing how to use hpdft. If you want to customize the character sets and encodings other than the Appendix D of the PDF specification, you could modify `PdfCharDict.hs`. For example, you can use ASCII single quote (`U+0027`) instead of `U+2019` by modifying the entry for `/quoteright`. diff --git a/data/sample/Sample.hs b/data/sample/Sample.hs --- a/data/sample/Sample.hs +++ b/data/sample/Sample.hs @@ -8,33 +8,38 @@ import Data.ByteString.UTF8 (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.List (nub) import Debug.Trace --- initstate = (0,0,70,660) initstate = PSR { linex=0 , liney=0 , absolutex=0 - , absolutey=700 + , absolutey=0 , leftmargin=0.0 - , top=700.0 + , top=0.0 , bottom=0.0 - , fontfactor=1.0 + , fontfactor=1 , curfont="" , fontmaps=[] - , cmaps=[]} + , cmaps=[] + , colorspace="" + , xcolorspaces=[] + } ------------------------------------------------ --- Show each PDF Object by its reference number ------------------------------------------------ +-- | Show bare data in 'ref'ed-object. objectByRef filename ref = getObjectByRef ref (getPDFObjFromFile filename) -streamByRef filename ref = do - obj <- getObjectByRef ref (getPDFObjFromFile filename) - return $ rawStream obj +-- | Show contents of page 'page' in 'filename'. +showPage filename page = do + pagetree <- refByPage filename + contentByRef filename $ pagetree !! (page - 1) + +-- | Show /Content referenced from the 'ref'ed-object in 'filename'. + contentByRef filename ref = do objs <- getPDFObjFromFile filename obj <- objectByRef filename ref @@ -44,6 +49,20 @@ Just dict -> contentsStream dict initstate objs Nothing -> "" +-- | Show raw bytestring stream (without deflated) of page 'page' in 'filename'. + +showRawPage filename page = do + pagetree <- refByPage filename + rawContentByRef filename $ pagetree !! (page - 1) + +-- | Show raw bytestring stream (without deflated) of 'ref'ed-object. + +streamByRef filename ref = do + obj <- getObjectByRef ref (getPDFObjFromFile filename) + return $ rawStream obj + +-- | Show raw bytestring stream (without deflated) in a /Content referenced from the 'ref'ed-object in 'filename'. + rawContentByRef filename ref = do objs <- getPDFObjFromFile filename obj <- objectByRef filename ref @@ -52,27 +71,21 @@ case findDictOfType "/Page" obj of Just dict -> rawContentsStream dict objs Nothing -> "" - -showPage filename page = do - pagetree <- refByPage filename - contentByRef filename $ pagetree !! (page - 1) -showRawPage filename page = do - pagetree <- refByPage filename - rawContentByRef filename $ pagetree !! (page - 1) +-- | Show CMap information in object 'ref' in 'filename'. cmapStreamByRef filename ref = do objs <- getPDFObjFromFile filename return $ toUnicode ref objs ---------------------------------------- --- Sort Object References in Page order ---------------------------------------- + data PageTree = Nop | Page Int | Pages [PageTree] deriving Show +-- | Sort object references in page order. + refByPage filename = do root <- getRootRef filename objs <- getPDFObjFromFile filename @@ -100,12 +113,10 @@ pageTreeToList Nop = [] --------------------------- --- Get Whole Text from PDF --------------------------- --- First: grub objects --- Second: parse within each object, deflating its stream --- Third: linearize stream +-- | Get a whole text from 'filename'. It works as: +-- (1) grub objects +-- (2) parse within each object, deflating its stream +-- (3) linearize stream pdfToText filename = do contents <- BS.readFile filename @@ -132,7 +143,48 @@ Nothing -> "" -------------------- --- Meta Information -------------------- +-- | Show /Title from meta information in 'filename' +showTitle filename = do + d <- getInfo filename + let title = + case findObjThroughDict d "/Title" of + Just (PdfText s) -> s + Just x -> show x + Nothing -> error "No title anyway" + putStrLn title + return () + +-- | Show /Info from meta information in 'filename' + +showInfo filename = do + d <- getInfo filename + putStrLn $ toString 0 (PdfDict d) + return () + +-- | Show /Outlines from meta information in 'filename' + +showOutlines filename = do + d <- getOutlines filename + putStrLn $ show d + return () + + +-- | Show device color spaces of each page. + +contentColorSpaceByRef filename ref = do + objs <- getPDFObjFromFile filename + obj <- objectByRef filename ref + putStrLn $ show $ filter (/="") $ nub $ csOfObject obj objs + where csOfObject obj objs = + case findDictOfType "/Page" obj of + Just dict -> contentsColorSpace dict initstate objs + Nothing -> error "Seems to be no color space in content stream" + +-- | Show device color spaces of all pages. + +showColorSpaces filename = do + pages <- refByPage filename + pagescs <- mapM (contentColorSpaceByRef filename) pages + mapM (putStrLn . show) $ zip [1..] pagescs + return () diff --git a/hpdft.cabal b/hpdft.cabal --- a/hpdft.cabal +++ b/hpdft.cabal @@ -1,5 +1,5 @@ name: hpdft -version: 0.1.0.3 +version: 0.1.0.4 synopsis: A tool for looking through PDF file using Haskell -- description: homepage: https://github.com/k16shikano/hpdft @@ -33,6 +33,7 @@ , bytestring >=0.10 && <0.11 , text >=0.11 , parsec >=3.1 && <3.2 + , attoparsec >=0.13.0 && <1.0 , zlib >=0.5 , utf8-string >=0.3 , directory >=1.2 && <1.3 diff --git a/src/PDF/ContentStream.hs b/src/PDF/ContentStream.hs --- a/src/PDF/ContentStream.hs +++ b/src/PDF/ContentStream.hs @@ -3,6 +3,7 @@ module PDF.ContentStream ( deflate , decompressStream + , parseColorSpace ) where import Data.Char (chr) @@ -32,9 +33,10 @@ parseContentStream p st = runParser p st "" parseDeflated :: PSR -> BSC.ByteString -> PDFStream -parseDeflated psr pdfstream = case parseContentStream (T.concat <$> many (elems <|> skipOther)) psr pdfstream of - Left err -> error "Nothing to be parsed" - Right str -> BSC.pack $ BS.unpack $ encodeUtf8 str +parseDeflated psr pdfstream = + case parseContentStream (T.concat <$> many (elems <|> skipOther)) psr pdfstream of + Left err -> error "Nothing to be parsed" + Right str -> BSC.pack $ BS.unpack $ encodeUtf8 str deflate :: PSR -> PDFStream -> PDFStream deflate = parseDeflated @@ -47,6 +49,18 @@ Left err -> "err" Right bs -> decompress bs +parseColorSpace :: PSR -> BSC.ByteString -> [T.Text] +parseColorSpace psr pdfstream = + case parseContentStream (many (choice [ try colorSpace + , try $ T.concat <$> xObject + , (T.empty <$ elems) + ])) psr pdfstream of + Left err -> error "Nothing to be parsed" + Right str -> str + + +-- | Parsers for Content Stream + elems :: PSParser T.Text elems = choice [ try pdfopBT , try pdfopTf @@ -57,32 +71,37 @@ , try pdfopTw , try pdfopTJ , try pdfopTj + , try pdfQuote + , try pdfDoubleQuote , try pdfopTast , try letters <* spaces , try hexletters <* spaces , try array <* spaces , try pdfopGraphics - , try xObject + , try dashPattern + , try pathConstructor + , try $ T.empty <$ xObject , try graphicState + , try pdfopcm + , try $ T.empty <$ colorSpace , unknowns ] pdfopGraphics :: PSParser T.Text pdfopGraphics = do spaces - choice [ try $ T.empty <$ oneOf "qQ" <* spaces + choice [ try $ T.empty <$ oneOf "qQ" <* space <* spaces , try $ T.empty <$ oneOf "fFbBW" <* (many $ string "*") <* spaces - , try $ T.empty <$ oneOf "nsS" <* spaces - , try $ T.empty <$ (digitParam <* spaces) <* oneOf "gG" <* spaces - , try $ T.empty <$ (digitParam <* spaces) <* oneOf "jJ" <* spaces - , try $ T.empty <$ (digitParam <* spaces) <* oneOf "dwi" <* spaces - , try $ T.empty <$ (many1 (digitParam <* spaces) <* oneOf "ml" <* spaces) - , try $ T.empty <$ (many1 (digitParam <* spaces) <* oneOf "kK" <* spaces) - , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "re" <* spaces) - , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "rg" <* spaces) - , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "RG" <* spaces) - , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "cm" <* spaces) - , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "c" <* spaces) + , try $ T.empty <$ oneOf "nsS" <* space <* spaces + , try $ T.empty <$ (digitParam <* spaces) <* oneOf "jJM" <* space <* spaces + , try $ T.empty <$ (digitParam <* spaces) <* oneOf "dwi" <* space <* spaces + , try $ T.empty <$ (many1 (digitParam <* spaces) <* oneOf "ml" <* space <* spaces) + , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "re " <* spaces) + , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "SCN " <* spaces) + , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "scn " <* spaces) + , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "SC " <* spaces) + , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "sc " <* spaces) + , try $ T.empty <$ (many1 (digitParam <* spaces) <* string "c" <* space <* spaces) ] return T.empty @@ -94,13 +113,41 @@ spaces return T.empty -xObject :: PSParser T.Text +colorSpace :: PSParser T.Text +colorSpace = do + gs <- choice [ try $ string "/" *> manyTill anyChar (try space) <* string "CS" <|> string "cs" <* spaces + , try $ "DeviceRGB" <$ (many1 (digitParam <* spaces) <* string "rg" <* spaces) + , try $ "DeviceRGB" <$ (many1 (digitParam <* spaces) <* string "RG" <* spaces) + , try $ "DeviceGray" <$ (digitParam <* spaces) <* oneOf "gG" <* spaces + , try $ "DeviceCMYK" <$ (many1 (digitParam <* spaces) <* oneOf "kK" <* spaces) + ] + updateState (\s -> s {colorspace = gs}) + return $ T.pack gs + +dashPattern :: PSParser T.Text +dashPattern = do + char '[' >> many digit >> char ']' >> spaces >> many1 digit >> spaces >> string "d" + return T.empty + +pathConstructor :: PSParser T.Text +pathConstructor = do + choice [ try $ T.empty <$ (digitParam <* spaces) <* oneOf "ml" <* spaces + , try $ T.empty <$ (digitParam <* spaces) <* oneOf "cvy" <* spaces + , try $ T.empty <$ (digitParam <* spaces) <* oneOf "re" <* spaces + , try $ T.empty <$ oneOf "h" <* spaces + ] + return T.empty + +xObject :: PSParser [T.Text] xObject = do - file <- (++) <$> string "/" <*> manyTill anyChar (try space) + n <- (++) <$> string "/" <*> manyTill anyChar (try space) spaces string "Do" spaces - return T.empty + st <- getState + let xobjcs = xcolorspaces st +-- updateState (\s -> s {colorspace = xobjcs}) + return $ map T.pack xobjcs pdfopBT :: PSParser T.Text pdfopBT = do @@ -124,11 +171,26 @@ spaces return $ T.concat t +pdfDoubleQuote :: PSParser T.Text +pdfDoubleQuote = do + spaces + t <- manyTill (letters <|> hexletters <|> array) (try $ string "\"") + spaces + return $ T.concat t + +pdfQuote :: PSParser T.Text +pdfQuote = do + spaces + t <- manyTill (letters <|> hexletters <|> array) (try $ string "\'") + spaces + return $ T.concat t + unknowns :: PSParser T.Text unknowns = do ps <- manyTill anyChar (try $ oneOf "\r\n") - return "" - return $ T.pack $ "[[[UNKNOWN STREAM:" ++ take 100 (show ps) ++ "]]]" + return $ if ps=="" + then "" + else T.pack $ "[[[UNKNOWN STREAM:" ++ take 100 (show ps) ++ "]]]" skipOther :: PSParser T.Text skipOther = do @@ -183,7 +245,7 @@ Nothing -> [] c <- try (char '\\' >> oneOf "\\()") <|> - try (octToString . readOct <$> (char '\\' >> (count 3 $ oneOf "01234567"))) + try (octToChar . readOct <$> (char '\\' >> (count 3 $ oneOf "01234567"))) <|> noneOf "\\" return $ replaceWithDiff fontmap c @@ -193,8 +255,8 @@ replaceWithCharDict s = case Map.lookup s pdfcharmap of Just cs -> cs Nothing -> T.pack s - octToString [] = '?' - octToString [(o,_)] = chr o + octToChar [] = '?' + octToChar [(o,_)] = chr o kern :: PSParser T.Text kern = do @@ -212,7 +274,9 @@ st <- getState let ff = fontfactor st updateState (\s -> s{ curfont = font - , fontfactor = ff*t}) + , fontfactor = t + , linex = t + , liney = t}) return "" pdfopTD :: PSParser T.Text @@ -230,15 +294,15 @@ ly = liney st lm = leftmargin st ff = fontfactor st - needBreak = abs t2 > 0 && abs (ly - t2) > 0 - updateState (\s -> s { absolutex = ax + t1 - , absolutey = ay + (if needBreak then 2*t2 else 0) - , linex = if abs t1 > 0 then t1 else lx - , liney = if abs t2 > 0 then 2*t2 else ly + needBreak = t2 < 0 + updateState (\s -> s { absolutex = ax - lx + , absolutey = ay - ly + , linex = lx + , liney = -t2*ff }) return $ if needBreak - then T.concat ["\n", (desideParagraphBreak t1 t2 lx ly lm ff)] - else "" + then T.concat ["\n", (desideParagraphBreak (t1*ff) (t2*ff) lx (-t2*ff) lm ff)] + else if t1 > ff then " " else "" pdfopTd :: PSParser T.Text pdfopTd = do @@ -255,15 +319,15 @@ ly = liney st lm = leftmargin st ff = fontfactor st - needBreak = abs t2 > 0 && abs (ly - t2) > 0 - updateState (\s -> s { absolutex = ax + t1 - , absolutey = ay + (if needBreak then t2 else 0) - , linex = if abs t1 > 0 then t1 else lx - , liney = if abs t2 > 0 then t2 else ly + needBreak = t2 < 0 && abs t2 > ly + updateState (\s -> s { absolutex = ax - lx + , absolutey = ay - ly + , linex = lx + , liney = ly }) return $ if needBreak then T.concat ["\n", (desideParagraphBreak t1 t2 lx ly lm ff)] - else "" + else if t1 > ff then " " else "" pdfopTw :: PSParser T.Text pdfopTw = do @@ -292,7 +356,7 @@ desideParagraphBreak :: Double -> Double -> Double -> Double -> Double -> Double -> T.Text desideParagraphBreak t1 t2 lx ly lm ff = T.pack $ - (if abs ly > abs ff || abs t2 > abs ff || (t1 - lm) > 0.5 + (if abs t2 > 1.8*ly || (t1 - lm) > 0.5 then "\n" else "") @@ -319,17 +383,48 @@ ly = liney st lm = leftmargin st ff = fontfactor st - needBreak = abs d*f > 0 && ly >= 0 - updateState (\s -> s { linex = lx - , liney = ly - , absolutex = a*e - , absolutey = d*f - , fontfactor = a*e*d*f*ff + newff = (a+d)/2 + needBreak = ay - f/newff > (ly/newff) + updateState (\s -> s { linex = lx/newff + , liney = ly/newff + , absolutex = e/newff + , absolutey = f/newff }) return $ if needBreak - then T.concat ["\n", desideParagraphBreak (d*f) (d*f) lx ly lm ff] - else if a*e > lx then " " else "" + then T.concat ["\n", desideParagraphBreak (e*newff) (f*newff) lx ly lm newff] + else if e > newff then " " else "" +pdfopcm :: PSParser T.Text +pdfopcm = do + a <- digitParam + spaces + b <- digitParam + spaces + c <- digitParam + spaces + d <- digitParam + spaces + e <- digitParam + spaces + f <- digitParam + spaces + string "cm" + spaces + st <- getState + let ax = absolutex st + ay = absolutey st + lx = linex st + ly = liney st + lm = leftmargin st + ff = fontfactor st + newff = (a+d)/2 + updateState (\s -> s { linex = lx/newff + , liney = ly/newff + , absolutex = e/newff + , absolutey = f/newff + }) + return T.empty + pdfopTast :: PSParser T.Text pdfopTast = do string "T*" @@ -340,8 +435,8 @@ ly = liney st updateState (\s -> s { linex = lx , liney = ly - , absolutex = ax - , absolutey = ay + , absolutex = ax - lx + , absolutey = ay - ly }) return "\n" diff --git a/src/PDF/Definition.hs b/src/PDF/Definition.hs --- a/src/PDF/Definition.hs +++ b/src/PDF/Definition.hs @@ -61,6 +61,9 @@ , fontfactor :: Double , curfont :: String , cmaps :: [(String, CMap)] - , fontmaps :: [(String, FontMap)]} + , fontmaps :: [(String, FontMap)] + , colorspace :: String + , xcolorspaces :: [String] + } deriving (Show) diff --git a/src/PDF/Object.hs b/src/PDF/Object.hs --- a/src/PDF/Object.hs +++ b/src/PDF/Object.hs @@ -8,6 +8,7 @@ , rawContentsStream , rawStreamByRef , rawStream + , contentsColorSpace , toUnicode , pagesKids , pages @@ -19,6 +20,7 @@ , findObjsByRef , parsePDFObj , parseRefsArray + , parsePdfLetters , getObjs , pdfObj , getRefs @@ -31,10 +33,15 @@ import Data.ByteString.UTF8 (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf16BE) +import Numeric (readOct, readHex) +import Data.ByteString.Builder (toLazyByteString, word16BE) -import Text.Parsec hiding (many, (<|>)) +import Data.Attoparsec.ByteString hiding (inClass, notInClass, satisfy) +import Data.Attoparsec.ByteString.Char8 +import Data.Attoparsec.Combinator import Control.Applicative -import Text.Parsec.ByteString import Codec.Compression.Zlib (decompress) import Debug.Trace @@ -43,16 +50,19 @@ import PDF.ContentStream import PDF.Cmap +spaces = skipSpace +oneOf = satisfy . inClass +noneOf = satisfy . notInClass -- parse pdf objects getObjs :: BS.ByteString -> [PDFBS] -getObjs contents = case parse (many1 pdfObj) "" contents of +getObjs contents = case parseOnly (many1 pdfObj) contents of Left err -> [] Right rlt -> rlt getXref :: BS.ByteString -> String -getXref contents = case parse (xref) "" contents of +getXref contents = case parseOnly (xref) contents of Left err -> [] Right rlt -> rlt @@ -66,7 +76,7 @@ return $ (read objn, BS.pack object) parsePDFObj :: PDFBS -> PDFObj -parsePDFObj (n,pdfobject) = case parse (spaces >> many1 (pdfobj <|> objother)) "" pdfobject of +parsePDFObj (n,pdfobject) = case parseOnly (spaces >> many1 (pdfobj <|> objother)) pdfobject of Left err -> (n,[PdfNull]) Right obj -> (n,obj) @@ -103,15 +113,44 @@ pdfarray = PdfArray <$> (string "[" >> spaces *> manyTill pdfobj (try $ spaces >> string "]")) pdfname :: Parser Obj -pdfname = PdfName <$> ((++) <$> string "/" <*> manyTill anyChar (try $ lookAhead $ oneOf "><][)( \n\r/")) <* spaces +pdfname = PdfName . BS.unpack <$> (BS.append <$> string "/" <*> (BS.pack <$> (manyTill anyChar (try $ lookAhead $ oneOf "><][)( \n\r/")))) <* spaces pdfletters :: Parser Obj -pdfletters = PdfText <$> (concat <$> (char '(' *> manyTill pdfletter (try $ char ')'))) - where pdfletter = choice [ return <$> try (char '\\' >> oneOf "\\()") - , (++) <$> ("(" <$ char '(') <*> ((++")") . concat <$> manyTill pdfletter (try $ char ')')) - , return <$> (noneOf "\\") - ] +pdfletters = PdfText <$> parsePdfLetters +parsePdfLetters :: Parser String +parsePdfLetters = (concat <$> (char '(' *> manyTill (choice [try pdfutf, try pdfoctutf, pdfletter]) (try $ char ')'))) + where pdfletter = do + str <- choice [ return <$> try (char '\\' >> oneOf "\\()") + , "\n" <$ try (string "\n") + , "\r" <$ try (string "\r") + , "\t" <$ try (string "\t") + , "\b" <$ try (string "\b") + , "\f" <$ try (string "\f") + , (++) <$> ("(" <$ char '(') <*> ((++")") . concat <$> manyTill pdfletter (try $ char ')')) + , return <$> (noneOf "\\") + ] + return $ str + pdfutf :: Parser String + pdfutf = do + str <- string "\254\255" *> manyTill anyChar (lookAhead $ string ")") + return $ utf16be str + + pdfoctutf :: Parser String + pdfoctutf = do + string "\\376\\377" + octstr <- manyTill (choice [ try (return . chr . fst . head . readOct <$> (char '\\' *> count 3 (oneOf "01234567"))) + , try ("\92" <$ string "\\\\") + , return <$> noneOf "\\" + ]) + (lookAhead $ string ")") + return $ utf16be $ concat octstr + + octToString [] = "????" + octToString [(o,_)] = [chr o] + +utf16be = T.unpack . decodeUtf16BE . BS.pack + pdfstream :: Parser Obj pdfstream = PdfStream <$> stream @@ -119,19 +158,31 @@ pdfnumber = PdfNumber <$> pdfdigit where pdfdigit = do sign <- many $ char '-' - num <- ((++) <$> (("0"++) <$> string ".") <*> many1 digit) + num <- ((++) <$> (("0"++) . BS.unpack <$> string ".") <*> (many1 digit)) <|> ((++) <$> (many1 digit) <*> ((++) <$> (many $ char '.') <*> many digit)) spaces return $ read $ sign ++ num pdfhex :: Parser Obj -pdfhex = PdfHex <$> hex +pdfhex = PdfHex <$> hex where hex = do char '<' - lets <- manyTill (oneOf "0123456789abcdefABCDEF") (try $ char '>') - return $ lets + lets <- BS.pack <$> manyTill (oneOf "0123456789abcdefABCDEF") (try $ char '>') + case parseOnly ((try $ string "feff" <|> string "FEFF") *> (many1 (oneOf "0123456789abcdefABCDEF"))) lets of + Right s -> return $ pdfhexletter $ BS.pack s + Left e -> return . BS.unpack $ lets +pdfhexletter s = case parseOnly (concat <$> many1 pdfhexutf16be) s of + Right t -> utf16be t + Left e -> BS.unpack s + +pdfhexutf16be :: Parser String +pdfhexutf16be = do + c <- count 4 $ oneOf "0123456789ABCDEFabcdef" + let b = BSL.unpack . toLazyByteString . word16BE $ fst . head . readHex $ c + return $ b + pdfbool :: Parser Obj pdfbool = PdfBool <$> (True <$ string "true" <|> @@ -142,9 +193,14 @@ pdfobj :: Parser Obj pdfobj = choice [ try rrefs <* spaces - , try pdfname <* spaces, try pdfnumber <* spaces, try pdfhex <* spaces - , try pdfbool <* spaces, try pdfnull <* spaces - , try pdfarray <* spaces, try pdfdictionary <* spaces, try pdfstream <* spaces + , try pdfname <* spaces + , try pdfnumber <* spaces + , try pdfhex <* spaces + , try pdfbool <* spaces + , try pdfnull <* spaces + , try pdfarray <* spaces + , try pdfdictionary <* spaces + , {-# SCC pdfstream #-} try pdfstream <* spaces , pdfletters <* spaces ] @@ -239,7 +295,8 @@ contents _ = False parsedContentStreamByRef :: Dict -> PSR -> [PDFObj] -> Int -> PDFStream -parsedContentStreamByRef dict st objs ref = deflate (st {fontmaps=fontdict, cmaps=cmap}) $ rawStreamByRef objs ref +parsedContentStreamByRef dict st objs ref = + deflate (st {fontmaps=fontdict, cmaps=cmap}) $ rawStreamByRef objs ref where fontdict = findFontMap dict objs cmap = findCMap dict objs @@ -261,7 +318,17 @@ parseRefsArray (x:y) = (parseRefsArray y) parseRefsArray [] = [] +contentsColorSpace :: Dict -> PSR -> [PDFObj] -> [T.Text] +contentsColorSpace dict st objs = case find contents dict of + Just (PdfName "/Contents", PdfArray arr) -> concat $ map (parseColorSpace (st {xcolorspaces=xobjcs}) . rawStreamByRef objs) (parseRefsArray arr) + Just (PdfName "/Contents", ObjRef x) -> parseColorSpace (st {xcolorspaces=xobjcs}) $ rawStreamByRef objs x + Nothing -> error "No content to be shown" + where + contents (PdfName "/Contents", _) = True + contents _ = False + xobjcs = findXObjectColorSpace dict objs + -- make fontmap from page's /Resources (see 3.7.2 of PDF Ref.) findFontMap d os = encoding (getFontObjs d os) os @@ -332,23 +399,55 @@ otherwise -> [] +-- find XObject + +findXObjectColorSpace d os = xobjColorSpaceMap (getXObject d os) os + +xobjColorSpaceMap dict objs = map pairwise dict + where + pairwise (PdfName n, ObjRef r) = xobjColorSpace r objs + pairwise x = "" + +getXObject dict objs = case findResourcesDict dict objs of + Just d -> case findObjThroughDict d "/XObject" of + Just (PdfDict d) -> d + otherwise -> [] + Nothing -> [] + +xobjColorSpace :: Int -> [PDFObj] -> String +xobjColorSpace x objs = case findObjThroughDictByRef x "/ColorSpace" objs of + Just (PdfName cs) -> cs + otherwise -> "" + + -- find root ref from Trailer or Cross-Reference Dictionary parseTrailer :: BS.ByteString -> Maybe Dict -parseTrailer bs = case parse trailer "" bs of - Left err -> Nothing +parseTrailer bs = case parseOnly (try trailer <|> xref) bs of + Left err -> (trace (show err) Nothing) Right rlt -> Just (parseCRDict rlt) where trailer :: Parser BS.ByteString trailer = do manyTill anyChar (try $ string "trailer") t <- manyTill anyChar (try $ string "startxref") return $ BS.pack t + xref :: Parser BS.ByteString + xref = do + manyTill anyChar (try $ string "startxref") + offset <- spaces *> many1 digit + return $ BS.drop (read offset :: Int) bs parseCRDict :: BS.ByteString -> Dict -parseCRDict rlt = case parse (spaces >> pdfdictionary <* spaces) "" rlt of - Left err -> error $ show err - Right (PdfDict dict) -> dict - Right other -> error "Could not find Cross-Reference dictionary" +parseCRDict rlt = case parseOnly crdict rlt of + Left err -> error $ show rlt + Right (PdfDict dict) -> dict + Right other -> error "Could not find Cross-Reference dictionary" + where crdict :: Parser Obj + crdict = do + spaces + many (many1 digit >> spaces >> digit >> string " obj" >> spaces) + d <- pdfdictionary <* spaces + return d rootRef :: BS.ByteString -> Maybe Int rootRef bs = case parseTrailer bs of @@ -393,20 +492,20 @@ objStm :: PDFObj -> [PDFObj] objStm (n, obj) = case findDictOfType "/ObjStm" obj of Nothing -> [(n,obj)] - Just _ -> getPdfObjStm n $ BS.pack $ BSL.unpack $ rawStream obj + Just _ -> getPdfObjStm n $ BSL.toStrict $ rawStream obj refOffset :: Parser ([(Int, Int)], String) refOffset = spaces *> ((,) - <$> many1 ((\r o -> (read r :: Int, read o :: Int)) + <$> many1 ((\r o -> (read r :: Int, read o :: Int)) <$> (many1 digit <* spaces) <*> (many1 digit <* spaces)) - <*> (manyTill anyChar (lookAhead $ string "<<") *> many1 anyChar)) + <*> many1 anyChar) getPdfObjStm n s = - let (location, objstr) = case parse refOffset "" s of + let (location, objstr) = case parseOnly refOffset s of Right val -> val Left err -> error $ "Failed to parse Object Stream: " in map (\(r,o) -> (r, parseDict $ BS.pack $ drop o objstr)) location - where parseDict s' = case parse pdfdictionary "" s' of + where parseDict s' = case parseOnly pdfdictionary s' of Right obj -> [obj] - Left err -> error "Failed to parse obj" + Left err -> error $ "Failed to parse obj " ++ (show s') ++ (show err) diff --git a/src/PDF/Outlines.hs b/src/PDF/Outlines.hs --- a/src/PDF/Outlines.hs +++ b/src/PDF/Outlines.hs @@ -7,7 +7,12 @@ import Debug.Trace import Data.List (find) -import PDF.Definition +import Data.Attoparsec.ByteString hiding (inClass, notInClass, satisfy) +import Data.Attoparsec.ByteString.Char8 +import Data.Attoparsec.Combinator +import qualified Data.ByteString.Char8 as BS + +import PDF.Definition hiding (toString) import PDF.Object import PDF.PDFIO @@ -17,8 +22,18 @@ , subs :: PDFOutlines } | PDFOutlinesNE - deriving (Show) +instance Show PDFOutlines where + show = toString 0 + +toString :: Int -> PDFOutlines -> String +toString depth PDFOutlinesEntry {dest=d, text=t, subs=s} = (replicate depth ' ' ++ t) ++ toString (depth+1) s +toString depth (PDFOutlinesTree os) = concatMap (toString depth) os +toString depth PDFOutlinesNE = "" + +-- | Get information of \/Outlines from 'filename' + +getOutlines :: FilePath -> IO PDFOutlines getOutlines filename = do dict <- outlineObjFromFile filename objs <- getPDFObjFromFile filename @@ -26,9 +41,9 @@ Just r -> return r Nothing -> error "No top level outline entry." firstdict <- case findObjsByRef firstref objs of - Just [PdfDict d] -> return $ d + Just [PdfDict d] -> return d Nothing -> error $ "No Object with Ref " ++ show firstref - showOutlines 0 $ gatherOutlines firstdict objs + return $ gatherOutlines firstdict objs gatherChildren dict objs = case findFirst dict of Just r -> case findObjsByRef r objs of @@ -41,19 +56,14 @@ in case findNext dict of Just r -> case findObjsByRef r objs of Just [PdfDict d] -> PDFOutlinesTree (PDFOutlinesEntry { dest = head $ findDest dict - , text = findTitle dict objs + , text = findTitle dict objs ++ "\n" , subs = c} : [gatherOutlines d objs]) Nothing -> error $ "No Object with Ref " ++ show r Nothing -> PDFOutlinesEntry { dest = head $ findDest dict - , text = findTitle dict objs + , text = findTitle dict objs ++ "\n" , subs = PDFOutlinesNE} -showOutlines :: Int -> PDFOutlines -> IO () -showOutlines depth (PDFOutlinesEntry {dest=d, text=t, subs=s}) = putStrLn (replicate depth ' ' ++ t) >> showOutlines (depth+1) s -showOutlines depth (PDFOutlinesTree os) = mapM_ (showOutlines (depth)) os -showOutlines depth PDFOutlinesNE = putStr "" - outlines :: Dict -> Int outlines dict = case find isOutlinesRef dict of Just (_, ObjRef x) -> x @@ -78,10 +88,13 @@ findTitle dict objs = case findObjThroughDict dict "/Title" of - Just (PdfText s) -> s + Just (PdfText s) -> case parseOnly parsePdfLetters (BS.pack s) of + Right t -> t + Left err -> s Just (ObjRef r) -> case findObjsByRef r objs of Just [PdfText s] -> s - Nothing -> error $ "No title object in "++(show r) + Nothing -> error $ "No title object in " ++ show r + Just x -> show x Nothing -> error "No title object." findDest dict = diff --git a/src/PDF/PDFIO.hs b/src/PDF/PDFIO.hs --- a/src/PDF/PDFIO.hs +++ b/src/PDF/PDFIO.hs @@ -1,3 +1,12 @@ +{-| +Module : PDF.PDFIO +Description : IO utilities for hpdft +Copyright : (c) Keiichiro Shikano, 2016 +License : MIT +Maintainer : k16.shikano@gmail.com + +Functions for use within IO. +-} module PDF.PDFIO ( getObjectByRef , getPDFBSFromFile , getPDFObjFromFile @@ -12,41 +21,34 @@ import qualified Data.ByteString.Char8 as BS - --- IO utilities +-- | Get PDF objects as a whole bytestring. Use 'getPDFObjFromFile' instead if there's no reason to see a raw bytestring. -getPDFBSFromFile :: String -> IO [PDFBS] +getPDFBSFromFile :: FilePath -> IO [PDFBS] getPDFBSFromFile f = do c <- BS.readFile f let bs = getObjs c return bs -getPDFObjFromFile :: String -> IO [PDFObj] +-- | Get PDF objects each parsed as 'PDFObj' without being sorted. + +getPDFObjFromFile :: FilePath -> IO [PDFObj] getPDFObjFromFile f = do c <- BS.readFile f let obj = expandObjStm $ map parsePDFObj $ getObjs c return obj -getRawObjFromFile :: String -> Int -> IO BS.ByteString -getRawObjFromFile f r = do - c <- BS.readFile f - let objs = getObjs c - case lookup r objs of - Just obj -> return obj - Nothing -> error $ "No object with ref "++show r +-- | Get a PDF object from a whole 'PDFObj' by specifying 'ref :: Int' getObjectByRef :: Int -> IO [PDFObj] -> IO [Obj] getObjectByRef ref pdfobjs = do objs <- pdfobjs case findObjsByRef ref objs of - Just os -> return $ os + Just os -> return os Nothing -> error $ "No Object with Ref " ++ show ref -getRootRefFromFile :: String -> IO (Maybe Int) -getRootRefFromFile f = do - c <- BS.readFile f - return $ rootRef c +-- | The reference number of /Root in 'filename'. +getRootRef :: FilePath -> IO Int getRootRef filename = do c <- BS.readFile filename let n = rootRef c @@ -54,6 +56,9 @@ Just i -> return i Nothing -> error "Could not find rood object" +-- | The /Root object in 'filename'. + +getRootObj :: FilePath -> IO [Obj] getRootObj filename = do rootref <- getRootRef filename objs <- getPDFObjFromFile filename @@ -61,10 +66,16 @@ Just os -> return os Nothing -> error "Could not get root object" +-- | The trailer of 'filename'. + +getTrailer :: FilePath -> IO Dict getTrailer filename = do c <- BS.readFile filename return $ findTrailer c +-- | /Info of 'filename'. + +getInfo :: FilePath -> IO Dict getInfo filename = do d <- getTrailer filename objs <- getPDFObjFromFile filename @@ -75,11 +86,3 @@ case findDictByRef inforef objs of Just os -> return os Nothing -> error "Could not get info object" - -getTitle filename = do - d <- getInfo filename - case findObjThroughDict d "/Title" of - Just (PdfText s) -> return s - Just x -> error $ show x - Nothing -> error "No title anyway" -