Koen Van Damme -- This is the implementation of a simple buffer in which text can be stored, removed, changed, or inserted before finally being sent to output. I sometimes use this for Code Generation, so that I can create fragments of code and tinker with them before giving them to puts. I call such buffers clipboards. A clipboard contains named plugs in which text or other plugs can be added. The plugs can be retrieved by their unique name within a clipboard. The current implementation is not robust at all, but it is simple. I like simple.
First, an example:
# A procedure that creates a new clipboard for me,
# containing the declaration of a class.
proc make_class {name base} {
clip $name {
cb_puts "class $name : public $base\n\{\n"
plug CLASS_BODY {
cb_puts "public:\n"
plug PUBLIC
cb_puts "private:\n"
plug PRIVATE
}
cb_puts "\};\n"
}
}
# Create a class, then fill in its plugs with code.
make_class A B
add A PUBLIC {
cb_puts " A() // Default constructor\n"
cb_puts " \{\n"
cb_puts " i= 5;\n"
cb_puts " \}\n"
}
add A PRIVATE {cb_puts " int i; // Some member variable\n"}
# Send result to output.
cb_output AThe procedure clip creates a new clipboard. Its final argument is like the body of an "if" or other control statement: it gets executed in the caller's scope. That's how you can nest plugs and text in a clipboard. The call to plug adds a new plug to the current clipboard, given the plug's name and again a body of statements to execute. Note how I can add code to the existing class body at a later time using add.
The intended output of the above code is this:
class A : public B
{
public:
A() // Default constructor
{
i= 5;
}
private:
int i; // Some member variable
};but you probably guessed that :-)
The power of these clipboards comes from
The rest of this page describes the code: first the clipboards themselves, then the interface procedures to access the clipboards in a very intuitive way. A clipboard is an array, in which each entry is the name of a plug, and the associated value is a list of tuples in which 't' is for freeform text, 'p' is a plug, and 'r' is a reference to another plug (useful for code snippets that need to be produced over and over again). The default plug of a new clipboard is called MAIN. The top plugs of all clipboards are stored in the global array cb__start.
# Create new clipboard called $name, with top plug called $plug_name
proc cb_new {name {plug_name MAIN}} {
global cb__start
set cb__start($name) $plug_name
set cb_name "cb_${name}"
upvar #0 $cb_name the_cb
# A clipboard is an array
set the_cb($plug_name) [list]
return $cb_name
}
# Remove a clipboard. I know, This can be automated with 'trace'
proc cb_delete {name} {
set cb_name "cb_${name}"
upvar #0 $cb_name the_cb
unset the_cb
}
# Add a new tuple to plug $where of clipboard $name.
# The tuple can be text ($what == "t"), a new plug
# ($what == "p") or a reference to another plug ($what == "r").
# $content is the text content, or the plug name,
# or the referenced clipboard name.
proc cb_add {name where what content} {
set cb_name "cb_${name}"
upvar #0 $cb_name the_cb
if { ![info exists the_cb] } {
return
}
if { $what == "p" } {
if { [info exists the_cb($content)] } {
# Plug with that name already exists
return
}
set the_cb($content) [list]
}
lappend the_cb($where) [list $what $content]
}
# Remove contents of plug $where of clipboard $name
proc cb_clear {name where} {
set cb_name "cb_${name}"
upvar #0 $cb_name the_cb
if { ![info exists the_cb] } {
return
}
set the_cb($where) [list]
}
# Does clipboard $name have a plug called $where ?
proc cb_exists {name where} {
set cb_name "cb_${name}"
upvar #0 $cb_name the_cb
if { ![info exists the_cb] } {
return 0
}
return [info exists the_cb($where)]
}
# Output the entire clipboard $name to a file
proc cb_output {name {fid stdout}} {
set cb_name "cb_${name}"
upvar #0 $cb_name the_cb
if { ![info exists the_cb] } {
return
}
global cb__start
set start $cb__start($name)
cb__output $cb_name $start $fid
}
proc cb__output {cb_name pt fid} {
upvar #0 $cb_name the_cb
foreach elt $the_cb($pt) {
if { [lindex $elt 0] == "t" } {
puts -nonewline $fid "[lindex $elt 1]"
} elseif { [lindex $elt 0] == "r" } {
cb_output [lindex $elt 1] $fid
} elseif { [lindex $elt 0] == "p" } {
cb__output $cb_name [lindex $elt 1] $fid
}
}
}Interface procedures:
set cb_curr_clip ""
set cb_curr_plug ""
# Write text to current plug of current clipboard
proc cb_puts {txt} {
global cb_curr_clip cb_curr_plug
cb_add $cb_curr_clip $cb_curr_plug t $txt
}
# New clipboard.
proc clip {clipname args} {
set plugname "MAIN"
if { [llength $args] > 1 } {
set plugname [lindex $args 0]
}
cb_new $clipname $plugname
global cb_curr_clip
set tmp_clip $cb_curr_clip
set cb_curr_clip $clipname
global cb_curr_plug
set tmp_plug $cb_curr_plug
set cb_curr_plug $plugname
uplevel [lindex $args end]
set cb_curr_clip $tmp_clip
set cb_curr_plug $tmp_plug
}
# New plug in current clipboard
proc plug {plugname args} {
global cb_curr_clip
global cb_curr_plug
cb_add $cb_curr_clip $cb_curr_plug p $plugname
if { [llength $args] == 0 } {
return
}
set tmp_plug $cb_curr_plug
set cb_curr_plug $plugname
uplevel [lindex $args end]
set cb_curr_plug $tmp_plug
}
# At current plug of current clipboard, insert references
# to other clipboards.
proc ref {args} {
global cb_curr_clip
global cb_curr_plug
foreach othername $args {
cb_add $cb_curr_clip $cb_curr_plug r $othername
}
}
# Add new text to an existing plug of a clipboard.
proc add {clipname args} {
set plugname "MAIN"
if { [llength $args] > 1 } {
set plugname [lindex $args 0]
}
global cb_curr_clip
set tmp_clip $cb_curr_clip
set cb_curr_clip $clipname
global cb_curr_plug
set tmp_plug $cb_curr_plug
set cb_curr_plug $plugname
uplevel [lindex $args end]
set cb_curr_clip $tmp_clip
set cb_curr_plug $tmp_plug
}
# Add new plug to an existing plug of a clipboard.
# Take that plug as the new default.
proc add_plug {clipname args} {
set plugname "MAIN"
set newname [lindex $args 0]
if { [llength $args] > 2 } {
set plugname [lindex $args 0]
set newname [lindex $args 1]
}
cb_add $clipname $plugname p $newname
global cb_curr_clip
set tmp_clip $cb_curr_clip
set cb_curr_clip $clipname
global cb_curr_plug
set tmp_plug $cb_curr_plug
set cb_curr_plug $newname
uplevel [lindex $args end]
set cb_curr_clip $tmp_clip
set cb_curr_plug $tmp_plug
}
# Replace existing text in a plug by something new.
proc replace {clipname args} {
set plugname "MAIN"
if { [llength $args] > 1 } {
set plugname [lindex $args 0]
}
cb_clear $clipname $plugname
global cb_curr_clip
set tmp_clip $cb_curr_clip
set cb_curr_clip $clipname
global cb_curr_plug
set tmp_plug $cb_curr_plug
set cb_curr_plug $plugname
uplevel [lindex $args end]
set cb_curr_clip $tmp_clip
set cb_curr_plug $tmp_plug
}