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