TclOO SVG class + tdom parser

package provide SVG 1.0

# Simple SVG elements
oo::class create SVGElement {
    variable type el metadata contents attrs svg

    # type of this element
    method type {} {
	return $type
    }

    # id of this element
    method id {args} {
	if {[llength $args]} {
	    dict set attrs id [lindex $args 0]
	}
	return [dict get $attrs id]
    }

    # access/modify attributes 
    method attr {args} {
	switch [llength $args] {
	    0 { return $attrs}
	    1 { return [dict get $attrs [lindex $arg 0]] }
	    2 { dict set attrs {*}$args }
	}
    }

    # find contained element by id (necessarily null)
    method byID {id} {
	return ""
    }

    # convert element into tcl identity constructor
    method tcl {args} {
	if {[llength $args]%2} {
	    set contents [lindex $args end]
	}
	foreach {n v} $args {
	    if {[string match -* $n]} {
		dict set metadata [string trimleft $n -] $v
	    } else {
		dict set attrs $n $v
	    }
	}

	set result {}
	dict for {n v} $metadata {
	    dict set result -$n $v
	}
	dict for {n v} $attrs {
	    dict set result $n $v
	}

	set result [list $type $result $contents]

	return $result
    }

    # format attrs into svg
    method attrs {args} {
	if {[llength $args] == 1} {
	    set args [lindex $args 0]
	}
	set a {}
	foreach {n v} $args {
	    lappend a $n='$v'
	}
	return [join $a]
    }

    # return contents of this element
    method contents {} {
	#puts "[self] $type contents: ($contents)"
	return $contents
    }

    # return components like <title> for this element
    method metaSVG {} {
	set c {}
	foreach md {desc title} {
	    if {[dict exists $metadata $md]} {
		lappend c "<$md>[dict get $metadata $md]</$md>"
	    }
	}
	foreach md {script} {
	    if {[dict exists $metadata $md]} {
		lappend c "<$md><!\[CDATA\[[join [dict get $metadata $md] \n]\]\]></$md>"
	    }
	}
	return [join $c \n]
    }

    # unconditionally convert element to SVG
    method ToSVG {} {
	append c [my metaSVG]
	append c [my contents]

	if {$c ne ""} {
	    set result "<$type [my attrs $attrs]>$c</$type>"
	} else {
	    set result "<$type [my attrs $attrs]/>"
	}

	return $result
    }

    # convert element to SVG or use cached version
    method toSVG {} {
	if {![info exists svg]} {
	    set svg [my ToSVG]
	}
	return $svg
    }

    destructor {next}

    constructor {t args} {
	set type $t
	set contents ""
	set metadata {}
	set attrs {}
	if {[llength $args]%2} {
	    set contents [lindex $args end]
	    set args [lrange $args 0 end-1]
	}

	foreach {n v} $args {
	    if {[string match -* $n]} {
		dict set metadata [string trimleft $n -] $v
	    } else {
		dict set attrs $n $v
	    }
	}

	# ensure every element has an id
	if {![dict exists $attrs id]} {
	    dict set attrs id ${type}_[incr [info object namespace [info object class [self]]]::_unique_id]
	}

	# allow -contents as a dict element
	if {[dict exists $metadata -contents]} {
	    set contents [dict get $metadata -contents]
	    dict unset metadata -contents
	}
    }
}

