1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
|
# -*- tcl -*-
# # ## ### ##### ######## #############
# (C) 2009 Andreas Kupries
# @@ Meta Begin
# Package tcl::chan::variable 1.0.5
# 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 9
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 }] }
}
# 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.5
return
|
