# Features covered:  Attribute Lists
#
# This file contains a collection of tests for the TclXML parser.
# This file tests the parser's performance on Attribute Lists.
# Sourcing this file into Tcl runs the tests and generates output
# for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2002 Zveno Pty Ltd.
#
# $Id: attribute.test,v 1.10 2002/12/10 03:29:37 balls Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if { ![llength [info commands ::xml::parser]] } {
     catch {puts stderr "You havent loaded a valid parser class before running this test"}
     return
 }            

catch {unset result}
proc EStart {tagName attrList args} {
    global result countAttributesOnly

    if {![llength $attrList] && !$countAttributesOnly} {
	if {[info exists result($tagName)]} {
	    set count 0
	    while {[info exists result($tagName/[incr count])]} {}
	    set result($tagName/$count) {}
	} else {
	    set result($tagName) {}
	}
	return {}
    }

    foreach {name value} $attrList {
	if {[info exists result($tagName,$name)]} {
	    set count 0
	    while {[info exists result($tagName,$name,[incr count])]} {}
	    set result($tagName,$name,$count) $value
	} else {
	    set result($tagName,$name) $value
	}
    }
}
catch {unset ::pcdata}
proc pcdata t {
    append ::pcdata $t
}

proc EntRef args {
    if {[catch {incr ::entrefs}]} {
	set ::entrefs 1
    }
}

test attrList-1.1 {empty attribute list} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-1.1 {}}
    set parser [xml::parser attrList-1.1 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test></Test>
}
    array size result
} 0

test attrList-1.2 {single attribute} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-1.2 {}}
    set parser [xml::parser attrList-1.2 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr="1"></Test>
}

    array get result
} {Test,attr 1}

test attrList-1.3 {multiple distinct attributes} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-1.3 {}}
    set parser [xml::parser attrList-1.3 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test first="1" second='2'></Test>
}

    list [array size result] $result(Test,first) $result(Test,second)
} {2 1 2}

test attrList-1.4 {hyphen in attribute name} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-1.4 {}}
    set parser [xml::parser attrList-1.4 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test first-attr="1"></Test>
}

    array get result
} {Test,first-attr 1}

test attrList-2.1 {right angle bracket in attribute value} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-2.1 {}}
    set parser [xml::parser attrList-2.1 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr="value>"></Test>
}

    array get result
} {Test,attr value>}

test attrList-2.2 {right angle bracket in attribute value} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-2.2 {}}
    set parser [xml::parser attrList-2.2 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr="value1>value2"></Test>
}

    array get result
} {Test,attr value1>value2}

test attrList-2.3 {right angle bracket in attribute value} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-2.3 {}}
    set parser [xml::parser attrList-2.3 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr1="value1" attr2="value2>"></Test>
}

    array get result
} {Test,attr1 value1 Test,attr2 value2>}

test attrList-2.4 {right angle bracket in attribute value} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-2.4 {}}
    set parser [xml::parser attrList-2.4 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr2="value2>" attr1="value1"></Test>
}

    array get result
} {Test,attr1 value1 Test,attr2 value2>}

test attrList-2.5 {right angle brackets in attribute values} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-2.5 {}}
    set parser [xml::parser attrList-2.5 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr1="value>1" attr2="value>2"></Test>
}

    array get result
} {Test,attr1 value>1 Test,attr2 value>2}

test attrList-2.6 {right angle brackets in attribute values} {
    catch {unset ::result}
    catch {unset ::pcdata}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-2.6 {}}
    set parser [xml::parser attrList-2.6 \
	-elementstartcommand EStart \
	-characterdatacommand pcdata]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr1="value>1">some text</Test>
}

    list [array get result] $::pcdata
} {{Test,attr1 value>1} {some text}}

test attrList-3.1 {unnested left brace in attribute value} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-3.1 {}}
    set parser [xml::parser attrList-3.1 \
	-elementstartcommand EStart]
    $parser parse [format {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr="%svalue"></Test>
} \{]

    array get result
} [list Test,attr [format {%svalue} \{]]

test attrList-3.2 {unnested right brace in attribute value} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-3.2 {}}
    set parser [xml::parser attrList-3.2 \
	-elementstartcommand EStart]
    $parser parse [format {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr="value%s"></Test>
} \}]

    array get result
} [list Test,attr [format {value%s} \}]]

test attrList-3.3 {Tcl special characters in attribute value} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-3.3 {}}
    set parser [xml::parser attrList-3.3 \
	-elementstartcommand EStart]
    $parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr="dollar $ backslash \ brackets [puts hello]"></Test>
}

    array get result
} {Test,attr {dollar $ backslash \ brackets [puts hello]}}

test attrList-4.1 {Unquoted attribute value} {xml_tcl} {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-4.1 {}}
    set parser [xml::parser attrList-4.1 \
	-elementstartcommand EStart]
    set retval [catch {
	$parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr=noquotes></Test>
}} msg]

    list $retval $msg
} [list 1 {invalid attribute list around line 2}]
# Enable this when ported to tcltest 2 package
if {0} {
test attrList-4.1 {Unquoted attribute value} -constraints {xml_expat} -body {
    catch {unset ::result}
    set ::countAttributesOnly 1

    catch {rename xml::attrList-4.1 {}}
    set parser [xml::parser attrList-4.1 \
	-elementstartcommand EStart]
    set retval [catch {
	$parser parse {<?xml version="1.0"?>
<!DOCTYPE Test>
<Test attr=noquotes></Test>
}} msg]

    list $retval $msg
} -result [list 1 {error "not well-formed" at line 3 character 11}]
}