# SVG container elements - inherit from Simple elements
oo::class create SVGContainer {
    superclass SVGElement
    variable collection

    # add Graphic constructors to object
    foreach n {
	path text rect circle ellipse line polyline polygon image use
    } {
	method $n {args} [string map [list %NAME% $n] {
	    return [SVGElement new %NAME% {*}$args]
	}]
    }

    # add Container constructors to SVGContainer
    foreach n {
	svg g defs symbol clipPath mask pattern marker a switch
    } {
	method $n {args} [string map [list %NAME% $n] {
	    return [SVGContainer new %NAME% {*}$args]
	}]
    }

    # return collection dict - these are the contained objects
    method collection {args} {
	if {[llength $args]} {
	    set collection [dict merge $collection $args]
	}
	return $collection
    }

    # add an external object to collection
    method object {o} {
	dict set collection [$o id] $o
    }

    # find an object by ID within this collection
    method byID {id} {
	if {[dict exists $collection $id]} {
	    return [dict get $collection $id]
	} else {
	    dict for {n o} $collection {
		set found [$o byID $id]
		if {$found ne ""} {
		    return $found
		}
	    }
	}
    }

    # return contents (ie: collection) as svg
    method contents {} {
	set result {}
	if {![info exists collection]} {
	    # empty collection
	    return ""
	}
	dict for {n o} $collection {
	    set osvg [$o toSVG]
	    #puts stderr "[self] [my type] contains: $n -> $osvg"
	    lappend result $osvg
	}
	#puts stderr "[self] [my type] contents: $collection -> $result"
	return \n[join $result \n]\n
    }

    # add object to collection
    method add {args} {
	set result {}
	set new {}
	foreach {type v} $args {
	    #puts stderr "add: '$type' $v"
	    set o [my $type {*}$v]
	    set id [$o id]
	    dict set collection $id $o
	    lappend new $id $o
	}
	return $new
    }

    # delete named object from collection
    method del {args} {
	foreach {o} $args {
	    dict unset collection $o
	}
    }

    # convert Container to Tcl constructor
    method tcl {args} {
	if {[llength $args]%2} {
	    set collection [dict merge $collection [lindex $args end]]
	    set args [lrange $args 0 end-1]
	}

	set result [lrange [next {*}$args] 0 end-1]
	set c {}
	dict for {n o} $collection {
	    lappend c [$o tcl]
	}

	if {[llength $c]} {
	    lappend result $c
	}

	return $result
    }

    # construct an attr dict from XML
    method domattrs {node} {
	set result {}
	puts stderr "node attr: [$node attributes]"

	foreach n [$node attributes] {
	    # the list that [domNode attributes] returns
	    # is {prefix localname namespaceURI}
	    if {[llength $n] == 3} {
		lassign $n name ns uri
		if {$uri eq ""} continue
		set n $ns:$name
	    }
	    if {[catch {lappend result $n [$node getAttribute $n]} e eo]} {
		puts stderr "attr error: $e ($eo)"
	    }
	}
	#puts stderr "node domattrs -> $result"
	return $result
    }

    # traverse SVG tdom tree, generating Tcl SVG hierarchy
    method explore {node} {
	set type [$node nodeType]
	switch -- $type {
	    ELEMENT_NODE {
		set name [$node nodeName]
		lassign [split $name :] ns n
		if {$n eq ""} {
		    set name $ns
		} elseif {$ns eq "svg"} {
		    set name $n
		}
		
		set attributes [$node attributes]
		switch -- $name {
		    path - rect - circle -
		    ellipse - line - polyline - polygon -
		    image - use {
			#puts "$node is a Graphic $name $type ($attributes)"
			set result [list $name {*}[my domattrs $node]]
			set c {}
			foreach child [$node childNodes] {
			    catch {
				lappend c -[$child nodeName] [lindex [my explore $child] 1]
			    }
			}
			if {[llength $c]} {
			    lappend result $c
			}
			return $result
		    }

		    text - title - desc - script {
			set text [string trim [[$node firstChild] nodeValue]]
			#puts "$node is a $name $type ($text)"
			return [list $name {*}[my domattrs $node] $text]
		    }

		    g - defs - symbol - clipPath -
		    mask - pattern - marker - a - switch - svg {
			#puts "$node is a Container $name $type ($attributes)"
			set c {}
			set m {}
			foreach child [$node childNodes] {
			    set cname [$child nodeName]
			    if {$cname in {title desc}} {
				catch {
				    dict set m -$cname [lindex [my explore $child] 1]
				}
			    } elseif {$cname in {script}} {
				catch {
				    dict lappend m -$cname [lindex [my explore $child] 1]
				}
			    } else {
				catch {
				    lappend c [my explore $child]
				}
			    }
			}
			set result [list $name {*}$m {*}[my domattrs $node]]
			if {[llength $c]} {
			    lappend result $c
			}
			return $result
		    }

		    default {
			error "unknown node type $name ($attributes)"
		    }
		}
	    }
	    default {
		error "unknown element type $type"
	    }
	}
    }

    # parse an SVG text, generating a Tcl SVG object hierarchy
    method parse {XML} {
	package require tdom

	set doc  [dom parse $XML]
	set root [$doc documentElement]
	set result [my explore $root]
	#puts stderr "parse: ($result)"
	$doc delete
	return $result
    }

    # parse a file containing SVG text, generating a Tcl SVG object hierarchy
    method file {name} {
	package require fileutil
	return [my parse [::fileutil::cat $name]]
    }

    destructor {
	dict for {n o} $collection {
	    $o destroy	;# destroy the children of this hierarchy
	}
	next	;# finally, destroy self as element
    }

    constructor {type args} {
	#puts stderr "Container: $type $args - [llength $args]"
	set text {}
	set children {}
	switch -- [lindex $args 0] {
	    file -
	    parse {
		# initialize container from file or text
		set text [lrange [my [lindex $args 0] [lindex $args 1]] 1 end]
		if {[llength $text]%2} {
		    lappend children {*}[lindex $text end]
		    set text [lrange $text 0 end-1]
		}
		#puts stderr "[lindex $args 0]: $text"

		set args [lrange $args 2 end]
	    }
	}

	if {[llength $args]%2} {
	    lappend children {*}[lindex $args end]
	    set args [lrange $args 0 end-1]
	}

	next $type {*}$text {*}$args
	#puts "Children: $children"
	foreach v $children {
	    set v [lassign $v type]
	    #puts stderr "c add: '$type' $v"
	    set o [my $type {*}$v]
	    set id [$o id]
	    dict set collection $id $o
	}
    }
}

oo::class create SVG {
    superclass SVGContainer

    # convert SVG hierarchy to SVG
    method toSVG {} {
	append result "<?xml version='1.0' standalone='no'?>" \n
	append result "<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 20001102//EN' 'http://www.w3.org/TR/2000/CR-SVG-20001102/DTD/svg-20001102.dtd'>" \n
	append result [next] \n
	return $result
    }

    destructor {next}

    constructor {args} {
	next svg {*}$args
    }
}

if {[info exists argv0] && $argv0 eq [info script]} {
    if {[lindex $argv 0] eq "examples"} {
	foreach file [glob /usr/share/inkscape/examples/*.svg] {
	    puts $file
	    set svg [SVG new file $file]
	    puts [$svg toSVG]
	    $svg destroy
	}
	return
    }
    # test - plug in an SVG constructor (e.g. file FILE.svg) and watch it work
    set svg [SVG new {*}$argv]
    puts [$svg toSVG]
}