Posted to tcl by colin at Fri Aug 05 02:27:43 GMT 2011view raw
- 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]
- }