Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

6 files changed, 368 insertions, 0 deletions

diff --git a/tcllib/examples/tie/README.txt b/tcllib/examples/tie/README.txt
new file mode 100644
index 0000000..25029a0
--- /dev/null
+++ b/tcllib/examples/tie/README.txt
@@ -0,0 +1,57 @@
+Documentation of the tie examples
+=================================
+
+metakit.tcl
+	This is the implementation of a data source storing the array
+	in a metakit database.
+
+server.tcl
+sending_client.tcl
+receiving_client.tcl
+
+	These three scripts belong together. They demonstrate how to
+	sharing an array across processes. It uses the package "comm"
+	and the data source "remotearray".
+
+	server.tcl
+
+		is invoked without arguments. It will print the id of
+		the TCP server port it is listening on. It has a
+		single array 'server'. Changes to the array are
+		reported on stdout.
+
+	sending_client.tcl
+
+		is invoked with the id of the server as its only
+		argument. It has a local array 'sender'. Changes to
+		'sender' are exported to the server vie tie,
+		remotearray, and comm. The changes made are hardwired
+		into the script and executed with a delay of 1/10th of
+		a second between them, after a 2 second startup delay.
+
+	receiving_client.tcl
+
+		is invoked with the id of the server as its only
+		argument. It has a local array 'receiver'. Changes to
+		receiver are reported to stdout. The script imports
+		the server array, and any changes on the server are
+		mirrored in the receiver.
+
+	Open three xterm and start the three scripts in them, in the
+	order
+		server.tcl
+		receiving_client.tcl
+		sending_client.tcl
+
+	Two seconds after the sending client has started both server
+	and receiver start to report the changes made by the sender to
+	its array and broadcast to server and then the receiver.
+
+transceiver.tcl
+
+	A combination of both sending_client.tcl and
+	receiving_client.tcl. Exports the local array to the server,
+	and imports the server array to the local one. Performs
+	changes both local and on the server, showing that both
+	changes get distributed to both partners, independent where
+	the change was made.
diff --git a/tcllib/examples/tie/metakit.tcl b/tcllib/examples/tie/metakit.tcl
new file mode 100644
index 0000000..a9484b2
--- /dev/null
+++ b/tcllib/examples/tie/metakit.tcl
@@ -0,0 +1,141 @@
+# -*- tcl -*-
+# Metakit backend for tie
+#
+# (C) 2005 Colin McCormack.
+# Taken from http://wiki.tcl.tk/13716, with permission.
+#
+# CMcC 20050303 - a backend for the tie tcllib package. Persists an
+#                 array in a metakit database. In conjunction with the
+#                 "remote" array backend, this might have similar
+#                 functionality to Tequila.
+
+# Modified AK 2005-09-12
+
+package require Mk4tcl
+package require tie
+package require snit
+
+snit::type mktie {
+    option -var    ""  ; # variable name in metakit
+    option -vtype  S   ; # set the variable value type
+    option -layout {}  ; # additional layout elements
+
+    constructor {args} {
+	$self configurelist $args
+
+	if {$options(-var) eq ""} {
+	    # no variable name supplied - use the caller's name
+	    upvar 3 avar rv     ;# skip some snit nesting
+	    #puts stderr "using $rv"
+	    set options(-var) $rv
+	}
+	#puts stderr "$self - [array get options]"
+	set layout [concat [list name text:$options(-vtype)] $options(-layout)]
+	mk::view layout tqs.$options(-var) $layout
+    }
+
+    # return a list containing the names of all keys found in the
+    # metakit database.
+
+    method names {} {
+	mk::loop c tqs.$options(-var) {
+	    lappend result [mk::get $c name]
+	}
+    }
+
+    # return an integer number specifying the number of keys found in
+    # the metakit database.
+
+    method size {} {
+	return [mk::view size tqs.$options(-var)]
+    }
+
+    # return a dictionary containing the data found in the metakit
+    # database.
+
+    method get {} {
+	set dict [dict create]
+	mk::loop c tqs.$options(-var) {
+	    set val [mk::get $c name text]
+	    #puts stderr "get $options(-var)(\#$c) - $val"
+	    dict set dict {*}$val
+	}
+	return $dict
+    }
+
+    # takes a dictionary and adds its contents to the metakit
+
+    method set {dict} {
+	dict for {key value} $dict {
+	    $self setv $key $value
+	}
+    }
+
+    # removes all elements whose keys match pattern
+
+    method unset {pattern} {
+	set matches [mk::select tqs.$options(-var) -glob name $pattern]
+	foreach n [lsort -integer -decreasing $matches] {
+	    mk::row delete tqs.$options(-var)!$n
+	}
+    }
+
+    # save value under key
+
+    method setv {key value} {
+	set n [mk::select tqs.$options(-var) name $key]
+	if {[llength $n] == 0} {
+	    set n [mk::view size tqs.$options(-var)]
+	} elseif {[mk::get tqs.$options(-var)!$n text] == $value} {
+	    return ; # no change, ignore
+	}
+	#puts stderr "set $options(-var)($key) to $value / $n"
+	mk::set tqs.$options(-var)!$n name $key text $value
+    }
+
+    # remove the value under key
+
+    method unsetv {key} {
+	set n [mk::select tqs.$options(-var) name $key]
+	if {[llength $n] == 0} {
+	    error "can't unset \"$options(-var)($key)\": no such element in array"
+	    return
+	}
+	mk::row delete tqs.$options(-var)!$n
+    }
+
+    # return the value for key
+
+    method getv {key} {
+	set n [mk::select tqs.$options(-var) name $key]
+	if {[llength $n] == 0} {
+	    error "can't read \"$options(-var)($key)\": no such element in array"
+	    return
+	}
+	return [mk::get tqs.$options(-var)!$n text]
+    }
+}
+
+mk::file open tqs tie.dat -nocommit
+::tie::register ::mktie as metakit
+
+package provide mktie 1.0
+
+# ### ### ### ######### ######### #########
+
+if {[info script] eq $argv0} {
+    unset -nocomplain av
+    array set         av {}
+
+    tie::tie av metakit
+    set av(x) blah
+    array set av {a 1 b 2 c 3 z 26}
+    ::tie::untie av
+
+    puts "second pass"
+    unset av
+    array set av {}
+    tie::tie av metakit
+    puts [array size av]
+    puts [array get av]
+}
diff --git a/tcllib/examples/tie/receiving_client.tcl b/tcllib/examples/tie/receiving_client.tcl
new file mode 100644
index 0000000..c41d9d3
--- /dev/null
+++ b/tcllib/examples/tie/receiving_client.tcl
@@ -0,0 +1,38 @@
+#!/usr/bin/env tclsh
+## -*- tcl -*-
+
+package require comm
+package require tie
+
+set id [lindex $argv 0]
+
+proc import {remotevar localvar} {
+    global id
+    comm::comm send $id [list \
+	    tie::tie $remotevar remotearray \
+	    $localvar {comm::comm send} [comm::comm self] \
+	 ]
+}
+
+proc Track {args} {
+    global receiver
+    puts *\ \[[join $args "\] \["]\]\ ([dictsort [array get receiver]])
+    return
+}
+
+proc dictsort {dict} {
+    array set a $dict
+    set out [list]
+    foreach key [lsort [array names a]] {
+	lappend out $key $a($key)
+    }
+    return $out
+}
+
+array set          receiver {}
+trace add variable receiver {write unset} Track
+
+import server receiver
+
+puts "Waiting on $id"
+vwait forever
diff --git a/tcllib/examples/tie/sending_client.tcl b/tcllib/examples/tie/sending_client.tcl
new file mode 100644
index 0000000..1dd200d
--- /dev/null
+++ b/tcllib/examples/tie/sending_client.tcl
@@ -0,0 +1,28 @@
+#!/usr/bin/env tclsh
+## -*- tcl -*-
+
+package require comm
+package require tie
+
+set id [lindex $argv 0]
+
+array set sender {}
+tie::tie  sender remotearray \
+	server {comm::comm send} $id
+
+proc ExecChanges {list} {
+    if {![llength $list]} exit
+
+    uplevel #0 [lindex $list 0]
+    after 100 [list ExecChanges [lrange $list 1 end]]
+}
+
+after 2000 {ExecChanges {
+    {set sender(a) 0}
+    {set sender(a) 1}
+    {set sender(b) .}
+    {unset sender(a)}
+    {array set sender {xa @ xb *}}
+    {array unset sender x*}}}
+
+vwait forever
diff --git a/tcllib/examples/tie/server.tcl b/tcllib/examples/tie/server.tcl
new file mode 100644
index 0000000..d3955bf
--- /dev/null
+++ b/tcllib/examples/tie/server.tcl
@@ -0,0 +1,28 @@
+#!/usr/bin/env tclsh
+## -*- tcl -*-
+# Array server ...
+
+package require comm
+package require tie
+
+puts "Listening on [comm::comm self]"
+
+proc Track {args} {
+    global server
+    puts *\ \[[join $args "\] \["]\]\ ([dictsort [array get server]])
+    return
+}
+
+proc dictsort {dict} {
+    array set a $dict
+    set out [list]
+    foreach key [lsort [array names a]] {
+	lappend out $key $a($key)
+    }
+    return $out
+}
+
+array set          server {}
+trace add variable server {write unset} Track
+
+vwait forever
diff --git a/tcllib/examples/tie/transceiver.tcl b/tcllib/examples/tie/transceiver.tcl
new file mode 100644
index 0000000..8f17c95
--- /dev/null
+++ b/tcllib/examples/tie/transceiver.tcl
@@ -0,0 +1,76 @@
+#!/usr/bin/env tclsh
+## -*- tcl -*-
+
+package require comm
+package require tie
+
+set id [lindex $argv 0]
+
+array set local {}
+
+proc export {localvar remotevar remoteid} {
+    uplevel #0 [list tie::tie $localvar remotearray $remotevar {comm::comm send} $remoteid]
+    return
+}
+
+proc import {remotevar remoteid localvar} {
+    comm::comm send $remoteid [list \
+	    tie::tie $remotevar remotearray \
+	    $localvar {comm::comm send} [comm::comm self] \
+	 ]
+}
+
+proc ExecChanges {list} {
+    if {![llength $list]} return
+
+    uplevel #0 [lindex $list 0]
+    after 100 [list ExecChanges [lrange $list 1 end]]
+}
+
+proc Track {args} {
+    global receiver
+    puts *\ \[[join $args "\] \["]\]\ ([dictsort [array get receiver]])
+    return
+}
+
+proc dictsort {dict} {
+    array set a $dict
+    set out [list]
+    foreach key [lsort [array names a]] {
+	lappend out $key $a($key)
+    }
+    return $out
+}
+
+export local server $id
+import server $id local
+
+trace add variable local {write unset} Track
+
+
+comm::comm send $id {
+    proc ExecChanges {list} {
+	puts ($list)
+	if {![llength $list]} return
+	uplevel #0 [lindex $list 0]
+	after 100 [list ExecChanges [lrange $list 1 end]]
+    }
+}
+
+set changes {
+    {set local(a) 0}
+    {set local(a) 1}
+    {set local(b) .}
+    {unset local(a)}
+    {array set local {xa @ xb *}}
+    {array unset local x*}
+}
+lappend changes \
+	[list comm::comm send $id [list ExecChanges {
+    {set server(ZZ) foo}
+    {set server(XX) bar}
+}]]
+
+after 2000 [list ExecChanges $changes]
+
+vwait forever