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