TclSVG -- an oo object hierarchy to parse, manipulate, and generate SVG.

Simple test:  call it as a tcl file, with the arguments: file somefile.svg ... it should produce a near-copy of its input.

Take 2: Decided to cleave more closely to tdom rather than use Tcl as an intermediate form for collections and attributes.  Resulted in cleaner, smaller code.  Old version is in history.


****A few notes for using this****
    * Ubuntu 9.xx users can install tdom by '''sudo apt-get install tdom'''.
    * At the time of this writing, you need to get the latest version of TclOO from http://tcl.cvs.sourceforge.net/viewvc/tcl/oocore/%|%CVS%|%.  The latest release package (0.6) currently lacks the the '''info object namespace''' subcommand.  
    * If you are compiling TclOO for Tcl 8.5, you need to copy the '''tclconfig''' subdirectory from the TclOO 0.6 release package.
-- Rob Shinn ([morgan_greywolf])

======
# SVG.tcl -- an oo hierarchy to parse, mutate and generate SVG

package require TclOO
package require tdom
package provide SVG 2.0

oo::class create ::SVG::element {
    variable node doc

    # turn tdom's attributes into something resembling sanity
    method Attr {n} {
        # 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
        }
        return $n
    }

    # get/set element attribute(s)
    method attr {args} {
        switch [llength $args] {
            0 {
                set result {}
                foreach n [$node attributes] {
                    set n [my Attr $n]
                    lappend result $n [$node getAttribute $n]
                }
                return $result
            }
            1 {
                return [$node getAttribute [lindex $args 0]]
            }
            default {
                if {[dict exists $args id]} {
                    if {[$node hasAttribute id]} {
                        if {[dict get $args id] ne [$node getAttribute id]} {
                            catch {$doc del_id2obj [$node getAttribute id]}
                        }
                    }
                    $doc id2obj [dict get $args id] [self]
                }
                $node setAttribute {*}$args
            }
        }
    }

    # descend element subtree applying script
    method descend {script {n ""}} {
        if {$n eq ""} {
            set $n $node
        }
        set r [::apply $script $n]
        set children [$n childNodes]
        if {[llength $children]} {
            foreach child $children {
                lappend result [my descend $script $n]
            }
            return [list $r $result]
        } else {
            return $r
        }
    }

    # type - this node's 'tag'
    method type {} {
        return [$node nodeName]
    }

    # nodeValue - as of Text nodes
    method value {args} {
        return [$node nodeValue {*}$args]
    }

    # parent of this element
    method parent {} {
        return [$doc node2obj [$node parentNode]]
    }

    # children of this element
    method children {} {
        set result {}
        foreach child [$node childNodes] {
            if {![catch {
                $doc node2obj $child
            } obj]} {
                lappend result $obj
            }
        }
        return $result
    }

    # element as XML
    method xml {{indent 4}} {
        return [$node asXML -indent $indent]
    }

    # element as a nested list
    method list {} {
        return [$node asList]
    }

    # add children to this node from their XML representations
    method add {args} {
        foreach obj $args {
            set child [$node appendXML [$obj xml]]
            lappend children [$doc explore $child]
        }
        return $children
    }

    # delete children from this node
    method del {args} {
        set children [my children]
        foreach obj $args {
            if {$obj in $chilren} {
                $obj destroy
            }
        }
    }

    destructor {
        foreach o [my children] {
            catch {$o destroy}        ;# if we have children, destroy them
        }
        catch {
            # remove interp-wide node->object mapping
            $doc del_node2obj $node
        }
        catch {
            # remove document-wide id->object mapping
            $doc del_id2obj [my attr id]
        }
    }

    constructor {n d} {
        set node $n        ;# we need to know our tdom node
        set doc $d        ;# we need to know our SVG document
    }
}

oo::class create ::SVG {
    variable doc id2obj

    # we maintain an interp-wide map of node->object.
    # elements themselves maintain their corresponding node
    method node2obj {node} {
        return [dict get [set [info object namespace [info object class [self]]]::node2obj] $node]
    }
    method del_node2obj {node} {
        dict unset [info object namespace [info object class [self]]]::node2obj $node
    }

    # we maintain a document-wide map of id->object.
    # id is just an attribute of elements
    # id is guaranteed unique within documents by means of this map.
    method id2obj {id obj} {
        dict set id2obj $id $obj
    }
    method del_id2obj {id} {
        dict unset id2obj $id
    }
    method by_id {id} {
        return [dict get $id2obj $id]
    }

    # traverse SVG tdom tree, generating Tcl SVG element object hierarchy
    method explore {node} {
        if {[$node nodeType] eq "ELEMENT_NODE"} {
            set obj [::SVG::element new $node [self]]
            dict set [info object namespace [info object class [self]]]::node2obj $node $obj

            if {![$node hasAttribute id]
                || [dict exists $id2obj [$node getAttribute id]]
            } {
                # no id or id collision - change id to something unique
                $obj attr id id[incr [info object namespace [info object class [self]]]::_unique_id]
            }

            foreach child [$node childNodes] {
                my explore $child
            }
            return $obj        ;# return element representation
        } else {
            return ""        ;# this has no element representation
        }
    }

    # generate XML form of document with appropriate verbiage
    method xml {{indent 4}} {
        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 $indent] \n
        return $result
    }

    superclass ::SVG::element        ;# the document is itself an element

    destructor {
        $doc del            ;# delete the tdom parsed doc
        next                ;# delete the corresponding doc element
    }

    constructor {args} {
        set id2obj {}        ;# map id->object

        if {[dict exists $args file]} {
            # create document from xml text in named file
            package require fileutil
            set xml [::fileutil::cat [dict get $args file]]
            set doc [dom parse $xml]
        } elseif {[dict exists $args xml]} {
            # create a document from xml text
            set doc [dom parse [dict get $args xml]]
        } else {
            # create an empty document
            set doc [dom createDocument svg]
        }

        # construct [self] as an element
        set root [$doc documentElement] 
        next [$doc documentElement] [self]
        my explore $root        ;# traverse tdom tree, creating svg elements
    }
}

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 xml]
            $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 xml]
}

======

<<categories>>Enter Category Here