hpdft 0.1.0.3 → 0.1.0.4

raw patch · 8 files changed

+416/−150 lines, 8 filesdep +attoparsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec

API changes (from Hackage documentation)

Files

• README.md +1/−1
• data/sample/Sample.hs +82/−30
• hpdft.cabal +2/−1
• src/PDF/ContentStream.hs +144/−49
• src/PDF/Definition.hs +4/−1
• src/PDF/Object.hs +130/−31
• src/PDF/Outlines.hs +26/−13
• src/PDF/PDFIO.hs +27/−24

@@ -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`.

@@ -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 ()

@@ -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

@@ -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" 

@@ -61,6 +61,9 @@                , fontfactor :: Double                , curfont    :: String                , cmaps      :: [(String, CMap)]-               , fontmaps   :: [(String, FontMap)]}+               , fontmaps   :: [(String, FontMap)]+               , colorspace :: String+               , xcolorspaces :: [String]+               }          deriving (Show) 

@@ -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)

@@ -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 = 

@@ -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"-