EKB This is an implementation of a "Context-oriented Programming" (COP) framework for Tcl.
The basic idea of COP is that there is a globally defined and dynamic context in which code is executed. The context is programmatically available through "layers", which may be either on or off. 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 them to either be defined with an optional linked 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 monitors -- 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 "mini-context".
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
}
}==== 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
## This is awkward -- is there a better way to do it Like Snit's "class" variables
::ct::AddLayer [self]
lappend state 0
if {$varname ne ""} {
uplevel trace add variable \
$varname write "\{[self] evaltrace\}"
}
}
method active {} {
my variable state
return [lindex $state end]
}
method base {val} {
my variable state
lset state 0 $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
}} ====
==== 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} ====
| enter categories here |
|---|