diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,124 @@ +{- Copyright (C) 2009 John Millikin + + 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 3 of the License, or + 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, see . +-} + +module Main () where + +import Test.HUnit +import Text.XML.LibXML.SAX + +allTests = "allTests" ~: TestList [beginTests, endTests, textTests, otherTests, incrementalTests] +beginTests = "beginTests" ~: TestList [testBegin, testBeginNS, testBeginPrefix] +endTests = "endTests" ~: TestList [testEnd, testEndNS, testEndPrefix] +textTests = "textTests" ~: TestList [testText, testPredefinedEntity, testNumericEntity] +otherTests = "otherTests" ~: TestList [testProcessingInstruction, testComment, testCDATA, testError] +incrementalTests = "incrementalTests" ~: TestList [incrBegin, incrEnd, incrText] + +testBegin = TestCase $ do + parser <- mkParser + [event] <- parse parser "" False + BeginElement (QName "" "" "test") [] @=? event + +testBeginNS = TestCase $ do + parser <- mkParser + [event] <- parse parser "" False + BeginElement (QName "urn:test" "" "test") [] @=? event + +testBeginPrefix = TestCase $ do + parser <- mkParser + [event] <- parse parser "" False + BeginElement (QName "urn:test" "t" "test") [] @=? event + +testEnd = TestCase $ do + parser <- mkParser + [_, event] <- parse parser "" True + EndElement (QName "" "" "test") @=? event + +testEndNS = TestCase $ do + parser <- mkParser + [_, event] <- parse parser "" True + EndElement (QName "urn:test" "" "test") @=? event + +testEndPrefix = TestCase $ do + parser <- mkParser + [_, event] <- parse parser "" True + EndElement (QName "urn:test" "t" "test") @=? event + +testText = TestCase $ do + parser <- mkParser + [_, event, _] <- parse parser "text here" True + Characters "text here" @=? event + +testPredefinedEntity = TestCase $ do + parser <- mkParser + events <- parse parser "text & here" True + let events' = init . tail $ events + [Characters "text ", Characters "&", Characters " here"] @=? events' + +testNumericEntity = TestCase $ do + parser <- mkParser + events <- parse parser "text < here" True + let events' = init . tail $ events + [Characters "text ", Characters "<", Characters " here"] @=? events' + +testProcessingInstruction = TestCase $ do + parser <- mkParser + events <- parse parser "" True + ProcessingInstruction "instr" "version='1.0'" @=? head events + +testComment = TestCase $ do + parser <- mkParser + events <- parse parser "" True + Comment " comment here " @=? head events + +testCDATA = TestCase $ do + parser <- mkParser + events <- parse parser "]]>" True + let events' = init . tail $ events + [Characters ""] @=? events' + +testError = TestCase $ do + parser <- mkParser + events <- parse parser "" True + [ParseError "StartTag: invalid element name\n"] @=? events + +incrBegin = TestCase $ do + parser <- mkParser + let parse' = parse parser + + [] <- parse' "" False + BeginElement (QName "" "" "test") [] @=? event + +incrEnd = TestCase $ do + parser <- mkParser + let parse' = parse parser + + [_] <- parse' "" True + EndElement (QName "" "" "test") @=? event + +incrText = TestCase $ do + parser <- mkParser + let parse' = parse parser + + [_] <- parse' "text" False + [] <- parse' " more text" False + [event, _] <- parse' "" True + Characters "text more text" @=? event + +main = do + runTestTT allTests + diff --git a/Text/XML/LibXML/SAX.chs b/Text/XML/LibXML/SAX.chs --- a/Text/XML/LibXML/SAX.chs +++ b/Text/XML/LibXML/SAX.chs @@ -18,13 +18,13 @@ #include -module Text.XML.LibXML.SAX ( - Parser - ,Event(..) - ,Attribute(..) - ,QName(..) - ,mkParser - ,parse +module Text.XML.LibXML.SAX + ( Parser + , Event(..) + , Attribute(..) + , QName(..) + , mkParser + , parse ) where import Data.IORef (newIORef, readIORef, writeIORef, IORef) @@ -37,18 +37,26 @@ | EndElement QName | Characters String | Comment String - | ProcessingInstruction String String -- Target, Data + | ProcessingInstruction String String -- ^ Target, Data | ParseError String deriving (Show, Eq) -data Attribute = Attribute QName String +data Attribute = Attribute + { attributeName :: QName + , attributeValue :: String + } deriving (Show, Eq) --- Namespace, prefix, local name -data QName = QName String String String +data QName = QName + { qnameNamespace :: String + , qnamePrefix :: String + , qnameLocalName :: String + } deriving (Show, Eq) -data Parser = Parser (ForeignPtr Context) +-- | An opaque reference to a libXML SAX parser. +-- +newtype Parser = Parser (ForeignPtr Context) data Context = Context data SAXHandler = SAXHandler @@ -63,6 +71,8 @@ {#pointer *xmlSAXHandler as SAXHandlerPtr -> SAXHandler #} {#pointer *_xmlSAXHandler as SAXHandlerPtr nocode #} +-- | Construct a new, empty parser. +-- mkParser :: IO Parser mkParser = let n = nullPtr in do context <- {#call xmlCreatePushParserCtxt #} n n n 0 n @@ -72,6 +82,13 @@ foreign import ccall "libxml/parser.h &xmlFreeParserCtxt" xmlFreeParserCtxt :: FunPtr (Ptr Context -> IO ()) +-- | Feed some text into the parser. This may be performed multiple times +-- per 'Parser' value, in which case the internal parser state is retained +-- between computations. +-- +-- If the third parameter is 'True', the parser assumes that this is the +-- last input and checks that the document was closed correctly. +-- parse :: Parser -> String -> Bool -> IO [Event] parse (Parser fptr) s final = do withCStringLen s $ \(cs, cs_len) -> do @@ -83,7 +100,7 @@ rc <- {#call xmlParseChunk #} ctxt cs (fromIntegral cs_len) cFinal errors <- checkErrors rc ctxt events <- readIORef eventRef - return $ events ++ errors + return $ reverse events ++ errors withHandlers :: Ptr Context -> (IORef [Event] -> IO a) -> IO a withHandlers ctxt block = do @@ -177,7 +194,7 @@ es <- readIORef eventref c_attrs <- splitCAttributes n_attrs (castPtr raw_attrs) attrs <- mapM convertCAttribute c_attrs - writeIORef eventref (es ++ [BeginElement (QName ns pfx ln) attrs]) + writeIORef eventref ((BeginElement (QName ns pfx ln) attrs):es) onEndElement :: IORef [Event] -> EndElementNsSAX2Func onEndElement eventref _ cln cpfx cns = do @@ -185,26 +202,26 @@ pfx <- peekNullable $ castPtr cpfx ln <- peekCString $ castPtr cln es <- readIORef eventref - writeIORef eventref (es ++ [EndElement (QName ns pfx ln)]) + writeIORef eventref ((EndElement (QName ns pfx ln)):es) onCharacters :: IORef [Event] -> CharactersSAXFunc onCharacters eventref _ ctext ctextlen = do text <- peekCStringLen (castPtr ctext, fromIntegral ctextlen) es <- readIORef eventref - writeIORef eventref (es ++ [Characters text]) + writeIORef eventref ((Characters text):es) onComment :: IORef [Event] -> CommentSAXFunc onComment eventRef _ ctext = do text <- peekCString (castPtr ctext) es <- readIORef eventRef - writeIORef eventRef (es ++ [Comment text]) + writeIORef eventRef ((Comment text):es) onProcessingInstruction :: IORef [Event] -> ProcessingInstructionSAXFunc onProcessingInstruction eventRef _ ctarget cdata = do target <- peekCString (castPtr ctarget) data' <- peekCString (castPtr cdata) es <- readIORef eventRef - writeIORef eventRef (es ++ [ProcessingInstruction target data']) + writeIORef eventRef ((ProcessingInstruction target data'):es) foreign import ccall "wrapper" wrappedBegin :: StartElementNsSAX2Func -> IO (FunPtr StartElementNsSAX2Func) diff --git a/libxml-sax.cabal b/libxml-sax.cabal --- a/libxml-sax.cabal +++ b/libxml-sax.cabal @@ -1,15 +1,20 @@ Name: libxml-sax -Version: 0.2 +Version: 0.3 Stability: Alpha Synopsis: Bindings for the libXML2 SAX interface Description: Incrementally convert text to lists of XML events -License: GPL +License: GPL-3 License-file: License.txt Author: John Millikin maintainer: jmillikin@gmail.com +copyright: Copyright (c) John Millikin 2009-2010, + (c) Dmitry Astapov 2010 Build-Type: Simple -Cabal-Version: >=1.2 +Cabal-Version: >=1.4 Category: XML +homepage: http://ianen.org/haskell/bindings/libxml-sax/ +tested-with: GHC==6.10.4 +extra-source-files: Tests.hs Library Build-Depends: base >=3 && < 5