What: can2svg
Where: http://hem.fyristorg.com/matben/download/can2svg.tcl Description: Package to translate a canvas to Adobe SVG format. Updated: 05/2002 Contact: mailto:[email protected] (Mats Bengtsson)
FYI: SVG is not an Adobe format, it's a W3C recommendation [L1 ].
Yes, the link is broken. Is this the same file as: http://cvs.rycks.com/cgi-bin/cvsweb/kidistb/can2svg.tcl ??
No, that one is just based on the can2svg.tcl from Mats Bengtsson but it is not the same.
ysk: It is still available on Internet Archive. http://web.archive.org/web/20050414013028/http://hem.fyristorg.com/matben/download/can2svg.tcl
# can2svg.tcl ---
#
# This file provides translation from canvas commands to XML/SVG format.
#
# Copyright (c) 2002 Mats Bengtsson
#
# ########################### USAGE ############################################
#
# NAME
# can2svg - translate canvas command to SVG.
#
# SYNOPSIS
# can2svg canvasCmd ?options?
# canvasCmd is everything except the widget path name.
#
# canvas2file widgetPath fileName ?options?
# options: -height
# -width
#
#
# ########################### CHANGES ##########################################
#
# 0.1 first release
#
# ########################### TODO #############################################
#
# handle units (m->mm etc.)
# better support for stipple patterns
# how to handle tk editing? DOM?
# URI encoding
#
# ...
package provide can2svg 0.1
namespace eval ::can2svg:: {
namespace export can2svg canvas2file
variable formatArrowMarker
variable formatArrowMarkerLast
# The key into this array is 'arrowMarkerDef_$col_$a_$b_$c', where
# col is color, and a, b, c are the arrow's shape.
variable defsArrowMarkerArr
# Similarly for stipple patterns.
variable defsStipplePatternArr
# This shouldn't be hardcoded!
variable defaultFont {Helvetica 12}
variable anglesToRadians [expr 3.14159265359/180.0]
variable grayStipples {gray75 gray50 gray25 gray12}
# Make 4x4 squares. Perhaps could be improved.
variable stippleDataArr
set stippleDataArr(gray75) \
{M 0 0 h3 M 0 1 h1 m 1 0 h2 M 0 2 h2 m 1 0 h1 M 0 3 h3}
set stippleDataArr(gray50) \
{M 0 0 h1 m 1 0 h1 M 1 1 h1 m 1 0 h1 \
M 0 2 h1 m 1 0 h1 M 1 3 h1 m 1 0 h1}
set stippleDataArr(gray25) \
{M 0 0 h1 M 2 1 h1 M 1 2 h1 M 3 3 h1}
set stippleDataArr(gray12) {M 0 0 h1 M 2 2 h1}
}
# ::can2svg::can2svg --
#
# Make xml out of a canvas command, widgetPath removed.
#
# Arguments:
# cmd canvas command without prepending widget path.
# args -usetags 0|all|first|last
#
# Results:
# xml data
proc ::can2svg::can2svg {cmd args} {
variable defsArrowMarkerArr
variable defsStipplePatternArr
variable anglesToRadians
variable defaultFont
variable grayStipples
set nonum_ {[^0-9]}
set wsp_ {[ ]+}
set xml ""
array set argsArr {-usetags all}
array set argsArr $args
switch -- [lindex $cmd 0] {
create {
set type [lindex $cmd 1]
set rest [lrange $cmd 2 end]
regexp -indices -- "-${nonum_}" $rest ind
set ind1 [lindex $ind 0]
set coo [string trim [string range $rest 0 [expr $ind1 - 1]]]
set opts [string range $rest $ind1 end]
array set optArr $opts
# Figure out if we've got a spline.
set haveSpline 0
if {[info exists optArr(-smooth)] && ($optArr(-smooth) != "0") && \
[info exists optArr(-splinesteps)] && ($optArr(-splinesteps) > 2)} {
set haveSpline 1
}
if {[info exists optArr(-fill)]} {
set fillValue $optArr(-fill)
} else {
set fillValue black
}
if {($argsArr(-usetags) != "0") && [info exists optArr(-tags)]} {
switch -- $argsArr(-usetags) {
all {
set idAttr [list "id" $optArr(-tags)]
}
first {
set idAttr [list "id" [lindex $optArr(-tags) 0]]
}
last {
set idAttr [list "id" [lindex $optArr(-tags) end]]
}
}
} else {
set idAttr ""
}
# If we need a marker (arrow head) need to make that first.
if {[info exists optArr(-arrow)]} {
if {[info exists optArr(-arrowshape)]} {
# Make a key of the arrowshape list into the array.
regsub -all -- $wsp_ $optArr(-arrowshape) _ shapeKey
set arrowKey ${fillValue}_${shapeKey}
set arrowShape $optArr(-arrowshape)
} else {
set arrowKey ${fillValue}
set arrowShape {8 10 3}
}
if {![info exists defsArrowMarkerArr($arrowKey)]} {
set defsArrowMarkerArr($arrowKey) \
[eval {MakeArrowMarker} $arrowShape {$fillValue}]
append xml $defsArrowMarkerArr($arrowKey)
append xml "\n\t"
}
}
# If we need a stipple bitmap, need to make that first. Limited!!!
# Only: gray12, gray25, gray50, gray75
foreach key {-stipple -outlinestipple} {
if {[info exists optArr($key)] && \
([lsearch $grayStipples $optArr($key)] >= 0)} {
set stipple $optArr($key)
if {![info exists defsStipplePatternArr($stipple)]} {
set defsStipplePatternArr($stipple) \
[MakeGrayStippleDef $stipple]
}
append xml $defsStipplePatternArr($stipple)
append xml "\n\t"
}
}
switch -- $type {
arc {
# Had to do it the hard way! (?)
# "Wrong" coordinate system :-(
set elem "path"
set style [MakeStyle $type $opts]
foreach {x1 y1 x2 y2} $coo {}
set cx [expr ($x1 + $x2)/2.0]
set cy [expr ($y1 + $y2)/2.0]
set rx [expr abs($x1 - $x2)/2.0]
set ry [expr abs($y1 - $y2)/2.0]
set rmin [expr $rx > $ry ? $ry : $rx]
# This approximation gives a maximum half pixel error.
set deltaPhi [expr 2.0/sqrt($rmin)]
set extent [expr $anglesToRadians * $optArr(-extent)]
set start [expr $anglesToRadians * $optArr(-start)]
set nsteps [expr int(abs($extent)/$deltaPhi) + 2]
set delta [expr $extent/$nsteps]
set data [format "M %.1f %.1f L" \
[expr $cx + $rx*cos($start)] [expr $cy - $ry*sin($start)]]
for {set i 0} {$i <= $nsteps} {incr i} {
set phi [expr $start + $i * $delta]
append data [format " %.1f %.1f" \
[expr $cx + $rx*cos($phi)] [expr $cy - $ry*sin($phi)]]
}
if {[info exists optArr(-style)]} {
switch -- $optArr(-style) {
chord {
append data " Z"
}
pieslice {
append data [format " %.1f %.1f Z" $cx $cy]
}
}
} else {
# Pieslice is the default.
append data [format " %.1f %.1f Z" $cx $cy]
}
set attr [list "d" $data "style" $style]
if {[string length $idAttr] > 0} {
set attr [concat $attr $idAttr]
}
set xmlList [MakeXMLList $elem -attrlist $attr]
}
image - bitmap {
set elem "image"
set attr [MakeImageAttr $coo $opts]
if {[string length $idAttr] > 0} {
set attr [concat $attr $idAttr]
}
set xmlList [MakeXMLList $elem -attrlist $attr]
}
line {
if {$haveSpline} {
set elem "path"
set style [MakeStyle $type $opts]
set data "M [lrange $coo 0 1] Q"
set i 4
foreach {x y} [lrange $coo 2 end-4] {
set x0 [expr ($x + [lindex $coo $i])/2.0]
incr i
set y0 [expr ($y + [lindex $coo $i])/2.0]
incr i
append data " $x $y $x0 $y0"
}
append data " [lrange $coo end-3 end]"
set attr [list "d" $data "style" $style]
} else {
set elem "polyline"
set style [MakeStyle $type $opts]
set attr [list "points" $coo "style" $style]
}
if {[string length $idAttr] > 0} {
set attr [concat $attr $idAttr]
}
set xmlList [MakeXMLList $elem -attrlist $attr]
}
oval {
foreach {x y w h} [NormalizeRectCoords $coo] {}
if {[expr $w == $h]} {
set elem "circle"
set attr [list \
"cx" [expr $x + $w/2.0] \
"cy" [expr $y + $h/2.0] \
"r" [expr $w/2.0]]
} else {
set elem "ellipse"
set attr [list \
"cx" [expr $x + $w/2.0] \
"cy" [expr $y + $h/2.0] \
"rx" [expr $w/2.0] \
"ry" [expr $h/2.0]]
}
set style [MakeStyle $type $opts]
lappend attr "style" $style
if {[string length $idAttr] > 0} {
set attr [concat $attr $idAttr]
}
set xmlList [MakeXMLList $elem -attrlist $attr]
}
polygon {
if {$haveSpline} {
set elem "path"
set style [MakeStyle $type $opts]
# Translating a closed polygon into a qubic bezier
# path is a little bit tricky.
set x0 [expr ([lindex $coo end-1] + [lindex $coo 0])/2.0]
set y0 [expr ([lindex $coo end] + [lindex $coo 1])/2.0]
set data "M $x0 $y0 Q"
set i 2
foreach {x y} [lrange $coo 0 end-2] {
set x1 [expr ($x + [lindex $coo $i])/2.0]
incr i
set y1 [expr ($y + [lindex $coo $i])/2.0]
incr i
append data " $x $y $x1 $y1"
}
append data " [lrange $coo end-1 end] $x0 $y0"
set attr [list "d" $data "style" $style]
} else {
set elem "polygon"
set style [MakeStyle $type $opts]
set attr [list "points" $coo "style" $style]
}
if {[string length $idAttr] > 0} {
set attr [concat $attr $idAttr]
}
set xmlList [MakeXMLList $elem -attrlist $attr]
}
rectangle {
set elem "rect"
set style [MakeStyle $type $opts]
# width and height must be non-negative!
foreach {x y w h} [NormalizeRectCoords $coo] {}
set attr [list "x" $x "y" $y "width" $w "height" $h]
lappend attr "style" $style
if {[string length $idAttr] > 0} {
set attr [concat $attr $idAttr]
}
set xmlList [MakeXMLList $elem -attrlist $attr]
}
text {
set elem "text"
set style [MakeStyle $type $opts]
set nlines 1
if {[info exists optArr(-text)]} {
set chdata $optArr(-text)
set nlines [expr [regexp -all "\n" $chdata] + 1]
} else {
set chdata ""
}
# Figure out the coords of the first baseline.
set anchor center
if {[info exists optArr(-anchor)]} {
set anchor $optArr(-anchor)
}
if {[info exists optArr(-font)]} {
set theFont $optArr(-font)
} else {
set theFont $defaultFont
}
set ascent [font metrics $theFont -ascent]
set lineSpace [font metrics $theFont -linespace]
foreach {xbase ybase} \
[GetTextSVGCoords $coo $anchor $chdata $theFont $nlines] {}
set attr [list "x" $xbase "y" $ybase]
lappend attr "style" $style
if {[string length $idAttr] > 0} {
set attr [concat $attr $idAttr]
}
set dy 0
if {$nlines > 1} {
# Use the 'tspan' trick here.
set subList {}
foreach line [split $chdata "\n"] {
lappend subList [MakeXMLList "tspan" \
-attrlist [list "x" $xbase "dy" $dy] -chdata $line]
set dy $lineSpace
}
set xmlList [MakeXMLList $elem -attrlist $attr \
-subtags $subList]
} else {
set xmlList [MakeXMLList $elem -attrlist $attr \
-chdata $chdata]
}
}
}
}
move {
foreach {tag dx dy} [lrange $cmd 1 3] {}
set attr [list "transform" "translate($dx,$dy)" \
"xlink:href" "#$tag"]
set xmlList [MakeXMLList "use" -attrlist $gattr]
}
scale {
}
}
append xml [MakeXML $xmlList]
return $xml
}
# ::can2svg::MakeStyle --
#
# Produce the SVG style attribute from the canvas item options.
#
# Arguments:
# type tk canvas widget item type
# opts
#
# Results:
# The SVG style attribute as a a string.
proc ::can2svg::MakeStyle {type opts} {
# Defaults for everything except text.
if {![string equal $type "text"]} {
array set styleArr {fill none stroke black}
}
set fillCol black
foreach {key value} $opts {
switch -- $key {
-arrow {
set arrowValue $value
}
-arrowshape {
set arrowShape $value
}
-capstyle {
if {[string equal $value "projecting"]} {
set value "square"
}
if {![string equal $value "butt"]} {
set styleArr(stroke-linecap) $value
}
}
-dash {
set dashValue $value
}
-dashoffset {
if {$value != 0} {
set styleArr(stroke-dashoffset) $value
}
}
-fill {
set fillCol $value
if {[string equal $type "line"]} {
set styleArr(stroke) [MapEmptyToNone $value]
} else {
set styleArr(fill) [MapEmptyToNone $value]
}
}
-font {
set styleArr(font-family) [lindex $value 0]
if {[llength $value] > 1} {
set styleArr(font-size) [lindex $value 1]
}
if {[llength $value] > 2} {
set tkstyle [lindex $value 2]
switch -- $tkstyle {
bold {
set styleArr(font-weight) $tkstyle
}
italic {
set styleArr(font-style) $tkstyle
}
underline {
set styleArr(text-decoration) underline
}
overstrike {
set styleArr(text-decoration) overline
}
}
}
}
-joinstyle {
set styleArr(stroke-linejoin) $value
}
-outline {
set styleArr(stroke) [MapEmptyToNone $value]
}
-outlinestipple {
set outlineStippleValue $value
}
-stipple {
set stippleValue $value
}
-width {
set styleArr(stroke-width) $value
}
}
}
# If any arrow specify its marker def url key.
if {[info exists arrowValue]} {
if {[info exists arrowShape]} {
foreach {a b c} $arrowShape {}
set arrowIdKey "arrowMarkerDef_${fillCol}_${a}_${b}_${c}"
set arrowIdKeyLast "arrowMarkerLastDef_${fillCol}_${a}_${b}_${c}"
} else {
set arrowIdKey "arrowMarkerDef_${fillCol}"
}
switch -- $arrowValue {
first {
set styleArr(marker-start) "url(#$arrowIdKey)"
}
last {
set styleArr(marker-end) "url(#$arrowIdKeyLast)"
}
both {
set styleArr(marker-start) "url(#$arrowIdKey)"
set styleArr(marker-end) "url(#$arrowIdKeyLast)"
}
}
}
if {[info exists stippleValue]} {
# Overwrite any existing.
set styleArr(fill) "url(#tile$stippleValue)"
}
if {[info exists outlineStippleValue]} {
# Overwrite any existing.
set styleArr(stroke) "url(#tile$stippleValue)"
}
# Transform dash value.
if {[info exists dashValue]} {
# Two different syntax here.
if {[regexp {[\.,\-_ ]} $dashValue]} {
# .=2 ,=4 -=6 space=4 times stroke width.
# A space enlarges the... space.
# Not foolproof!
regsub -all -- {[^ ]} $dashValue "& " dash
regsub -all -- " " $dash "12 " dash
regsub -all -- " " $dash "8 " dash
regsub -all -- " " $dash "4 " dash
regsub -all -- {\.} $dash "2 " dash
regsub -all -- {,} $dash "4 " dash
regsub -all -- {-} $dash "6 " dash
# Multiply with stroke width if > 1.
if {[info exists styleArr(stroke-width)] && \
($styleArr(stroke-width) > 1)} {
set width $styleArr(stroke-width)
set dashOrig $dash
set dash {}
foreach num $dashOrig {
lappend dash [expr int($width * $num)]
}
}
set styleArr(stroke-dasharray) [string trim $dash]
} else {
set styleArr(stroke-dasharray) $value
}
}
if {[string equal $type "polygon"]} {
set styleArr(fill-rule) "evenodd"
}
set style ""
foreach {key value} [array get styleArr] {
append style "${key}: ${value}; "
}
return [string trim $style]
}
# ::can2svg::MakeImageAttr --
#
# Special code is needed to make the attributes for an image item.
#
# Arguments:
# elem
#
# Results:
#
proc ::can2svg::MakeImageAttr {coo opts} {
array set optArr {-anchor nw}
array set optArr $opts
set theImage $optArr(-image)
set w [image width $theImage]
set h [image height $theImage]
# We should make this an URI.
set theFile [$theImage cget -file]
set uri [UriFromLocalFile $theFile]
foreach {x0 y0} $coo {}
switch -- $optArr(-anchor) {
nw {
set x $x0
set y $y0
}
n {
set x [expr $x0 - $w/2.0]
set y $y0
}
ne {
set x [expr $x0 - $w]
set y $y0
}
e {
set x $x0
set y [expr $y0 - $h/2.0]
}
se {
set x [expr $x0 - $w]
set y [expr $y0 - $h]
}
s {
set x [expr $x0 - $w/2.0]
set y [expr $y0 - $h]
}
sw {
set x $x0
set y [expr $y0 - $h]
}
w {
set x $x0
set y [expr $y0 - $h/2.0]
}
center {
set x [expr $x0 - $w/2.0]
set y [expr $y0 - $h/2.0]
}
}
set attrList [list "x" $x "y" $y "width" $w "height" $h \
"xlink:href" $uri]
return $attrList
}
# ::can2svg::GetTextSVGCoords --
#
# Figure out the baseline coords of the svg text element from
# the canvas text item.
#
# Arguments:
# coo {x y}
# anchor
# chdata character data, newlines included.
#
# Results:
# raw xml data of the marker def element.
proc ::can2svg::GetTextSVGCoords {coo anchor chdata theFont nlines} {
foreach {x y} $coo {}
set ascent [font metrics $theFont -ascent]
set lineSpace [font metrics $theFont -linespace]
# If not anchored to the west it gets more complicated.
if {![string match $anchor "*w*"]} {
# Need to figure out the extent of the text.
if {$nlines <= 1} {
set textWidth [font measure $theFont $chdata]
} else {
set textWidth 0
foreach line [split $chdata "\n"] {
set lineWidth [font measure $theFont $line]
if {$lineWidth > $textWidth} {
set textWidth $lineWidth
}
}
}
}
switch -- $anchor {
nw {
set xbase $x
set ybase [expr $y + $ascent]
}
w {
set xbase $x
set ybase [expr $y - $nlines*$lineSpace/2.0 + $ascent]
}
sw {
set xbase $x
set ybase [expr $y - $nlines*$lineSpace + $ascent]
}
s {
set xbase [expr $x - $textWidth/2.0]
set ybase [expr $y - $nlines*$lineSpace + $ascent]
}
se {
set xbase [expr $x - $textWidth]
set ybase [expr $y - $nlines*$lineSpace + $ascent]
}
e {
set xbase [expr $x - $textWidth]
set ybase [expr $y - $nlines*$lineSpace/2.0 + $ascent]
}
ne {
set xbase [expr $x - $textWidth]
set ybase [expr $y + $ascent]
}
n {
set xbase [expr $x - $textWidth/2.0]
set ybase [expr $y + $ascent]
}
center {
set xbase [expr $x - $textWidth/2.0]
set ybase [expr $y - $nlines*$lineSpace/2.0 + $ascent]
}
}
return [list $xbase $ybase]
}
# ::can2svg::MakeArrowMarker --
#
# Make the xml for an arrow marker def element.
#
# Arguments:
# a arrows length along its symmetry line
# b arrows total length
# c arrows half width
# col its color
#
# Results:
# raw xml data of the marker def elements, both start and last.
proc ::can2svg::MakeArrowMarker {a b c col} {
variable formatArrowMarker
variable formatArrowMarkerLast
catch {unset formatArrowMarker}
if {![info exists formatArrowMarker]} {
# "M 0 c, b 0, a c, b 2*c Z" for the start marker.
# "M 0 0, b c, 0 2*c, b-a c Z" for the last marker.
set data "M 0 %s, %s 0, %s %s, %s %s Z"
set style "fill: %s; stroke: %s;"
set attr [list "d" $data "style" $style]
set arrowList [MakeXMLList "path" -attrlist $attr]
set markerAttr [list "id" %s "markerWidth" %s "markerHeight" %s \
"refX" %s "refY" %s "orient" "auto"]
set defElemList [MakeXMLList "defs" -subtags \
[list [MakeXMLList "marker" -attrlist $markerAttr \
-subtags [list $arrowList] ] ] ]
set formatArrowMarker [MakeXML $defElemList]
# ...and the last arrow marker.
set dataLast "M 0 0, %s %s, 0 %s, %s %s Z"
set attrLast [list "d" $dataLast "style" $style]
set arrowLastList [MakeXMLList "path" -attrlist $attrLast]
set defElemLastList [MakeXMLList "defs" -subtags \
[list [MakeXMLList "marker" -attrlist $markerAttr \
-subtags [list $arrowLastList] ] ] ]
set formatArrowMarkerLast [MakeXML $defElemLastList]
}
set idKey "arrowMarkerDef_${col}_${a}_${b}_${c}"
set idKeyLast "arrowMarkerLastDef_${col}_${a}_${b}_${c}"
# Figure out the order of all %s substitutions.
set markerXML [format $formatArrowMarker $idKey \
$b [expr 2*$c] 0 $c \
$c $b $a $c $b [expr 2*$c] $col $col]
set markerLastXML [format $formatArrowMarkerLast $idKeyLast \
$b [expr 2*$c] $b $c \
$b $c [expr 2*$c] [expr $b-$a] $c $col $col]
return "$markerXML\n\t$markerLastXML"
}
# ::can2svg::MakeGrayStippleDef --
#
#
proc ::can2svg::MakeGrayStippleDef {stipple} {
variable stippleDataArr
set pathList [MakeXMLList "path" -attrlist \
[list "d" $stippleDataArr($stipple) "style" "stroke: black; fill: none;"]]
set patterAttr [list "id" "tile$stipple" "x" 0 "y" 0 "width" 4 "height" 4 \
"patternUnits" "userSpaceOnUse"]
set defElemList [MakeXMLList "defs" -subtags \
[list [MakeXMLList "pattern" -attrlist $patterAttr \
-subtags [list $pathList] ] ] ]
return [MakeXML $defElemList]
}
# ::can2svg::MapEmptyToNone --
#
#
# Arguments:
# elem
#
# Results:
#
proc ::can2svg::MapEmptyToNone {val} {
if {[string length $val] == 0} {
return "none"
} else {
return $val
}
}
# ::can2svg::NormalizeRectCoords --
#
#
# Arguments:
# elem
#
# Results:
#
proc ::can2svg::NormalizeRectCoords {coo} {
foreach {x1 y1 x2 y2} $coo {}
return [list [expr $x2 > $x1 ? $x1 : $x2] \
[expr $y2 > $y1 ? $y1 : $y2] \
[expr abs($x1-$x2)] \
[expr abs($y1-$y2)]]
}
# ::can2svg::makedocument --
#
# Adds the prefix and suffix elements to make a complete XML/SVG
# document.
#
# Arguments:
# elem
#
# Results:
#
proc ::can2svg::makedocument {width height xml} {
set pre "<?xml version='1.0'?>\n\
<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.0//EN\"\
\"http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd\">"
set svgStart "<svg width='$width' height='$height'>"
set svgEnd "</svg>"
return "${pre}\n${svgStart}\n${xml}${svgEnd}"
}
# ::can2svg::canvas2file --
#
# Takes everything on a canvas widget, translates it to XML/SVG,
# and puts it on a file.
#
# Arguments:
# wcan the canvas widget path
# path the file path
# args: -height
# -width
#
# Results:
#
proc ::can2svg::canvas2file {wcan path args} {
variable defsArrowMarkerArr
variable defsStipplePatternArr
# Need to make a fresh start for marker def's.
catch {unset defsArrowMarkerArr}
catch {unset defsStipplePatternArr}
array set argsArr \
[list -width [winfo width $wcan] -height [winfo height $wcan]]
array set argsArr $args
set fd [open $path w]
set xml ""
foreach id [$wcan find all] {
set type [$wcan type $id]
set opts [$wcan itemconfigure $id]
set opcmd {}
foreach opt $opts {
set op [lindex $opt 0]
set val [lindex $opt 4]
# Empty val's except -fill can be stripped off.
if {![string equal $op "-fill"] && ([string length $val] == 0)} {
continue
}
lappend opcmd $op $val
}
set co [$wcan coords $id]
set cmd [concat "create" $type $co $opcmd]
append xml "\t[can2svg $cmd]\n"
}
puts $fd [makedocument $argsArr(-width) $argsArr(-height) $xml]
close $fd
}
# ::can2svg::MakeXML --
#
# Creates raw xml data from a hierarchical list of xml code.
# This proc gets called recursively for each child.
# It makes also internal entity replacements on character data.
# Mixed elements aren't treated correctly generally.
#
# Arguments:
# xmlList a list of xml code in the format described in the header.
#
# Results:
# raw xml data.
proc ::can2svg::MakeXML {xmlList} {
# Extract the XML data items.
foreach {tag attrlist isempty chdata childlist} $xmlList {}
set rawxml "<$tag"
foreach {attr value} $attrlist {
append rawxml " ${attr}='${value}'"
}
if {$isempty} {
append rawxml "/>"
return $rawxml
} else {
append rawxml ">"
}
# Call ourselves recursively for each child element.
# There is an arbitrary choice here where childs are put before PCDATA.
foreach child $childlist {
append rawxml [MakeXML $child]
}
# Make standard entity replacements.
if {[string length $chdata]} {
append rawxml [XMLCrypt $chdata]
}
append rawxml "</$tag>"
return $rawxml
}
# ::can2svg::MakeXMLList --
#
# Build an element list given the tag and the args.
#
# Arguments:
# tagname: the name of this element.
# args:
# -empty 0|1 Is this an empty tag? If $chdata
# and $subtags are empty, then whether
# to make the tag empty or not is decided
# here. (default: 1)
# -attrlist {attr1 value1 attr2 value2 ..} Vars is a list
# consisting of attr/value pairs, as shown.
# -chdata $chdata ChData of tag (default: "").
# -subtags {$subchilds $subchilds ...} is a list containing xmldata
# of $tagname's subtags. (default: no sub-tags)
#
# Results:
# a list suitable for ::can2svg::MakeXML.
proc ::can2svg::MakeXMLList {tagname args} {
# Fill in the defaults.
array set xmlarr {-isempty 1 -attrlist {} -chdata {} -subtags {}}
# Override the defults with actual values.
if {[llength $args] > 0} {
array set xmlarr $args
}
if {!(($xmlarr(-chdata) == "") && ($xmlarr(-subtags) == ""))} {
set xmlarr(-isempty) 0
}
# Build sub elements list.
set sublist {}
foreach child $xmlarr(-subtags) {
lappend sublist $child
}
set xmlList [list $tagname $xmlarr(-attrlist) $xmlarr(-isempty) \
$xmlarr(-chdata) $sublist]
return $xmlList
}
# ::can2svg::XMLCrypt --
#
# Makes standard XML entity replacements.
#
# Arguments:
# chdata: character data.
#
# Results:
# chdata with XML standard entities replaced.
proc ::can2svg::XMLCrypt {chdata} {
foreach from {\& < > {"} {'}} \
to {{\&} {\<} {\>} {\"} {\'}} {
regsub -all $from $chdata $to chdata
}
return $chdata
}
# ::can2svg::UriFromLocalFile --
#
# Not foolproof!
proc ::can2svg::UriFromLocalFile {path} {
# Windows???
# TODO: Encoding?
if {[string equal $::tcl_platform(platform) "windows"]} {
# Trim the volume specifier.
set vol_ {([A-Z]:/|[A-Z]:\\)}
regexp "${vol_}+(.+)$" $path match x path
}
set pathList [split $path "/:\\"]
set pathJoin [join $pathList /]
# Any characters not 7bit encode as %xx hex???
regsub -all -- " " $pathJoin "%20" pathJoin
return file:///${pathJoin}
}
#-------------------------------------------------------------------------------[ Category Package | Category Graphics | Category Broken Links ]