Attachment "virtchan.patch" to
ticket [1985a34255]
added by
chwchw
2021-04-22 12:10:40.
Index: modules/virtchannel_base/facade.tcl
==================================================================
--- modules/virtchannel_base/facade.tcl
+++ modules/virtchannel_base/facade.tcl
@@ -30,11 +30,11 @@
# @@ Meta End
# # ## ### ##### ######## #############
## TODO document the special options of the facade
## TODO log integration.
-## TODO document that facada takes ownership of the channel.
+## TODO document that facade takes ownership of the channel.
package require Tcl 8.5
package require TclOO
package require logger
package require tcl::chan::core
@@ -204,10 +204,22 @@
-user $user
log::debug {[self] cgetall $myself -> $result}
return $result
}
+
+ method seek {myself offset base} {
+ set value [::chan seek $chan $offset $base]
+ log::debug {[self] seek $myself $option $base -> $value}
+ return $value
+ }
+
+ method truncate {myself newloc} {
+ ::chan truncate $chan $newloc
+ log::debug {[self] truncate $myself $newloc}
+ return
+ }
# # ## ### ##### ######## #############
# Internals. Methods. Event generation.
method Readable {myself} {
@@ -228,7 +240,7 @@
# # ## ### ##### ######## #############
}
# # ## ### ##### ######## #############
-package provide tcl::chan::facade 1.0.1
+package provide tcl::chan::facade 1.0.2
return
Index: modules/virtchannel_base/halfpipe.tcl
==================================================================
--- modules/virtchannel_base/halfpipe.tcl
+++ modules/virtchannel_base/halfpipe.tcl
@@ -146,11 +146,11 @@
# is to split the buffer into two. An append-only receive buffer
# (`write`) for incoming data, and a `read` buffer with the
# pointer. When the current read buffer is entirely consumed the
# current receive buffer becomes the new read buffer and a new
# empty receive buffer is started.
-
+
# # ## ### ##### ######## #############
constructor {args} {
array set options {
-write-command {}
Index: modules/virtchannel_base/memchan.tcl
==================================================================
--- modules/virtchannel_base/memchan.tcl
+++ modules/virtchannel_base/memchan.tcl
@@ -57,11 +57,11 @@
my allow write
my Events
next {*}$args
}
- variable content at
+ variable content at
method read {c n} {
# 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
@@ -151,10 +151,28 @@
set at $newloc
my Events
return $at
}
+
+ method truncate {c newloc} {
+ # Check if the new location is beyond the range given by the
+ # content.
+
+ set max [string length $content]
+ if {$newloc < 0} {
+ return -code error "Cannot truncate before the start of the channel"
+ } elseif {$newloc > $max} {
+ # We can truncate beyond the end of the current contents, add
+ # a block of zeros.
+ #puts XXX.PAD.[expr {$newloc - $max}]
+ append content [binary format @[expr {$newloc - $max}]]
+ } elseif {$newloc < $max} {
+ set content [string range $content 0 $newloc-1]
+ }
+ return
+ }
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
@@ -163,7 +181,7 @@
my allow read
}
}
# # ## ### ##### ######## #############
-package provide tcl::chan::memchan 1.0.4
+package provide tcl::chan::memchan 1.0.5
return
Index: modules/virtchannel_base/pkgIndex.tcl
==================================================================
--- modules/virtchannel_base/pkgIndex.tcl
+++ modules/virtchannel_base/pkgIndex.tcl
@@ -1,17 +1,17 @@
if {![package vsatisfies [package provide Tcl] 8.5]} {return}
package ifneeded tcl::chan::cat 1.0.3 [list source [file join $dir cat.tcl]]
-package ifneeded tcl::chan::facade 1.0.1 [list source [file join $dir facade.tcl]]
+package ifneeded tcl::chan::facade 1.0.2 [list source [file join $dir facade.tcl]]
package ifneeded tcl::chan::fifo 1 [list source [file join $dir fifo.tcl]]
package ifneeded tcl::chan::fifo2 1 [list source [file join $dir fifo2.tcl]]
package ifneeded tcl::chan::halfpipe 1.0.1 [list source [file join $dir halfpipe.tcl]]
-package ifneeded tcl::chan::memchan 1.0.4 [list source [file join $dir memchan.tcl]]
+package ifneeded tcl::chan::memchan 1.0.5 [list source [file join $dir memchan.tcl]]
package ifneeded tcl::chan::null 1 [list source [file join $dir null.tcl]]
package ifneeded tcl::chan::nullzero 1 [list source [file join $dir nullzero.tcl]]
package ifneeded tcl::chan::random 1 [list source [file join $dir random.tcl]]
package ifneeded tcl::chan::std 1.0.1 [list source [file join $dir std.tcl]]
package ifneeded tcl::chan::string 1.0.3 [list source [file join $dir string.tcl]]
package ifneeded tcl::chan::textwindow 1 [list source [file join $dir textwindow.tcl]]
-package ifneeded tcl::chan::variable 1.0.4 [list source [file join $dir variable.tcl]]
+package ifneeded tcl::chan::variable 1.0.5 [list source [file join $dir variable.tcl]]
package ifneeded tcl::chan::zero 1 [list source [file join $dir zero.tcl]]
package ifneeded tcl::randomseed 1 [list source [file join $dir randseed.tcl]]
Index: modules/virtchannel_base/string.tcl
==================================================================
--- modules/virtchannel_base/string.tcl
+++ modules/virtchannel_base/string.tcl
@@ -49,11 +49,11 @@
method initialize {args} {
my Events
next {*}$args
}
- variable content at
+ variable content at
method read {c n} {
# First determine the location of the last byte to read,
# relative to the current location, and limited by the maximum
Index: modules/virtchannel_base/variable.tcl
==================================================================
--- modules/virtchannel_base/variable.tcl
+++ modules/virtchannel_base/variable.tcl
@@ -58,11 +58,11 @@
my allow write
my Events
next {*}$args
}
- variable varname at
+ variable varname at
method read {c n} {
# Bring connected variable for content into scope.
upvar #0 $varname content
@@ -163,10 +163,32 @@
set at $newloc
my Events
return $at
}
+
+ method truncate {c newloc} {
+ # Bring connected variable for content into scope.
+
+ upvar #0 $varname content
+
+ # Check if the new location is beyond the range given by the
+ # content.
+
+ set max [string length $content]
+ if {$newloc < 0} {
+ return -code error "Cannot truncate before the start of the channel"
+ } elseif {$newloc > $max} {
+ # We can truncate beyond the end of the current contents, add
+ # a block of zeros.
+ #puts XXX.PAD.[expr {$newloc - $max}]
+ append content [binary format @[expr {$newloc - $max}]]
+ } elseif {$newloc < $max} {
+ set content [string range $content 0 $newloc-1]
+ }
+ return
+ }
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
@@ -175,7 +197,7 @@
my allow read
}
}
# # ## ### ##### ######## #############
-package provide tcl::chan::variable 1.0.4
+package provide tcl::chan::variable 1.0.5
return
Index: modules/virtchannel_core/core.tcl
==================================================================
--- modules/virtchannel_core/core.tcl
+++ modules/virtchannel_core/core.tcl
@@ -43,11 +43,11 @@
set channel $thechannel
set supported {}
foreach m {
initialize finalize watch read write seek configure cget
- cgetall blocking
+ cgetall blocking truncate
} {
if {$m in $methods} {
lappend supported $m
}
}
Index: modules/virtchannel_core/events.tcl
==================================================================
--- modules/virtchannel_core/events.tcl
+++ modules/virtchannel_core/events.tcl
@@ -86,11 +86,11 @@
# # ## ### ##### ######## #############
# Event System State - Timer driven
- variable timer allowed requested posting delay
+ variable timer allowed requested posting delay
# channel = The channel to post events to - provided by superclass
# timer = Timer controlling the posting.
# allowed = Set of events allowed to post.
# requested = Set of events requested by core.
Index: modules/virtchannel_transform/rot.tcl
==================================================================
--- modules/virtchannel_transform/rot.tcl
+++ modules/virtchannel_transform/rot.tcl
@@ -80,16 +80,14 @@
set n [binary format c \
[expr { (($dx - 97 + $key) % 26) + 97 }]]
} else {
set n $d
}
-
append result $n
-
}
return $result
}
}
# # ## ### ##### ######## #############
package provide tcl::transform::rot 1
return