# Test case contributed by David Sutton <dsutton@coactive.com>
test attrList-5.0 {Complicated attribute list} {
    catch {unset ::result}
    catch {unset ::pcdata}
    set ::countAttributesOnly 0

    catch {rename xml::attrList-5.0 {}}
    set parser [xml::parser attrList-5.0 \
	-elementstartcommand EStart \
	-characterdatacommand pcdata]
    set retval [catch {
	$parser parse {<?xml version="1.0"?>
<event name='LogAlarmReset' ID='22' startDisabled='no' deleteOnCompletion='no' startDateTime='' endDateTime=''>
  <stateChangeTrigger initialState='true' condition='AlarmSwitch = FALSE'/>
  <eventAction>LightState = LightCtl</eventAction>
  <eventAction>LOG(AlarmSwitch)</eventAction>
  <eventAction>DISABLE(BlinkLight)</eventAction>
  <eventAction>NOTIFY( AlarmSwitch,"Alarm has been reset")</eventAction>
</event>
}} msg]

    regsub -all "\[ \t\n\]+" $::pcdata { } ::pcdata
    set sortedResult {}
    foreach key [lsort -dictionary [array names ::result]] {
	lappend sortedResult $key $::result($key)
    }
    list $retval $sortedResult $::pcdata
} [list 0 {event,deleteOnCompletion no event,endDateTime {} event,ID 22 event,name LogAlarmReset event,startDateTime {} event,startDisabled no eventAction {} eventAction/1 {} eventAction/2 {} eventAction/3 {} stateChangeTrigger,condition {AlarmSwitch = FALSE} stateChangeTrigger,initialState true} { LightState = LightCtl LOG(AlarmSwitch) DISABLE(BlinkLight) NOTIFY( AlarmSwitch,"Alarm has been reset") }]

# Test case contributed by Marshall Rose <mrose@dbc.mtview.ca.us>
test attrList-5.1 {Attribute list with quoted value} {
    catch {unset ::result}
    set ::countAttributesOnly 0

    catch {rename xml::attrList-5.1 {}}
    set parser [xml::parser attrList-5.1 \
	-elementstartcommand EStart]
    set retval [catch {
	$parser parse {<test example="isn&apos;t this legal?"/>}
    }]

    list $retval [array get ::result]
} {0 {test,example {isn't this legal?}}}

test attrList-5.2 {Attribute list with unresolved entity reference} {
    catch {unset ::result}
    set ::countAttributesOnly 0

    catch {rename xml::attrList-5.2 {}}
    set parser [xml::parser attrList-5.2 \
	-elementstartcommand EStart]
    set retval [catch {
	$parser parse {
<test example='isn&apos;t this legal&ques;'/>
}
    }]

    set retval
} 1

test attrList-5.3 {Attribute list with unresolved entity reference and entity callback} {
    catch {unset ::result}
    set ::countAttributesOnly 0
    set ::entrefs 0

    catch {rename xml::attrList-5.3 {}}
    set parser [xml::parser attrList-5.3 \
	-elementstartcommand EStart \
	-entityreferencecommand EntRef]
    set retval [catch {
	$parser parse {
<test example='isn&apos;t this great&quot;'/>
}
    } retmsg]

    list $retval $entrefs
} {0 0}

test attrList-5.4 {Attribute list with entity reference} {
    catch {unset ::result}
    set ::countAttributesOnly 0

    catch {rename xml::attrList-5.4 {}}
    set parser [xml::parser attrList-5.4 \
	-elementstartcommand EStart]
    set retval [catch {
	$parser parse {<!DOCTYPE test [
<!ENTITY ques "?">
]>
<test example='isn&apos;t this great&ques;'/>
}
    }]

    list $retval [array get result]
} {0 {test,example {isn't this great?}}}

test attrList-5.5 {Attribute list with nested entity references} {
    catch {unset ::result}
    set ::countAttributesOnly 0

    catch {rename xml::attrList-5.5 {}}
    set parser [xml::parser attrList-5.5 \
	-elementstartcommand EStart]
    set retval [catch {
	$parser parse {<!DOCTYPE test [
<!ENTITY rules "rules, &level2;?">
<!ENTITY level2 "OK">
]>
<test example='XML &rules;'/>
}
    }]

    list $retval [array get result]
} {0 {test,example {XML rules, OK?}}}

# Test case contributed by Joe English, bug #546295
test attrList-5.6 {Attribute list with character entity references} {
    catch {unset ::result}
    set ::countAttributesOnly 0

    catch {rename xml::attrList-5.6 {}}
    set parser [xml::parser attrList-5.6 \
	-elementstartcommand EStart]
    set retval [catch {
	$parser parse {
<foo bar="abc&#xA;def"/>
}
    }]

    list $retval [array get result]
} {0 {foo,bar {abc
def}}}

# Test case contributed by Laurent Duperval, bug #620034
test attrList-5.7 {Attribute with right angle bracket} {
    catch {unset ::result}
    set ::countAttributesOnly 0

    catch {rename xml::attrList-5.7 {}}
    set parser [xml::parser attrList-5.7 \
	-elementstartcommand EStart]
    set retval [catch {
	$parser parse {
<foo><bar att=">=foo"/></foo>
}
    }]

    list $retval [array get result]
} {0 {foo {} bar,att >=foo}}

# cleanup
::tcltest::cleanupTests
return