ContexTcl: Playing with Context-oriented Programming

EKB This is an implementation of a "Context-oriented Programming" (COP) [1 ] framework for Tcl. I have presumptuously called it "ContexTcl", in parallel to the existing ContextJ (for Java), ContextS (Smalltalk), and ContextL (Lisp).

Background

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.

Turning layers on and off

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.

Using layers

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
        }
    }

Examples

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

Implementaton

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
    }
}