diff --git a/data/sample/Sample.hs b/data/sample/Sample.hs --- a/data/sample/Sample.hs +++ b/data/sample/Sample.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} +module Main where + import PDF.Definition + import PDF.Object import PDF.PDFIO import PDF.Outlines diff --git a/hpdft.cabal b/hpdft.cabal --- a/hpdft.cabal +++ b/hpdft.cabal @@ -1,5 +1,5 @@ name: hpdft -version: 0.1.0.4 +version: 0.1.0.5 synopsis: A tool for looking through PDF file using Haskell -- description: homepage: https://github.com/k16shikano/hpdft @@ -18,6 +18,7 @@ data-files: map/Adobe-Japan1-6.map data-files: sample/Sample.hs + library hs-source-dirs: src/ exposed-modules: PDF.PDFIO @@ -27,18 +28,31 @@ , PDF.Definition , PDF.Outlines , PDF.Object - -- other-modules: + other-modules: Paths_hpdft other-extensions: OverloadedStrings build-depends: base >=4.6 && <5 , bytestring >=0.10 && <0.11 , text >=0.11 - , parsec >=3.1 && <3.2 + , parsec >=3.0 && <3.2 , attoparsec >=0.13.0 && <1.0 , zlib >=0.5 , utf8-string >=0.3 - , directory >=1.2 && <1.3 + , directory >=1.2 , containers >=0.5 && <0.6 , file-embed >=0.0.9 && <1.0 , binary >=0.7.5 && <0.8.2 - -- hs-source-dirs: + autogen-modules: Paths_hpdft default-language: Haskell2010 + buildable: True + +executable hpdft + main-is: hpdft.hs + hs-source-dirs: . + other-modules: Paths_hpdft + other-extensions: OverloadedStrings + build-depends: hpdft + , base >=4.6 && <5 + , bytestring >=0.10 && <0.11 + , utf8-string >=0.3 + default-language: Haskell2010 + buildable: True diff --git a/hpdft.hs b/hpdft.hs new file mode 100644 --- /dev/null +++ b/hpdft.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import PDF.Definition + +import PDF.Object +import PDF.PDFIO +import PDF.Outlines + +import System.Environment (getArgs) + +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 Data.Maybe (fromMaybe) + +import Debug.Trace + +initstate = PSR { linex=0 + , liney=0 + , absolutex=0 + , absolutey=0 + , leftmargin=0.0 + , top=0.0 + , bottom=0.0 + , fontfactor=1 + , curfont="" + , fontmaps=[] + , cmaps=[] + , colorspace="" + , xcolorspaces=[] + } + +main = do + fn:_ <- getArgs + pdfToText fn + +-- | 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 + let objs = expandObjStm $ map parsePDFObj $ getObjs contents + let rootref = fromMaybe 0 (rootRef contents) + BSL.putStrLn $ linearize rootref objs + +linearize :: Int -> [PDFObj] -> PDFStream +linearize parent objs = + case findObjsByRef parent objs of + Just os -> case findDictOfType "/Catalog" os of + Just dict -> case pages dict of + Just pr -> linearize pr objs + Nothing -> "" + Nothing -> case findDictOfType "/Pages" os of + Just dict -> case pagesKids dict of + Just kidsrefs -> BSL.concat $ map ((\f -> f objs) . linearize) kidsrefs + Nothing -> "" + Nothing -> case findDictOfType "/Page" os of + Just dict -> contentsStream dict initstate objs + Nothing -> "" + Nothing -> "" diff --git a/src/PDF/Cmap.hs b/src/PDF/Cmap.hs --- a/src/PDF/Cmap.hs +++ b/src/PDF/Cmap.hs @@ -23,12 +23,15 @@ import PDF.Definition parseCMap :: BSL.ByteString -> CMap -parseCMap str = case runParser (concat <$> manyTill cmapParser (try $ string "endcmap")) () "" str of +parseCMap str = case runParser (concat <$> + manyTill + (try bfchar <|> (concat <$> bfrange)) + (try $ string "endcmap")) () "" str of Left err -> error "Can not parse CMap" Right cmap -> cmap -cmapParser :: Parser CMap -cmapParser = do +bfchar :: Parser CMap +bfchar = do spaces manyTill anyChar (try $ string "beginbfchar") spaces @@ -38,6 +41,23 @@ spaces return ms where toCmap cid ucs = ((fst.head.readHex) cid, ((:[]).chr.fst.head.readHex) ucs) + +bfrange :: Parser [CMap] +bfrange = do + spaces + manyTill anyChar (try $ string "beginbfrange") + spaces + ms <- many1 (toCmap <$> (getRange <$> hexletters <*> hexletters) <*> hexletters) + spaces + string "endbfrange" + spaces + return ms + where + getRange cid cid' = [gethex cid .. gethex cid'] + toCmap range ucs = zip range (map ((:[]).chr) [gethex ucs ..]) + +gethex = fst.head.readHex + hexletters :: Parser String hexletters = do diff --git a/src/PDF/ContentStream.hs b/src/PDF/ContentStream.hs --- a/src/PDF/ContentStream.hs +++ b/src/PDF/ContentStream.hs @@ -7,7 +7,10 @@ ) where import Data.Char (chr) +import Data.String (fromString) +import Data.List (isPrefixOf) import Numeric (readOct, readHex) +import Data.Maybe (fromMaybe) import Data.Binary (decode) import Data.ByteString (ByteString) @@ -35,7 +38,7 @@ 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" + Left err -> error $ "Nothing to be parsed: " ++ (show err) Right str -> BSC.pack $ BS.unpack $ encodeUtf8 str deflate :: PSR -> PDFStream -> PDFStream @@ -84,15 +87,16 @@ , try graphicState , try pdfopcm , try $ T.empty <$ colorSpace + , try $ T.empty <$ renderingIntent , unknowns ] pdfopGraphics :: PSParser T.Text pdfopGraphics = do spaces - choice [ try $ T.empty <$ oneOf "qQ" <* space <* spaces - , try $ T.empty <$ oneOf "fFbBW" <* (many $ string "*") <* spaces - , try $ T.empty <$ oneOf "nsS" <* space <* spaces + choice [ try $ T.empty <$ oneOf "qQ" <* spaces + , try $ T.empty <$ oneOf "fFbBW" <* (many $ string "*") <* space <* spaces + , try $ T.empty <$ oneOf "nsS" <* 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) @@ -128,7 +132,14 @@ dashPattern = do char '[' >> many digit >> char ']' >> spaces >> many1 digit >> spaces >> string "d" return T.empty - + +renderingIntent :: PSParser T.Text +renderingIntent = do + ri <- choice [ try $ string "/" *> manyTill anyChar (try space) <* string "ri " <* spaces + , try $ string "/" *> manyTill anyChar (try space) <* string "Intent" <* spaces + ] + return $ T.pack ri + pathConstructor :: PSParser T.Text pathConstructor = do choice [ try $ T.empty <$ (digitParam <* spaces) <* oneOf "ml" <* spaces @@ -218,24 +229,22 @@ return $ T.concat lets adobeOneSix :: Int -> T.Text -adobeOneSix a = case Map.lookup a (adobeJapanOneSixMap) of +adobeOneSix a = case Map.lookup a adobeJapanOneSixMap of Just cs -> T.pack $ BSL.toString cs Nothing -> T.pack $ "[" ++ (show a) ++ "]" toUcs :: CMap -> Int -> T.Text -toUcs map h = case lookup h map of +toUcs m h = case lookup h m of Just ucs -> T.pack ucs Nothing -> adobeOneSix h hexletter :: PSParser T.Text hexletter = do st <- getState - let cmap = case lookup (curfont st) (cmaps st) of - Just m -> m - Nothing -> [] + let cmap = fromMaybe [] (lookup (curfont st) (cmaps st)) (hexToString cmap . readHex) <$> (count 4 $ oneOf "0123456789ABCDEFabcdef") - where hexToString map [] = "????" - hexToString map [(h,_)] = toUcs map h + where hexToString m [(h,"")] = toUcs m h + hexToString _ _ = "????" psletter :: PSParser T.Text psletter = do @@ -254,9 +263,15 @@ Nothing -> T.pack [c'] replaceWithCharDict s = case Map.lookup s pdfcharmap of Just cs -> cs - Nothing -> T.pack s - octToChar [] = '?' - octToChar [(o,_)] = chr o + Nothing -> if "/uni" `isPrefixOf` s + then readUni s + else T.pack s + readUni s = case readHex (drop 4 s) of + [(i,"")] -> T.singleton $ chr i + [(i,x)] -> T.pack (chr i : " ") + _ -> T.pack s + octToChar [(o,"")] = chr o + octToChar _ = '?' kern :: PSParser T.Text kern = do diff --git a/src/PDF/Definition.hs b/src/PDF/Definition.hs --- a/src/PDF/Definition.hs +++ b/src/PDF/Definition.hs @@ -37,6 +37,7 @@ dictentry e = error $ "Illegular dictionary entry "++show e toString depth (PdfText t) = t toString depth (PdfStream s) = "\n " ++ (BSL.unpack $ decompress s) +--toString depth (PdfStream s) = "\n " ++ (BSL.unpack $ s) toString depth (PdfNumber r) = show r toString depth (PdfHex h) = h toString depth (PdfArray a) = intercalate ", " $ map (toString depth) a diff --git a/src/PDF/Object.hs b/src/PDF/Object.hs --- a/src/PDF/Object.hs +++ b/src/PDF/Object.hs @@ -1,5 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-| +Module : PDF.Object +Description : Function to parse objects in a PDF file +Copyright : (c) Keiichiro Shikano, 2016 +License : MIT +Maintainer : k16.shikano@gmail.com + +Functions to parsea and show objects in a PDF file. +It provides a basic way to get information from a PDF file. +-} + module PDF.Object ( parseTrailer , findTrailer @@ -34,12 +45,13 @@ 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 Data.Text.Encoding (decodeUtf16BEWith) +import Data.Text.Encoding.Error (lenientDecode) import Numeric (readOct, readHex) import Data.ByteString.Builder (toLazyByteString, word16BE) -import Data.Attoparsec.ByteString hiding (inClass, notInClass, satisfy) -import Data.Attoparsec.ByteString.Char8 +import Data.Attoparsec.ByteString hiding (inClass, notInClass, satisfy, take) +import Data.Attoparsec.ByteString.Char8 hiding (take) import Data.Attoparsec.Combinator import Control.Applicative import Codec.Compression.Zlib (decompress) @@ -73,10 +85,11 @@ object <- manyTill anyChar (try $ string "endobj") spaces skipMany xref + skipMany startxref return $ (read objn, BS.pack object) parsePDFObj :: PDFBS -> PDFObj -parsePDFObj (n,pdfobject) = case parseOnly (spaces >> many1 (pdfobj <|> objother)) pdfobject of +parsePDFObj (n,pdfobject) = case parseOnly (spaces >> many1 (try pdfobj <|> try objother)) pdfobject of Left err -> (n,[PdfNull]) Right obj -> (n,obj) @@ -96,6 +109,15 @@ spaces return "" +startxref :: Parser String +startxref = do + spaces + string "startxref" + spaces + ref <- manyTill anyChar (try $ string "%%EOF") + spaces + return "" + stream :: Parser PDFStream stream = do string "stream" @@ -149,7 +171,7 @@ octToString [] = "????" octToString [(o,_)] = [chr o] -utf16be = T.unpack . decodeUtf16BE . BS.pack +utf16be = T.unpack . decodeUtf16BEWith lenientDecode . BS.pack pdfstream :: Parser Obj pdfstream = PdfStream <$> stream @@ -303,16 +325,27 @@ rawStreamByRef :: [PDFObj] -> Int -> BSL.ByteString rawStreamByRef objs x = case findObjsByRef x objs of Just objs -> rawStream objs - Nothing -> error "No stream to be shown" + Nothing -> error "No object with stream to be shown" rawStream :: [Obj] -> BSL.ByteString rawStream objs = case find isStream objs of - Just (PdfStream strm) -> decompress strm - Nothing -> error "No stream to be shown" + Just (PdfStream strm) -> streamFilter strm + Nothing -> error $ (show objs) ++ "\n No stream to be shown" where isStream (PdfStream s) = True isStream _ = False + streamFilter = case findDict objs of + Just d -> case find withFilter d of + Just (PdfName "/Filter", PdfName "/FlateDecode") + -> decompress + Just _ -> id -- need fix + Nothing -> id + Nothing -> id + withFilter (PdfName "/Filter", _) = True + withFilter _ = False + + parseRefsArray :: [Obj] -> [Int] parseRefsArray (ObjRef x:y) = (x:parseRefsArray y) parseRefsArray (x:y) = (parseRefsArray y) @@ -433,13 +466,13 @@ return $ BS.pack t xref :: Parser BS.ByteString xref = do - manyTill anyChar (try $ string "startxref") - offset <- spaces *> many1 digit + manyTill anyChar (try $ string "startxref" >> spaces >> lookAhead (oneOf "123456789")) + offset <- many1 digit return $ BS.drop (read offset :: Int) bs parseCRDict :: BS.ByteString -> Dict parseCRDict rlt = case parseOnly crdict rlt of - Left err -> error $ show rlt + Left err -> error $ show (BS.take 100 rlt) Right (PdfDict dict) -> dict Right other -> error "Could not find Cross-Reference dictionary" where crdict :: Parser Obj @@ -456,7 +489,7 @@ rootRefFromCRStream :: BS.ByteString -> Maybe Int rootRefFromCRStream bs = - let offset = (read . BS.unpack . head . drop 1 . reverse . BS.lines $ bs) :: Int + let offset = (read . BS.unpack . head . drop 1 . reverse . BS.lines $ (trace (show bs) bs)) :: Int crstrm = snd . head . getObjs $ BS.drop offset bs crdict = parseCRDict crstrm in getRefs isRootRef $ crdict @@ -508,4 +541,7 @@ in map (\(r,o) -> (r, parseDict $ BS.pack $ drop o objstr)) location where parseDict s' = case parseOnly pdfdictionary s' of Right obj -> [obj] - Left err -> error $ "Failed to parse obj " ++ (show s') ++ (show err) + Left _ -> case parseOnly pdfarray s' of + Right obj -> [obj] + Left err -> error $ (show err) ++ ":\n Failed to parse obj around; \n" + ++ (show $ BS.take 100 s') diff --git a/src/PDF/Outlines.hs b/src/PDF/Outlines.hs --- a/src/PDF/Outlines.hs +++ b/src/PDF/Outlines.hs @@ -1,5 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} +{-| +Module : PDF.Outlines +Description : Function to get /Outlines object +Copyright : (c) Keiichiro Shikano, 2016 +License : MIT +Maintainer : k16.shikano@gmail.com + +Function to grub /Outlines in PDF trailer. It mainly provides texts for Table of Contents. +-} + module PDF.Outlines ( getOutlines ) where diff --git a/src/PDF/PDFIO.hs b/src/PDF/PDFIO.hs --- a/src/PDF/PDFIO.hs +++ b/src/PDF/PDFIO.hs @@ -19,6 +19,8 @@ import PDF.Definition import PDF.Object +import Debug.Trace + import qualified Data.ByteString.Char8 as BS -- | Get PDF objects as a whole bytestring. Use 'getPDFObjFromFile' instead if there's no reason to see a raw bytestring.