summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorfiddlosopher <fiddlosopher@788f1e2b-df1e-0410-8736-df70ead52e1b>2008-08-10 17:33:07 +0000
committerfiddlosopher <fiddlosopher@788f1e2b-df1e-0410-8736-df70ead52e1b>2008-08-10 17:33:07 +0000
commitf435d14f28e2323120f215996a979030e93f393d (patch)
tree81ab521f876d7283b4316de5a530fd0700cfea00
parent9d54611d874a9555a64bfeabd8e7c1da6611ebb2 (diff)
Use 'bracket' to improve withTempDir Text.Pandoc.Shared.
git-svn-id: https://pandoc.googlecode.com/svn/trunk@1393 788f1e2b-df1e-0410-8736-df70ead52e1b
-rw-r--r--Text/Pandoc/PDF.hs144
-rw-r--r--Text/Pandoc/Shared.hs7
2 files changed, 146 insertions, 5 deletions
diff --git a/Text/Pandoc/PDF.hs b/Text/Pandoc/PDF.hs
new file mode 100644
index 000000000..5b900bf03
--- /dev/null
+++ b/Text/Pandoc/PDF.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE TemplateHaskell, CPP #-}
+{-
+Copyright (C) 2008 John MacFarlane <jgm@berkeley.edu>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+-}
+
+{- |
+ Module : Text.Pandoc.ODT
+ Copyright : Copyright (C) 2006-7 John MacFarlane
+ License : GNU GPL, version 2 or above
+
+ Maintainer : John MacFarlane <jgm@berkeley.edu>
+ Stability : alpha
+ Portability : portable
+
+Functions for producing an ODT file from OpenDocument XML.
+-}
+module Text.Pandoc.ODT ( saveOpenDocumentAsODT ) where
+import Text.Pandoc.TH ( binaryContentsOf )
+import Data.Maybe ( fromJust )
+import Data.List ( partition, intersperse )
+import System.Directory
+import System.FilePath ( (</>), takeDirectory, takeFileName, splitDirectories )
+import System.Process ( runProcess, waitForProcess )
+import System.Exit
+import Text.XML.Light
+import Text.XML.Light.Cursor
+import Text.Pandoc.Shared ( withTempDir )
+import Network.URI ( isURI )
+import qualified Data.ByteString as B ( writeFile, pack )
+import Data.ByteString.Internal ( c2w )
+import Prelude hiding ( writeFile, readFile )
+import System.IO ( stderr )
+#ifdef _UTF8STRING
+import System.IO.UTF8
+#else
+import Text.Pandoc.UTF8
+#endif
+
+-- | Produce an ODT file from OpenDocument XML.
+saveOpenDocumentAsODT :: FilePath -- ^ Pathname of ODT file to be produced.
+ -> FilePath -- ^ Relative directory of source file.
+ -> String -- ^ OpenDocument XML contents.
+ -> IO ()
+saveOpenDocumentAsODT destinationODTPath sourceDirRelative xml = do
+ let zipCmd = "zip"
+ -- check for zip in path:
+ zipPathMaybe <- findExecutable zipCmd
+ let zipPath = case zipPathMaybe of
+ Nothing -> error $ "The '" ++ zipCmd ++
+ "' command, which is needed to build an ODT file, was not found.\n" ++
+ "It can be obtained from http://www.info-zip.org/Zip.html\n" ++
+ "Debian (and Debian-based) linux: apt-get install zip\n" ++
+ "Windows: See http://gnuwin32.sourceforge.net/packages/zip.htm"
+ Just x -> x
+ withTempDir "pandoc-odt" $ \tempDir -> do
+ let tempODT = tempDir </> "reference.odt"
+ B.writeFile tempODT $ B.pack $ map c2w $(binaryContentsOf $ "odt-styles" </> "reference.odt")
+ xml' <- handlePictures tempODT sourceDirRelative xml
+ writeFile (tempDir </> "content.xml") xml'
+ ph <- runProcess zipPath ["-9", "-q", "-r", tempODT, "content.xml", "Pictures"]
+ (Just tempDir) Nothing Nothing Nothing (Just stderr)
+ ec <- waitForProcess ph -- requires compilation with -threaded
+ case ec of
+ ExitSuccess -> copyFile tempODT destinationODTPath
+ _ -> error "Error creating ODT." >> exitWith ec
+
+-- | Find <draw:image ... /> elements and copy the file (xlink:href attribute) into Pictures/ in
+-- the zip file. If filename is a URL, attempt to download it. Modify xlink:href attributes
+-- to point to the new locations in Pictures/. Return modified XML.
+handlePictures :: FilePath -- ^ Path of ODT file in temp directory
+ -> FilePath -- ^ Directory (relative) containing source file
+ -> String -- ^ OpenDocument XML string
+ -> IO String -- ^ Modified XML
+handlePictures tempODT sourceDirRelative xml = do
+ let parsed = case parseXMLDoc xml of
+ Nothing -> error "Could not parse OpenDocument XML."
+ Just x -> x
+ let cursor = case (fromForest $ elContent parsed) of
+ Nothing -> error "ODT appears empty"
+ Just x -> x
+ cursor' <- scanPictures tempODT sourceDirRelative cursor
+ let modified = parsed { elContent = toForest $ root cursor' }
+ return $ showTopElement modified
+
+scanPictures :: FilePath -> FilePath -> Cursor -> IO Cursor
+scanPictures tempODT sourceDirRelative cursor = do
+ cursor' <- handleTree tempODT sourceDirRelative cursor
+ case right cursor' of
+ Just n -> scanPictures tempODT sourceDirRelative n
+ Nothing -> return cursor'
+
+handleTree :: FilePath -> FilePath -> Cursor -> IO Cursor
+handleTree tempODT sourceDirRelative cursor = do
+ case firstChild cursor of
+ Nothing -> modifyContentM (handleContent tempODT sourceDirRelative) cursor
+ Just n -> scanPictures tempODT sourceDirRelative n >>= return . fromJust . parent
+
+-- | If content is an image link, handle it appropriately.
+-- Otherwise, handle children if any.
+handleContent :: FilePath -> FilePath -> Content -> IO Content
+handleContent tempODT sourceDirRelative content@(Elem el) = do
+ if qName (elName el) == "image"
+ then do
+ let (hrefs, rest) = partition (\a -> qName (attrKey a) == "href") $ elAttribs el
+ let href = case hrefs of
+ [] -> error $ "No href found in " ++ show el
+ [x] -> x
+ _ -> error $ "Multiple hrefs found in " ++ show el
+ if isURI $ attrVal href
+ then return content
+ else do -- treat as filename
+ let oldLoc = sourceDirRelative </> attrVal href
+ fileExists <- doesFileExist oldLoc
+ if fileExists
+ then do
+ let pref = take 230 $ concat $ intersperse "_" $
+ splitDirectories $ takeDirectory $ attrVal href
+ let newLoc = "Pictures" </> pref ++ "_" ++ (takeFileName $ attrVal href)
+ let tempDir = takeDirectory tempODT
+ createDirectoryIfMissing False $ tempDir </> takeDirectory newLoc
+ copyFile oldLoc $ tempDir </> newLoc
+ let newAttrs = (href { attrVal = newLoc }) : rest
+ return $ Elem (el { elAttribs = newAttrs })
+ else do
+ hPutStrLn stderr $ "Warning: Unable to find image at " ++ oldLoc ++ " - ignoring."
+ return content
+ else return content
+
+handleContent _ _ c = return c -- not Element
+
diff --git a/Text/Pandoc/Shared.hs b/Text/Pandoc/Shared.hs
index 6f37f633b..d14a49d82 100644
--- a/Text/Pandoc/Shared.hs
+++ b/Text/Pandoc/Shared.hs
@@ -112,6 +112,7 @@ import Text.Pandoc.CharacterReferences ( characterReference )
import Data.Char ( toLower, toUpper, ord, isLower, isUpper )
import Data.List ( find, isPrefixOf )
import Control.Monad ( join )
+import Control.Exception ( bracket )
import Network.URI ( parseURI, URI (..), isAllowedInURI )
import System.FilePath ( (</>), (<.>) )
import System.IO.Error ( catch, ioError, isAlreadyExistsError )
@@ -925,11 +926,7 @@ defaultWriterOptions =
-- | Perform a function in a temporary directory and clean up.
withTempDir :: FilePath -> (FilePath -> IO a) -> IO a
-withTempDir baseName func = do
- tempDir <- createTempDir 0 baseName
- result <- catch (func tempDir) $ \e -> removeDirectoryRecursive tempDir >> ioError e
- removeDirectoryRecursive tempDir
- return result
+withTempDir baseName = bracket (createTempDir 0 baseName) (removeDirectoryRecursive)
-- | Create a temporary directory with a unique name.
createTempDir :: Integer -> FilePath -> IO FilePath