diff options
| -rw-r--r-- | pandoc.cabal | 3 | ||||
| -rw-r--r-- | test/Tests/Writers/Powerpoint.hs | 91 |
2 files changed, 79 insertions, 15 deletions
diff --git a/pandoc.cabal b/pandoc.cabal index dea141a8f..988241567 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -622,7 +622,8 @@ test-suite test-pandoc QuickCheck >= 2.4 && < 2.11, containers >= 0.4.2.1 && < 0.6, executable-path >= 0.0 && < 0.1, - zip-archive >= 0.2.3.4 && < 0.4 + zip-archive >= 0.2.3.4 && < 0.4, + xml >= 1.3.12 && < 1.4 if flag(old-locale) build-depends: old-locale >= 1 && < 1.1, time >= 1.2 && < 1.5 diff --git a/test/Tests/Writers/Powerpoint.hs b/test/Tests/Writers/Powerpoint.hs index 7c72f948e..39fd1bab5 100644 --- a/test/Tests/Writers/Powerpoint.hs +++ b/test/Tests/Writers/Powerpoint.hs @@ -5,27 +5,35 @@ module Tests.Writers.Powerpoint (tests) where import Control.Exception (throwIO) import Text.Pandoc import Text.Pandoc.Builder +import Text.Pandoc.Arbitrary () +import Text.Pandoc.Walk import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.QuickCheck import Codec.Archive.Zip -import Data.List (isPrefixOf, isSuffixOf) +import Text.XML.Light +import Data.List (isPrefixOf, isSuffixOf, sort) +import Data.Maybe (mapMaybe) + +getPptxArchive :: WriterOptions -> Pandoc -> IO Archive +getPptxArchive opts pd = do + mbs <- runIO $ + do setUserDataDir $ Just "../data" + writePowerpoint opts pd + case mbs of + Left e -> throwIO e + Right bs -> return $ toArchive bs ----- Number of Slides ----------- numberOfSlides :: WriterOptions -> Pandoc -> IO Int numberOfSlides opts pd = do - mbs <- runIO $ - do setUserDataDir $ Just "../data" - writePowerpoint opts pd - case mbs of - Left e -> throwIO e - Right bs -> do - let archive = toArchive bs - return $ - length $ - filter (isSuffixOf ".xml") $ - filter (isPrefixOf "ppt/slides/slide") $ - filesInArchive archive + archive <- getPptxArchive opts pd + return $ + length $ + filter (isSuffixOf ".xml") $ + filter (isPrefixOf "ppt/slides/slide") $ + filesInArchive archive testNumberOfSlides :: TestName -> Int -> WriterOptions -> Pandoc -> TestTree testNumberOfSlides name n opts pd = @@ -101,6 +109,61 @@ numSlideTests = testGroup "Number of slides in output" para $ text "Foo" <> note (para "note text")) ] +----- Content Types ----------- + + +contentTypesFileExists :: WriterOptions -> Pandoc -> TestTree +contentTypesFileExists opts pd = + testCase "Existence of [Content_Types].xml file" $ + do archive <- getPptxArchive opts pd + assertBool "Missing [Content_Types].xml file" $ + "[Content_Types].xml" `elem` (filesInArchive archive) + + + +-- We want an "Override" entry for each xml file under ppt/. +prop_ContentOverrides :: Pandoc -> IO Bool +prop_ContentOverrides pd = do + -- remove Math to avoid warnings + let go :: Inline -> Inline + go (Math _ _) = Str "Math" + go i = i + pd' = walk go pd + archive <- getPptxArchive def pd' + let xmlFiles = filter ("[Content_Types].xml" /=) $ + filter (isSuffixOf ".xml") $ + filesInArchive archive + contentTypes <- case findEntryByPath "[Content_Types].xml" archive of + Just ent -> return $ fromEntry ent + Nothing -> throwIO $ + PandocSomeError "Missing [Content_Types].xml file" + typesElem <- case parseXMLDoc contentTypes of + Just element -> return $ element + Nothing -> throwIO $ + PandocSomeError "[Content_Types].xml cannot be parsed" + let ns = findAttr (QName "xmlns" Nothing Nothing) typesElem + overrides = findChildren (QName "Override" ns Nothing) typesElem + partNames = mapMaybe (findAttr (QName "PartName" Nothing Nothing)) overrides + -- files in content_types are absolute + absXmlFiles = map (\fp -> case fp of + ('/':_) -> fp + _ -> '/': fp + ) + xmlFiles + return $ sort absXmlFiles == sort partNames + +contentOverridesTests :: TestTree +contentOverridesTests = localOption (QuickCheckTests 20) $ + testProperty "Content Overrides for each XML file" $ + \x -> ioProperty $ prop_ContentOverrides (x :: Pandoc) + +contentTypeTests :: TestTree +contentTypeTests = testGroup "[Content_Types].xml file" + [ contentTypesFileExists def (doc $ para "foo") + , contentOverridesTests + ] tests :: [TestTree] -tests = [numSlideTests] +tests = [ numSlideTests + , contentTypeTests + ] |