1 files changed, 181 insertions, 0 deletions
diff --git a/tcllib/modules/virtchannel_base/variable.tcl b/tcllib/modules/virtchannel_base/variable.tcl
new file mode 100644
index 0000000..fd6f837
--- /dev/null
+++ b/tcllib/modules/virtchannel_base/variable.tcl
@@ -0,0 +1,181 @@
+# -*- tcl -*-
+# # ## ### ##### ######## #############
+# (C) 2009 Andreas Kupries
+
+# @@ Meta Begin
+# Package tcl::chan::variable 1.0.2
+# Meta as::author {Andreas Kupries}
+# Meta as::copyright 2009
+# Meta as::license BSD
+# Meta description Implementation of a channel representing
+# Meta description an in-memory read-write random-access
+# Meta description file. Based on Tcl 8.5's channel reflection
+# Meta description support. Exports a single command for the
+# Meta description creation of new channels. No arguments.
+# Meta description Result is the handle of the new channel.
+# Meta description Similar to -> tcl::chan::memchan, except
+# Meta description that the variable holding the content
+# Meta description exists outside of the channel itself, in
+# Meta description some namespace, and as such is not a part
+# Meta description of the channel. Seekable beyond the end
+# Meta description of the data, implies appending of 0x00
+# Meta description bytes.
+# Meta platform tcl
+# Meta require TclOO
+# Meta require tcl::chan::events
+# Meta require {Tcl 8.5}
+# @@ Meta End
+
+# # ## ### ##### ######## #############
+
+package require Tcl 8.5
+package require TclOO
+package require tcl::chan::events
+
+# # ## ### ##### ######## #############
+
+namespace eval ::tcl::chan {}
+
+proc ::tcl::chan::variable {varname} {
+    return [::chan create {read write} [variable::implementation new $varname]]
+}
+
+oo::class create ::tcl::chan::variable::implementation {
+    superclass ::tcl::chan::events ; # -> initialize, finalize, watch
+
+    constructor {thevarname} {
+	set varname $thevarname
+	set at 0
+
+	upvar #0 $varname content
+	if {![info exists content]} {
+	    set content {}
+	}
+	next
+    }
+
+    method initialize {args} {
+	my allow write
+	my Events
+	next {*}$args
+    }
+
+    variable varname at 
+
+    method read {c n} {
+	# Bring connected variable for content into scope.
+
+	upvar #0 $varname content
+
+	# First determine the location of the last byte to read,
+	# relative to the current location, and limited by the maximum
+	# location we are allowed to access per the size of the
+	# content.
+
+	set last [expr {min($at + $n,[string length $content])-1}]
+
+	# Then extract the relevant range from the content, move the
+	# seek location behind it, and return the extracted range. Not
+	# to forget, switch readable events based on the seek
+	# location.
+
+	set res [string range $content $at $last]
+	set at $last
+	incr at
+
+	my Events
+	return $res
+    }
+
+    method write {c newbytes} {
+	# Bring connected variable for content into scope.
+
+	upvar #0 $varname content
+
+	# Return immediately if there is nothing is to write.
+	set n [string length $newbytes]
+	if {$n == 0} {
+	    return $n
+	}
+
+	# Determine where and how to write. There are three possible cases.
+	# (1) Append at/after the end.
+	# (2) Starting in the middle, but extending beyond the end.
+	# (3) Replace in the middle.
+
+	set max [string length $content]
+	if {$at >= $max} {
+	    # Ad 1.
+	    append content $newbytes
+	    set at [string length $content]
+	} else {
+	    set last [expr {$at + $n - 1}]
+	    if {$last >= $max} {
+		# Ad 2.
+		set content [string replace $content $at end $newbytes]
+		set at [string length $content]
+	    } else {
+		# Ad 3.
+		set content [string replace $content $at $last $newbytes]
+		set at $last
+		incr at
+	    }
+	}
+
+	my Events
+	return $n
+    }
+
+    method seek {c offset base} {
+	# offset == 0 && base == current
+	# <=> Seek nothing relative to current
+	# <=> Report current location.
+
+	if {!$offset && ($base eq "current")} {
+	    return $at
+	}
+
+	# Bring connected variable for content into scope.
+
+	upvar #0 $varname content
+
+	# Compute the new location per the arguments.
+
+	set max [string length $content]
+	switch -exact -- $base {
+	    start   { set newloc $offset}
+	    current { set newloc [expr {$at  + $offset    }] }
+	    end     { set newloc [expr {$max + $offset - 1}] }
+	}
+
+	# Check if the new location is beyond the range given by the
+	# content.
+
+	if {$newloc < 0} {
+	    return -code error "Cannot seek before the start of the channel"
+	} elseif {$newloc >= $max} {
+	    # We can seek beyond the end of the current contents, add
+	    # a block of zeros.
+	    append content [binary format @[expr {$newloc - $max}]]
+	}
+
+	# Commit to new location, switch readable events, and report.
+	set at $newloc
+
+	my Events
+	return $at
+    }
+
+    method Events {} {
+	# Always readable -- Even if the seek location is at the end
+	# (or beyond).  In that case the readable events are fired
+	# endlessly until the eof indicated by the seek location is
+	# properly processed by the event handler. Like for regular
+	# files -- Ticket [864a0c83e3].
+	my allow read
+    }
+}
+
+# # ## ### ##### ######## #############
+package provide tcl::chan::variable 1.0.3
+return