1# -*- tcl -*-
2# # ## ### ##### ######## #############
3# (C) 2009 Andreas Kupries
4
5# @@ Meta Begin
6# Package tcl::chan::variable 1
7# Meta as::author {Andreas Kupries}
8# Meta as::copyright 2009
9# Meta as::license BSD
10# Meta description Implementation of a channel representing
11# Meta description an in-memory read-write random-access
12# Meta description file. Based on Tcl 8.5's channel reflection
13# Meta description support. Exports a single command for the
14# Meta description creation of new channels. No arguments.
15# Meta description Result is the handle of the new channel.
16# Meta description Similar to -> tcl::chan::memchan, except
17# Meta description that the variable holding the content
18# Meta description exists outside of the channel itself, in
19# Meta description some namespace, and as such is not a part
20# Meta description of the channel. Seekable beyond the end
21# Meta description of the data, implies appending of 0x00
22# Meta description bytes.
23# Meta platform tcl
24# Meta require TclOO
25# Meta require tcl::chan::events
26# Meta require {Tcl 8.5}
27# @@ Meta End
28
29# # ## ### ##### ######## #############
30
31package require Tcl 8.5
32package require TclOO
33package require tcl::chan::events
34
35# # ## ### ##### ######## #############
36
37namespace eval ::tcl::chan {}
38
39proc ::tcl::chan::variable {varname} {
40    return [::chan create {read write} [variable::implementation new $varname]]
41}
42
43oo::class create ::tcl::chan::variable::implementation {
44    superclass ::tcl::chan::events ; # -> initialize, finalize, watch
45
46    constructor {thevarname} {
47	set varname $thevarname
48	set at 0
49    }
50
51    method initialize {args} {
52	my allow write
53	my Events
54	next {*}$args
55    }
56
57    variable varname at
58
59    method read {c n} {
60	# Bring connected variable for content into scope.
61
62	upvar #0 $varname content
63
64	# First determine the location of the last byte to read,
65	# relative to the current location, and limited by the maximum
66	# location we are allowed to access per the size of the
67	# content.
68
69	set last [expr {min($at + $n,[string length $content])-1}]
70
71	# Then extract the relevant range from the content, move the
72	# seek location behind it, and return the extracted range. Not
73	# to forget, switch readable events based on the seek
74	# location.
75
76	set res [string range $content $at $last]
77	set at $last
78	incr at
79
80	my Events
81	return $res
82    }
83
84    method write {c newbytes} {
85	# Bring connected variable for content into scope.
86
87	upvar #0 $varname content
88
89	# Return immediately if there is nothing is to write.
90	set n [string length $newbytes]
91	if {$n == 0} {
92	    return $n
93	}
94
95	# Determine where and how to write. There are three possible cases.
96	# (1) Append at/after the end.
97	# (2) Starting in the middle, but extending beyond the end.
98	# (3) Replace in the middle.
99
100	set max [string length $content]
101	if {$at >= $max} {
102	    # Ad 1.
103	    append content $newbytes
104	    set at [string length $content]
105	} else {
106	    set last [expr {$at + $n - 1}]
107	    if {$last >= $max} {
108		# Ad 2.
109		set content [string replace $content $at end $newbytes]
110		set at [string length $content]
111	    } else {
112		# Ad 3.
113		set content [string replace $content $at $last $newbytes]
114		set at $last
115		incr at
116	    }
117	}
118
119	my Events
120	return $n
121    }
122
123    method seek {c offset base} {
124	# offset == 0 && base == current
125	# <=> Seek nothing relative to current
126	# <=> Report current location.
127
128	if {!$offset && ($base eq "current")} {
129	    return $at
130	}
131
132	# Bring connected variable for content into scope.
133
134	upvar #0 $varname content
135
136	# Compute the new location per the arguments.
137
138	set max [string length $content]
139	switch -exact -- $base {
140	    start   { set newloc $offset}
141	    current { set newloc [expr {$at  + $offset    }] }
142	    end     { set newloc [expr {$max + $offset - 1}] }
143	}
144
145	# Check if the new location is beyond the range given by the
146	# content.
147
148	if {$newloc < 0} {
149	    return -code error "Cannot seek before the start of the channel"
150	} elseif {$newloc >= $max} {
151	    # We can seek beyond the end of the current contents, add
152	    # a block of zeros.
153	    append content [binary format @[expr {$newloc - $max}]]
154	}
155
156	# Commit to new location, switch readable events, and report.
157	set at $newloc
158
159	my Events
160	return $at
161    }
162
163    method Events {} {
164	if {$at >= [string length $content]} {
165	    my disallow read
166	} else {
167	    my allow read
168	}
169    }
170}
171
172# # ## ### ##### ######## #############
173package provide tcl::chan::variable 1
174return
175