# ddom.tcl 
#
# Different helper methods to make TclDOM API more user friendly


# dom::getText --
#   Returns the node contents if a text node or the contents of all the text
# children if it is an element. 
#
# Example: getText on <foo>bar</foo> would return "bar"

proc ::dom::getText { token } {
    switch [dom::node cget $token -nodeType]  {
	element {
	    set result {}
	    foreach child [dom::children $token] {
	         append result [dom::node cget $child -nodeValue]
	    }
	    return  $result
	} 
	textNode {
	    return [dom::node cget $token -nodeValue]
	} default {
	}
    }
}


# dom::getElements --
#   Returns a list with all children of type element of a given node

proc ::dom::getElements { token } {
    set result {}
    foreach child [dom::children $token] {
	if ![string compare [dom::node cget $child -nodeType] element] {
	    lappend result $child
	}
    }
    return $result
}

# dom::getTagName --
#   Helper function for getting the tag for a node of type element

proc ::dom::getTagName {token} {
    switch [dom::node cget $token -nodeType] {
	element {
	    return [dom::element cget $token -tagName ]
	} default {
	    return /textnode
	}
    }
}


# dom::rp --
#   Resolve path. Given a node and a path, return the node the path points to
# Path are constructed:
#   tagName<attr1="some value">/tagname2<5>  etc.
#
# Examples:
#   Given the following document
#
#  <puppets>
#    <puppet name="kermit"><color>green</color></puppet>
#    <puppet name="cookie monster"><color>blue</color></puppet>
#  </puppets>
#
# dom::rp $initialToken puppets/puppet<0>   
# will return the first <puppet> element (kermit)
# 
# dom::rp $initialToken puppets/puppet<name="kermit">
# will return the <puppet> element that has attribute name="kermit"(kermit)
#
# dom::rp $initialToken puppets/puppet<0>/color  
# will return the text node that contains the "green" text
#
# TO-DO: more robust error checking

proc ::dom::rp {token path} {
    set currentNode $token
    regsub -all {(//*([^/<]+(<[^>]*>)?))} $path { \2} spath
    foreach pathComponent $spath {
	set result {}
	set children [myGetElementsByTagName $currentNode \
		[getTagFromPath $pathComponent]] 
	set attrs [getAttrsFromPath $pathComponent]
	if  {[lindex $attrs 0] == "</idx>"} {
	    set result [lindex $children [lindex $attrs 1]]
	} else {
	    foreach ch $children {
		if {[matchesAttrs $ch $attrs]} {
		    lappend result  $ch
		}
	    }
	}
	switch [llength $result]  {
	    0 {
		error "No such element $pathComponent while resolving $path"
	    } 1 { 
	    	set currentNode $result
	    } 2 {
		error "Too many elements match $pathComponent in $path"
	    }
	}
    }
    return $currentNode
}

# dom::matchesAttrs --
#   Check that a certain node has ALL specified attributes

proc ::dom::matchesAttrs {node attrs} {
    array set attr $attrs
    foreach attribute [array names attr] {
	if {$attr($attribute) != [getAttribute $node $attribute]} {
	    return 0
	}
    }
    return 1
}


# dom::getTagFromPath --
#  Given a path, return the tagname
#
# Example
#   getAttrsFromPath foo<a="5",b="6">
# returns 
#   "foo"

proc ::dom::getTagFromPath {path} {
    regexp {([^<]+)} $path tag
    return $tag
}

# dom::getAttrsFromPath --
#  Given a path, return a list of attribute/value pairs
#
# Example
#   getAttrsFromPath foo<a="5",b="6">
# returns
#   {a 5 b 6}
#
# TO-DO : Does we handle correctly attribute values with spaces?

proc ::dom::getAttrsFromPath {path} {
    set attrs {}
    regexp {([^<]+)<([^>]*)>} $path whole tag attrs
    if [regexp {^[0-9]+$} $attrs idx ] {
	return [list </idx> $idx]
    }
    regsub -all {([^=]+)(=("[^"]*"))?,?} $attrs {\1 \3 } list 
    return $list 
}


proc dom::newDoc {{filename {}}} {
    if [llength $filename] {
        set f [open $filename]      
	set domDoc [dom::DOMImplementation parse [read $f]]
	close $f   
	return $domDoc
    } else {
        return [dom::DOMImplementation create]
    }
}          

proc dom::deleteDoc {node} {
    dom::DOMImplementation destroy $node     
}
 
# Rename procedures so they are easier to type and we do not have to 
# remember in which interface (node, element, document the node is defined)

foreach procedure { insertBefore  replaceChild  \
	removeChild appendChild hasChildNodes \
	clodeNode  children  parent 
} {
    proc dom::$procedure args "eval ::dom::node $procedure \$args"
}

foreach procedure { getElementsByTagName createElement createDocumentFragment \
	createTextNode createComment createCDATASection \
	createProcessingInstruction createAttribute createEntity  \
	createEntityReference  createDocTypeDecl cget configure} {
    proc dom::$procedure args "eval ::dom::document $procedure \$args"
}

foreach procedure { getAttribute setAttribute removeAttribute\
	getAttributeNode setAttributeNode removeAttributeNode \
        getElementsByTagName normalize 
} {
    proc dom::$procedure args "eval ::dom::element $procedure \$args"
}


proc dom::myGetElementsByTagName {node tagname} {
    # getElementsByTagName descends the tree :(
    set result {}
    foreach element [getElements $node] {
	if ![string compare [getTagName $element] $tagname] {
	    lappend result $element
	}
    }
    return $result
}