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 "\tcan2svg $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 ]