[EKB] This is an implementation of a "Context-oriented Programming" (COP) 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 them to either be defined with an optional linked 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 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".

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

**Code**

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

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


----
!!!!!!
%| enter categories here |%
!!!!!!