From 54526525bf2035b8517a8abf45def9c4aaa9444c Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Sun, 21 Jan 2018 00:25:03 -0500 Subject: Powerpoint writer tests: New test framework for pptx. Previously we had tested certain properties of the output PowerPoint slides. Corruption, though, comes as the result of a numebr of interrelated issues in the output pptx archive. This is a new approach, which compares the output of the Powerpoint writer with files that we know to (a) not be corrupt, and (b) to show the desired output behavior (details below). This commit introduces three tests using the new framework. More will follow. The test procedure: given a native file and a pptx file, we generate a pptx archive from the native file, and then test: 1. Whether the same files are in the two archives 2. Whether each of the contained xml files is the same. (We skip time entries in `docProps/core.xml`, since these are derived from IO. We just check to make sure that they're there in the same way in both files.) 3. Whether each of the media files is the same. Note that steps 2 and 3, though they compare multiple files, are one test each, since the number of files depends on the input file (if there is a failure, it will only report the first failed file comparison in the test failure). --- pandoc.cabal | 2 + test/Tests/Writers/Powerpoint.hs | 341 ++++++++++++++++-------------- test/pptx/inline_formatting.native | 5 + test/pptx/inline_formatting.pptx | Bin 0 -> 25582 bytes test/pptx/slide_breaks.native | 7 + test/pptx/slide_breaks.pptx | Bin 0 -> 28032 bytes test/pptx/slide_breaks_slide_level_1.pptx | Bin 0 -> 27202 bytes 7 files changed, 198 insertions(+), 157 deletions(-) create mode 100644 test/pptx/inline_formatting.native create mode 100644 test/pptx/inline_formatting.pptx create mode 100644 test/pptx/slide_breaks.native create mode 100644 test/pptx/slide_breaks.pptx create mode 100644 test/pptx/slide_breaks_slide_level_1.pptx diff --git a/pandoc.cabal b/pandoc.cabal index 0d81bcdf4..148a3a81c 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -302,6 +302,8 @@ extra-source-files: test/docx/*.native test/epub/*.epub test/epub/*.native + test/pptx/*.pptx + test/pptx/*.native test/txt2tags.t2t test/twiki-reader.twiki test/tikiwiki-reader.tikiwiki diff --git a/test/Tests/Writers/Powerpoint.hs b/test/Tests/Writers/Powerpoint.hs index e179742ed..139081013 100644 --- a/test/Tests/Writers/Powerpoint.hs +++ b/test/Tests/Writers/Powerpoint.hs @@ -1,169 +1,196 @@ +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} module Tests.Writers.Powerpoint (tests) where -import Control.Exception (throwIO) +-- 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 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 - 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 = - testCase name $ do - n' <- numberOfSlides opts pd - n' @=? n - -numSlideTests :: TestTree -numSlideTests = testGroup "Number of slides in output" - [ testNumberOfSlides - "simple one-slide deck" 1 - def - (doc $ para "foo") - , testNumberOfSlides - "with metadata (header slide)" 2 - def - (setTitle "My Title" $ doc $ para "foo") - , testNumberOfSlides - "With h1 slide (using default slide-level)" 1 - def - (doc $ header 1 "Header" <> para "foo") - , testNumberOfSlides - "With h2 slide (using default slide-level)" 2 - def - (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo") - , testNumberOfSlides - "With h1 slide (using slide-level 3)" 2 - def {writerSlideLevel= Just 3} - (doc $ header 1 "Header" <> para "foo") - , testNumberOfSlides - "With h2 slide (using slide-level 3)" 3 - def {writerSlideLevel= Just 3} - (doc $ header 1 "Header" <> header 2 "subeader" <> para "foo") - , testNumberOfSlides - "With image slide, no header" 3 - def - (doc $ - para "first slide" <> - para (image "lalune.jpg" "" "") <> - para "foo") - , testNumberOfSlides - "With image slide, header" 3 - def - (doc $ - para "first slide" <> - header 2 "image header" <> - para (image "lalune.jpg" "" "") <> - para "foo") - , testNumberOfSlides - "With table, no header" 3 - def - (doc $ - para "first slide" <> - simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]] <> - para "foo") - , testNumberOfSlides - "With table, header" 3 - def - (doc $ - para "first slide" <> - header 2 "table header" <> - simpleTable [para "foo" <> para "bar"] [[para "this" <> para "that"]] <> - para "foo") - , testNumberOfSlides - "hrule" 2 - def - (doc $ - para "first slide" <> horizontalRule <> para "last slide") - , testNumberOfSlides - "with notes slide" 2 - def - (doc $ - 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 - ] +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text.IO as T +import Data.List (isPrefixOf, isSuffixOf, sort, (\\), intercalate) +import Data.Maybe (fromJust, isNothing) +import Tests.Helpers +import Data.Algorithm.Diff +import Control.Monad (when) + + +getPptxBytes :: WriterOptions + -> FilePath + -> FilePath + -> IO (BL.ByteString, BL.ByteString) +getPptxBytes opts nativeFp pptxFp = do + ntvTxt <- T.readFile nativeFp + ntv <- runIOorExplode $ readNative def ntvTxt + myPptxBs <- runIOorExplode $ writePowerpoint opts ntv + goodPptxBs <- BL.readFile pptxFp + return (myPptxBs, goodPptxBs) + + +assertSameFileList :: Archive -> Archive -> FilePath -> Assertion +assertSameFileList myArch goodArch pptxFp = do + let filesMy = filesInArchive myArch + filesGood = filesInArchive goodArch + diffMyGood = filesMy \\ filesGood + diffGoodMy = filesGood \\ filesMy + if | null diffMyGood && null diffGoodMy -> return () + | null diffMyGood -> + assertFailure $ + "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++ + intercalate ", " diffGoodMy + | null diffGoodMy -> + assertFailure $ + "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++ + intercalate ", " diffMyGood + | otherwise -> + assertFailure $ + "Files in " ++ pptxFp ++ " but not in generated archive:\n" ++ + intercalate ", " diffGoodMy ++ + "\n" ++ + "Files in generated archive but not in " ++ pptxFp ++ ":\n" ++ + intercalate ", " diffMyGood + +compareXMLBool :: Content -> Content -> Bool +-- We make a special exception for times at the moment, and just pass +-- them because we can't control the utctime when running IO. Besides, +-- so long as we have two times, we're okay. +compareXMLBool (Elem myElem) (Elem goodElem) + | (QName "created" _ (Just "dcterms")) <- elName myElem + , (QName "created" _ (Just "dcterms")) <- elName goodElem = + True +compareXMLBool (Elem myElem) (Elem goodElem) + | (QName "modified" _ (Just "dcterms")) <- elName myElem + , (QName "modified" _ (Just "dcterms")) <- elName goodElem = + True +compareXMLBool (Elem myElem) (Elem goodElem) = + and [ elName myElem == elName goodElem + , elAttribs myElem == elAttribs goodElem + , and $ + map (uncurry compareXMLBool) $ + zip (elContent myElem) (elContent goodElem) + ] +compareXMLBool (Text myCData) (Text goodCData) = + and [ cdVerbatim myCData == cdVerbatim goodCData + , cdData myCData == cdData goodCData + , cdLine myCData == cdLine goodCData + ] +compareXMLBool (CRef myStr) (CRef goodStr) = + myStr == goodStr +compareXMLBool _ _ = False + +displayDiff :: Content -> Content -> String +displayDiff elemA elemB = + showDiff (1,1) $ getDiff (lines $ ppContent elemA) (lines $ ppContent elemB) + +compareXMLFile :: FilePath -> Archive -> Archive -> Assertion +compareXMLFile fp myArch goodArch = do + let mbMyEntry = findEntryByPath fp myArch + when (isNothing mbMyEntry) + (assertFailure $ + "Can't extract " ++ fp ++ " from generated archive") + let mbMyXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbMyEntry + when (isNothing mbMyXMLDoc) + (assertFailure $ + "Can't parse xml in " ++ fp ++ " from generated archive") + let myContent = Elem $ fromJust mbMyXMLDoc + + let mbGoodEntry = findEntryByPath fp goodArch + when (isNothing mbGoodEntry) + (assertFailure $ + "Can't extract " ++ fp ++ " from archive in stored pptx file") + let mbGoodXMLDoc = parseXMLDoc $ fromEntry $ fromJust mbGoodEntry + when (isNothing mbGoodXMLDoc) + (assertFailure $ + "Can't parse xml in " ++ fp ++ " from archive in stored pptx file") + let goodContent = Elem $ fromJust mbGoodXMLDoc + + assertBool + ("Non-matching xml in " ++ fp ++ ":\n" ++ displayDiff myContent goodContent) + (compareXMLBool myContent goodContent) + +compareBinaryFile :: FilePath -> Archive -> Archive -> Assertion +compareBinaryFile fp myArch goodArch = do + let mbMyEntry = findEntryByPath fp myArch + when (isNothing mbMyEntry) + (assertFailure $ + "Can't extract " ++ fp ++ " from generated archive") + let myBytes = fromEntry $ fromJust mbMyEntry + + let mbGoodEntry = findEntryByPath fp goodArch + when (isNothing mbGoodEntry) + (assertFailure $ + "Can't extract " ++ fp ++ " from archive in stored pptx file") + let goodBytes = fromEntry $ fromJust mbGoodEntry + + assertBool (fp ++ " doesn't match") (myBytes == goodBytes) + +testSameFileList :: WriterOptions -> FilePath -> FilePath -> TestTree +testSameFileList opts myFp goodFp = + testCase ("Identical file list in archives") $ do + (myBS, goodBS) <- getPptxBytes opts myFp goodFp + let myArch = toArchive myBS + goodArch = toArchive goodBS + (assertSameFileList myArch goodArch goodFp) + +testSameXML :: WriterOptions -> FilePath -> FilePath -> TestTree +testSameXML opts myFp goodFp = testCaseSteps "Comparing extracted xml files" $ + \step -> do + (myBS, goodBS) <- getPptxBytes opts myFp goodFp + let myArch = toArchive myBS + goodArch = toArchive goodBS + + let xmlFileList = sort $ + filter (\fp -> ".xml" `isSuffixOf` fp || ".rels" `isSuffixOf` fp) + (filesInArchive myArch) + mapM_ + (\fp -> step ("- " ++ fp) >> compareXMLFile fp myArch goodArch) + xmlFileList + +testSameMedia :: WriterOptions -> FilePath -> FilePath -> TestTree +testSameMedia opts myFp goodFp = testCaseSteps "Comparing media files" $ + \step -> do + (myBS, goodBS) <- getPptxBytes opts myFp goodFp + let myArch = toArchive myBS + goodArch = toArchive goodBS + + let mediaFileList = sort $ + filter (\fp -> "ppt/media/" `isPrefixOf` fp) + (filesInArchive myArch) + + mapM_ + (\fp -> step ("- " ++ fp) >> compareBinaryFile fp myArch goodArch) + mediaFileList + +testCompareWithOpts :: String -> WriterOptions ->FilePath -> FilePath -> TestTree +testCompareWithOpts testName opts nativeFp pptxFp = + testGroup testName [ testSameFileList opts nativeFp pptxFp + , testSameXML opts nativeFp pptxFp + , testSameMedia opts nativeFp pptxFp + ] + + +testCompare :: String -> FilePath -> FilePath -> TestTree +testCompare testName nativeFp pptxFp = + testCompareWithOpts testName def nativeFp pptxFp + +-------------------------------------------------------------- tests :: [TestTree] -tests = [ numSlideTests - , contentTypeTests +tests = [ testCompare + "Inline formatting" + "pptx/inline_formatting.native" + "pptx/inline_formatting.pptx" + , testCompare + "slide breaks (default slide-level)" + "pptx/slide_breaks.native" + "pptx/slide_breaks.pptx" + , testCompareWithOpts + "slide breaks (slide-level set to 1)" + def{writerSlideLevel=Just 1} + "pptx/slide_breaks.native" + "pptx/slide_breaks_slide_level_1.pptx" ] diff --git a/test/pptx/inline_formatting.native b/test/pptx/inline_formatting.native new file mode 100644 index 000000000..d79220e4f --- /dev/null +++ b/test/pptx/inline_formatting.native @@ -0,0 +1,5 @@ +Pandoc (Meta {unMeta = fromList []}) +[Para [Str "Here",Space,Str "are",Space,Str "examples",Space,Str "of",Space,Emph [Str "italics"],Str ",",Space,Strong [Str "bold"],Str ",",Space,Str "and",Space,Strong [Emph [Str "bold",Space,Str "italics"]],Str "."] +,Para [Str "Here",Space,Str "is",Space,Strikeout [Str "strook-three"],Space,Str "strike-through",Space,Str "and",Space,SmallCaps [Str "small",Space,Str "caps"],Str "."] +,Para [Str "We",Space,Str "can",Space,Str "also",Space,Str "do",Space,Str "subscripts",Space,Str "(H",Subscript [Str "2"],Str "0)",Space,Str "and",Space,Str "super",Superscript [Str "script"],Str "."] +,RawBlock (Format "html") ""] diff --git a/test/pptx/inline_formatting.pptx b/test/pptx/inline_formatting.pptx new file mode 100644 index 000000000..e128f1bce Binary files /dev/null and b/test/pptx/inline_formatting.pptx differ diff --git a/test/pptx/slide_breaks.native b/test/pptx/slide_breaks.native new file mode 100644 index 000000000..084c61737 --- /dev/null +++ b/test/pptx/slide_breaks.native @@ -0,0 +1,7 @@ +Pandoc (Meta {unMeta = fromList []}) +[Para [Str "Break",Space,Str "with",Space,Str "a",Space,Str "new",Space,Str "section-level",Space,Str "header"] +,Header 1 ("below-section-level",[],[]) [Str "Below",Space,Str "section-level"] +,Header 2 ("section-level",[],[]) [Str "Section-level"] +,Para [Str "Third",Space,Str "slide",Space,Str "(with",Space,Str "a",Space,Str "section-level",Space,Str "of",Space,Str "2)"] +,HorizontalRule +,Para [Str "This",Space,Str "is",Space,Str "another",Space,Str "slide."]] diff --git a/test/pptx/slide_breaks.pptx b/test/pptx/slide_breaks.pptx new file mode 100644 index 000000000..b22b0bc50 Binary files /dev/null and b/test/pptx/slide_breaks.pptx differ diff --git a/test/pptx/slide_breaks_slide_level_1.pptx b/test/pptx/slide_breaks_slide_level_1.pptx new file mode 100644 index 000000000..d4d7bc415 Binary files /dev/null and b/test/pptx/slide_breaks_slide_level_1.pptx differ -- cgit v1.2.3