@@ -0,0 +1,144 @@
1+{-# LANGUAGE TemplateHaskell, CPP #-}
2+{-
3+Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>
4+
5+This program is free software; you can redistribute it and/or modify
6+it under the terms of the GNU General Public License as published by
7+the Free Software Foundation; either version 2 of the License, or
8+(at your option) any later version.
9+
10+This program is distributed in the hope that it will be useful,
11+but WITHOUT ANY WARRANTY; without even the implied warranty of
12+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13+GNU General Public License for more details.
14+
15+You should have received a copy of the GNU General Public License
16+along with this program; if not, write to the Free Software
17+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18+-}
19+
20+{- |
21+ Module : Text.Pandoc.ODT
22+ Copyright : Copyright (C) 2006-7 John MacFarlane
23+ License : GNU GPL, version 2 or above
24+
25+ Maintainer : John MacFarlane <jgm@berkeley.edu>
26+ Stability : alpha
27+ Portability : portable
28+
29+Functions for producing an ODT file from OpenDocument XML.
30+-}
31+module Text.Pandoc.ODT ( saveOpenDocumentAsODT ) where
32+import Text.Pandoc.TH ( binaryContentsOf )
33+import Data.Maybe ( fromJust )
34+import Data.List ( partition, intersperse )
35+import System.Directory
36+import System.FilePath ( (</>), takeDirectory, takeFileName, splitDirectories )
37+import System.Process ( runProcess, waitForProcess )
38+import System.Exit
39+import Text.XML.Light
40+import Text.XML.Light.Cursor
41+import Text.Pandoc.Shared ( withTempDir )
42+import Network.URI ( isURI )
43+import qualified Data.ByteString as B ( writeFile, pack )
44+import Data.ByteString.Internal ( c2w )
45+import Prelude hiding ( writeFile, readFile )
46+import System.IO ( stderr )
47+#ifdef _UTF8STRING
48+import System.IO.UTF8
49+#else
50+import Text.Pandoc.UTF8
51+#endif
52+
53+-- | Produce an ODT file from OpenDocument XML.
54+saveOpenDocumentAsODT :: FilePath -- ^ Pathname of ODT file to be produced.
55+ -> FilePath -- ^ Relative directory of source file.
56+ -> String -- ^ OpenDocument XML contents.
57+ -> IO ()
58+saveOpenDocumentAsODT destinationODTPath sourceDirRelative xml = do
59+ let zipCmd = "zip"
60+ -- check for zip in path:
61+ zipPathMaybe <- findExecutable zipCmd
62+ let zipPath = case zipPathMaybe of
63+ Nothing -> error $ "The '" ++ zipCmd ++
64+ "' command, which is needed to build an ODT file, was not found.\n" ++
65+ "It can be obtained from http://www.info-zip.org/Zip.html\n" ++
66+ "Debian (and Debian-based) linux: apt-get install zip\n" ++
67+ "Windows: See http://gnuwin32.sourceforge.net/packages/zip.htm"
68+ Just x -> x
69+ withTempDir "pandoc-odt" $ \tempDir -> do
70+ let tempODT = tempDir </> "reference.odt"
71+ B.writeFile tempODT $ B.pack $ map c2w $(binaryContentsOf $ "odt-styles" </> "reference.odt")
72+ xml' <- handlePictures tempODT sourceDirRelative xml
73+ writeFile (tempDir </> "content.xml") xml'
74+ ph <- runProcess zipPath ["-9", "-q", "-r", tempODT, "content.xml", "Pictures"]
75+ (Just tempDir) Nothing Nothing Nothing (Just stderr)
76+ ec <- waitForProcess ph -- requires compilation with -threaded
77+ case ec of
78+ ExitSuccess -> copyFile tempODT destinationODTPath
79+ _ -> error "Error creating ODT." >> exitWith ec
80+
81+-- | Find <draw:image ... /> elements and copy the file (xlink:href attribute) into Pictures/ in
82+-- the zip file. If filename is a URL, attempt to download it. Modify xlink:href attributes
83+-- to point to the new locations in Pictures/. Return modified XML.
84+handlePictures :: FilePath -- ^ Path of ODT file in temp directory
85+ -> FilePath -- ^ Directory (relative) containing source file
86+ -> String -- ^ OpenDocument XML string
87+ -> IO String -- ^ Modified XML
88+handlePictures tempODT sourceDirRelative xml = do
89+ let parsed = case parseXMLDoc xml of
90+ Nothing -> error "Could not parse OpenDocument XML."
91+ Just x -> x
92+ let cursor = case (fromForest $ elContent parsed) of
93+ Nothing -> error "ODT appears empty"
94+ Just x -> x
95+ cursor' <- scanPictures tempODT sourceDirRelative cursor
96+ let modified = parsed { elContent = toForest $ root cursor' }
97+ return $ showTopElement modified
98+
99+scanPictures :: FilePath -> FilePath -> Cursor -> IO Cursor
100+scanPictures tempODT sourceDirRelative cursor = do
101+ cursor' <- handleTree tempODT sourceDirRelative cursor
102+ case right cursor' of
103+ Just n -> scanPictures tempODT sourceDirRelative n
104+ Nothing -> return cursor'
105+
106+handleTree :: FilePath -> FilePath -> Cursor -> IO Cursor
107+handleTree tempODT sourceDirRelative cursor = do
108+ case firstChild cursor of
109+ Nothing -> modifyContentM (handleContent tempODT sourceDirRelative) cursor
110+ Just n -> scanPictures tempODT sourceDirRelative n >>= return . fromJust . parent
111+
112+-- | If content is an image link, handle it appropriately.
113+-- Otherwise, handle children if any.
114+handleContent :: FilePath -> FilePath -> Content -> IO Content
115+handleContent tempODT sourceDirRelative content@(Elem el) = do
116+ if qName (elName el) == "image"
117+ then do
118+ let (hrefs, rest) = partition (\a -> qName (attrKey a) == "href") $ elAttribs el
119+ let href = case hrefs of
120+ [] -> error $ "No href found in " ++ show el
121+ [x] -> x
122+ _ -> error $ "Multiple hrefs found in " ++ show el
123+ if isURI $ attrVal href
124+ then return content
125+ else do -- treat as filename
126+ let oldLoc = sourceDirRelative </> attrVal href
127+ fileExists <- doesFileExist oldLoc
128+ if fileExists
129+ then do
130+ let pref = take 230 $ concat $ intersperse "_" $
131+ splitDirectories $ takeDirectory $ attrVal href
132+ let newLoc = "Pictures" </> pref ++ "_" ++ (takeFileName $ attrVal href)
133+ let tempDir = takeDirectory tempODT
134+ createDirectoryIfMissing False $ tempDir </> takeDirectory newLoc
135+ copyFile oldLoc $ tempDir </> newLoc
136+ let newAttrs = (href { attrVal = newLoc }) : rest
137+ return $ Elem (el { elAttribs = newAttrs })
138+ else do
139+ hPutStrLn stderr $ "Warning: Unable to find image at " ++ oldLoc ++ " - ignoring."
140+ return content
141+ else return content
142+
143+handleContent _ _ c = return c -- not Element
144+