# Commands covered:  ::dom::DOMimplementation parse
#
# This file contains a collection of tests for one or more of the 
# TclDOM commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2008 Explain
# Copyright (c) 1998-2004 Zveno Pty Ltd.
#
# $Id: parse.test,v 1.10 2004/02/25 20:10:31 balls Exp $

package require tcltest
source [file join [tcltest::workingDirectory] tcldomutils.tcl]

testPackage dom

namespace eval ::dom::parseTest {
    namespace import -force ::tcltest::*

    testConstraint sa [file exists $::tcltest::testsDirectory/sa]

    proc readUtfOrUnicode {name} {
	set f [open $name r]
	fconfigure $f -encoding binary
	set prefix [read $f 2]
	seek $f 0 start
	if {[string equal $prefix \u00ff\u00fe]} {
	    fconfigure $f -encoding identity
	} else {
	    fconfigure $f -encoding utf-8
	}
	set xml [read $f]
	close $f
	return $xml
    }

    proc readBinary {name} {
	set f [open $name r]
	fconfigure $f -encoding binary
	set data [read $f]
	close $f
	return $data
    }

    proc makeUnicode {data} {
	return [encoding convertfrom identity [encoding convertto unicode $data]]
    }

    test parse-1.1 {single element document} -constraints {dom_c} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test></Test>}]
	checkTree $result {
	    {pi xml}
	    {pi DOCTYPE}
	    {element Test {} {}}
	}
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.1 {single element document} -constraints {dom_tcl} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test></Test>}]
	dom::trim $result
	checkTree $result {
	    {doctype Test {} {}}
	    {element Test {} {}}
	}
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.1 {single element document} -constraints {dom_libxml2} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test></Test>}]
	dom::trim $result
	checkTree $result {
	    {doctype Test {} {}}
	    {element Test {} {}}
	} 0
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.2 {nested element document} -constraints {dom_c} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested><Deeper></Deeper></Nested><Nested></Nested></Test>}]
	checkTree $result {
	    {pi xml}
	    {pi DOCTYPE}
	    {element Test {} {
		{element Nested {} {
		    {element Deeper {} {}}
		}}
		{element Nested {} {}}
	    }}
	}
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.2 {nested element document} -constraints {dom_tcl} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested><Deeper></Deeper></Nested><Nested></Nested></Test>}]
	dom::trim $result
	checkTree $result {
	    {doctype Test {} {}}
	    {element Test {} {
		{element Nested {} {
		    {element Deeper {} {}}
		}}
		{element Nested {} {}}
	    }}
	}
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.2 {nested element document} -constraints {dom_libxml2} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested><Deeper></Deeper></Nested><Nested></Nested></Test>}]
	dom::trim $result
	checkTree $result {
	    {doctype Test {} {}}
	    {element Test {} {
		{element Nested {} {
		    {element Deeper {} {}}
		}}
		{element Nested {} {}}
	    }}
	} 0
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.3 {elements with attributes} -constraints {dom_c} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested depth="1"><Nested depth="2"></Nested></Nested></Test>}]
	checkTree $result {
	    {pi xml}
	    {pi DOCTYPE}
	    {element Test {} {
		{element Nested {depth 1} {
		    {element Nested {depth 2} {}}
		}}
	    }}
	}
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.3 {elements with attributes} -constraints {dom_tcl} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested depth="1"><Nested depth="2"></Nested></Nested></Test>}]
	dom::trim $result
	checkTree $result {
	    {doctype Test {} {}}
	    {element Test {} {
		{element Nested {depth 1} {
		    {element Nested {depth 2} {}}
		}}
	    }}
	}
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.3 {elements with attributes} -constraints {dom_libxml2} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested depth="1"><Nested depth="2"></Nested></Nested></Test>}]
	dom::trim $result
	checkTree $result {
	    {doctype Test {} {}}
	    {element Test {} {
		{element Nested {depth 1} {
		    {element Nested {depth 2} {}}
		}}
	    }}
	} 0
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.4 {elements with text content} -constraints {dom_c} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested><Deeper>Inside Deeper</Deeper></Nested><Nested>Second Nested</Nested></Test>}]
	checkTree $result {
	    {pi xml}
	    {pi DOCTYPE}
	    {element Test {} {
		{element Nested {} {
		    {element Deeper {} {
			{text {Inside Deeper}}
		    }}
		}}
		{element Nested {} {
		    {text {Second Nested}}
		}}
	    }}
	}
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.4 {elements with text content} -constraints {dom_tcl} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested><Deeper>Inside Deeper</Deeper></Nested><Nested>Second Nested</Nested></Test>}]
	dom::trim $result
	checkTree $result {
	    {doctype Test {} {}}
	    {element Test {} {
		{element Nested {} {
		    {element Deeper {} {
			{text {Inside Deeper}}
		    }}
		}}
		{element Nested {} {
		    {text {Second Nested}}
		}}
	    }}
	}
    } -cleanup {
	dom::destroy $result
    } -result 1
    test parse-1.4 {elements with text content} -constraints {dom_libxml2} -body {
	set result [::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test><Nested><Deeper>Inside Deeper</Deeper></Nested><Nested>Second Nested</Nested></Test>}]
	dom::trim $result
	checkTree $result {
	    {doctype Test {} {}}
	    {element Test {} {
		{element Nested {} {
		    {element Deeper {} {
			{text {Inside Deeper}}
		    }}
		}}
		{element Nested {} {
		    {text {Second Nested}}
		}}
	    }}
	} 0
    } -cleanup {
	dom::destroy $result
    } -result 1

    test parse-1.5 {incremental parse} -constraints {!dom_libxml2} -setup {
	set part1 {<?xml version="1.0"?>}
	set part2 {<!DOCTYPE Test><Test></Test>}
    } -body {
	set result1 [catch {::dom::DOMImplementation parse $part1 -final 0} m1]
	set result2 [catch {::dom::DOMImplementation parse $part2 -final 1} m2]
	list $result1 $result2
    } -cleanup {
	::dom::DOMImplementation destroy $m2
    } -result {0 0}

    test parse-1.6 {incremental parse -- parsingComplete flag} -constraints {dom_c} -setup {
	set part1 {<?xml version="1.0"?><Test><A>abc</A><B>def</B>xyz}
	set part2 {</Test>}
    } -body {

	# parse xml that contains <A>...</A>
	set doc [::dom::DOMImplementation parse $part1 -final 0]
	set top [::dom::node cget $doc -firstChild]
	set child [::dom::node cget $top -firstChild]
	set textNode [::dom::node cget $child -lastChild]
	set value [::dom::node cget $child -nodeName]

	# get completion flags for first chunk of xml
	set flag1 [::dom::node cget $top -parsingComplete]
	set flag2 [::dom::node cget $child -parsingComplete]
	set flag3 [::dom::node cget $textNode -parsingComplete]

	# parse rest of xml -- close tag for top node
	::dom::DOMImplementation parse $part2 -final 1

	# get completion flags for completely parsed xml
	set flag4 [::dom::node cget $top -parsingComplete]
	set flag5 [::dom::node cget $child -parsingComplete]
	set flag6 [::dom::node cget $textNode -parsingComplete]

	list $flag1 $flag2 $flag3 $flag4 $flag5 $flag6
    } -cleanup {
	::dom::DOMImplementation destroy $doc
    } -result {0 1 1 1 1 1}

    test parse-2.1 {expat test suite; tests UTF-16 compliance} -constraints {sa} -body {
	set compositeResult 0
	foreach fname [glob $::tcltest::testsDirectory/sa/*.xml] {
	    set xml [readUtfOrUnicode $fname]
	    set result [catch {::dom::DOMImplementation parse $xml} doc]
	    if {$result == 0} {
		::dom::DOMImplementation destroy $doc
	    } else {
		if {$compositeResult == 0} {
		    set compositeResult ""
		}
		lappend compositeResult [file tail $fname]
	    }
	}
	set compositeResult 
    } -result 0

    test parse-2.2 {expat test suite with incrmental parsing} -constraints {sa} -body {
	set compositeResult 0
	foreach fname [glob $::tcltest::testsDirectory/sa/*.xml] {
	    set xml [readUtfOrUnicode $fname]
	    set xml1 [string range $xml 0 10]
	    set xml2 [string range $xml 11 end]
	    catch {::dom::DOMImplementation parse $xml1 -final 0}
	    set result [catch {::dom::DOMImplementation parse $xml2 -final 1} doc]
	    if {$result == 0} {
		::dom::DOMImplementation destroy $doc
	    } else {
		if {$compositeResult == 0} {
		    set compositeResult ""
		}
		lappend compositeResult [file tail $fname]
	    }
	}
	set compositeResult 
    } -result 0

    test parse-2.3 {expat test suite with incremental parsing errors} -constraints {sa} -body {
	set count 0
	set passCount 0
	foreach fname [glob $::tcltest::testsDirectory/sa/*.xml] {
	    set xml [readUtfOrUnicode $fname]
	    set xml1 [string range $xml 0 10]
	    set xml2 [string range $xml 11 end]
	    catch {::dom::DOMImplementation parse $xml1 -final 0}
	    # intentionally bad xml -- all parsing should fail
	    set result [catch {::dom::DOMImplementation parse $xml1 -final 1} doc]
	    if {$result == 0} {
		::dom::DOMImplementation destroy $doc
		incr passCount
	    } else {
		incr count
	    }
	}
	list $count $passCount	
    } -result {119 0}

    test parse-2.4 {incremental parsing errors -- error on first parse} -constraints {sa} -body {
	set count 0
	set passCount 0
	foreach fname [glob $::tcltest::testsDirectory/sa/*.xml] {
	    set xml [readUtfOrUnicode $fname]
	    set xml1 [string range $xml 0 10]
	    set xml2 [string range $xml 11 end]
	    set result [catch {::dom::DOMImplementation parse xx${xml1} -final 0}]
	    if {$result == 1} {
		incr count
		continue
	    }
	    # intentionally bad xml -- all parsing should fail
	    set result [catch {::dom::DOMImplementation parse $xml2 -final 1} doc]
	    if {$result == 0} {
		::dom::DOMImplementation destroy $doc
		incr passCount
	    } else {
		incr count
	    }
	}
	list $count $passCount	
    } -result {119 0}

    test parse-3.1 {parse error reporting} -match regexp -body {
	expectError {
	    ::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test>
<A>
<B>
Here is some text
</A>
</B>
</Test>}
	}
    } -result {(.*tag-name-mismatch.*)|(illegalendtag.*)}

    test parse-3.2 {parse error reporting; error at char pos 0} -match regexp -body {
	expectError {
	    ::dom::DOMImplementation parse {>?xml version="1.0"?>
<!DOCTYPE Test>
<Test>
<A>
<B>
Here is some text
</B>
</A>
</Test>}
	}
    } -result {(.*document-empty.*)|(unexpectedtext.*)}

    test parse-3.3 {parse error reporting -- error at last char} -match regexp -body {
	expectError {
    	    ::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test>
<A>
<B>
Here is some text
</B>
</A>
</Test<}
}
    } -result {(.*greater-than-character-required.*)|(unclosedelement.*)}

    test parse-3.4 {parse error reporting -- UNICODE source} -constraints {sa} -match glob -body {
	set fname $::tcltest::testsDirectory/sa/049.xml
	set xml [readBinary $fname]
	set part1 [string range $xml 0 9]
	set part2 [string range $xml 10 end]
	set badXML [encoding convertfrom identity $part1]
	if {$tcl_platform(byteOrder) == "littleEndian"} {
	    append badXML [makeUnicode "<Z>"]
	} else {
	    append badXML [makeUnicode "\u3c00\u5a00\u3e00"]
	}
	append badXML [encoding convertfrom identity $part2]
	expectError {
    	    ::dom::DOMImplementation parse $badXML
	}
    } -result {error "not well-formed*}

    test parse-3.5 {parse error reporting, UTF-16 source, error at first char} -constraints {sa} -body {
	set fname $::tcltest::testsDirectory/sa/049.xml
	set xml [readBinary $fname]
	set badXML [encoding convertfrom identity [string range $xml 0 1]]
	if {$tcl_platform(byteOrder) == "littleEndian"} {
	    append badXML [makeUnicode ">"]
	} else {
	    append badXML [makeUnicode "\u3e00"]
	}
	append badXML [encoding convertfrom identity [string range $xml 2 end]]
	expectError {
	    ::dom::DOMImplementation parse $badXML
	}
    } -result {error "syntax error" at line 1 character 1; at "><!DOCTY"}

    test parse-3.6 {parse error reporting, UTF-16 source, error at last char} -constraints {sa} -body {
	set fname $::tcltest::testsDirectory/sa/049.xml
	set xml [readBinary $fname]
	set badXML [encoding convertfrom identity [string range $xml 0 end-4]]
	if {$tcl_platform(byteOrder) == "littleEndian"} {
	    append badXML [makeUnicode "Z"]
	} else {
	    append badXML [makeUnicode "\u5a00"]
	}
	expectError {
	    ::dom::DOMImplementation parse $badXML
	}
    } -result {error "junk after document element" at line 7 character 12; at "Z" within "></doc>Z"}

    test parse-3.8 {parse error reporting, UTF-16 source, error is CR} -constraints {sa} -body {
	set fname $::tcltest::testsDirectory/sa/049.xml
	set xml [readBinary $fname]
	set badXML [encoding convertfrom identity [string range $xml 0 9]]
	set part2 [string range $xml 10 end]
	if {$tcl_platform(byteOrder) == "littleEndian"} {
	    append badXML [makeUnicode "\n"]
	} else {
	    append badXML [makeUnicode "\u0a00"]
	}
	append badXML [encoding convertfrom identity $part2]
	expectError {
	    ::dom::DOMImplementation parse $badXML
	}
    } -result {error "syntax error" at line 1 character 1; at "<!DO" within "<!DO
CTY"}

    test parse-3.9 {parse error reporting; UTF-8 source, error is CR} -match regexp -body {
	expectError {
	    ::dom::DOMImplementation parse {<?xml version="1.0"?>
<!DO
CTYPE Test>
<Test>
<A>
<B>
Here is some text
</B>
</A>
</Test>}
	}
    } -result {(.*NAME-required.*)|(unknowninstruction.*)}

    test parse-4.1 {white space trimming} -constraints {dom_c} -body {
	set part1 {<?xml version="1.0"?>
    <Test>
    <A>  abc  </A>
    <B>
    def
    </B>
    xyz}
    set part2 {
	</Test>}

	# parse xml that contains <A>...</A>
	set doc [::dom::DOMImplementation parse $part1 -final 0 -trim]
	# parse rest of xml -- close tag for top node
	::dom::DOMImplementation parse $part2 -final 1 -trim
	set result [::dom::DOMImplementation serialize $doc]
    } -cleanup {
	::dom::DOMImplementation destroy $doc
    } -result {<?xml version='1.0'?>
<!DOCTYPE Test>
<Test><A>  abc  </A><B>
    def
    </B>
    xyz
	</Test>}

    #
    # Test processing instruction parsing.
    #
    variable PIPARSE {
	set piparse_text "<test><?PITGT processing instruction data?></test>"
	set doc  [dom::DOMImplementation parse $piparse_text]
	dom::trim $doc
	set root [dom::document cget $doc -documentElement]
	set children [dom::node children $root]
	set pinode [lindex $children 0]
    }
    variable CLEANUP {
	dom::destroy $doc
    }

    test parse-5.0 {Processing instruction parsing} -setup $PIPARSE -body {
	dom::node cget $root -nodeName
    } -cleanup $CLEANUP -result {test}

    test parse-5.1 {PI present} -setup $PIPARSE -body {
	llength $children
    } -cleanup $CLEANUP -result 1

    test parse-5.2 {PI right type} -setup $PIPARSE -body {
	dom::node cget $pinode -nodeType
    } -cleanup $CLEANUP -result {processingInstruction}

    test parse-5.3 {PI node name} -setup $PIPARSE -body {
	dom::node cget $pinode -nodeName
    } -cleanup $CLEANUP -result {PITGT}

    test parse-5.4 {PI node value} -setup $PIPARSE -body {
	dom::node cget $pinode -nodeValue
    } -cleanup $CLEANUP -result {processing instruction data}

    test parse-5.5 {PI serialization} -setup $PIPARSE -constraints {!dom_libxml2} -body {
	dom::DOMImplementation serialize $root
    } -cleanup $CLEANUP -result $piparse_text

    variable SETUP6 {
	variable result {}
	proc estart {tag attrs args} {
	    variable result
	    lappend result [list $tag $attrs]
	}
	proc pcdata {text args} {
	    variable result
	    lappend result $text
	}
    }
    variable CLEANUP6 {
	dom::destroy $doc
	catch {unset result}
	rename estart {}
	rename pcdata {}
    }

    # TODO: pure-Tcl implementation should support this usage as well
    test parse-6.0 {SAX callbacks} -setup $SETUP6 -constraints {dom_libxml2} -body {
	set doc [dom::DOMImplementation parse {<Hello>World</Hello>} \
	    -elementstartcommand [namespace code estart] \
	    -characterdatacommand [namespace code pcdata]]
	set result
    } -cleanup $CLEANUP6 -result {{Hello {}} World}

    cleanupTests
}

namespace delete ::dom::parseTest

return