2 files changed, 166 insertions, 1 deletions
diff --git a/Text/Pandoc/ODT.hs b/Text/Pandoc/ODT.hs
new file mode 100644
index 000000000..f388515fb
--- /dev/null
+++ b/Text/Pandoc/ODT.hs
@@ -0,0 +1,141 @@
+{-
+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 Data.Maybe ( fromJust )
+import Data.List ( partition, intersperse )
+import Prelude hiding ( writeFile, readFile )
+import System.IO.UTF8
+import System.IO ( stderr )
+import System.Directory
+import System.FilePath ( (</>), takeDirectory, takeFileName, splitDirectories )
+import System.Process ( runCommand, waitForProcess )
+import System.Exit
+import Text.XML.Light
+import Text.XML.Light.Cursor
+import Text.Pandoc.Shared ( withTempDir )
+import Network.URI ( isURI )
+import Paths_pandoc
+
+-- | 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:
+  maybeZipPath <- findExecutable zipCmd
+  let zipPath = case maybeZipPath of
+                     Just p  -> p
+                     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"
+  referenceODTPath <- getDataFileName "reference.odt"
+  withTempDir "pandoc-odt" $ \tempDir -> do
+    let tempODT = tempDir </> "reference.odt"
+    copyFile referenceODTPath tempODT
+    createDirectory $ tempDir </> "Pictures"
+    xml' <- handlePictures tempODT sourceDirRelative xml
+    writeFile (tempDir </> "content.xml") xml'
+    oldDir <- getCurrentDirectory
+    setCurrentDirectory tempDir
+    let zipCmdLine = zipPath ++ " -9 -q -r " ++ tempODT ++ " " ++ "content.xml Pictures"
+    ec <- runCommand zipCmdLine >>= waitForProcess   -- this requires compilation with -threaded
+    setCurrentDirectory oldDir
+    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' }
+  putStrLn $ showTopElement modified
+  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
+                   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 05289d6a6..3c202db0f 100644
--- a/Text/Pandoc/Shared.hs
+++ b/Text/Pandoc/Shared.hs
@@ -98,7 +98,9 @@ module Text.Pandoc.Shared (
                      -- * Writer options
                      HTMLMathMethod (..),
                      WriterOptions (..),
-                     defaultWriterOptions
+                     defaultWriterOptions,
+                     -- * File handling
+                     withTempDir
                     ) where
 
 import Text.Pandoc.Definition
@@ -110,6 +112,9 @@ import Data.Char ( toLower, toUpper, ord, isLower, isUpper )
 import Data.List ( find, isPrefixOf )
 import Control.Monad ( join )
 import Network.URI ( parseURI, URI (..), isAllowedInURI )
+import System.FilePath ( (</>), (<.>) )
+import System.IO.Error ( catch, ioError, isAlreadyExistsError )
+import System.Directory
 
 --
 -- List processing
@@ -900,3 +905,22 @@ defaultWriterOptions =
                 , writerReferenceLinks  = False
                 , writerWrapText        = True
                 }
+
+-- | 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
+
+-- | Create a temporary directory with a unique name.
+createTempDir :: Integer -> FilePath -> IO FilePath
+createTempDir num baseName = do
+  sysTempDir <- getTemporaryDirectory
+  let dirName = sysTempDir </> baseName <.> show num
+  catch (createDirectory dirName >> return dirName) $
+      \e -> if isAlreadyExistsError e
+               then createTempDir (num + 1) baseName
+               else ioError e
+