@@ -36,11 +36,11 @@ import Control.Monad.Except (throwError)
3636import Control.Monad.Reader
3737import Control.Monad.State
3838import Codec.Archive.Zip
39−import Data.List (intercalate, stripPrefix, isPrefixOf, nub)
39+import Data.List (intercalate, stripPrefix, nub, union)
4040import Data.Default
4141import Data.Time.Clock (UTCTime)
4242import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
43−import System.FilePath.Posix (splitDirectories, splitExtension)
43+import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension)
4444import Text.XML.Light
4545import qualified Text.XML.Light.Cursor as XMLC
4646import Text.Pandoc.Definition
@@ -61,6 +61,7 @@ import qualified Data.Map as M
6161import Data.Maybe (mapMaybe, listToMaybe, maybeToList, catMaybes)
6262import Text.Pandoc.ImageSize
6363import Control.Applicative ((<|>))
64+import System.FilePath.Glob
6465
6566import Text.TeXMath
6667import Text.Pandoc.Writers.Math (convertMath)
@@ -90,9 +91,13 @@ writePowerpoint opts (Pandoc meta blks) = do
9091 Just n -> n
9192 Nothing -> getSlideLevel blks'
9293 }
93− runP env def $ do pres <- blocksToPresentation blks'
94− archv <- presentationToArchive pres
95− return $ fromArchive archv
94+
95+ let st = def { stMediaGlobalIds = initialGlobalIds refArchive distArchive
96+ }
97+
98+ runP env st $ do pres <- blocksToPresentation blks'
99+ archv <- presentationToArchive pres
100+ return $ fromArchive archv
96101
97102concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
98103concatMapM f xs = liftM concat (mapM f xs)
@@ -149,6 +154,8 @@ data WriterState = WriterState { stLinkIds :: M.Map Int (M.Map Int (URL, String)
149154 , stNoteIds :: M.Map Int [Block]
150155 -- associate anchors with slide id
151156 , stAnchorMap :: M.Map String Int
157+ -- media inherited from the template.
158+ , stTemplateMedia :: [FilePath]
152159 } deriving (Show, Eq)
153160
154161instance Default WriterState where
@@ -157,8 +164,25 @@ instance Default WriterState where
157164 , stMediaGlobalIds = mempty
158165 , stNoteIds = mempty
159166 , stAnchorMap= mempty
167+ , stTemplateMedia = []
160168 }
161169
170+-- This populates the global ids map with images already in the
171+-- template, so the ids won't be used by images introduced by the
172+-- user.
173+initialGlobalIds :: Archive -> Archive -> M.Map FilePath Int
174+initialGlobalIds refArchive distArchive =
175+ let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
176+ mediaPaths = filter (match (compile "ppt/media/image")) archiveFiles
177+
178+ go :: FilePath -> Maybe (FilePath, Int)
179+ go fp = do
180+ s <- stripPrefix "ppt/media/image" $ fst $ splitExtension fp
181+ (n, _) <- listToMaybe $ reads s
182+ return (fp, n)
183+ in
184+ M.fromList $ mapMaybe go mediaPaths
185+
162186type P m = ReaderT WriterEnv (StateT WriterState m)
163187
164188runP :: Monad m => WriterEnv -> WriterState -> P m a -> m a
@@ -760,75 +784,111 @@ copyFileToArchive arch fp = do
760784 Nothing -> fail $ fp ++ " missing in reference file"
761785 Just e -> return $ addEntryToArchive e arch
762786
763−getMediaFiles :: PandocMonad m => P m [FilePath]
764−getMediaFiles = do
787+-- getMediaFiles :: PandocMonad m => P m [FilePath]
788+-- getMediaFiles = do
789+-- refArchive <- asks envRefArchive
790+-- distArchive <- asks envDistArchive
791+-- let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive
792+-- return $ filter (isPrefixOf "ppt/media") allEntries
793+
794+
795+-- copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive
796+-- copyFileToArchiveIfExists arch fp = do
797+-- refArchive <- asks envRefArchive
798+-- distArchive <- asks envDistArchive
799+-- case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
800+-- Nothing -> return $ arch
801+-- Just e -> return $ addEntryToArchive e arch
802+
803+inheritedPatterns :: [Pattern]
804+inheritedPatterns = map compile [ "_rels/.rels"
805+ , "docProps/app.xml"
806+ , "docProps/core.xml"
807+ , "ppt/slideLayouts/slideLayout*.xml"
808+ , "ppt/slideLayouts/_rels/slideLayout*.xml.rels"
809+ , "ppt/slideMasters/slideMaster1.xml"
810+ , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
811+ , "ppt/theme/theme1.xml"
812+ , "ppt/theme/_rels/theme1.xml.rels"
813+ , "ppt/presProps.xml"
814+ , "ppt/viewProps.xml"
815+ , "ppt/tableStyles.xml"
816+ , "ppt/media/image*"
817+ ]
818+
819+patternToFilePaths :: PandocMonad m => Pattern -> P m [FilePath]
820+patternToFilePaths pat = do
765821 refArchive <- asks envRefArchive
766822 distArchive <- asks envDistArchive
767− let allEntries = nub $ filesInArchive refArchive ++ filesInArchive distArchive
768− return $ filter (isPrefixOf "ppt/media") allEntries
769823
824+ let archiveFiles = filesInArchive refArchive `union` filesInArchive distArchive
825+ return $ filter (match pat) archiveFiles
826+
827+patternsToFilePaths :: PandocMonad m => [Pattern] -> P m [FilePath]
828+patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats
829+
830+-- requiredFiles :: [FilePath]
831+-- requiredFiles = inheritedFiles
832+
833+-- inheritedFiles :: [FilePath]
834+-- inheritedFiles = [ "_rels/.rels"
835+-- , "docProps/app.xml"
836+-- , "docProps/core.xml"
837+-- , "ppt/slideLayouts/slideLayout4.xml"
838+-- , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"
839+-- , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
840+-- , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"
841+-- , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
842+-- , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
843+-- , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"
844+-- , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"
845+-- , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"
846+-- , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"
847+-- , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
848+-- , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"
849+-- , "ppt/slideLayouts/slideLayout2.xml"
850+-- , "ppt/slideLayouts/slideLayout8.xml"
851+-- , "ppt/slideLayouts/slideLayout11.xml"
852+-- , "ppt/slideLayouts/slideLayout3.xml"
853+-- , "ppt/slideLayouts/slideLayout6.xml"
854+-- , "ppt/slideLayouts/slideLayout9.xml"
855+-- , "ppt/slideLayouts/slideLayout5.xml"
856+-- , "ppt/slideLayouts/slideLayout7.xml"
857+-- , "ppt/slideLayouts/slideLayout1.xml"
858+-- , "ppt/slideLayouts/slideLayout10.xml"
859+-- -- , "ppt/_rels/presentation.xml.rels"
860+-- , "ppt/theme/theme1.xml"
861+-- , "ppt/presProps.xml"
862+-- -- , "ppt/slides/_rels/slide1.xml.rels"
863+-- -- , "ppt/slides/_rels/slide2.xml.rels"
864+-- -- This is the one we're
865+-- -- going to build
866+-- -- , "ppt/slides/slide2.xml"
867+-- -- , "ppt/slides/slide1.xml"
868+-- , "ppt/viewProps.xml"
869+-- , "ppt/tableStyles.xml"
870+-- , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
871+-- , "ppt/slideMasters/slideMaster1.xml"
872+-- -- , "ppt/presentation.xml"
873+-- -- , "[Content_Types].xml"
874+-- ]
875+
876+-- -- Here are some that might not be there. We won't fail if they're not
877+-- possibleInheritedFiles :: [FilePath]
878+-- possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ]
770879
771−copyFileToArchiveIfExists :: PandocMonad m => Archive -> FilePath -> P m Archive
772−copyFileToArchiveIfExists arch fp = do
773− refArchive <- asks envRefArchive
774− distArchive <- asks envDistArchive
775− case findEntryByPath fp refArchive `mplus` findEntryByPath fp distArchive of
776− Nothing -> return $ arch
777− Just e -> return $ addEntryToArchive e arch
778−
779−inheritedFiles :: [FilePath]
780−inheritedFiles = [ "_rels/.rels"
781− , "docProps/app.xml"
782− , "docProps/core.xml"
783− , "ppt/slideLayouts/slideLayout4.xml"
784− , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"
785− , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
786− , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"
787− , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
788− , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
789− , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"
790− , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"
791− , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"
792− , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"
793− , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
794− , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"
795− , "ppt/slideLayouts/slideLayout2.xml"
796− , "ppt/slideLayouts/slideLayout8.xml"
797− , "ppt/slideLayouts/slideLayout11.xml"
798− , "ppt/slideLayouts/slideLayout3.xml"
799− , "ppt/slideLayouts/slideLayout6.xml"
800− , "ppt/slideLayouts/slideLayout9.xml"
801− , "ppt/slideLayouts/slideLayout5.xml"
802− , "ppt/slideLayouts/slideLayout7.xml"
803− , "ppt/slideLayouts/slideLayout1.xml"
804− , "ppt/slideLayouts/slideLayout10.xml"
805− -- , "ppt/_rels/presentation.xml.rels"
806− , "ppt/theme/theme1.xml"
807− , "ppt/presProps.xml"
808− -- , "ppt/slides/_rels/slide1.xml.rels"
809− -- , "ppt/slides/_rels/slide2.xml.rels"
810− -- This is the one we're
811− -- going to build
812− -- , "ppt/slides/slide2.xml"
813− -- , "ppt/slides/slide1.xml"
814− , "ppt/viewProps.xml"
815− , "ppt/tableStyles.xml"
816− , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
817− , "ppt/slideMasters/slideMaster1.xml"
818− -- , "ppt/presentation.xml"
819− -- , "[Content_Types].xml"
820− ]
821−
822−-- Here are some that might not be there. We won't fail if they're not
823−possibleInheritedFiles :: [FilePath]
824−possibleInheritedFiles = [ "ppt/theme/_rels/theme1.xml.rels" ]
825880
826881presentationToArchive :: PandocMonad m => Presentation -> P m Archive
827882presentationToArchive p@(Presentation _ slides) = do
828− newArch <- foldM copyFileToArchive emptyArchive inheritedFiles
829− mediaDir <- getMediaFiles
830− newArch' <- foldM copyFileToArchiveIfExists newArch $
831− possibleInheritedFiles ++ mediaDir
883+ filePaths <- patternsToFilePaths inheritedPatterns
884+ newArch' <- foldM copyFileToArchive emptyArchive filePaths
885+
886+ -- set the template media to the relevant fps:
887+
888+ -- we register any media fp in the filepaths
889+ -- mediaDir <- getMediaFiles
890+ -- newArch' <- foldM copyFileToArchiveIfExists newArch $
891+ -- possibleInheritedFiles ++ mediaDir
832892 -- presentation entry and rels. We have to do the rels first to make
833893 -- sure we know the correct offset for the rIds.
834894 presEntry <- presentationToPresEntry p
@@ -1808,6 +1868,17 @@ contentTypesToEntry ct = elemToEntry "[Content_Types].xml" $ contentTypesToEleme
18081868pathToOverride :: FilePath -> Maybe OverrideContentType
18091869pathToOverride fp = OverrideContentType ("/" ++ fp) <$> (getContentType fp)
18101870
1871+mediaFileContentType :: FilePath -> Maybe DefaultContentType
1872+mediaFileContentType fp = case takeExtension fp of
1873+ '.' : ext -> Just $
1874+ DefaultContentType { defContentTypesExt = ext
1875+ , defContentTypesType =
1876+ case getMimeType fp of
1877+ Just mt -> mt
1878+ Nothing -> "application/octet-stream"
1879+ }
1880+ _ -> Nothing
1881+
18111882mediaContentType :: MediaInfo -> Maybe DefaultContentType
18121883mediaContentType mInfo
18131884 | Just ('.' : ext) <- mInfoExt mInfo =
@@ -1822,11 +1893,16 @@ mediaContentType mInfo
18221893presentationToContentTypes :: PandocMonad m => Presentation -> P m ContentTypes
18231894presentationToContentTypes (Presentation _ slides) = do
18241895 mediaInfos <- (mconcat . M.elems) <$> gets stMediaIds
1896+ filePaths <- patternsToFilePaths inheritedPatterns
1897+ let mediaFps = filter (match (compile "ppt/media/image*")) filePaths
18251898 let defaults = [ DefaultContentType "xml" "application/xml"
18261899 , DefaultContentType "rels" "application/vnd.openxmlformats-package.relationships+xml"
18271900 ]
1828− mediaDefaults = nub $ mapMaybe mediaContentType mediaInfos
1829− inheritedOverrides = mapMaybe pathToOverride inheritedFiles
1901+ mediaDefaults = nub $
1902+ (mapMaybe mediaContentType $ mediaInfos) ++
1903+ (mapMaybe mediaFileContentType $ mediaFps)
1904+
1905+ inheritedOverrides = mapMaybe pathToOverride filePaths
18301906 presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"]
18311907 slideOverrides =
18321908 mapMaybe