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