EKB This is an implementation of a "Context-oriented Programming" (COP) [L1 ] framework for Tcl. I have presumptuously called it "ContexTcl", in parallel to the existing ContextJ (for Java), ContextS (Smalltalk), and ContextL (Lisp).
The basic idea of COP is that there is a globally defined and dynamic context in which code is executed. As far as I can tell, this is essentially saving the global state in a way that is prettier and more consistent than using a bunch of global (or namespace) state variables.
The context in COP is programmatically available through “layers”, which may be either on or off (or active/inactive). Layers are first-class objects. Other than that there appears to be a lot of flexibility in implementing COP. The approach here is to make a new class, called “layer”. The constructor for the layer class allows layers to optionally be linked to a variable.
The base/default value for the layer can be set using the “base” method or by setting the value of the linked variable, if any. More complex behavior — for example, setting the state depending on a set of values from external sensors — can be added by creating a new class that inherits from the layer class.
Following the example of the Java implementation of COP, ContextJ, a temporary state for layers can be set using “with” and “without” statements. These turn on or off one or more layers, creating a programmatically set local context. A local setting for a layer via with/without overrides the base setting.
There are three ways to use layers. These are defined in a namespace that is separate from the layer class.
The “active” method, e.g.
if [mylayer active] {
... do things ...
}The “allactive” proc, e.g.
if [allactive {layer1 layer2 layer3}] {
...do things...
}The “context” control construct, e.g.,
context {
{layer1 layer2} {
do something
}
{layer2 layer3 layer4} {
do something else
}
default {
default action
}
}namespace import ct::*
console show
# Define a standard layer
layer create remote-access
# Define a layer linked to a variable
layer create text-mode nographics
# Create a context-sensitive test proc
proc test {} {
if [remote-access active] {
set a "In a remote location"
} else {
set a "Local"
}
if [text-mode active] {
set b "Accepting text-only output"
} else {
set b "Can display graphics"
}
puts "$a & $b"
}
# Tests 1 & 2 try out the linked variable
puts "Test 1..."
set nographics 1
with text-mode {
test
}
test
puts "\nTest 2..."
set nographics 0
with text-mode {
test
}
test
# Test 3 tries out identifying more than one layer
puts "\nTest 3..."
with {remote-access text-mode} {
test
}
test
# Test 4 tries out nested with/without, combined with setting the
# "base" value within a with/without clause
puts "\nTest 4..."
with {remote-access text-mode} {
test
without {remote-access} {
remote-access base 1
test
}
}
test
# Test 5 checks that an error is generated for a non-existent
# layer
puts "\nTest 5..."
if [catch {with {have-graphics text-mode} {test}} err] {
puts "Generated an error: $err"
}
# Test 6 tries out the "layers" command to get a list of layers
puts "\nTest 6..."
puts [layers]
# Test 7 checks whether the test for grouped context variables works
puts "\nTest 7..."
proc test2 {} {
if [allactive {remote-access text-mode}] {
puts "All are active!"
} else {
puts "Not all are active..."
}
}
test2
with {remote-access text-mode} {
test2
}
# Test 8 tries out the "context" control construct
puts "\nTest 8..."
proc test3 {} {
context {
{remote-access text-mode} {
puts "Connecting remotely, no graphics"
}
remote-access {
puts "Connecting remotely, in whatever way"
}
default {
puts "Must be local"
}
}
}
test3
without remote-access {test3}
with text-mode {test3}
# Test 9 checks to make sure that setting "base" will update the linked variable
puts "\nTest 9..."
set nographics 1
test
puts $nographics
text-mode base 0
test
puts $nographics
package require TclOO
namespace eval ct {
namespace export with without layer layers allactive context
variable LayerList {}
}
proc ct::AddLayer {layer} {
variable LayerList
lappend LayerList $layer
}
proc ct::WrapEval {layers body state} {
variable LayerList
# First, check
foreach layer $layers {
if {[lsearch -glob $LayerList "*::$layer"] == -1} {
error "Layer \"$layer\" does not exist"
}
}
foreach layer $layers {
$layer push $state
}
uplevel $body
foreach layer $layers {
$layer pop
}
}
proc ct::layers {} {
variable LayerList
set LayerList
}
proc ct::with {layers body} {
WrapEval $layers $body 1
}
proc ct::without {layers body} {
WrapEval $layers $body 0
}
proc ct::allactive layers {
variable LayerList
# Check if exist & on
set active true
foreach layer $layers {
if {[lsearch -glob $LayerList "*::$layer"] == -1} {
error "Layer \"$layer\" does not exist"
}
set active [expr {$active && [$layer active]}]
}
return $active
}
proc ct::context cbset {
foreach {layers body} $cbset {
if {$layers == "default"} {
uplevel $body
return
}
if [allactive $layers] {
uplevel $body
return
}
}
}
oo::class create ct::layer {
constructor {{varname ""}} {
my variable state
my variable linkvar
my variable linked
## This is awkward -- is there a better way to do it Like Snit's "class" variables
::ct::AddLayer [self]
lappend state 0
set linkvar $varname
set linked [expr {$varname ne ""}]
if $linked {
uplevel trace add variable \
$varname write "\{[self] evaltrace\}"
}
}
method active {} {
my variable state
return [lindex $state end]
}
method base {val} {
my variable state
my variable linkvar
my variable linked
lset state 0 $val
if $linked {
uplevel set $linkvar $val
}
}
method evaltrace {name args} {
my base [uplevel set $name]
}
method push newstate {
my variable state
lappend state $newstate
}
method pop {} {
my variable state
set retval [lindex $state end]
if {[llength $state] > 1} {
set state [lrange $state 0 end-1]
}
return $retval
}
}