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

======
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]
    }

    # 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 attr {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 attr $attrs]>$c</$type>"
        } else {
            set result "<$type [my attr $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 {}
        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 {}
        foreach n [$node attributes] {
            set n [lindex $n 0]
            if {[catch {lappend result $n [$node getAttribute $n]} e eo]} {
                puts stderr "attr error: $e ($eo)"
            }
        }
        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]
                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] {
                            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}} {
                                dict set m -$cname [lindex [my explore $child] 1]
                            } elseif {$cname in {script}} {
                                dict lappend m -$cname [lindex [my explore $child] 1]
                            } else {
                                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 -- $type {
            file -
            parse {
                # initialize container from file or text
                set text [lrange [my $type [lindex $args 0]] 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 1 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]} {
    # test - plug in an SVG constructor (e.g. file FILE.svg) and watch it work
    set svg [SVG new {*}$argv]
    puts [$svg toSVG]
}
======

<<categories>>Enter Category Here