Load, save cut and paste tag formatted text widget contents.
Available at:
http://www1.clearlight.com/~oakley/tcl/ttd/index.html
Archived at: [
1]
APN 2016-10-29 The above link is broken so below is a copy of some version of that code.
# Tcl/Tk text dump
#
# Copyright (c) 1999, Bryan Douglas Oakley
# All Rights Reserved.
#
# This code is provide as-is, with no warranty expressed or implied. Use
# at your own risk.
#
#
package provide ttd 1.0
namespace eval ::ttd {
# this is the public interface
namespace export get insert
variable code
variable ttdVersion {}
variable taglist
variable safeInterpreter
}
proc ::ttd::get {args} {
set argc [llength $args]
if {$argc == 0} {
error "wrong \# args: must be ::ttd::get pathName ?index1? ?index2?"
}
set w [lindex $args 0]
if {[winfo class $w] != "Text"} {
error "\"$w\" is not a text widget"
}
if {$argc == 1} {
set index1 "1.0"
# one might think we want "end -1c" here, but if we do that
# we end up losing some tagoff directives. We'll remove the
# trailing space later.
set index2 "end"
} elseif {$argc == 2} {
set index1 [lindex $args 1]
set index2 "[$w index {$index1 + 1c}]"
} else {
set index1 [lindex $args 1]
set index2 [lindex $args 2]
}
set tagData {}
set imageData {}
set header "# -*- tcl -*-\n#\n\n"
set version [list ttd.version 1.0]
set result [list ]
# we use these arrays to keep track of actual images, tags
# and windows (though, not really windows...)
catch {unset tags}
catch {unset images}
catch {unset windows}
foreach {key value index} [$w dump $index1 $index2] {
switch -exact -- $key {
tagon {
lappend result [list ttd.tagon $value]
if {![info exists tags($value)]} {
# we need to steal all of the configuration data
set tagname $value
set tags($tagname) {}
foreach item [$w tag configure $tagname] {
set value [lindex $item 4]
if {[string length $value] > 0} {
set option [lindex $item 0]
lappend tags($tagname) $option $value
}
}
}
}
tagoff {
lappend result [list ttd.tagoff $value]
}
text {
lappend result [list ttd.text $value]
}
mark {
# bah! marks aren't interesting, are they?
# lappend result [list ttd.mark $value]
}
image {
# $value is an internal identifier. We need the actual
# image name so we can grab its data...
set imagename [$w image cget $value -image]
set image [list ttd.image]
# this gets all of the options for this image
# at this location (such as -align, etc)
foreach item [$w image configure $value] {
set value [lindex $item 4]
if {[string length $value] != 0} {
set option [lindex $item 0]
lappend image $option $value
}
}
lappend result $image
# if we don't yet have a definition for this
# image, grab it
if {[string length $imagename] > 0 \
&& ![info exists images($imagename)]} {
# we need to steal all of the configuration data
set images($imagename) $imagename
foreach item [$imagename configure] {
set value [lindex $item 4]
if {[string length $imagename] > 0} {
set option [lindex $item 0]
lappend images($imagename) $option $value
}
}
}
}
window {
set window [list ttd.window $value]
foreach item [$w window configure $index] {
set value [lindex $item 4]
if {[string length $value] != 0} {
set option [lindex $item 0]
lappend window $option $value
}
}
lappend result $window
}
}
}
# process tags in priority order; ignore tags that aren't used
set tagData {}
foreach tag [$w tag names] {
if {[info exists tags($tag)]} {
lappend tagData [concat ttd.tagdef $tag $tags($tag)]
}
}
set imageData {}
foreach image [array names images] {
lappend imageData [concat ttd.imgdef $images($image)]
}
# remove the trailing newline that the text widget added
# for us
set result [lreplace $result end end]
set tmp $header
append tmp "$version\n\n"
append tmp "[join $tagData \n]\n\n"
append tmp "[join $imageData \n]\n\n"
append tmp "[join $result \n]\n"
return $tmp
}
proc ::ttd::insert {w ttd} {
variable ttdVersion {}
variable taglist
variable safeInterpreter
variable ttdCode
# create a safe interpreter, if we haven't already done so
catch {interp delete $safeInterpreter }
set safeInterpreter [interp create -safe]
# we want the widget command to be available to the
# safe interpreter. Also, the text may include embedded
# images, so we need the image command available as well.
interp alias $safeInterpreter masterTextWidget {} $w
interp alias $safeInterpreter image {} image
# interp alias $safeInterpreter puts {} puts
# this defines the commands we use to parse the data
$safeInterpreter eval $ttdCode
# this processes the data. Alert the user if there was
# a problem.
if {[catch {$safeInterpreter eval $ttd} error]} {
set message "Error opening file:\n\n$error"
tk_messageBox -icon info \
-message $message \
-title "Bad file" \
-type ok
}
# and clean up after ourselves
interp delete $safeInterpreter
}
# this code defines the commands which are embedded in the ttd
# data. It should only executed in a safe interpreter.
set ::ttd::ttdCode {
set taglist ""
set command ""
set ttdVersion ""
proc ttd.version {version} {
global ttdVersion
set ttdVersion $version
}
proc ttd.window {args} {
# not supported yet
error "embedded windows aren't supported in this version"
}
proc ttd.image {args} {
global taglist
set index [masterTextWidget index insert]
eval masterTextWidget image create $index $args
# we want the current tags associated with the image...
# (I wonder why I can't supply tags at the time I create
# the image, like I can when I insert text?)
foreach tag $taglist {
masterTextWidget tag add $tag $index
}
}
proc ttd.imgdef {name args} {
eval image create photo $name $args
}
proc ttd.tagdef {name args} {
eval masterTextWidget tag configure $name $args
}
proc ttd.text {string} {
global taglist
masterTextWidget insert insert $string $taglist
}
proc ttd.tagon {tag} {
global taglist
# I'm confused by this, but we need to keep track of our
# tags in reverse order.
set taglist [concat $tag $taglist]
}
proc ttd.tagoff {tag} {
global taglist
set i [lsearch -exact $taglist $tag]
if {$i >= 0} {
set taglist [lreplace $taglist $i $i]
}
masterTextWidget tag remove $tag insert
}
proc ttd.mark {name} {
masterTextWidget mark set $name [masterTextWidget index insert]
}
}
