Posted to tcl by colin at Fri Aug 05 02:27:43 GMT 2011view raw

  1. package provide SVG 1.0
  2.  
  3. # Simple SVG elements
  4. oo::class create SVGElement {
  5. variable type el metadata contents attrs svg
  6.  
  7. # type of this element
  8. method type {} {
  9. return $type
  10. }
  11.  
  12. # id of this element
  13. method id {args} {
  14. if {[llength $args]} {
  15. dict set attrs id [lindex $args 0]
  16. }
  17. return [dict get $attrs id]
  18. }
  19.  
  20. # access/modify attributes
  21. method attr {args} {
  22. switch [llength $args] {
  23. 0 { return $attrs}
  24. 1 { return [dict get $attrs [lindex $arg 0]] }
  25. 2 { dict set attrs {*}$args }
  26. }
  27. }
  28.  
  29. # find contained element by id (necessarily null)
  30. method byID {id} {
  31. return ""
  32. }
  33.  
  34. # convert element into tcl identity constructor
  35. method tcl {args} {
  36. if {[llength $args]%2} {
  37. set contents [lindex $args end]
  38. }
  39. foreach {n v} $args {
  40. if {[string match -* $n]} {
  41. dict set metadata [string trimleft $n -] $v
  42. } else {
  43. dict set attrs $n $v
  44. }
  45. }
  46.  
  47. set result {}
  48. dict for {n v} $metadata {
  49. dict set result -$n $v
  50. }
  51. dict for {n v} $attrs {
  52. dict set result $n $v
  53. }
  54.  
  55. set result [list $type $result $contents]
  56.  
  57. return $result
  58. }
  59.  
  60. # format attrs into svg
  61. method attrs {args} {
  62. if {[llength $args] == 1} {
  63. set args [lindex $args 0]
  64. }
  65. set a {}
  66. foreach {n v} $args {
  67. lappend a $n='$v'
  68. }
  69. return [join $a]
  70. }
  71.  
  72. # return contents of this element
  73. method contents {} {
  74. #puts "[self] $type contents: ($contents)"
  75. return $contents
  76. }
  77.  
  78. # return components like <title> for this element
  79. method metaSVG {} {
  80. set c {}
  81. foreach md {desc title} {
  82. if {[dict exists $metadata $md]} {
  83. lappend c "<$md>[dict get $metadata $md]</$md>"
  84. }
  85. }
  86. foreach md {script} {
  87. if {[dict exists $metadata $md]} {
  88. lappend c "<$md><!\[CDATA\[[join [dict get $metadata $md] \n]\]\]></$md>"
  89. }
  90. }
  91. return [join $c \n]
  92. }
  93.  
  94. # unconditionally convert element to SVG
  95. method ToSVG {} {
  96. append c [my metaSVG]
  97. append c [my contents]
  98.  
  99. if {$c ne ""} {
  100. set result "<$type [my attrs $attrs]>$c</$type>"
  101. } else {
  102. set result "<$type [my attrs $attrs]/>"
  103. }
  104.  
  105. return $result
  106. }
  107.  
  108. # convert element to SVG or use cached version
  109. method toSVG {} {
  110. if {![info exists svg]} {
  111. set svg [my ToSVG]
  112. }
  113. return $svg
  114. }
  115.  
  116. destructor {next}
  117.  
  118. constructor {t args} {
  119. set type $t
  120. set contents ""
  121. set metadata {}
  122. set attrs {}
  123. if {[llength $args]%2} {
  124. set contents [lindex $args end]
  125. set args [lrange $args 0 end-1]
  126. }
  127.  
  128. foreach {n v} $args {
  129. if {[string match -* $n]} {
  130. dict set metadata [string trimleft $n -] $v
  131. } else {
  132. dict set attrs $n $v
  133. }
  134. }
  135.  
  136. # ensure every element has an id
  137. if {![dict exists $attrs id]} {
  138. dict set attrs id ${type}_[incr [info object namespace [info object class [self]]]::_unique_id]
  139. }
  140.  
  141. # allow -contents as a dict element
  142. if {[dict exists $metadata -contents]} {
  143. set contents [dict get $metadata -contents]
  144. dict unset metadata -contents
  145. }
  146. }
  147. }
  148.  
  149. # SVG container elements - inherit from Simple elements
  150. oo::class create SVGContainer {
  151. superclass SVGElement
  152. variable collection
  153.  
  154. # add Graphic constructors to object
  155. foreach n {
  156. path text rect circle ellipse line polyline polygon image use
  157. } {
  158. method $n {args} [string map [list %NAME% $n] {
  159. return [SVGElement new %NAME% {*}$args]
  160. }]
  161. }
  162.  
  163. # add Container constructors to SVGContainer
  164. foreach n {
  165. svg g defs symbol clipPath mask pattern marker a switch
  166. } {
  167. method $n {args} [string map [list %NAME% $n] {
  168. return [SVGContainer new %NAME% {*}$args]
  169. }]
  170. }
  171.  
  172. # return collection dict - these are the contained objects
  173. method collection {args} {
  174. if {[llength $args]} {
  175. set collection [dict merge $collection $args]
  176. }
  177. return $collection
  178. }
  179.  
  180. # add an external object to collection
  181. method object {o} {
  182. dict set collection [$o id] $o
  183. }
  184.  
  185. # find an object by ID within this collection
  186. method byID {id} {
  187. if {[dict exists $collection $id]} {
  188. return [dict get $collection $id]
  189. } else {
  190. dict for {n o} $collection {
  191. set found [$o byID $id]
  192. if {$found ne ""} {
  193. return $found
  194. }
  195. }
  196. }
  197. }
  198.  
  199. # return contents (ie: collection) as svg
  200. method contents {} {
  201. set result {}
  202. if {![info exists collection]} {
  203. # empty collection
  204. return ""
  205. }
  206. dict for {n o} $collection {
  207. set osvg [$o toSVG]
  208. #puts stderr "[self] [my type] contains: $n -> $osvg"
  209. lappend result $osvg
  210. }
  211. #puts stderr "[self] [my type] contents: $collection -> $result"
  212. return \n[join $result \n]\n
  213. }
  214.  
  215. # add object to collection
  216. method add {args} {
  217. set result {}
  218. set new {}
  219. foreach {type v} $args {
  220. #puts stderr "add: '$type' $v"
  221. set o [my $type {*}$v]
  222. set id [$o id]
  223. dict set collection $id $o
  224. lappend new $id $o
  225. }
  226. return $new
  227. }
  228.  
  229. # delete named object from collection
  230. method del {args} {
  231. foreach {o} $args {
  232. dict unset collection $o
  233. }
  234. }
  235.  
  236. # convert Container to Tcl constructor
  237. method tcl {args} {
  238. if {[llength $args]%2} {
  239. set collection [dict merge $collection [lindex $args end]]
  240. set args [lrange $args 0 end-1]
  241. }
  242.  
  243. set result [lrange [next {*}$args] 0 end-1]
  244. set c {}
  245. dict for {n o} $collection {
  246. lappend c [$o tcl]
  247. }
  248.  
  249. if {[llength $c]} {
  250. lappend result $c
  251. }
  252.  
  253. return $result
  254. }
  255.  
  256. # construct an attr dict from XML
  257. method domattrs {node} {
  258. set result {}
  259. puts stderr "node attr: [$node attributes]"
  260.  
  261. foreach n [$node attributes] {
  262. # the list that [domNode attributes] returns
  263. # is {prefix localname namespaceURI}
  264. if {[llength $n] == 3} {
  265. lassign $n name ns uri
  266. if {$uri eq ""} continue
  267. set n $ns:$name
  268. }
  269. if {[catch {lappend result $n [$node getAttribute $n]} e eo]} {
  270. puts stderr "attr error: $e ($eo)"
  271. }
  272. }
  273. #puts stderr "node domattrs -> $result"
  274. return $result
  275. }
  276.  
  277. # traverse SVG tdom tree, generating Tcl SVG hierarchy
  278. method explore {node} {
  279. set type [$node nodeType]
  280. switch -- $type {
  281. ELEMENT_NODE {
  282. set name [$node nodeName]
  283. lassign [split $name :] ns n
  284. if {$n eq ""} {
  285. set name $ns
  286. } elseif {$ns eq "svg"} {
  287. set name $n
  288. }
  289.  
  290. set attributes [$node attributes]
  291. switch -- $name {
  292. path - rect - circle -
  293. ellipse - line - polyline - polygon -
  294. image - use {
  295. #puts "$node is a Graphic $name $type ($attributes)"
  296. set result [list $name {*}[my domattrs $node]]
  297. set c {}
  298. foreach child [$node childNodes] {
  299. catch {
  300. lappend c -[$child nodeName] [lindex [my explore $child] 1]
  301. }
  302. }
  303. if {[llength $c]} {
  304. lappend result $c
  305. }
  306. return $result
  307. }
  308.  
  309. text - title - desc - script {
  310. set text [string trim [[$node firstChild] nodeValue]]
  311. #puts "$node is a $name $type ($text)"
  312. return [list $name {*}[my domattrs $node] $text]
  313. }
  314.  
  315. g - defs - symbol - clipPath -
  316. mask - pattern - marker - a - switch - svg {
  317. #puts "$node is a Container $name $type ($attributes)"
  318. set c {}
  319. set m {}
  320. foreach child [$node childNodes] {
  321. set cname [$child nodeName]
  322. if {$cname in {title desc}} {
  323. catch {
  324. dict set m -$cname [lindex [my explore $child] 1]
  325. }
  326. } elseif {$cname in {script}} {
  327. catch {
  328. dict lappend m -$cname [lindex [my explore $child] 1]
  329. }
  330. } else {
  331. catch {
  332. lappend c [my explore $child]
  333. }
  334. }
  335. }
  336. set result [list $name {*}$m {*}[my domattrs $node]]
  337. if {[llength $c]} {
  338. lappend result $c
  339. }
  340. return $result
  341. }
  342.  
  343. default {
  344. error "unknown node type $name ($attributes)"
  345. }
  346. }
  347. }
  348. default {
  349. error "unknown element type $type"
  350. }
  351. }
  352. }
  353.  
  354. # parse an SVG text, generating a Tcl SVG object hierarchy
  355. method parse {XML} {
  356. package require tdom
  357.  
  358. set doc [dom parse $XML]
  359. set root [$doc documentElement]
  360. set result [my explore $root]
  361. #puts stderr "parse: ($result)"
  362. $doc delete
  363. return $result
  364. }
  365.  
  366. # parse a file containing SVG text, generating a Tcl SVG object hierarchy
  367. method file {name} {
  368. package require fileutil
  369. return [my parse [::fileutil::cat $name]]
  370. }
  371.  
  372. destructor {
  373. dict for {n o} $collection {
  374. $o destroy ;# destroy the children of this hierarchy
  375. }
  376. next ;# finally, destroy self as element
  377. }
  378.  
  379. constructor {type args} {
  380. #puts stderr "Container: $type $args - [llength $args]"
  381. set text {}
  382. set children {}
  383. switch -- [lindex $args 0] {
  384. file -
  385. parse {
  386. # initialize container from file or text
  387. set text [lrange [my [lindex $args 0] [lindex $args 1]] 1 end]
  388. if {[llength $text]%2} {
  389. lappend children {*}[lindex $text end]
  390. set text [lrange $text 0 end-1]
  391. }
  392. #puts stderr "[lindex $args 0]: $text"
  393.  
  394. set args [lrange $args 2 end]
  395. }
  396. }
  397.  
  398. if {[llength $args]%2} {
  399. lappend children {*}[lindex $args end]
  400. set args [lrange $args 0 end-1]
  401. }
  402.  
  403. next $type {*}$text {*}$args
  404. #puts "Children: $children"
  405. foreach v $children {
  406. set v [lassign $v type]
  407. #puts stderr "c add: '$type' $v"
  408. set o [my $type {*}$v]
  409. set id [$o id]
  410. dict set collection $id $o
  411. }
  412. }
  413. }
  414.  
  415. oo::class create SVG {
  416. superclass SVGContainer
  417.  
  418. # convert SVG hierarchy to SVG
  419. method toSVG {} {
  420. append result "<?xml version='1.0' standalone='no'?>" \n
  421. append result "<!DOCTYPE svg PUBLIC '-//W3C//DTD SVG 20001102//EN' 'http://www.w3.org/TR/2000/CR-SVG-20001102/DTD/svg-20001102.dtd'>" \n
  422. append result [next] \n
  423. return $result
  424. }
  425.  
  426. destructor {next}
  427.  
  428. constructor {args} {
  429. next svg {*}$args
  430. }
  431. }
  432.  
  433. if {[info exists argv0] && $argv0 eq [info script]} {
  434. if {[lindex $argv 0] eq "examples"} {
  435. foreach file [glob /usr/share/inkscape/examples/*.svg] {
  436. puts $file
  437. set svg [SVG new file $file]
  438. puts [$svg toSVG]
  439. $svg destroy
  440. }
  441. return
  442. }
  443. # test - plug in an SVG constructor (e.g. file FILE.svg) and watch it work
  444. set svg [SVG new {*}$argv]
  445. puts [$svg toSVG]
  446. }