From b31ea43affa04580e6a74cb40e63c3455b0ed485 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Tue, 19 Mar 2024 00:04:11 +1100 Subject: [PATCH] add Tcllib's tcl::chan virtchannel packages to vendorlib --- src/vendorlib/virtchannel_base/ChangeLog | 124 ++++++++++ src/vendorlib/virtchannel_base/README.txt | 44 ++++ src/vendorlib/virtchannel_base/cat.man | 48 ++++ src/vendorlib/virtchannel_base/cat.tcl | 135 ++++++++++ src/vendorlib/virtchannel_base/cat.test | 69 ++++++ src/vendorlib/virtchannel_base/facade.man | 73 ++++++ src/vendorlib/virtchannel_base/facade.tcl | 234 ++++++++++++++++++ src/vendorlib/virtchannel_base/fifo.tcl | 138 +++++++++++ src/vendorlib/virtchannel_base/fifo2.tcl | 113 +++++++++ src/vendorlib/virtchannel_base/fifo2.test | 82 ++++++ src/vendorlib/virtchannel_base/halfpipe.man | 81 ++++++ src/vendorlib/virtchannel_base/halfpipe.tcl | 194 +++++++++++++++ src/vendorlib/virtchannel_base/memchan.tcl | 169 +++++++++++++ src/vendorlib/virtchannel_base/memchan.test | 92 +++++++ src/vendorlib/virtchannel_base/null.tcl | 54 ++++ src/vendorlib/virtchannel_base/nullzero.man | 44 ++++ src/vendorlib/virtchannel_base/nullzero.tcl | 62 +++++ src/vendorlib/virtchannel_base/pkgIndex.tcl | 17 ++ src/vendorlib/virtchannel_base/random.tcl | 80 ++++++ src/vendorlib/virtchannel_base/randseed.man | 43 ++++ src/vendorlib/virtchannel_base/randseed.tcl | 58 +++++ src/vendorlib/virtchannel_base/std.man | 43 ++++ src/vendorlib/virtchannel_base/std.tcl | 97 ++++++++ src/vendorlib/virtchannel_base/string.tcl | 124 ++++++++++ src/vendorlib/virtchannel_base/string.test | 94 +++++++ .../virtchannel_base/tcllib_fifo.man | 43 ++++ .../virtchannel_base/tcllib_fifo2.man | 50 ++++ .../virtchannel_base/tcllib_memchan.man | 45 ++++ .../virtchannel_base/tcllib_null.man | 45 ++++ .../virtchannel_base/tcllib_random.man | 46 ++++ .../virtchannel_base/tcllib_string.man | 46 ++++ .../virtchannel_base/tcllib_variable.man | 47 ++++ .../virtchannel_base/tcllib_zero.man | 45 ++++ src/vendorlib/virtchannel_base/textwindow.man | 39 +++ src/vendorlib/virtchannel_base/textwindow.tcl | 74 ++++++ src/vendorlib/virtchannel_base/variable.tcl | 181 ++++++++++++++ src/vendorlib/virtchannel_base/variable.test | 102 ++++++++ src/vendorlib/virtchannel_base/zero.tcl | 54 ++++ src/vendorlib/virtchannel_core/ChangeLog | 39 +++ src/vendorlib/virtchannel_core/README.txt | 5 + src/vendorlib/virtchannel_core/core.man | 72 ++++++ src/vendorlib/virtchannel_core/core.tcl | 73 ++++++ src/vendorlib/virtchannel_core/events.man | 79 ++++++ src/vendorlib/virtchannel_core/events.tcl | 154 ++++++++++++ src/vendorlib/virtchannel_core/pkgIndex.tcl | 8 + .../virtchannel_core/transformcore.man | 72 ++++++ .../virtchannel_core/transformcore.tcl | 71 ++++++ src/vendorlib/virtchannel_transform/ChangeLog | 53 ++++ .../virtchannel_transform/README.txt | 38 +++ .../virtchannel_transform/adler32.man | 70 ++++++ .../virtchannel_transform/adler32.tcl | 103 ++++++++ .../virtchannel_transform/base64.tcl | 111 +++++++++ .../virtchannel_transform/counter.tcl | 94 +++++++ src/vendorlib/virtchannel_transform/crc32.tcl | 103 ++++++++ src/vendorlib/virtchannel_transform/hex.man | 43 ++++ src/vendorlib/virtchannel_transform/hex.tcl | 58 +++++ .../virtchannel_transform/identity.man | 50 ++++ .../virtchannel_transform/identity.tcl | 59 +++++ .../virtchannel_transform/limitsize.man | 46 ++++ .../virtchannel_transform/limitsize.tcl | 88 +++++++ .../virtchannel_transform/observe.man | 50 ++++ .../virtchannel_transform/observe.tcl | 80 ++++++ src/vendorlib/virtchannel_transform/otp.tcl | 98 ++++++++ .../virtchannel_transform/pkgIndex.tcl | 14 ++ src/vendorlib/virtchannel_transform/rot.man | 57 +++++ src/vendorlib/virtchannel_transform/rot.tcl | 95 +++++++ .../virtchannel_transform/spacer.man | 45 ++++ .../virtchannel_transform/spacer.tcl | 151 +++++++++++ .../virtchannel_transform/tcllib_zlib.man | 46 ++++ .../virtchannel_transform/vt_base64.man | 44 ++++ .../virtchannel_transform/vt_counter.man | 68 +++++ .../virtchannel_transform/vt_crc32.man | 70 ++++++ .../virtchannel_transform/vt_otp.man | 53 ++++ src/vendorlib/virtchannel_transform/zlib.tcl | 100 ++++++++ 74 files changed, 5589 insertions(+) create mode 100644 src/vendorlib/virtchannel_base/ChangeLog create mode 100644 src/vendorlib/virtchannel_base/README.txt create mode 100644 src/vendorlib/virtchannel_base/cat.man create mode 100644 src/vendorlib/virtchannel_base/cat.tcl create mode 100644 src/vendorlib/virtchannel_base/cat.test create mode 100644 src/vendorlib/virtchannel_base/facade.man create mode 100644 src/vendorlib/virtchannel_base/facade.tcl create mode 100644 src/vendorlib/virtchannel_base/fifo.tcl create mode 100644 src/vendorlib/virtchannel_base/fifo2.tcl create mode 100644 src/vendorlib/virtchannel_base/fifo2.test create mode 100644 src/vendorlib/virtchannel_base/halfpipe.man create mode 100644 src/vendorlib/virtchannel_base/halfpipe.tcl create mode 100644 src/vendorlib/virtchannel_base/memchan.tcl create mode 100644 src/vendorlib/virtchannel_base/memchan.test create mode 100644 src/vendorlib/virtchannel_base/null.tcl create mode 100644 src/vendorlib/virtchannel_base/nullzero.man create mode 100644 src/vendorlib/virtchannel_base/nullzero.tcl create mode 100644 src/vendorlib/virtchannel_base/pkgIndex.tcl create mode 100644 src/vendorlib/virtchannel_base/random.tcl create mode 100644 src/vendorlib/virtchannel_base/randseed.man create mode 100644 src/vendorlib/virtchannel_base/randseed.tcl create mode 100644 src/vendorlib/virtchannel_base/std.man create mode 100644 src/vendorlib/virtchannel_base/std.tcl create mode 100644 src/vendorlib/virtchannel_base/string.tcl create mode 100644 src/vendorlib/virtchannel_base/string.test create mode 100644 src/vendorlib/virtchannel_base/tcllib_fifo.man create mode 100644 src/vendorlib/virtchannel_base/tcllib_fifo2.man create mode 100644 src/vendorlib/virtchannel_base/tcllib_memchan.man create mode 100644 src/vendorlib/virtchannel_base/tcllib_null.man create mode 100644 src/vendorlib/virtchannel_base/tcllib_random.man create mode 100644 src/vendorlib/virtchannel_base/tcllib_string.man create mode 100644 src/vendorlib/virtchannel_base/tcllib_variable.man create mode 100644 src/vendorlib/virtchannel_base/tcllib_zero.man create mode 100644 src/vendorlib/virtchannel_base/textwindow.man create mode 100644 src/vendorlib/virtchannel_base/textwindow.tcl create mode 100644 src/vendorlib/virtchannel_base/variable.tcl create mode 100644 src/vendorlib/virtchannel_base/variable.test create mode 100644 src/vendorlib/virtchannel_base/zero.tcl create mode 100644 src/vendorlib/virtchannel_core/ChangeLog create mode 100644 src/vendorlib/virtchannel_core/README.txt create mode 100644 src/vendorlib/virtchannel_core/core.man create mode 100644 src/vendorlib/virtchannel_core/core.tcl create mode 100644 src/vendorlib/virtchannel_core/events.man create mode 100644 src/vendorlib/virtchannel_core/events.tcl create mode 100644 src/vendorlib/virtchannel_core/pkgIndex.tcl create mode 100644 src/vendorlib/virtchannel_core/transformcore.man create mode 100644 src/vendorlib/virtchannel_core/transformcore.tcl create mode 100644 src/vendorlib/virtchannel_transform/ChangeLog create mode 100644 src/vendorlib/virtchannel_transform/README.txt create mode 100644 src/vendorlib/virtchannel_transform/adler32.man create mode 100644 src/vendorlib/virtchannel_transform/adler32.tcl create mode 100644 src/vendorlib/virtchannel_transform/base64.tcl create mode 100644 src/vendorlib/virtchannel_transform/counter.tcl create mode 100644 src/vendorlib/virtchannel_transform/crc32.tcl create mode 100644 src/vendorlib/virtchannel_transform/hex.man create mode 100644 src/vendorlib/virtchannel_transform/hex.tcl create mode 100644 src/vendorlib/virtchannel_transform/identity.man create mode 100644 src/vendorlib/virtchannel_transform/identity.tcl create mode 100644 src/vendorlib/virtchannel_transform/limitsize.man create mode 100644 src/vendorlib/virtchannel_transform/limitsize.tcl create mode 100644 src/vendorlib/virtchannel_transform/observe.man create mode 100644 src/vendorlib/virtchannel_transform/observe.tcl create mode 100644 src/vendorlib/virtchannel_transform/otp.tcl create mode 100644 src/vendorlib/virtchannel_transform/pkgIndex.tcl create mode 100644 src/vendorlib/virtchannel_transform/rot.man create mode 100644 src/vendorlib/virtchannel_transform/rot.tcl create mode 100644 src/vendorlib/virtchannel_transform/spacer.man create mode 100644 src/vendorlib/virtchannel_transform/spacer.tcl create mode 100644 src/vendorlib/virtchannel_transform/tcllib_zlib.man create mode 100644 src/vendorlib/virtchannel_transform/vt_base64.man create mode 100644 src/vendorlib/virtchannel_transform/vt_counter.man create mode 100644 src/vendorlib/virtchannel_transform/vt_crc32.man create mode 100644 src/vendorlib/virtchannel_transform/vt_otp.man create mode 100644 src/vendorlib/virtchannel_transform/zlib.tcl diff --git a/src/vendorlib/virtchannel_base/ChangeLog b/src/vendorlib/virtchannel_base/ChangeLog new file mode 100644 index 0000000..a67b5d4 --- /dev/null +++ b/src/vendorlib/virtchannel_base/ChangeLog @@ -0,0 +1,124 @@ +2019-03-12 Aldo Buratti + + * cat.tcl - BUGFIX in event-handling . Version bumped to 1.0.3 + * +2013-12-17 Andreas Kupries + + * randseed.man: Fixed package name. + +2013-11-22 Andreas Kupries + + * memchan.tcl (Events): Ticket [864a0c83e3]. Do not suppress + * string.tcl: readable events at end of the channel. Needed + * variable.tcl: to signal the eof condition. Like for regular + files, always readable. Versions bumped to 1.0.3, 1.0.2, and + 1.0.3 respectively + +2013-04-03 Andreas Kupries + + * tclib_fifo2.man: Renamed more manpages, clashing with the + * tclib_fifo.man: Memchan package. List are the new names, + * tclib_memchan.man: with prefix "tcllib_". + * tclib_null.man: + * tclib_random.man: + * tclib_zero.man: + +2013-03-04 Andreas Kupries + + * string.man: Renamed, clashes with Tcl core manpage. + * tcllib_string.man: New name. + + * variable.man: Renamed, clashes with Tcl core manpage. + * tcllib_variable.man: New name. + +2013-02-01 Andreas Kupries + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2012-10-05 Andreas Kupries + + * cat.tcl (read): Fixed bugs in the reader. Bad check of buffer + * pkgIndex.tcl: length, and buffer length was not taken into + account for the next read after an incomplete one. Version + bumped to 1.0.2. + +2011-12-13 Andreas Kupries + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-08-09 Andreas Kupries + + * memchan.tcl: Fixed missing initialization of 'content' instance + variable. Bumped to version 1.0.2. + + * variable.tcl: Fixed missing invokation of superclass + constructor. Fixed missing initialization of linked 'content' + variable, if not existing. Fixed missing import of linked + variable into the event handling. Bumped to version 1.0.2. + + * cat.tcl: Removed bogus invokation of superclass constructor, + there is no such. Bumped to version 1.0.1. + + * facade.tcl: Added missing logger requirements, dropped bogus + call to superclass constructor. Bumped to version 1.0.1. + + * std.tcl: Fixed command scoping issues, and dropped bogus call to + superclass constructor. Bumped to version 1.0.1. + +2011-05-31 Andreas Kupries + + * cat.man: New base channels. Concatenation of channels, + * cat.tcl: standard channel combining stdin and stdout, + * facade.man: and a facade for wrapping around other + * facade.tcl: channels. + * std.man: + * std.tcl: + * pkgIndex.tcl: + +2011-02-21 Andreas Kupries + + * pkgIndex.tcl: Removed the superfluous [list] command in the + ifneeded script. + +2011-02-16 Andreas Kupries + + * memchan.tcl: Fixed constructor chaining, added the missing + * pkgIndex.tcl: 'next'. The bug prevented proper initialization + * string.tcl: of the event core. All versions bumped to 1.0.1 + * variable.tcl: + +2011-01-24 Andreas Kupries + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2010-07-29 Andreas Kupries + + * fifo.man: New files, documentation for the packages in + * fifo2.man: this module. + * halfpipe.man: + * memchan.man: + * null.man: + * nullzero.man: + * random.man: + * randseed.man: + * string.man: + * textwindow.man: + * variable.man: + * zero.man: + +2009-12-07 Andreas Kupries + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-12-01 Andreas Kupries + + * New module 'virtchannel_base', providing classes implementing + various virtual channels aka reflected channels. TclOO based. diff --git a/src/vendorlib/virtchannel_base/README.txt b/src/vendorlib/virtchannel_base/README.txt new file mode 100644 index 0000000..4b1e65f --- /dev/null +++ b/src/vendorlib/virtchannel_base/README.txt @@ -0,0 +1,44 @@ +null, zero, fifo, memchan, fifo2 + + Re-implementations of Memchan's channel types. + +random + + Semi re-implementation of a Memchan channel type. + "Random" byte generator, simple feedback register. + Memchan uses ISAAC (http://burtleburtle.net/bob/rand/isaacafa.html). + +string, variable + + Variants of 'memchan', with fixed content, and the content + factored out to a namespaced variable, respectively. + +randomseed + + Support to generate and combine seed lists for the + random channel, using semi-random sources in Tcl. + +halfpipe + + Half channel, simpler callback API. fifo2 is build on top this + basic block. + +textwindow + + Channel attaches to text widget to write data into. + +cat + + Concatenation channel, delivering the data from 1 or more + channels, one after the other. + +facade + + A wrapper around any other channel. Mainly for debugging, + allowing a developer to observe the activity on the wrapped + channel. + +std + + Unification of stdin and stdout into a single read/write + channel diff --git a/src/vendorlib/virtchannel_base/cat.man b/src/vendorlib/virtchannel_base/cat.man new file mode 100644 index 0000000..f1feb05 --- /dev/null +++ b/src/vendorlib/virtchannel_base/cat.man @@ -0,0 +1,48 @@ +[comment {-*- tcl -*- doctools manpage}] +[vset Version 1.0.4] +[manpage_begin tcl::chan::cat n [vset Version]] +[keywords {concatenation channel}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2011 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Concatenation channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::core [opt 1.1]] +[require tcl::chan::cat [opt [vset Version]]] +[description] +[para] + +The [package tcl::chan::cat] package provides a command creating +concatenation channels. These are non-seekable channels owning a list +of subordinate channels whose contents they return in order, until all +are exhausted. In this manner the channel is the concatentation of the +contents of all the sub-ordinate channels. + +[para] Note that the created channels take ownership of the channels +they were constructed with. Whenever they have exhausted one of their +channel it will be closed. Similarly, closing the cat channel will +close all the sub-ordinates it still has. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::core] framework. + +[para] Event handling is delegated to the currently active sub-channel. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::cat] [arg chan]...] + +This command creates the concatenation channel using all the provided +channels, and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/cat.tcl b/src/vendorlib/virtchannel_base/cat.tcl new file mode 100644 index 0000000..28a287a --- /dev/null +++ b/src/vendorlib/virtchannel_base/cat.tcl @@ -0,0 +1,135 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2011,2019 Andreas Kupries + +# Facade concatenating the contents of the channels it was constructed +# with. Owns the sub-ordinate channels and closes them on exhaustion and/or +# when closed itself. + +# @@ Meta Begin +# Package tcl::chan::cat 1.0.4 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2011 +# Meta as::license BSD +# Meta description Facade concatenating the contents of the channels it +# Meta description was constructed with. Owns the sub-ordinate channels +# Meta description and closes them on exhaustion and/or when closed itself. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::core +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::cat {args} { + return [::chan create {read} [cat::implementation new {*}$args]] +} + +oo::class create ::tcl::chan::cat::implementation { + superclass ::tcl::chan::core ; # -> initialize, finalize. + + # We are not using the standard event handling class, because here + # it will not be timer-driven. We propagate anything related to + # events to catin and catout instead and let them handle things. + + constructor {args} { + set channels $args + # Disable translation (and hence encoding) in the wrapped channels. + # This will happen in our generic layer instead. + foreach c $channels { + fconfigure $c -translation binary + } + set delay 10 + set watching 0 + return + } + + destructor { + foreach c $channels { + ::close $c + } + return + } + + variable channels timer delay watching + + method watch {c requestmask} { + if {"read" in $requestmask} { + # Activate event handling. Either drive an eof home via + # timers, or activate things in the foremost sub-ordinate. + + set watching 1 + if {![llength $channels]} { + set timer [after $delay [namespace code [list my Post $c]]] + } else { + chan event [lindex $channels 0] readable [list chan postevent $c read] + } + } else { + # Stop events. Either kill timer, or disable in the + # foremost sub-ordinate. + + set watching 0 + if {![llength $channels]} { + catch { after cancel $timer } + } else { + chan event [lindex $channels 0] readable {} + } + } + return + } + + method read {c n} { + if {![llength $channels]} { + # This signals EOF higher up. + return {} + } + + set buf {} + while {([string length $buf] < $n) && + [llength $channels]} { + + set in [lindex $channels 0] + set toread [expr {$n - [string length $buf]}] + append buf [::read $in $toread] + + if {[eof $in]} { + close $in + set channels [lrange $channels 1 end] + + # The close of the exhausted subordinate killed any + # fileevent handling we may have had attached to this + # channel. Update the settings (i.e. move to the next + # subordinate, or to timer-based, to drive the eof + # home). + + if {$watching} { + my watch $c read + } + } + } + + # When `buf` is empty, all channels have been exhausted and + # closed, therefore returning this empty string will cause an + # EOF higher up. + return $buf + } + + method Post {c} { + set timer [after $delay [namespace code [list my Post $c]]] + chan postevent $c read + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::cat 1.0.4 +return diff --git a/src/vendorlib/virtchannel_base/cat.test b/src/vendorlib/virtchannel_base/cat.test new file mode 100644 index 0000000..7389e0d --- /dev/null +++ b/src/vendorlib/virtchannel_base/cat.test @@ -0,0 +1,69 @@ +#- - -- --- ----- -------- ------------- --------------------- +# cat.test -*- tcl -*- +# (C) 2019 Andreas Kupries. BSD licensed. +#- - -- --- ----- -------- ------------- --------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.0 +testsNeed TclOO 1 + +support { + use virtchannel_core/core.tcl tcl::chan::core + use virtchannel_core/events.tcl tcl::chan::events + useLocal string.tcl tcl::chan::string +} +testing { + useLocal cat.tcl tcl::chan::cat +} + +#- - -- --- ----- -------- ------------- --------------------- +## No wrong#args, allowed to zero and up + +#- - -- --- ----- -------- ------------- --------------------- + +test tcl-chan-cat-2.0 {tell, nothing} -setup { + set c [tcl::chan::cat] +} -body { + tell $c +} -cleanup { + close $c + unset c +} -result -1 + +test tcl-chan-cat-2.1 {ticket 1975182bdd - file events} -setup { + # setup a cat'enated channel + set fa [tcl::chan::string "ABCDE..XYZ"] + set fb [tcl::chan::string "0123456789"] + set ch [tcl::chan::cat $fa $fb] +} -body { + set r {} + chan event $ch readable { + if { [eof $ch] } { + set done . + } else { + lappend r [read $ch 4] + } + } + vwait done + set r +} -cleanup { + close $ch + unset ch fa fb r +} -result {ABCD E..X YZ01 2345 6789 {}} + +#- - -- --- ----- -------- ------------- --------------------- +# Explicit cleanup of loaded support classes. + +rename tcl::chan::events {} +rename tcl::chan::core {} +testsuiteCleanup +return + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/vendorlib/virtchannel_base/facade.man b/src/vendorlib/virtchannel_base/facade.man new file mode 100644 index 0000000..c0a477c --- /dev/null +++ b/src/vendorlib/virtchannel_base/facade.man @@ -0,0 +1,73 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::facade n 1.1] +[keywords {concatenation channel}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2011 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Facade channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require logger] +[require tcl::chan::core [opt 1.1]] +[require tcl::chan::facade [opt 1.1]] +[description] +[para] + +The [package tcl::chan::facade] package provides a command creating +facades to other channels. These are channels which own a single +subordinate channel and delegate all operations to. + +[para] The main use for facades is the debugging of actions on a +channel. While most of the information could be tracked by a virtual +channel transformation it does not have access to the event-related +operation, and furthermore they are only available in Tcl 8.6. + +[para] Therefore this channel, usable with Tcl 8.5, and having access +to everything going on for a channel. + +[para] The intercepted actions on channel are logged through package +[package logger]. + +[para] Beyond that facades provide the following additional channel +configuration options: + +[list_begin options] +[opt_def -self] +The TclOO object handling the facade. + +[opt_def -fd] +The handle of the subordinate, i.e. wrapped channel. + +[opt_def -used] +The last time the wrapped channel was read from or written to by +the facade, as per [cmd {clock milliseconds}]. A value of [const 0] +indicates that the subordinate channel was not accessed at all, yet. + +[opt_def -created] +The time the facade was created, as per [cmd {clock milliseconds}]. + +[opt_def -user] +A free-form value identifying the user of the facade and its +wrapped channel. + +[list_end] + +Of these only option [option -user] is writable. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::facade] [arg chan]] + +This command creates the facade channel around the provided +channel [arg chan], and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/facade.tcl b/src/vendorlib/virtchannel_base/facade.tcl new file mode 100644 index 0000000..d738446 --- /dev/null +++ b/src/vendorlib/virtchannel_base/facade.tcl @@ -0,0 +1,234 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2011 Andreas Kupries + +# Facade wrapping around some other channel. All operations on the +# facade are delegated to the wrapped channel. This makes it useful +# for debugging of Tcl's activity on a channel. While a transform can +# be used for that as well it does not have access to some things of +# the base-channel, i.e. all the event managment is not visible to it, +# whereas the facade has access to even this. + +# @@ Meta Begin +# Package tcl::chan::facade 1.0.2 +# Meta as::author {Colin McCormack} +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2011 +# Meta as::license BSD +# Meta description Facade wrapping around some other channel. All +# Meta description operations on the facade are delegated to the +# Meta description wrapped channel. This makes it useful for debugging +# Meta description of Tcl's activity on a channel. While a transform +# Meta description can be used for that as well it does not have +# Meta description access to some things of the base-channel, i.e. all +# Meta description the event managment is not visible to it, whereas +# Meta description the facade has access to even this. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::core +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# +## TODO document the special options of the facade +## TODO log integration. +## TODO document that facada takes ownership of the channel. + +package require Tcl 8.5 9 +package require TclOO +package require logger +package require tcl::chan::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +logger::initNamespace ::tcl::chan::facade +proc ::tcl::chan::facade {args} { + return [::chan create {read} [facade::implementation new {*}$args]] +} + +# # ## ### ##### ######## ############# + +oo::class create ::tcl::chan::facade::implementation { + superclass ::tcl::chan::core ; # -> initialize, finalize. + + # # ## ### ##### ######## ############# + + # We are not using the standard event handling class, because here + # it will not be timer-driven. We propagate anything related to + # events to the wrapped channel instead and let it handle things. + + constructor {thechan} { + # Access to the log(ger) commands. + namespace path [list {*}[namespace path] ::tcl::chan::facade] + + set chan $thechan + + # set some configuration data + set created [clock milliseconds] + set used 0 + set user "" ;# user data - freeform + + # validate args + if {$chan eq [self]} { + return -code error "recursive chan! No good." + } elseif {$chan eq ""} { + return -code error "Needs a chan argument" + } + + set blocking [::chan configure $chan -blocking] + return + } + + destructor { + log::debug {[self] destroyed} + if {[catch { ::chan close $chan } e o]} { + log::debug {failed to close $chan [self] because "$e" ($o)} + } + return + } + + variable chan used user created blocking + + method initialize {myself mode} { + log::debug {$myself initialize $chan $mode} + log::debug {$chan configured: ([::chan configure $chan])} + return [next $chan $mode] + } + + method finalize {myself} { + log::debug {$myself finalize $chan} + catch {::chan close $chan} + catch {next $myself} + catch {my destroy} + return + } + + method blocking {myself mode} { + if {[catch { + ::chan configure $chan -blocking $mode + set blocking $mode + } e o]} { + log::debug {$myself blocking $chan $mode -> error $e ($o)} + } else { + log::debug {$myself blocking $chan $mode -> $e} + } + return + } + + method watch {myself requestmask} { + log::debug {$myself watch $chan $requestmask} + + if {"read" in $requestmask} { + fileevent readable $chan [my Callback Readable $myself] + } else { + fileevent readable $chan {} + } + + if {"write" in $requestmask} { + fileevent writable $chan [my Callback Writable $myself] + } else { + fileevent writable $chan {} + } + return + } + + method read {myself n} { + log::debug {$myself read $chan begin eof: [::chan eof $chan], blocked: [::chan blocked $chan]} + set used [clock milliseconds] + + if {[catch { + set data [::chan read $chan $n] + } e o]} { + log::error {$myself read $chan $n -> error $e ($o)} + } else { + log::debug {$myself read $chan $n -> [string length $data] bytes: [string map {\n \\n} "'[string range $data 0 20]...[string range $data end-20 end]"]'} + log::debug {$myself read $chan eof = [::chan eof $chan]} + log::debug {$myself read $chan blocked = [::chan blocked $chan]} + log::debug {$chan configured: ([::chan configure $chan])} + + set gone [catch {chan eof $chan} eof] + if { + ($data eq {}) && + !$gone && !$eof && !$blocking + } { + log::error {$myself EAGAIN} + return -code error EAGAIN + } + } + + log::debug {$myself read $chan result: [string length $data] bytes} + return $data + } + + method write {myself data} { + log::debug {$myself write $chan [string length $data] / [::chan pending output $chan] / [::chan pending output $myself]} + set used [clock milliseconds] + ::chan puts -nonewline $chan $data + return [string length $data] + } + + method configure {myself option value} { + log::debug {[self] configure $myself $option -> $value} + + if {$option eq "-user"} { + set user $value + return + } + + ::chan configure $fd $option $value + return + } + + method cget {myself option} { + switch -- $option { + -self { return [self] } + -fd { return $chan } + -used { return $used } + -created { return $created } + -user { return $user } + default { + return [::chan configure $chan $option] + } + } + } + + method cgetall {myself} { + set result [::chan configure $chan] + lappend result \ + -self [self] \ + -fd $chan \ + -used $used \ + -created $created \ + -user $user + + log::debug {[self] cgetall $myself -> $result} + return $result + } + + # # ## ### ##### ######## ############# + + # Internals. Methods. Event generation. + method Readable {myself} { + log::debug {$myself readable $chan - [::chan pending input $chan]} + ::chan postevent $myself read + return + } + + method Writable {myself} { + log::debug {$myself writable $chan - [::chan pending output $chan]} + ::chan postevent $myself write + return + } + + method Callback {method args} { + list [uplevel 1 {namespace which my}] $method {*}$args + } + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::facade 1.0.2 +return diff --git a/src/vendorlib/virtchannel_base/fifo.tcl b/src/vendorlib/virtchannel_base/fifo.tcl new file mode 100644 index 0000000..5f04aaf --- /dev/null +++ b/src/vendorlib/virtchannel_base/fifo.tcl @@ -0,0 +1,138 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::fifo 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Re-implementation of Memchan's fifo +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# 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::fifo {} { + return [::chan create {read write} [fifo::implementation new]] +} + +oo::class create ::tcl::chan::fifo::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow write + next {*}$args + } + + method read {c n} { + set max [string length $read] + set last [expr {$at + $n - 1}] + set result {} + + # last+1 <= max + # <=> at+n <= max + # <=> n <= max-at + + if {$n <= ($max - $at)} { + # The request is less than what we have left in the read + # buffer, we take it, and move the read pointer forward. + + append result [string range $read $at $last] + incr at $n + incr $size -$n + } else { + # We need the whole remaining read buffer, and more. For + # the latter we shift the write buffer contents over into + # the read buffer, and then read from the latter again. + + append result [string range $read $at end] + incr n -[string length $result] + + set at 0 + set read $write + set write {} + set size [string length $read] + set max $size + + # at == 0 + if {$n <= $max} { + # The request is less than what we have in the updated + # read buffer, we take it, and move the read pointer + # forward. + + append result [string range $read 0 $last] + set at $n + incr $size -$n + } else { + # We need the whole remaining read buffer, and + # more. As we took the data from write already we have + # nothing left, and update accordingly. + + append result $read + + set at 0 + set read {} + set size 0 + } + } + + my Readable + + if {$result eq {}} { + return -code error EAGAIN + } + + return $result + } + + method write {c bytes} { + append write $bytes + set n [string length $bytes] + incr size $n + my Readable + return $n + } + + # # ## ### ##### ######## ############# + + variable at read write size + + # # ## ### ##### ######## ############# + + constructor {} { + set at 0 + set read {} + set write {} + set size 0 + next + } + + method Readable {} { + if {$size} { + my allow read + } else { + my disallow read + } + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::fifo 1.1 +return diff --git a/src/vendorlib/virtchannel_base/fifo2.tcl b/src/vendorlib/virtchannel_base/fifo2.tcl new file mode 100644 index 0000000..8de162e --- /dev/null +++ b/src/vendorlib/virtchannel_base/fifo2.tcl @@ -0,0 +1,113 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::fifo2 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes This fifo2 command does not have to +# Meta as::notes deal with the pesky details of +# Meta as::notes threading for cross-thread +# Meta as::notes communication. That is hidden in the +# Meta as::notes implementation of reflected +# Meta as::notes channels. It is less optimal as the +# Meta as::notes command provided by Memchan as this +# Meta as::notes fifo2 may involve three threads when +# Meta as::notes sending data around: The threads the +# Meta as::notes two endpoints are in, and the thread +# Meta as::notes holding this code. Memchan's C +# Meta as::notes implementation does not need this last +# Meta as::notes intermediary thread. +# Meta description Re-implementation of Memchan's fifo2 +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result are the +# Meta description handles of the two new channels. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::halfpipe +# Meta require {Tcl 8.5} +# @@ Meta End +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::halfpipe + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::fifo2 {} { + + set coordinator [fifo2::implementation new] + + lassign [halfpipe \ + -write-command [list $coordinator froma] \ + -close-command [list $coordinator closeda]] \ + a ha + + lassign [halfpipe \ + -write-command [list $coordinator fromb] \ + -close-command [list $coordinator closedb]] \ + b hb + + $coordinator connect $a $ha $b $hb + + return [list $a $b] +} + +oo::class create ::tcl::chan::fifo2::implementation { + method connect {thea theha theb thehb} { + set a $thea + set b $theb + set ha $theha + set hb $thehb + return + } + + method closeda {c} { + set a {} + if {$b ne {}} { + close $b + set b {} + } else { + my destroy + } + return + } + + method closedb {c} { + set b {} + if {$a ne {}} { + close $a + set a {} + } else { + my destroy + } + return + } + + method froma {c bytes} { + $hb put $bytes + return + } + + method fromb {c bytes} { + $ha put $bytes + return + } + + # # ## ### ##### ######## ############# + + variable a b ha hb + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::fifo2 1.1 +return diff --git a/src/vendorlib/virtchannel_base/fifo2.test b/src/vendorlib/virtchannel_base/fifo2.test new file mode 100644 index 0000000..bd465b8 --- /dev/null +++ b/src/vendorlib/virtchannel_base/fifo2.test @@ -0,0 +1,82 @@ +# ------------------------------------------------------------------------- +# fifo2.test -*- tcl -*- +# (C) 2019 Andreas Kupries. BSD licensed. +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.0 +testsNeed TclOO 1 + +support { + use virtchannel_core/core.tcl tcl::chan::core + use virtchannel_core/events.tcl tcl::chan::events +} +testing { + useLocal halfpipe.tcl tcl::chan::halfpipe + useLocal fifo2.tcl tcl::chan::fifo2 +} + +# ------------------------------------------------------------------------- + +test tcl-chan-fifo2-1.1 {constructor wrong\#args} -body { + tcl::chan::fifo2 X +} -returnCodes error \ + -result {wrong # args: should be "tcl::chan::fifo2"} + +test tcl-chan-fifo2-1.2 {destructor kills both sides and coordinator} -setup { + lassign [tcl::chan::fifo2] a b +} -match glob -body { + lappend r [lsort -dict [file channels]] + lappend r [info class instances ::tcl::chan::fifo2::implementation] + close $a + lappend r [lsort -dict [file channels]] + lappend r [info class instances ::tcl::chan::fifo2::implementation] +} -cleanup { + unset a b r +} -result {{rc4 rc5 stderr stdin stdout} ::oo::Obj* {stderr stdin stdout} {}} + +# ------------------------------------------------------------------------- + +test tcl-chan-fifo2-2.0 {tell, initial, empty} -setup { + lassign [tcl::chan::fifo2] a b +} -body { + list [tell $a] [tell $b] +} -cleanup { + close $a + unset a b +} -result {-1 -1} + +# ------------------------------------------------------------------------- + +test tcl-chan-fifo2-tkt-3f48fd6ea2 {fixed misindexing} -setup { + lassign [tcl::chan::fifo2] a b + chan configure $a -buffersize 1 + chan configure $b -buffering none + chan puts -nonewline $b foobar ;# push 6 chars + chan read $a 2 ;# read 2 + chan read $a 4 ;# read 4, fifo has nothing left + chan puts -nonewline $b baz ;# push 3 more +} -body { + chan read $a 1 ;# read 1, the `b` +} -cleanup { + close $a + unset a b +} -result b + +# ------------------------------------------------------------------------- +# Explicit cleanup of loaded (support) classes. +rename tcl::chan::events {} +rename tcl::chan::core {} +rename tcl::chan::halfpipe {} +rename tcl::chan::fifo2 {} +testsuiteCleanup +return + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/vendorlib/virtchannel_base/halfpipe.man b/src/vendorlib/virtchannel_base/halfpipe.man new file mode 100644 index 0000000..c4fb5bf --- /dev/null +++ b/src/vendorlib/virtchannel_base/halfpipe.man @@ -0,0 +1,81 @@ +[vset VERSION 1.0.2] +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::halfpipe n [vset VERSION]] +[keywords callbacks] +[keywords fifo] +[keywords {in-memory channel}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009, 2019 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {In-memory channel, half of a fifo2}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::halfpipe [opt [vset VERSION]]] +[description] +[para] + +The [package tcl::chan::halfpipe] package provides a command creating +one half of a [package tcl::chan::fifo2] pair. Writing into such a +channel invokes a set of callbacks which then handle the data. This is +similar to a channel handler, except having a much simpler API. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::halfpipe] [opt "[option -option] [arg value]..."]] + +This command creates a halfpipe channel and configures it with the +callbacks to run when the channel is closed, data was written to it, +or ran empty. See the section [sectref Options] for the list of +options and associated semantics. + +The result of the command is a list containing two elements, the +handle of the new channel, and the object command of the channel +handler, in this order. + +The latter is supplied to the caller to provide her with access to the +[method put] method for adding data to the channel. + +[para] Two halfpipes with a bit of glue logic in the callbacks make +for one [package tcl::chan::fifo2]. + +[call [arg objectCmd] [method put] [arg bytes]] + +This method of the channel handler object puts the data [arg bytes] +into the channel so that it can be read from it. + +[list_end] + +[section Options] + +[list_begin options] +[opt_def -close-command cmdprefix] + +This callback is invoked when the channel is closed. +A single argument is supplied, the handle of the channel being closed. +The result of the callback is ignored. + +[opt_def -write-command cmdprefix] + +This callback is invoked when data is written to the channel. +Two arguments are supplied, the handle of the channel written to, and the data written. +The result of the callback is ignored. + +[opt_def -empty-command cmdprefix] + +This callback is invoked when the channel has run out of data to read. +A single argument is supplied, the handle of the channel. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/halfpipe.tcl b/src/vendorlib/virtchannel_base/halfpipe.tcl new file mode 100644 index 0000000..845218e --- /dev/null +++ b/src/vendorlib/virtchannel_base/halfpipe.tcl @@ -0,0 +1,194 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009, 2019 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::halfpipe 1.0.3 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009,2019 +# Meta as::license BSD +# Meta description Implementation of one half of a pipe +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. Option arguments. Result is the +# Meta description handle of the new channel, and the object +# Meta description command of the handler object. +# 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::halfpipe {args} { + set handler [halfpipe::implementation new {*}$args] + return [list [::chan create {read write} $handler] $handler] +} + +oo::class create ::tcl::chan::halfpipe::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow write + set eof 0 + next {*}$args + } + + method finalize {c} { + my Call -close-command $c + next $c + } + + method read {c n} { + set max [string length $read] + set last [expr {$at + $n - 1}] + set result {} + + # last+1 <= max + # <=> at+n <= max + # <=> n <= max-at + + if {$n <= ($max - $at)} { + # There is enough data in the buffer to fill the request, so take + # it from there and move the read pointer forward. + + append result [string range $read $at $last] + incr at $n + incr $size -$n + } else { + # We need the whole remaining read buffer, and more. For + # the latter we make the write buffer the new read buffer, + # and then read from it again. + + append result [string range $read $at end] + incr n -[string length $result] + + set at 0 + set last [expr {$n - 1}] + set read $write + set write {} + set size [string length $read] + set max $size + + # at == 0 simplifies expressions + if {$n <= $max} { + # The request is less than what we have in the new + # read buffer, we take it, and move the read pointer + # forward. + + append result [string range $read 0 $last] + set at $n + incr $size -$n + } else { + # We need the whole remaining read buffer, and + # more. As we took the data from write already we have + # nothing left, and update accordingly. + + append result $read + + set at 0 + set read {} + set size 0 + } + } + my Readable + if {$result eq {} && !$eof} { + return -code error EAGAIN + } + return $result + } + + method write {c bytes} { + my Call -write-command $c $bytes + return [string length $bytes] + } + + # # ## ### ##### ######## ############# + + method put bytes { + append write $bytes + set n [string length $bytes] + if {$n == 0} { + my variable eof + set eof 1 + } else { + incr size $n + } + my Readable + return $n + } + + # # ## ### ##### ######## ############# + + variable at eof read write size options + # at : first location in read buffer not yet read + # eof : indicates whether the end of the data has been reached + # read : read buffer + # write : buffer for received data, i.e. + # written into the halfpipe from + # the other side. + # size : combined length of receive and read buffers + # == amount of stored data + # options : configuration array + + # The halpipe uses a pointer (`at`) into the data buffer to + # extract the characters read by the user, while not shifting the + # data down in memory. Doing such a shift would cause a large + # performance hit (O(n**2) operation vs O(n)). This however comes + # with the danger of the buffer growing out of bounds as ever more + # data is appended by the receiver while the reader is not + # catching up, preventing a release. The solution to this in turn + # 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 {} + -empty-command {} + -close-command {} + } + # todo: validity checking of options (legal names, legal + # values, etc.) + array set options $args + set at 0 + set read {} + set write {} + set size 0 + next + } + + method Readable {} { + if {$size || $eof} { + my allow read + } else { + my variable channel + my disallow read + my Call -empty-command $channel + } + return + } + + method Call {o args} { + if {![llength $options($o)]} return + uplevel \#0 [list {*}$options($o) {*}$args] + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::halfpipe 1.0.3 +return diff --git a/src/vendorlib/virtchannel_base/memchan.tcl b/src/vendorlib/virtchannel_base/memchan.tcl new file mode 100644 index 0000000..e23b444 --- /dev/null +++ b/src/vendorlib/virtchannel_base/memchan.tcl @@ -0,0 +1,169 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# Variable string channel (in-memory r/w file, internal variable). +# Seekable beyond the end of the data, implies appending of 0x00 +# bytes. + +# @@ Meta Begin +# Package tcl::chan::memchan 1.0.5 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Re-implementation of Memchan's memchan +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. Essentially +# Meta description an in-memory read/write random-access +# Meta description file. Similar to -> tcl::chan::variable, +# Meta description except the content variable is internal, +# Meta description part of the channel. Further similar to +# Meta description -> tcl::chan::string, except that the +# Meta description content is here writable, and +# Meta description extendable. +# 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::memchan {} { + return [::chan create {read write} [memchan::implementation new]] +} + +oo::class create ::tcl::chan::memchan::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + constructor {} { + set content {} + set at 0 + next + } + + method initialize {args} { + my allow write + my Events + next {*}$args + } + + 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 + # 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} { + # 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 + } + + # 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. + #puts XXX.PAD.[expr {$newloc - $max}] + 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::memchan 1.0.5 +return diff --git a/src/vendorlib/virtchannel_base/memchan.test b/src/vendorlib/virtchannel_base/memchan.test new file mode 100644 index 0000000..19c4f33 --- /dev/null +++ b/src/vendorlib/virtchannel_base/memchan.test @@ -0,0 +1,92 @@ +# ------------------------------------------------------------------------- +# memchan.test -*- tcl -*- +# (C) 2017 Andreas Kupries. BSD licensed. +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.0 +testsNeed TclOO 1 + +support { + use virtchannel_core/core.tcl tcl::chan::core + use virtchannel_core/events.tcl tcl::chan::events +} +testing { + useLocal memchan.tcl tcl::chan::memchan +} + +# ------------------------------------------------------------------------- + +test tcl-chan-memchan-1.0 {constructor wrong\#args} -body { + tcl::chan::memchan X +} -returnCodes error \ + -result {wrong # args: should be "tcl::chan::memchan"} + +# ------------------------------------------------------------------------- + +test tcl-chan-memchan-2.0 {tell, initial, empty} -setup { + set c [tcl::chan::memchan] +} -body { + tell $c +} -cleanup { + close $c + unset c +} -result 0 + +test tcl-chan-memchan-2.1 {seek from start, expand, tell} -setup { + set c [tcl::chan::memchan] +} -body { + seek $c 10 + tell $c +} -cleanup { + close $c + unset c +} -result 10 + +test tcl-chan-memchan-2.2 {seek from end, eof, empty, tell} -setup { + set c [tcl::chan::memchan] +} -body { + seek $c 0 end + tell $c +} -cleanup { + close $c + unset c +} -result 0 + +test tcl-chan-memchan-2.3 {seek from end, eof, non-empty, tell} -setup { + set c [tcl::chan::memchan] + puts $c Hello +} -body { + seek $c 0 end + tell $c +} -cleanup { + close $c + unset c +} -result 6 + +test tcl-chan-memchan-2.4 {seek from end, non-eof, non-empty, tell} -setup { + set c [tcl::chan::memchan] + puts $c Hello +} -body { + seek $c -6 end + tell $c +} -cleanup { + close $c + unset c +} -result 0 + +# ------------------------------------------------------------------------- +# Explicit cleanup of loaded support classes. +rename tcl::chan::events {} +rename tcl::chan::core {} +testsuiteCleanup +return + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/vendorlib/virtchannel_base/null.tcl b/src/vendorlib/virtchannel_base/null.tcl new file mode 100644 index 0000000..da9d734 --- /dev/null +++ b/src/vendorlib/virtchannel_base/null.tcl @@ -0,0 +1,54 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::null 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Re-implementation of Memchan's null +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# 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::null {} { + return [::chan create {write} [null::implementation new]] +} + +oo::class create ::tcl::chan::null::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow write + next {*}$args + } + + # Ignore the data in most particulars. We do count it so that we + # can tell the caller that everything was written. Null device. + + method write {c data} { + return [string length $data] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::null 1.1 +return diff --git a/src/vendorlib/virtchannel_base/nullzero.man b/src/vendorlib/virtchannel_base/nullzero.man new file mode 100644 index 0000000..66d806b --- /dev/null +++ b/src/vendorlib/virtchannel_base/nullzero.man @@ -0,0 +1,44 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::nullzero n 1.1] +[keywords /dev/null] +[keywords /dev/zero] +[keywords null] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[keywords zero] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Null/Zero channel combination}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::nullzero [opt 1.1]] +[description] +[para] + +The [package tcl::chan::nullzero] package provides a command creating channels, +which are a combination of null and zero devices. They immediately forget +whatever is written to them, and on reading return an infinite stream of null +characters. + +[para] Packages related to this are [package tcl::chan::null] and +[package tcl::chan::zero]. + +[para] The internal [package TclOO] class implementing the channel handler +is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::nullzero]] + +This command creates a new nullzero channel and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/nullzero.tcl b/src/vendorlib/virtchannel_base/nullzero.tcl new file mode 100644 index 0000000..c217657 --- /dev/null +++ b/src/vendorlib/virtchannel_base/nullzero.tcl @@ -0,0 +1,62 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::nullzero 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a channel combining +# Meta description Memchan's null and zero channels in a +# Meta description single device. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# 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::nullzero {} { + return [::chan create {read write} [nullzero::implementation new]] +} + +oo::class create ::tcl::chan::nullzero::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow read write + next {*}$args + } + + # Ignore the data in most particulars. We do count it so that we + # can tell the caller that everything was written. Null device. + + method write {c data} { + return [string length $data] + } + + # Generate and return a block of N null bytes, as requested. Zero + # device. + + method read {c n} { + return [binary format @$n] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::nullzero 1.1 +return diff --git a/src/vendorlib/virtchannel_base/pkgIndex.tcl b/src/vendorlib/virtchannel_base/pkgIndex.tcl new file mode 100644 index 0000000..c8431a2 --- /dev/null +++ b/src/vendorlib/virtchannel_base/pkgIndex.tcl @@ -0,0 +1,17 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} + +package ifneeded tcl::chan::cat 1.0.4 [list source [file join $dir cat.tcl]] +package ifneeded tcl::chan::facade 1.0.2 [list source [file join $dir facade.tcl]] +package ifneeded tcl::chan::fifo 1.1 [list source [file join $dir fifo.tcl]] +package ifneeded tcl::chan::fifo2 1.1 [list source [file join $dir fifo2.tcl]] +package ifneeded tcl::chan::halfpipe 1.0.3 [list source [file join $dir halfpipe.tcl]] +package ifneeded tcl::chan::memchan 1.0.5 [list source [file join $dir memchan.tcl]] +package ifneeded tcl::chan::null 1.1 [list source [file join $dir null.tcl]] +package ifneeded tcl::chan::nullzero 1.1 [list source [file join $dir nullzero.tcl]] +package ifneeded tcl::chan::random 1.1 [list source [file join $dir random.tcl]] +package ifneeded tcl::chan::std 1.0.2 [list source [file join $dir std.tcl]] +package ifneeded tcl::chan::string 1.0.4 [list source [file join $dir string.tcl]] +package ifneeded tcl::chan::textwindow 1.1 [list source [file join $dir textwindow.tcl]] +package ifneeded tcl::chan::variable 1.0.5 [list source [file join $dir variable.tcl]] +package ifneeded tcl::chan::zero 1.1 [list source [file join $dir zero.tcl]] +package ifneeded tcl::randomseed 1.1 [list source [file join $dir randseed.tcl]] diff --git a/src/vendorlib/virtchannel_base/random.tcl b/src/vendorlib/virtchannel_base/random.tcl new file mode 100644 index 0000000..c1778b8 --- /dev/null +++ b/src/vendorlib/virtchannel_base/random.tcl @@ -0,0 +1,80 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::random 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a channel similar to +# Meta description Memchan's random channel. Based on Tcl +# Meta description 8.5's channel reflection support. Exports +# Meta description a single command for the creation of new +# Meta description channels. One argument, a list of +# Meta description numbers to initialize the feedback +# Meta description register of the internal random number +# Meta description generator. Result is the handle of the +# Meta description new channel. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::events +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require tcl::chan::events +package require Tcl 8.5 9 +package require TclOO + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::random {seed} { + return [::chan create {read} [random::implementation new $seed]] +} + +oo::class create ::tcl::chan::random::implementation { + superclass tcl::chan::events ; # -> initialize, finalize, watch + + constructor {theseed} { + my variable seed next + set seed $theseed + set next [expr "([join $seed +]) & 0xff"] + next + } + + method initialize {args} { + my allow read + next {*}$args + } + + # Generate and return a block of N randomly selected bytes, as + # requested. Random device. + + method read {c n} { + set buffer {} + while {$n} { + append buffer [binary format c [my Next]] + incr n -1 + } + return $buffer + } + + variable seed + variable next + + method Next {} { + my variable seed next + set result $next + set next [expr {(2*$next - [lindex $seed 0]) & 0xff}] + set seed [linsert [lrange $seed 1 end] end $result] + return $result + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::random 1.1 +return diff --git a/src/vendorlib/virtchannel_base/randseed.man b/src/vendorlib/virtchannel_base/randseed.man new file mode 100644 index 0000000..339568d --- /dev/null +++ b/src/vendorlib/virtchannel_base/randseed.man @@ -0,0 +1,43 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::randomseed n 1.1] +[keywords /dev/random] +[keywords merge] +[keywords random] +[keywords {reflected channel}] +[keywords seed] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Utilities for random channels}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::randomseed [opt 1.1]] +[description] +[para] + +The [package tcl::randomseed] package provides a a few utility commands +to help with the seeding of [package tcl::chan::random] channels. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::randomseed]] + +This command creates returns a list of seed integers suitable as seed +argument for random channels. The numbers are derived from the process +id, current time, and Tcl random number generator. + +[call [cmd ::tcl::combine] [arg seed1] [arg seed2]] + +This command takes to seed lists and combines them into a single list +by XORing them elementwise, modulo 256. If the lists are not of equial +length the shorter of the two is padded with 0s before merging. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/randseed.tcl b/src/vendorlib/virtchannel_base/randseed.tcl new file mode 100644 index 0000000..5e0cbed --- /dev/null +++ b/src/vendorlib/virtchannel_base/randseed.tcl @@ -0,0 +1,58 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::randomseed 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Generate and combine seed lists for the +# Meta description random number generator inside of the +# Meta description tcl::chan::random channel. Sources of +# Meta description randomness are process id, time in two +# Meta description granularities, and Tcl's random number +# Meta description generator. +# Meta platform tcl +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 + +# # ## ### ##### ######## ############# + +namespace eval ::tcl {} + +proc ::tcl::randomseed {} { + set result {} + foreach v [list \ + [pid] \ + [clock seconds] \ + [expr {int(256*rand())}] \ + [clock clicks -milliseconds]] \ + { + lappend result [expr {$v % 256}] + } + return $result +} + +proc ::tcl::combine {a b} { + while {[llength $a] < [llength $b]} { + lappend a 0 + } + while {[llength $b] < [llength $a]} { + lappend b 0 + } + + set result {} + foreach x $a y $b { + lappend result [expr {($x ^ $y) % 256}] + } + return $result +} + +# # ## ### ##### ######## ############# +package provide tcl::randomseed 1.1 +return diff --git a/src/vendorlib/virtchannel_base/std.man b/src/vendorlib/virtchannel_base/std.man new file mode 100644 index 0000000..0f3c049 --- /dev/null +++ b/src/vendorlib/virtchannel_base/std.man @@ -0,0 +1,43 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::std n 1.1] +[keywords {reflected channel}] +[keywords {standard io}] +[keywords stdin] +[keywords stdout] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2011 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Standard I/O, unification of stdin and stdout}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::core [opt 1.1]] +[require tcl::chan::std [opt 1.1]] +[description] +[para] + +The [package tcl::chan::std] package provides a command creating +a standard channel which unifies stdin and stdout into a single +read- and writable channel. The result is not seek-able, like +the original standard channels. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::core] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::std]] + +This command creates the std channel and returns its handle. + +[para] The channel is created only once, on the first call, and all +future calls simply return this handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/std.tcl b/src/vendorlib/virtchannel_base/std.tcl new file mode 100644 index 0000000..24927e3 --- /dev/null +++ b/src/vendorlib/virtchannel_base/std.tcl @@ -0,0 +1,97 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2011 Andreas Kupries + +# Facade wrapping the separate channels for stdin and stdout into a +# single read/write channel for all regular standard i/o. Not +# seekable. Fileevent handling is propagated to the regular channels +# the facade wrapped about. Only one instance of the class is +# ever created. + +# @@ Meta Begin +# Package tcl::chan::std 1.0.2 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2011 +# Meta as::license BSD +# Meta description Facade wrapping the separate channels for stdin +# Meta description and stdout into a single read/write channel for +# Meta description all regular standard i/o. Not seekable. Only one +# Meta description instance of the class is ever created. +# Meta platform tcl +# Meta require TclOO +# Meta require tcl::chan::core +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan {} + +proc ::tcl::chan::std {} { + ::variable std + if {$std eq {}} { + set std [::chan create {read write} [std::implementation new]] + } + return $std +} + +oo::class create ::tcl::chan::std::implementation { + superclass ::tcl::chan::core ; # -> initialize, finalize. + + # We are not using the standard event handling class, because here + # it will not be timer-driven. We propagate anything related to + # events to stdin and stdout instead and let them handle things. + + constructor {} { + # Disable encoding and translation processing in the wrapped channels. + # This will happen in our generic layer instead. + fconfigure stdin -translation binary + fconfigure stdout -translation binary + return + } + + method watch {c requestmask} { + + if {"read" in $requestmask} { + fileevent readable stdin [list chan postevent $c read] + } else { + fileevent readable stdin {} + } + + if {"write" in $requestmask} { + fileevent readable stdin [list chan postevent $c write] + } else { + fileevent readable stdout {} + } + + return + } + + method read {c n} { + # Read is redirected to stdin. + return [::read stdin $n] + } + + method write {c newbytes} { + # Write is redirected to stdout. + puts -nonewline stdout $newbytes + flush stdout + return [string length $newbytes] + } +} + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::chan { + ::variable std {} +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::std 1.0.2 +return diff --git a/src/vendorlib/virtchannel_base/string.tcl b/src/vendorlib/virtchannel_base/string.tcl new file mode 100644 index 0000000..277f949 --- /dev/null +++ b/src/vendorlib/virtchannel_base/string.tcl @@ -0,0 +1,124 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::string 1.0.4 +# 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-only random-access +# Meta description file. Based on using Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new channels. +# Meta description One argument, the contents of the file. +# Meta description Result is the handle of the new channel. +# Meta description Similar to -> tcl::chan::memchan, except +# Meta description that the content is read-only. Seekable +# Meta description only within the bounds of the content. +# 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::string {content} { + return [::chan create {read} [string::implementation new $content]] +} + +oo::class create ::tcl::chan::string::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + constructor {thecontent} { + set content $thecontent + set at 0 + next + } + + method initialize {args} { + my Events + next {*}$args + } + + 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 + # 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 seek {c offset base} { + # offset == 0 && base == current + # <=> Seek nothing relative to current + # <=> Report current location. + + if {!$offset && ($base eq "current")} { + return $at + } + + # 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} { + return -code error "Cannot seek after the end of the channel" + } + + # 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::string 1.0.4 +return diff --git a/src/vendorlib/virtchannel_base/string.test b/src/vendorlib/virtchannel_base/string.test new file mode 100644 index 0000000..b239b4d --- /dev/null +++ b/src/vendorlib/virtchannel_base/string.test @@ -0,0 +1,94 @@ +# ------------------------------------------------------------------------- +# string.test -*- tcl -*- +# (C) 2017 Andreas Kupries. BSD licensed. +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.0 +testsNeed TclOO 1 + +support { + use virtchannel_core/core.tcl tcl::chan::core + use virtchannel_core/events.tcl tcl::chan::events +} +testing { + useLocal string.tcl tcl::chan::string +} + +# ------------------------------------------------------------------------- + +test tcl-chan-string-1.0 {constructor wrong\#args} -body { + tcl::chan::string +} -returnCodes error \ + -result {wrong # args: should be "tcl::chan::string content"} + +test tcl-chan-string-1.1 {constructor wrong\#args} -body { + tcl::chan::string C X +} -returnCodes error \ + -result {wrong # args: should be "tcl::chan::string content"} + +# ------------------------------------------------------------------------- + +test tcl-chan-string-2.0 {tell, initial, empty} -setup { + set c [tcl::chan::string ""] +} -body { + tell $c +} -cleanup { + close $c + unset c +} -result 0 + +test tcl-chan-string-2.1 {seek from start beyond eof is error} -setup { + set c [tcl::chan::string ""] +} -body { + seek $c 10 +} -cleanup { + close $c + unset c +} -returnCodes error -result {Cannot seek after the end of the channel} + +test tcl-chan-string-2.2 {seek from end, eof, empty, tell} -setup { + set c [tcl::chan::string ""] +} -body { + seek $c 0 end + tell $c +} -cleanup { + close $c + unset c +} -result 0 + +test tcl-chan-string-2.3 {seek from end, eof, non-empty, tell} -setup { + set c [tcl::chan::string Hello\n] +} -body { + seek $c 0 end + tell $c +} -cleanup { + close $c + unset c +} -result 6 + +test tcl-chan-string-2.4 {seek from end, non-eof, non-empty, tell} -setup { + set c [tcl::chan::string Hello\n] +} -body { + seek $c -6 end + tell $c +} -cleanup { + close $c + unset c +} -result 0 + +# ------------------------------------------------------------------------- +# Explicit cleanup of loaded support classes. +rename tcl::chan::events {} +rename tcl::chan::core {} +testsuiteCleanup +return + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/vendorlib/virtchannel_base/tcllib_fifo.man b/src/vendorlib/virtchannel_base/tcllib_fifo.man new file mode 100644 index 0000000..b21e4aa --- /dev/null +++ b/src/vendorlib/virtchannel_base/tcllib_fifo.man @@ -0,0 +1,43 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::fifo n 1.1] +[keywords fifo] +[keywords {in-memory channel}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {In-memory fifo channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::fifo [opt 1.1]] +[description] +[para] + +The [package tcl::chan::fifo] package provides a command creating +channels which live purely in memory. Access is fifo-like, i.e. things +are read out of the channel in the order they were written to it. + +This is equivalent to the fifo channels provided by the package +[package Memchan], except that this is written in pure Tcl, not C. On +the other hand, [package Memchan] is usable with Tcl 8.4 and before, +whereas this package requires Tcl 8.5 or higher, and [package TclOO]. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::fifo]] + +This command creates a new fifo channel and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/tcllib_fifo2.man b/src/vendorlib/virtchannel_base/tcllib_fifo2.man new file mode 100644 index 0000000..d93b4a8 --- /dev/null +++ b/src/vendorlib/virtchannel_base/tcllib_fifo2.man @@ -0,0 +1,50 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::fifo2 n 1.1] +[keywords {connected fifos}] +[keywords fifo] +[keywords {in-memory channel}] +[keywords {inter-thread communication}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {In-memory interconnected fifo channels}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::halfpipe [opt 1.1]] +[require tcl::chan::fifo2 [opt 1.1]] +[description] +[para] + +The [package tcl::chan::fifo2] package provides a command creating +pairs of channels which live purely in memory and are connected to +each other in a fifo manner. What is written to one half of the pair +can be read from the other half, in the same order. One particular +application for this is communication between threads, with one half +of the pair moved to the thread to talk to. + +This is equivalent to the fifo2 channels provided by the package +[package Memchan], except that this is written in pure Tcl, not C. On +the other hand, [package Memchan] is usable with Tcl 8.4 and before, +whereas this package requires Tcl 8.5 or higher, and [package TclOO]. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::fifo2]] + +This command creates a new connected pair of fifo channels and returns +their handles, as a list containing two elements. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/tcllib_memchan.man b/src/vendorlib/virtchannel_base/tcllib_memchan.man new file mode 100644 index 0000000..66d01e8 --- /dev/null +++ b/src/vendorlib/virtchannel_base/tcllib_memchan.man @@ -0,0 +1,45 @@ +[vset VERSION 1.0.5] +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::memchan n [vset VERSION]] +[keywords {in-memory channel}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009-2017 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {In-memory channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::memchan [opt [vset VERSION]]] +[description] +[para] + +The [package tcl::chan::memchan] package provides a command creating +channels which live purely in memory. They provide random-access, +i.e. are seekable. This is equivalent to the memchan channels provided by +the package [package Memchan], except that this is written in pure Tcl, +not C. On the other hand, [package Memchan] is usable with Tcl 8.4 and +before, whereas this package requires Tcl 8.5 or higher, and +[package TclOO]. + +[para] Packages related to this are [package tcl::chan::string] and +[package tcl::chan::variable]. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::memchan]] + +This command creates a new memchan channel and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/tcllib_null.man b/src/vendorlib/virtchannel_base/tcllib_null.man new file mode 100644 index 0000000..d3fb3a6 --- /dev/null +++ b/src/vendorlib/virtchannel_base/tcllib_null.man @@ -0,0 +1,45 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::null n 1.1] +[keywords /dev/null] +[keywords null] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Null channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::null [opt 1.1]] +[description] +[para] + +The [package tcl::chan::null] package provides a command creating null +channels, i.e. write-only channels which immediately forget whatever +is written to them. This is equivalent to the null channels provided by +the package [package Memchan], except that this is written in pure Tcl, +not C. On the other hand, [package Memchan] is usable with Tcl 8.4 and +before, whereas this package requires Tcl 8.5 or higher, and +[package TclOO]. + +[para] Packages related to this are [package tcl::chan::zero] and +[package tcl::chan::nullzero]. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::null]] + +This command creates a new null channel and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/tcllib_random.man b/src/vendorlib/virtchannel_base/tcllib_random.man new file mode 100644 index 0000000..f3bba03 --- /dev/null +++ b/src/vendorlib/virtchannel_base/tcllib_random.man @@ -0,0 +1,46 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::random n 1.1] +[keywords /dev/random] +[keywords random] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Random channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::random [opt 1.1]] +[description] +[para] + +The [package tcl::chan::random] package provides a command creating +random channels, i.e. read-only channels which return an infinite +stream of pseudo-random characters upon reading. This is similar to +the random channels provided by the package [package Memchan], except +that this is written in pure Tcl, not C, and uses a much simpler +generator as well. On the other hand, [package Memchan] is usable with +Tcl 8.4 and before, whereas this package requires Tcl 8.5 or higher, +and TclOO. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::random] [arg seed]] + +This command creates a new random channel and returns its handle. + +The seed is a list of integer numbers used to initialize the +internal feedback shift register of the generator. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/tcllib_string.man b/src/vendorlib/virtchannel_base/tcllib_string.man new file mode 100644 index 0000000..338c9b9 --- /dev/null +++ b/src/vendorlib/virtchannel_base/tcllib_string.man @@ -0,0 +1,46 @@ +[vset VERSION 1.0.4] +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::string n [vset VERSION]] +[keywords {in-memory channel}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Read-only in-memory channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::string [opt [vset VERSION]]] +[description] +[para] + +The [package tcl::chan::string] package provides a command creating +channels which live purely in memory. They provide random-access, +i.e. are seekable. + +In contrast to the channels created by [package tcl::chan::memchan] +they are read-only however, their content is provided at the time of +construction and immutable afterward. + +[para] Packages related to this are [package tcl::chan::memchan] and +[package tcl::chan::variable]. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::string] [arg content]] + +This command creates a new string channel and returns its handle. The +channel provides random read-only access to the [arg content] string. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/tcllib_variable.man b/src/vendorlib/virtchannel_base/tcllib_variable.man new file mode 100644 index 0000000..911b12c --- /dev/null +++ b/src/vendorlib/virtchannel_base/tcllib_variable.man @@ -0,0 +1,47 @@ +[vset VERSION 1.0.5] +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::variable n [vset VERSION]] +[keywords {in-memory channel}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {In-memory channel using variable for storage}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::variable [opt [vset VERSION]]] +[description] +[para] + +The [package tcl::chan::variable] package provides a command creating +channels which live purely in memory. They provide random-access, +i.e. are seekable. + +In contrast to the channels created by [package tcl::chan::memchan] +the data is not hidden in the channel however, but stored in an +associated variable, specified at the time of construction. + +[para] Packages related to this are [package tcl::chan::memchan] and +[package tcl::chan::string]. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::variable] [arg varname]] + +This command creates a new variable channel and returns its handle. +The content of the channel is stored in the associated namespace +variable [arg varname]. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/tcllib_zero.man b/src/vendorlib/virtchannel_base/tcllib_zero.man new file mode 100644 index 0000000..d55d050 --- /dev/null +++ b/src/vendorlib/virtchannel_base/tcllib_zero.man @@ -0,0 +1,45 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::zero n 1.1] +[keywords /dev/zero] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[keywords zero] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Zero channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::zero [opt 1.1]] +[description] +[para] + +The [package tcl::chan::zero] package provides a command creating zero +channels, i.e. read-only channels which return an infinite stream of null +characters upon reading. This is equivalent to the zero channels +provided by the package [package Memchan], except that this is written +in pure Tcl, not C. On the other hand, [package Memchan] is usable with +Tcl 8.4 and before, whereas this package requires Tcl 8.5 or higher, +and TclOO. + +[para] Packages related to this are [package tcl::chan::null] and +[package tcl::chan::nullzero]. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::zero]] + +This command creates a new zero channel and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/textwindow.man b/src/vendorlib/virtchannel_base/textwindow.man new file mode 100644 index 0000000..310ca01 --- /dev/null +++ b/src/vendorlib/virtchannel_base/textwindow.man @@ -0,0 +1,39 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::textwindow n 1.1] +[keywords {reflected channel}] +[keywords {text widget}] +[keywords {tip 219}] +[keywords Tk] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Textwindow channel}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::events [opt 1.1]] +[require tcl::chan::textwindow [opt 1.1]] +[description] +[para] + +The [package tcl::chan::textwindow] package provides a command creating +write-only channels connected to text widgets. Anything written to the +channel is printed into the associated widget. + +[para] The internal [package TclOO] class implementing the channel +handler is a sub-class of the [package tcl::chan::events] framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::chan::textwindow] [arg widget]] + +This command creates a new textwindow channel and returns its handle. +Data written to this channel will appear in the associated [arg widget]. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_base/textwindow.tcl b/src/vendorlib/virtchannel_base/textwindow.tcl new file mode 100644 index 0000000..4e23a37 --- /dev/null +++ b/src/vendorlib/virtchannel_base/textwindow.tcl @@ -0,0 +1,74 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::textwindow 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::credit To Bryan Oakley for rotext, see +# Meta as::credit http://wiki.tcl.tk/22036. His code was +# Meta as::credit used here as template for the text +# Meta as::credit widget portions of the channel. +# Meta description Implementation of a text window +# Meta description channel, using Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# 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::textwindow {w} { + set chan [::chan create {write} [textwindow::implementation new $w]] + fconfigure $chan -encoding utf-8 -buffering none + return $chan +} + +oo::class create ::tcl::chan::textwindow::implementation { + superclass ::tcl::chan::events ; # -> initialize, finalize, watch + + constructor {w} { + set widget $w + next + } + + # # ## ### ##### ######## ############# + + variable widget + + # # ## ### ##### ######## ############# + + method initialize {args} { + my allow write + next {*}$args + } + + method write {c data} { + # NOTE: How is encoding convertfrom dealing with a partial + # utf-8 character at the end of the buffer ? Should be saved + # up for the next buffer. No idea if we can. + + $widget insert end [encoding convertfrom utf-8 $data] + $widget see end + return [string length $data] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::textwindow 1.1 +return diff --git a/src/vendorlib/virtchannel_base/variable.tcl b/src/vendorlib/virtchannel_base/variable.tcl new file mode 100644 index 0000000..0c65a37 --- /dev/null +++ b/src/vendorlib/virtchannel_base/variable.tcl @@ -0,0 +1,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 diff --git a/src/vendorlib/virtchannel_base/variable.test b/src/vendorlib/virtchannel_base/variable.test new file mode 100644 index 0000000..c8c9501 --- /dev/null +++ b/src/vendorlib/virtchannel_base/variable.test @@ -0,0 +1,102 @@ +# ------------------------------------------------------------------------- +# variable.test -*- tcl -*- +# (C) 2017 Andreas Kupries. BSD licensed. +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.5 +testsNeedTcltest 2.0 +testsNeed TclOO 1 + +support { + use virtchannel_core/core.tcl tcl::chan::core + use virtchannel_core/events.tcl tcl::chan::events +} +testing { + useLocal variable.tcl tcl::chan::variable +} + +# ------------------------------------------------------------------------- + +test tcl-chan-variable-1.0 {constructor wrong\#args} -body { + tcl::chan::variable +} -returnCodes error \ + -result {wrong # args: should be "tcl::chan::variable varname"} + +test tcl-chan-variable-1.1 {constructor wrong\#args} -body { + tcl::chan::variable V X +} -returnCodes error \ + -result {wrong # args: should be "tcl::chan::variable varname"} + +# ------------------------------------------------------------------------- + +test tcl-chan-variable-2.0 {tell, initial, empty} -setup { + set content "" + set c [tcl::chan::variable content] +} -body { + tell $c +} -cleanup { + close $c + unset c content +} -result 0 + +test tcl-chan-variable-2.1 {seek from start, expand, tell} -setup { + set content "" + set c [tcl::chan::variable content] +} -body { + seek $c 10 + tell $c +} -cleanup { + close $c + unset c content +} -result 10 + +test tcl-chan-variable-2.2 {seek from end, eof, empty, tell} -setup { + set content "" + set c [tcl::chan::variable content] +} -body { + seek $c 0 end + tell $c +} -cleanup { + close $c + unset c content +} -result 0 + +test tcl-chan-variable-2.3 {seek from end, eof, non-empty, tell} -setup { + set content "" + set c [tcl::chan::variable content] + puts $c Hello +} -body { + seek $c 0 end + tell $c +} -cleanup { + close $c + unset c content +} -result 6 + +test tcl-chan-variable-2.4 {seek from end, non-eof, non-empty, tell} -setup { + set content "" + set c [tcl::chan::variable content] + puts $c Hello +} -body { + seek $c -6 end + tell $c +} -cleanup { + close $c + unset c content +} -result 0 + +# ------------------------------------------------------------------------- +# Explicit cleanup of loaded support classes. +rename tcl::chan::events {} +rename tcl::chan::core {} +testsuiteCleanup +return + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/src/vendorlib/virtchannel_base/zero.tcl b/src/vendorlib/virtchannel_base/zero.tcl new file mode 100644 index 0000000..752e109 --- /dev/null +++ b/src/vendorlib/virtchannel_base/zero.tcl @@ -0,0 +1,54 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::zero 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Re-implementation of Memchan's zero +# Meta description channel. Based on Tcl 8.5's channel +# Meta description reflection support. Exports a single +# Meta description command for the creation of new +# Meta description channels. No arguments. Result is the +# Meta description handle of the new channel. +# 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::zero {} { + return [::chan create {read} [zero::implementation new]] +} + +oo::class create ::tcl::chan::zero::implementation { + superclass tcl::chan::events ; # -> initialize, finalize, watch + + method initialize {args} { + my allow read + next {*}$args + } + + # Generate and return a block of N null bytes, as requested. + # Zero device. + + method read {c n} { + return [binary format @$n] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::chan::zero 1.1 +return diff --git a/src/vendorlib/virtchannel_core/ChangeLog b/src/vendorlib/virtchannel_core/ChangeLog new file mode 100644 index 0000000..08dae20 --- /dev/null +++ b/src/vendorlib/virtchannel_core/ChangeLog @@ -0,0 +1,39 @@ +2013-02-01 Andreas Kupries + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2011-12-13 Andreas Kupries + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-02-21 Andreas Kupries + + * pkgIndex.tcl: Removed the superfluous [list] command in the + ifneeded script. + +2011-01-24 Andreas Kupries + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2010-07-28 Andreas Kupries + + * core.man: New files, documentation for the packages in + * events.man: this module. + * transformcore.man: + +2009-12-07 Andreas Kupries + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-12-01 Andreas Kupries + + * New module 'virtchannel_core', with core classes for virtual + channels aka reflected channels. TclOO based. diff --git a/src/vendorlib/virtchannel_core/README.txt b/src/vendorlib/virtchannel_core/README.txt new file mode 100644 index 0000000..302b63b --- /dev/null +++ b/src/vendorlib/virtchannel_core/README.txt @@ -0,0 +1,5 @@ + +core, events + + Support packages for initialization, finalization, and + timer-driven event support. diff --git a/src/vendorlib/virtchannel_core/core.man b/src/vendorlib/virtchannel_core/core.man new file mode 100644 index 0000000..c412b77 --- /dev/null +++ b/src/vendorlib/virtchannel_core/core.man @@ -0,0 +1,72 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::core n 1.1] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Basic reflected/virtual channel support}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::core [opt 1.1]] +[description] +[para] + +The [package tcl::chan::core] package provides a [package TclOO] +class implementing common behaviour needed by virtually every +reflected or virtual channel (initialization, finalization). + +[para] This class expects to be used as either superclass of a concrete +channel class, or to be mixed into such a class. + +[section {Class API}] + +[list_begin definitions] + +[call [cmd ::tcl::chan::core] [arg objectName]] + +This command creates a new channel core object with an associated +global Tcl command whose name is [emph objectName]. This command may +be used to invoke various operations on the object, as described in +the section for the [sectref {Instance API}]. + +[list_end] + +[section {Instance API}] + +The API of channel core instances provides only two methods, both +corresponding to channel handler commands (For reference see +[uri http:/tip.tcl.tk/219 {TIP 219}]). They expect to be called +from whichever object instance the channel core was made a part of. + +[list_begin definitions] + +[call [arg objectName] [method initialize] [arg thechannel] [arg mode]] + +This method implements standard behaviour for the [method initialize] +method of channel handlers. Using introspection it finds the handler +methods supported by the instance and returns a list containing their +names, as expected by the support for reflected channels in the Tcl +core. + +[para] It further remembers the channel handle in an instance variable +for access by sub-classes. + +[call [arg objectName] [method finalize] [arg thechannel]] + +This method implements standard behaviour for the [method finalize] +method of channel handlers. It simply destroys itself. + +[call [arg objectName] [method destroy]] + +Destroying the channel core instance closes the channel it was +initialized for, see the method [method initialize]. When destroyed +from within a call of [method finalize] this does not happen, under +the assumption that the channel is being destroyed by Tcl. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_core/core.tcl b/src/vendorlib/virtchannel_core/core.tcl new file mode 100644 index 0000000..f31ac62 --- /dev/null +++ b/src/vendorlib/virtchannel_core/core.tcl @@ -0,0 +1,73 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::core 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Support package handling a core +# Meta description aspect of reflected base channels +# Meta description (initialization, finalization). +# Meta description It is expected that this class +# Meta description is used as either one superclass of the +# Meta description class C for a specific channel, or is +# Meta description mixed into C. +# Meta platform tcl +# Meta require TclOO +# Meta require {Tcl 8.5} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO + +# # ## ### ##### ######## ############# + +oo::class create ::tcl::chan::core { + destructor { + if {$channel eq {}} return + close $channel + return + } + + # # ## ### ##### ######## ############# + + method initialize {thechannel mode} { + set methods [info object methods [self] -all] + + # Note: Checking of the mode against the supported methods is + # done by the caller. + + set channel $thechannel + set supported {} + foreach m { + initialize finalize watch read write seek configure cget + cgetall blocking + } { + if {$m in $methods} { + lappend supported $m + } + } + return $supported + } + + method finalize {c} { + set channel {} ; # Prevent destroctor from calling close. + my destroy + return + } + + # # ## ### ##### ######## ############# + + variable channel + + # channel The channel the handler belongs to. + # # ## ### ##### ######## ############# +} + +# # ## ### ##### +package provide tcl::chan::core 1.1 +return diff --git a/src/vendorlib/virtchannel_core/events.man b/src/vendorlib/virtchannel_core/events.man new file mode 100644 index 0000000..1c27331 --- /dev/null +++ b/src/vendorlib/virtchannel_core/events.man @@ -0,0 +1,79 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::chan::events n 1.1] +[keywords {event management}] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Event support for reflected/virtual channels}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::chan::core [opt 1.1]] +[require tcl::chan::events [opt 1.1]] +[description] +[para] + +The [package tcl::chan::events] package provides a [package TclOO] +class implementing common behaviour needed by virtually every +reflected or virtual channel supporting event driven IO. It is a +sub-class of [package tcl::chan::core], inheriting all of its behaviour. + +[para] This class expects to be used as either superclass of a concrete +channel class, or to be mixed into such a class. + +[section {Class API}] + +[list_begin definitions] + +[call [cmd ::tcl::chan::events] [arg objectName]] + +This command creates a new channel event core object with an associated +global Tcl command whose name is [emph objectName]. This command may +be used to invoke various operations on the object, as described in +the section for the [sectref {Instance API}]. + +[list_end] + +[section {Instance API}] + +The API of channel event core instances provides only four methods, two +corresponding to channel handler commands (For reference see +[uri http:/tip.tcl.tk/219 {TIP 219}]), and the other two for use by +sub-classes to control event generation. They former expect to be called +from whichever object instance the channel event core was made a part of. + +[list_begin definitions] + +[call [arg objectName] [method finalize] [arg thechannel]] + +This method implements standard behaviour for the [method finalize] +method of channel handlers. It overrides the behaviour inherited from +[package tcl::chan::core] and additionally disables any and all event +generation before destroying itself. + +[call [arg objectName] [method watch] [arg thechannel] [arg eventmask]] + +This method implements standard behaviour for the [method watch] +method of channel handlers. Called by the IO system whenever the +interest in event changes it updates the instance state to activate +and/or suppress the generation of the events of (non-)interest. + +[call [arg objectName] [method allow] [arg eventname]...] +[call [arg objectName] [method disallow] [arg eventname]...] + +These two methods are exported to sub-classes, so that their instances +can notify their event core of the events the channel they implement +can (allow) or cannot (disallow) generate. + +Together with the information about the events requested by Tcl's IO +system coming in through the [method watch] method the event core is +able to determine which events it should (not) generate and act +accordingly. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_core/events.tcl b/src/vendorlib/virtchannel_core/events.tcl new file mode 100644 index 0000000..e84f606 --- /dev/null +++ b/src/vendorlib/virtchannel_core/events.tcl @@ -0,0 +1,154 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::chan::events 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Support package handling a core +# Meta description aspect of reflected base channels +# Meta description (timer +# Meta description driven file event support). Controls a +# Meta description timer generating the expected read/write +# Meta description events. It is expected that this class +# Meta description is used as either one superclass of the +# Meta description class C for a specific channel, or is +# Meta description mixed into C. +# Meta platform tcl +# Meta require tcl::chan::core +# Meta require TclOO +# Meta require {Tcl 8.5} +# @@ Meta End + +# TODO :: set/get accessor methods for the timer delay + +# # ## ### ##### ######## ############# + +package require Tcl 8.5 9 +package require TclOO +package require tcl::chan::core + +# # ## ### ##### ######## ############# + +oo::class create ::tcl::chan::events { + superclass ::tcl::chan::core ; # -> initialize, finalize, destructor + + constructor {} { + array set allowed { + read 0 + write 0 + } + set requested {} + set delay 10 + return + } + + # # ## ### ##### ######## ############# + + method finalize {c} { + my disallow read write + next $c + } + + # Allow/disallow the posting of events based on the + # events requested by Tcl's IO system, and the mask of + # events the instance's channel can handle, per all + # preceding calls of allow and disallow. + + method watch {c requestmask} { + if {$requestmask eq $requested} return + set requested $requestmask + my Update + return + } + + # # ## ### ##### ######## ############# + + # Declare that the named events are handled by the + # channel. This may start a timer to periodically post + # these events to the instance's channel. + + method allow {args} { + my Allowance $args yes + return + } + + # Declare that the named events are not handled by the + # channel. This may stop the periodic posting of events + # to the instance's channel. + + method disallow {args} { + my Allowance $args no + return + } + + # # ## ### ##### ######## ############# + + # Event System State - Timer driven + + 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. + # posting = Set of events we are posting. + # delay = Millisec interval between posts. + + # 'allowed' is an Array (event name -> boolean). The + # value is true if the named event is allowed to be + # posted. + + # Common code used by both allow and disallow to enter + # the state change. + + method Allowance {events enable} { + set changed no + foreach event $events { + if {$allowed($event) == $enable} continue + set allowed($event) $enable + set changed yes + } + if {!$changed} return + my Update + return + } + + # Merge the current event allowance and the set of + # requested events into one datum, the set of events to + # post. From that then derive whether we need a timer or + # not and act accordingly. + + method Update {} { + catch { after cancel $timer } + set posting {} + foreach event $requested { + if {!$allowed($event)} continue + lappend posting $event + } + if {[llength $posting]} { + set timer [after $delay \ + [namespace code [list my Post]]] + } else { + catch { unset timer } + } + return + } + + # Post the current set of events, then reschedule to + # make this periodic. + + method Post {} { + my variable channel + set timer [after $delay \ + [namespace code [list my Post]]] + chan postevent $channel $posting + return + } +} + +# # ## ### ##### +package provide tcl::chan::events 1.1 +return diff --git a/src/vendorlib/virtchannel_core/pkgIndex.tcl b/src/vendorlib/virtchannel_core/pkgIndex.tcl new file mode 100644 index 0000000..300eb27 --- /dev/null +++ b/src/vendorlib/virtchannel_core/pkgIndex.tcl @@ -0,0 +1,8 @@ +if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} + +package ifneeded tcl::chan::core 1.1 [list source [file join $dir core.tcl]] +package ifneeded tcl::chan::events 1.1 [list source [file join $dir events.tcl]] + +if {![package vsatisfies [package provide Tcl] 8.6 9]} {return} + +package ifneeded tcl::transform::core 1.1 [list source [file join $dir transformcore.tcl]] diff --git a/src/vendorlib/virtchannel_core/transformcore.man b/src/vendorlib/virtchannel_core/transformcore.man new file mode 100644 index 0000000..0fd0c60 --- /dev/null +++ b/src/vendorlib/virtchannel_core/transformcore.man @@ -0,0 +1,72 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::core n 1.1] +[keywords {reflected channel}] +[keywords {tip 219}] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Basic reflected/virtual channel transform support}] +[require Tcl "8.5 9"] +[require TclOO] +[require tcl::transform::core [opt 1.1]] +[description] +[para] + +The [package tcl::transform::core] package provides a [package TclOO] +class implementing common behaviour needed by virtually every +reflected or virtual channel transformation (initialization, finalization). + +[para] This class expects to be used as either superclass of a concrete +channel class, or to be mixed into such a class. + +[section {Class API}] + +[list_begin definitions] + +[call [cmd ::tcl::transform::core] [arg objectName]] + +This command creates a new transform core object with an associated +global Tcl command whose name is [emph objectName]. This command may +be used to invoke various operations on the object, as described in +the section for the [sectref {Instance API}]. + +[list_end] + +[section {Instance API}] + +The API of transform core instances provides only two methods, both +corresponding to transform handler commands (For reference see +[uri http:/tip.tcl.tk/230 {TIP 230}]). They expect to be called +from whichever object instance the transform core was made a part of. + +[list_begin definitions] + +[call [arg objectName] [method initialize] [arg thechannel] [arg mode]] + +This method implements standard behaviour for the [method initialize] +method of transform handlers. Using introspection it finds the handler +methods supported by the instance and returns a list containing their +names, as expected by the support for reflected transformation in the +Tcl core. + +[para] It further remembers the channel handle in an instance variable +for access by sub-classes. + +[call [arg objectName] [method finalize] [arg thechannel]] + +This method implements standard behaviour for the [method finalize] +method of channel handlers. It simply destroys itself. + +[call [arg objectName] [method destroy]] + +Destroying the transform core instance closes the channel and transform +it was initialized for, see the method [method initialize]. When destroyed +from within a call of [method finalize] this does not happen, under +the assumption that the channel and transform are being destroyed by Tcl. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_core/transformcore.tcl b/src/vendorlib/virtchannel_core/transformcore.tcl new file mode 100644 index 0000000..3cd8c69 --- /dev/null +++ b/src/vendorlib/virtchannel_core/transformcore.tcl @@ -0,0 +1,71 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::core 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Support package handling a core +# Meta description aspect of reflected transform channels +# Meta description (initialization, finalization). +# Meta description It is expected that this class +# Meta description is used as either one superclass of the +# Meta description class C for a specific channel, or is +# Meta description mixed into C. +# Meta platform tcl +# Meta require TclOO +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 + +# # ## ### ##### ######## ############# + +oo::class create ::tcl::transform::core { + destructor { + if {$channel eq {}} return + close $channel + return + } + + # # ## ### ##### ######## ############# + + method initialize {thechannel mode} { + set methods [info object methods [self] -all] + + # Note: Checking of the mode against the supported methods is + # done by the caller. + + set channel $thechannel + set supported {} + foreach m { + initialize finalize read write drain flush limit? + } { + if {$m in $methods} { + lappend supported $m + } + } + return $supported + } + + method finalize {c} { + set channel {} ; # Prevent destroctor from calling close. + my destroy + return + } + + # # ## ### ##### ######## ############# + + variable channel + + # channel The channel the handler belongs to. + # # ## ### ##### ######## ############# +} + +# # ## ### ##### +package provide tcl::transform::core 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/ChangeLog b/src/vendorlib/virtchannel_transform/ChangeLog new file mode 100644 index 0000000..ec450b8 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/ChangeLog @@ -0,0 +1,53 @@ +2013-03-04 Andreas Kupries + + * zlib.man: Renamed, clashes with Tcl core manpage. + * tcllib_zlib.man: New name. + +2013-02-01 Andreas Kupries + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2011-12-13 Andreas Kupries + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-02-21 Andreas Kupries + + * pkgIndex.tcl: Removed the superfluous [list] command in the + ifneeded script. + +2011-01-24 Andreas Kupries + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2010-08-04 Andreas Kupries + + * adler32.man: New files, documentation for the packages in + * base64.man: this module. + * counter.man: + * crc32.man: + * hex.man: + * identity.man: + * limitsize.man: + * observe.man: + * otp.man: + * rot.man: + * spacer.man: + * zlib.man: + +2009-12-07 Andreas Kupries + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2009-12-01 Andreas Kupries + + * New module 'virtchannel_transform, providing classes implementing + various channel transformation. TclOO based. diff --git a/src/vendorlib/virtchannel_transform/README.txt b/src/vendorlib/virtchannel_transform/README.txt new file mode 100644 index 0000000..46c7e9b --- /dev/null +++ b/src/vendorlib/virtchannel_transform/README.txt @@ -0,0 +1,38 @@ +base64, hex + + Base64 and hex de- and encoding of data flowing + through a channel. + + Encodes on write, decodes on read. + +identity + + No transformation + +counter + + Identity, counting bytes. + +adler32, adler32pure, crc32 + + Compute checksums and write to external variables. + +observe + + Divert copy of the data to additional channels. + +limitsize + + Force EOF after reading N bytes, N configurable. + +spacer + + Inserts separator string every n bytes. + +otp + + One-Time-Pad encryption. + +zlib + + zlib (de)compression (deflate, inflate). diff --git a/src/vendorlib/virtchannel_transform/adler32.man b/src/vendorlib/virtchannel_transform/adler32.man new file mode 100644 index 0000000..8a96a7e --- /dev/null +++ b/src/vendorlib/virtchannel_transform/adler32.man @@ -0,0 +1,70 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::adler32 n 1.1] +[keywords adler32] +[keywords {channel transformation}] +[keywords checksum] +[keywords {reflected channel}] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Adler32 transformation}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::adler32 [opt 1.1]] +[description] +[para] + +The [package tcl::transform::adler32] package provides a command +creating a channel transformation which passes the read and written +bytes through unchanged (like [package tcl::transform::identity]), but +additionally continuously computes the adler32 checksums of the data +it has seen for each direction and stores them in Tcl variables +specified at construction time. + +[para] Related transformations in this module are +[package tcl::transform::counter], +[package tcl::transform::crc32], +[package tcl::transform::identity], and +[package tcl::transform::observe]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::adler32] [arg chan] [option -option] [arg value]...] + +This command creates an adler32 checksumming transformation on top of +the channel [arg chan] and returns its handle. The accepted options are + +[list_begin options] +[opt_def -read-variable varname] + +The value of the option is the name of a global or namespaced +variable, the location where the transformation has to store the +adler32 checksum of the data read from the channel. + +[para] If not specified, or the empty string, the checksum of the read +direction is not saved. + +[opt_def -write-variable varname] + +The value of the option is the name of a global or namespaced +variable, the location where the transformation has to store the +adler32 checksum of the data written to the channel. + +[para] If not specified, or the empty string, the checksum of the +write direction is not saved. + +[list_end] +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/adler32.tcl b/src/vendorlib/virtchannel_transform/adler32.tcl new file mode 100644 index 0000000..af31e0c --- /dev/null +++ b/src/vendorlib/virtchannel_transform/adler32.tcl @@ -0,0 +1,103 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::adler32 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes For other observers see crc32, counter, +# Meta as::notes identity, and observer (stream copy). +# Meta description Implementation of an adler32 checksum +# Meta description transformation. Based on Tcl 8.6's +# Meta description transformation reflection support (TIP +# Meta description 230), and its zlib support (TIP 234) for +# Meta description the adler32 functionality. An observer +# Meta description instead of a transformation. For details +# Meta description on the adler checksum see +# Meta description http://en.wikipedia.org/wiki/Adler-32 . +# Meta description The observer saves the checksums into two +# Meta description namespaced external variables specified +# Meta description at construction time. Exports a single +# Meta description command adding a new transformation of +# Meta description this type to a channel. One argument, +# Meta description the channel to extend, plus options to +# Meta description specify the variables for the checksums. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::adler32 {chan args} { + ::chan push $chan [adler32::implementation new {*}$args] +} + +oo::class create ::tcl::transform::adler32::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation continuously computes a checksum from the + # data it sees. This data may be arbitrary parts of the input or + # output if the channel is seeked while the transform is + # active. This may not be what is wanted and the desired behaviour + # may require the destruction of the transform before seeking. + + method write {c data} { + my Adler32 -write-variable $data + return $data + } + + method read {c data} { + my Adler32 -read-variable $data + return $data + } + + # # ## ### ##### ######## ############# + + constructor {args} { + array set options { + -read-variable {} + -write-variable {} + } + # todo: validity checking of options (legal names, legal + # values, etc.) + array set options $args + my Init -read-variable + my Init -write-variable + return + } + + # # ## ### ##### ######## ############# + + variable options + + # # ## ### ##### ######## ############# + + method Init {o} { + if {$options($o) eq ""} return + upvar #0 $options($o) adler + set adler 1 + return + } + + method Adler32 {o data} { + if {$options($o) eq ""} return + upvar #0 $options($o) adler + set adler [zlib adler32 $data $adler] + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::adler32 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/base64.tcl b/src/vendorlib/virtchannel_transform/base64.tcl new file mode 100644 index 0000000..feaf7da --- /dev/null +++ b/src/vendorlib/virtchannel_transform/base64.tcl @@ -0,0 +1,111 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::base64 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes Possibilities for extension: Currently +# Meta as::notes the mapping between read/write and +# Meta as::notes decode/encode is fixed. Allow it to be +# Meta as::notes configured at construction time. +# Meta description Implementation of a base64 +# Meta description transformation (RFC 4648). Based on Tcl +# Meta description 8.6's transformation reflection support +# Meta description (TIP 230) and binary en/decode (TIP 317). +# Meta description Exports a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description One argument, the channel to extend. No +# Meta description result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::base64 {chan} { + ::chan push $chan [base64::implementation new] + return +} + +oo::class create ::tcl::transform::base64::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + my Code encodebuf encode $data 3 + } + + method read {c data} { + my Code decodebuf decode $data 4 + } + + method flush {c} { + set data [binary encode base64 $encodebuf] + set encodebuf {} + return $data + } + + method drain {c} { + set data [binary decode base64 $decodebuf] + set decodebuf {} + return $data + } + + method clear {c} { + set decodebuf {} + return + } + + # # ## ### ##### ######## ############# + + constructor {} { + set encodebuf {} + set decodebuf {} + return + } + + # # ## ### ##### ######## ############# + + variable encodebuf decodebuf + + # # ## ### ##### ######## ############# + + method Code {bufvar op data n} { + upvar 1 $bufvar buffer + + append buffer $data + + set n [my Complete $buffer $n] + if {$n < 0} { + return {} + } + + set result \ + [binary $op base64 \ + [string range $buffer 0 $n]] + incr n + set buffer \ + [string range $buffer $n end] + + return $result + } + + method Complete {buffer n} { + set len [string length $buffer] + return [expr {(($len / $n) * $n)-1}] + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::base64 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/counter.tcl b/src/vendorlib/virtchannel_transform/counter.tcl new file mode 100644 index 0000000..4b8a6f2 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/counter.tcl @@ -0,0 +1,94 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::counter 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes For other observers see adler32, crc32, +# Meta as::notes identity, and observer (stream copy). +# Meta as::notes Possibilities for extension: Separate +# Meta as::notes counters per byte value. Count over +# Meta as::notes fixed time-intervals = channel speed. +# Meta as::notes Use callbacks or traces to save changes +# Meta as::notes in the counters, etc. as time-series. +# Meta as::notes Compute statistics over the time-series. +# Meta description Implementation of a counter +# Meta description transformation. Based on Tcl 8.6's +# Meta description transformation reflection support (TIP +# Meta description 230). An observer instead of a +# Meta description transformation, it counts the number of +# Meta description bytes read and written. The observer +# Meta description saves the counts into two external +# Meta description namespaced variables specified at +# Meta description construction time. Exports a single +# Meta description command adding a new transformation of +# Meta description this type to a channel. One argument, +# Meta description the channel to extend, plus options to +# Meta description specify the variables for the counters. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::counter {chan args} { + ::chan push $chan [counter::implementation new {*}$args] +} + +oo::class create ::tcl::transform::counter::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + my Count -write-variable $data + return $data + } + + method read {c data} { + my Count -read-variable $data + return $data + } + + # No partial data, nor state => no flush, drain, nor clear needed. + + # # ## ### ##### ######## ############# + + constructor {args} { + array set options { + -read-variable {} + -write-variable {} + } + # todo: validity checking of options (legal names, legal + # values, etc.) + array set options $args + return + } + + # # ## ### ##### ######## ############# + + variable options + + # # ## ### ##### ######## ############# + + method Count {o data} { + if {$options($o) eq ""} return + upvar #0 $options($o) counter + incr counter [string length $data] + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::counter 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/crc32.tcl b/src/vendorlib/virtchannel_transform/crc32.tcl new file mode 100644 index 0000000..2897491 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/crc32.tcl @@ -0,0 +1,103 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::crc32 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes For other observers see adler32, counter, +# Meta as::notes identity, and observer (stream copy). +# Meta description Implementation of a crc32 checksum +# Meta description transformation. Based on Tcl 8.6's +# Meta description transformation reflection support (TIP +# Meta description 230), and its zlib support (TIP 234) for +# Meta description the crc32 functionality. An observer +# Meta description instead of a transformation. For details +# Meta description on the crc checksum see +# Meta description http://en.wikipedia.org/wiki/Cyclic_redundancy_check#Commonly_used_and_standardised_CRCs . +# Meta description The observer saves the checksums into two +# Meta description namespaced external variables specified +# Meta description at construction time. Exports a single +# Meta description command adding a new transformation of +# Meta description this type to a channel. One argument, +# Meta description the channel to extend, plus options to +# Meta description specify the variables for the checksums. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::crc32 {chan args} { + ::chan push $chan [crc32::implementation new {*}$args] +} + +oo::class create ::tcl::transform::crc32::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation continuously computes a checksum from the + # data it sees. This data may be arbitrary parts of the input or + # output if the channel is seeked while the transform is + # active. This may not be what is wanted and the desired behaviour + # may require the destruction of the transform before seeking. + + method write {c data} { + my Crc32 -write-variable $data + return $data + } + + method read {c data} { + my Crc32 -read-variable $data + return $data + } + + # # ## ### ##### ######## ############# + + constructor {args} { + array set options { + -read-variable {} + -write-variable {} + } + # todo: validity checking of options (legal names, legal + # values, etc.) + array set options $args + my Init -read-variable + my Init -write-variable + return + } + + # # ## ### ##### ######## ############# + + variable options + + # # ## ### ##### ######## ############# + + method Init {o} { + if {$options($o) eq ""} return + upvar #0 $options($o) crc + set crc 0 + return + } + + method Crc32 {o data} { + if {$options($o) eq ""} return + upvar #0 $options($o) crc + set crc [zlib crc32 $data $crc] + return + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::crc32 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/hex.man b/src/vendorlib/virtchannel_transform/hex.man new file mode 100644 index 0000000..5a11ad2 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/hex.man @@ -0,0 +1,43 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::hex n 1.1] +[keywords {channel transformation}] +[keywords hexadecimal] +[keywords {reflected channel}] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Hexadecimal encoding transformation}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::hex [opt 1.1]] +[description] +[para] + +The [package tcl::transform::hex] package provides a command creating +a channel transformation which hex encodes data written to it, and +decodes the data read from it. + +[para] A related transformations in this module is +[package tcl::transform::base64]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::hex] [arg chan]] + +This command creates a hex transformation on top of the channel +[arg chan] and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/hex.tcl b/src/vendorlib/virtchannel_transform/hex.tcl new file mode 100644 index 0000000..799eac7 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/hex.tcl @@ -0,0 +1,58 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::hex 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a hex transformation, +# Meta description using Tcl 8.6's transformation +# Meta description reflection support. Uses the binary +# Meta description command to implement the transformation. +# Meta description Exports a single command adding a new +# Meta description transform of this type to a channel. One +# Meta description argument, the channel to extend. No +# Meta description result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::hex {chan} { + ::chan push $chan [hex::implementation new] + return +} + +oo::class create ::tcl::transform::hex::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + # bytes -> hex + binary scan $data H* hex + return $hex + } + + method read {c data} { + # hex -> bytes + return [binary format H* $data] + } + + # No partial data, nor state => no flush, drain, nor clear needed. + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::hex 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/identity.man b/src/vendorlib/virtchannel_transform/identity.man new file mode 100644 index 0000000..48e9693 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/identity.man @@ -0,0 +1,50 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::identity n 1.1] +[keywords {channel transformation}] +[keywords identity] +[keywords {reflected channel}] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Identity transformation}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::identity [opt 1.1]] +[description] +[para] + +The [package tcl::transform::identity] package provides a command +creating an identity channel transformation, which does nothing but +pass the read and written bytes through it unchanged. Not really +useful in an application, however as the prototypical observer +transformation its code is a useful starting point for any other +observers people may wish to write. + +[para] The transformations in this module which derived from +identity's code are +[package tcl::transform::adler32], +[package tcl::transform::counter], +[package tcl::transform::crc32], and +[package tcl::transform::observe]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::identity] [arg chan]] + +This command creates an identity transformation on top of the channel +[arg chan] and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/identity.tcl b/src/vendorlib/virtchannel_transform/identity.tcl new file mode 100644 index 0000000..d3b613c --- /dev/null +++ b/src/vendorlib/virtchannel_transform/identity.tcl @@ -0,0 +1,59 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::identity 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes The prototypical observer transformation. +# Meta as::notes To observers what null is to reflected +# Meta as::notes base channels. For other observers see +# Meta as::notes adler32, crc32, counter, and observer +# Meta as::notes (stream copy). +# Meta description Implementation of an identity +# Meta description transformation, i.e one which does not +# Meta description change the data in any way, shape, or +# Meta description form. Based on Tcl 8.6's transformation +# Meta description reflection support. Exports a single +# Meta description command adding a new transform of this +# Meta description type to a channel. One argument, the +# Meta description channel to extend. No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::identity {chan} { + ::chan push $chan [identity::implementation new] +} + +oo::class create ::tcl::transform::identity::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + return $data + } + + method read {c data} { + return $data + } + + # No partial data, nor state => no flush, drain, nor clear needed. + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::identity 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/limitsize.man b/src/vendorlib/virtchannel_transform/limitsize.man new file mode 100644 index 0000000..3749a06 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/limitsize.man @@ -0,0 +1,46 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::limitsize n 1.1] +[keywords {channel transformation}] +[keywords limitsize] +[keywords {reflected channel}] +[keywords {size limit}] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {limiting input}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::limitsize [opt 1.1]] +[description] +[para] + +The [package tcl::transform::limitsize] package provides a command +creating a channel transformation which limits the number of +characters which can be read from the channel. A generator for an +artificial EOF. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::limitsize] [arg chan] [arg max]] + +This command creates a size limiting transformation on top of the +channel [arg chan] and returns its handle. + +[para] [arg max] is the number of bytes which can be read from the +channel before EOF is signaled by the transformation. Note that +popping the transformation clears the EOF it generated as well. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/limitsize.tcl b/src/vendorlib/virtchannel_transform/limitsize.tcl new file mode 100644 index 0000000..7d1f821 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/limitsize.tcl @@ -0,0 +1,88 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::limitsize 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes Possibilities for extension: Trigger the +# Meta as::notes EOF when finding specific patterns in +# Meta as::notes the input. Trigger the EOF based on some +# Meta as::notes external signal routed into the limiter. +# Meta as::notes Make the limit reconfigurable. +# Meta description Implementation of a transformation +# Meta description limiting the number of bytes read +# Meta description from its channel. An observer instead of +# Meta description a transformation, forcing an artificial +# Meta description EOF marker. Based on Tcl 8.6's +# Meta description transformation reflection support. +# Meta description Exports a single command adding a new +# Meta description transform of this type to a channel. One +# Meta description argument, the channel to extend, and the +# Meta description number of bytes to allowed to be read. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# This may help with things like zlib compression of messages. Have +# the message format a length at the front, followed by a payload of +# that size. Now we may compress messages. On the read side we can use +# the limiter to EOF on a message, then reset the limit for the +# next. This is a half-baked idea. + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::limitsize {chan max} { + ::chan push $chan [limitsize::implementation new $max] +} + +oo::class create ::tcl::transform::limitsize::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + return $data + } + + method read {c data} { + # Reduce the limit of bytes allowed in the future according to + # the number of bytes we have seen already. + + if {$max > 0} { + incr max -[string length $data] + if {$max < 0} { + set max 0 + } + } + return $data + } + + method limit? {c} { + return $max + } + + # # ## ### ##### ######## ############# + + constructor {themax} { + set max $themax + return + } + + variable max + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::limitsize 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/observe.man b/src/vendorlib/virtchannel_transform/observe.man new file mode 100644 index 0000000..89bce96 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/observe.man @@ -0,0 +1,50 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::observe n 1.1] +[keywords {channel transformation}] +[keywords observer] +[keywords {reflected channel}] +[keywords {stream copy}] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Observer transformation, stream copy}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::observe [opt 1.1]] +[description] +[para] + +The [package tcl::transform::observer] package provides a command +creating a channel transformation which passes the read and written +bytes through unchanged (like [package tcl::transform::identity]), but +additionally copies the data it has seen for each direction into +channels specified at construction time. + +[para] Related transformations in this module are +[package tcl::transform::adler32], +[package tcl::transform::counter], +[package tcl::transform::crc32], and +[package tcl::transform::identity]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::observe] [arg chan] [arg logw] [arg logr]] + +This command creates an observer transformation on top of the channel +[arg chan] and returns its handle. The channel handles [arg logr] and +[arg logw] are there the data is copied to. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/observe.tcl b/src/vendorlib/virtchannel_transform/observe.tcl new file mode 100644 index 0000000..93e1331 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/observe.tcl @@ -0,0 +1,80 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::observe 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes For other observers see adler32, crc32, +# Meta as::notes identity, and counter. +# Meta as::notes Possibilities for extension: Save the +# Meta as::notes observed bytes to variables instead of +# Meta as::notes channels. Use callbacks to save the +# Meta as::notes observed bytes. +# Meta description Implementation of an observer +# Meta description transformation copying the bytes going +# Meta description through it into two channels configured +# Meta description at construction time. Based on Tcl 8.6's +# Meta description transformation reflection support. +# Meta description Exports a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description Three arguments, the channel to extend, +# Meta description plus the channels to write the bytes to. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::observe {chan logw logr} { + ::chan push $chan [observe::implementation new $logw $logr] +} + +oo::class create ::tcl::transform::observe::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + method write {c data} { + if {$logw ne {}} { + puts -nonewline $logw $data + } + return $data + } + + method read {c data} { + if {$logr ne {}} { + puts -nonewline $logr $data + } + return $data + } + + # No partial data, nor state => no flush, drain, nor clear needed. + + # # ## ### ##### ######## ############# + + constructor {lw lr} { + set logr $lr + set logw $lw + return + } + + # # ## ### ##### ######## ############# + + variable logr logw + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::observe 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/otp.tcl b/src/vendorlib/virtchannel_transform/otp.tcl new file mode 100644 index 0000000..61663f7 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/otp.tcl @@ -0,0 +1,98 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::otp 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of an onetimepad +# Meta description encryption transformation. Based on Tcl +# Meta description 8.6's transformation reflection support. +# Meta description The key bytes are read from two channels +# Meta description configured at construction time. Exports +# Meta description a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description Three arguments, the channel to extend, +# Meta description plus the channels to read the keys from. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::otp {chan keychanw keychanr} { + ::chan push $chan [otp::implementation new $keychanw $keychanr] +} + +oo::class create ::tcl::transform::otp::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation is intended for streaming operation. Seeking + # the channel while it is active may cause undesirable + # output. Proper behaviour may require the destruction of the + # transform before seeking. + + method write {c data} { + return [my Xor $data $keychanw] + } + + method read {c data} { + return [my Xor $data $keychanr] + } + + # # ## ### ##### ######## ############# + + constructor {keyw keyr} { + set keychanr $keyr + set keychanw $keyw + return + } + + # # ## ### ##### ######## ############# + + variable keychanr keychanw + + # # ## ### ##### ######## ############# + + # A very convoluted way to perform the XOR would be to use TIP + # #317's hex encoding to convert the bytes into strings, then zip + # key and data into an interleaved string (nibble wise), then + # perform the xor as a 'string map' of the whole thing, and at + # last 'binary decode hex' the string back into bytes. Even so + # most ops would run on the whole message at C level. Except for + # the interleave. :( + + method Xor {data keychan} { + # xor is done byte-wise. to keep IO down we read the key bytes + # once, before the loop handling the bytes. Note that we are + # having binary data at this point, making it necessary to + # convert into numbers (scan), and back (binary format). + + set keys [read $keychan [string length $data]] + set result {} + foreach d [split $data {}] k [split $keys {}] { + append result \ + [binary format c \ + [expr { + [scan $d %c] ^ + [scan $k %c] + }]] + } + return $result + } +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::otp 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/pkgIndex.tcl b/src/vendorlib/virtchannel_transform/pkgIndex.tcl new file mode 100644 index 0000000..0067c17 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/pkgIndex.tcl @@ -0,0 +1,14 @@ +if {![package vsatisfies [package provide Tcl] 8.6 9]} {return} + +package ifneeded tcl::transform::adler32 1.1 [list source [file join $dir adler32.tcl]] +package ifneeded tcl::transform::base64 1.1 [list source [file join $dir base64.tcl]] +package ifneeded tcl::transform::counter 1.1 [list source [file join $dir counter.tcl]] +package ifneeded tcl::transform::crc32 1.1 [list source [file join $dir crc32.tcl]] +package ifneeded tcl::transform::hex 1.1 [list source [file join $dir hex.tcl]] +package ifneeded tcl::transform::identity 1.1 [list source [file join $dir identity.tcl]] +package ifneeded tcl::transform::limitsize 1.1 [list source [file join $dir limitsize.tcl]] +package ifneeded tcl::transform::observe 1.1 [list source [file join $dir observe.tcl]] +package ifneeded tcl::transform::otp 1.1 [list source [file join $dir otp.tcl]] +package ifneeded tcl::transform::rot 1.1 [list source [file join $dir rot.tcl]] +package ifneeded tcl::transform::spacer 1.1 [list source [file join $dir spacer.tcl]] +package ifneeded tcl::transform::zlib 1.0.2 [list source [file join $dir zlib.tcl]] diff --git a/src/vendorlib/virtchannel_transform/rot.man b/src/vendorlib/virtchannel_transform/rot.man new file mode 100644 index 0000000..0e94ef4 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/rot.man @@ -0,0 +1,57 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::rot n 1.1] +[keywords {caesar cipher}] +[keywords {channel transformation}] +[keywords cipher] +[keywords decryption] +[keywords encryption] +[keywords {reflected channel}] +[keywords rot] +[keywords rot13] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {rot-encryption}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::rot [opt 1.1]] +[description] +[para] + +The [package tcl::transform::rot] package provides a command creating +a channel transformation which performs primitive encryption (on +writing) and decryption (on reading) on the alphabetic characters. The +algorithm is the Caesar-cipher, a specific variant of which is rot13. + +[para] A related transformations in this module is +[package tcl::transform::otp]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::rot] [arg chan] [arg key]] + +This command creates a rot encryption transformation on top of the +channel [arg chan] and returns its handle. + +[para] The "[arg key]" specifies how far characters are rotated in the +alphabet, and is wrapped to the range "0...25". + +[para] Note that this transformation affects only bytes in the ranges +ASCII 65...90, and 97...122, i.e. the upper- and lower-case alphabetic +characters, i.e. "A...Z" and "a...z". All other bytes are passed +through unchanged. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/rot.tcl b/src/vendorlib/virtchannel_transform/rot.tcl new file mode 100644 index 0000000..2fa9803 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/rot.tcl @@ -0,0 +1,95 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::rot 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a rot +# Meta description encryption transformation. Based on Tcl +# Meta description 8.6's transformation reflection support. +# Meta description The key byte is +# Meta description configured at construction time. Exports +# Meta description a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description Two arguments, the channel to extend, +# Meta description plus the key byte. +# Meta description No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::rot {chan key} { + ::chan push $chan [rot::implementation new $key] +} + +oo::class create ::tcl::transform::rot::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation is intended for streaming operation. Seeking + # the channel while it is active may cause undesirable + # output. Proper behaviour may require the destruction of the + # transform before seeking. + + method write {c data} { + return [my Rot $data $key] + } + + method read {c data} { + return [my Rot $data $ikey] + } + + # # ## ### ##### ######## ############# + + constructor {thekey} { + set key [expr {$thekey % 26}] + set ikey [expr {26 - $key}] + return + } + + # # ## ### ##### ######## ############# + + variable key ikey + + # # ## ### ##### ######## ############# + + method Rot {data key} { + # rot'ation is done byte-wise. Note that we are having binary + # data at this point, making it necessary to convert into + # numbers (scan), and back (binary format). + + set result {} + foreach d [split $data {}] { + set dx [scan $d %c] + if {(65 <= $dx) && ($dx <= 90)} { + set n [binary format c \ + [expr { (($dx - 65 + $key) % 26) + 65 }]] + } elseif {(97 <= $dx) && ($dx <= 122)} { + 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.1 +return diff --git a/src/vendorlib/virtchannel_transform/spacer.man b/src/vendorlib/virtchannel_transform/spacer.man new file mode 100644 index 0000000..0a29981 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/spacer.man @@ -0,0 +1,45 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::spacer n 1.1] +[keywords {channel transformation}] +[keywords {reflected channel}] +[keywords spacing] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Space insertation and removal}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::spacer [opt 1.1]] +[description] +[para] + +The [package tcl::transform::spacer] package provides a command +creating a channel transformation which adds spacing to the data +written to it, and removes such spacing from the data read from it. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::spacer] [arg chan] [arg n] [opt [arg space]]] + +This command creates a spacer transformation on top of the channel +[arg chan] and returns its handle. + +[para] The [arg space] character sequence will be added every [arg n] +bytes of data written, and on the read side the same is done in +reverse, removing the spacing. If [arg space] is not specified it +defaults to a single space character (ASCII 32). + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/spacer.tcl b/src/vendorlib/virtchannel_transform/spacer.tcl new file mode 100644 index 0000000..e3f481a --- /dev/null +++ b/src/vendorlib/virtchannel_transform/spacer.tcl @@ -0,0 +1,151 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::spacer 1.1 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta description Implementation of a spacer +# Meta description transformation, using Tcl 8.6's +# Meta description transformation reflection support. Uses +# Meta description counters to implement the transformation, +# Meta description i.e. decide where to insert the spacing. +# Meta description Exports a single command adding a new +# Meta description transform of this type to a channel. One +# Meta description argument, the channel to extend. No +# Meta description result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::spacer {chan n {space { }}} { + ::chan push $chan [spacer::implementation new $n $space] + return +} + +oo::class create ::tcl::transform::spacer::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation is intended for streaming operation. Seeking + # the channel while it is active may cause undesirable + # output. Proper behaviour may require the destruction of the + # transform before seeking. + + method write {c data} { + # add spacing, data is split into groups of delta chars. + set result {} + set len [string length $data] + + if {$woffset} { + # The beginning of the buffer is the remainder of the + # partial group found at the end of the buffer in the last + # call. It may still be partial, if the current buffer is + # short enough. + + if {($woffset + $len) < $delta} { + # Yes, the group is still not fully covered. + # Move the offset forward, and return the whole + # buffer. spacing is not needed yet. + incr woffset $len + return $data + } + + # The buffer completes the group. Add it and the following + # spacing, then fix the offset to start the processing of + # the groups coming after at the proper location. + + set stop [expr {$delta - $woffset - 1}] + + append result [string range $data 0 $stop] + append result $spacing + + set woffset $stop + incr woffset + } + + # Process full groups in the middle of the incoming buffer. + + set at $woffset + set stop [expr {$at + $delta - 1}] + while {$stop < $len} { + append result [string range $data $at $stop] + append result $spacing + incr at $delta + incr stop $delta + } + + # Process partial group at the end of the buffer and remember + # the offset, for the processing of the group remainder in the + # next call. + + if {($at < $len) && ($stop >= $len)} { + append result [string range $data $at end] + } + set woffset [expr {$len - $at}] + return $result + } + + method read {c data} { + # remove spacing from groups of delta+sdelta chars, keeping + # the first delta in each group. + set result {} + set iter [expr {$delta + $sdelta}] + set at 0 + if {$roffset} { + if {$roffset < $delta} { + append result [string range $data 0 ${roffset}-1] + } + incr at [expr {$iter - $roffset}] + } + set len [string length $data] + set end [expr {$at + $delta - 1}] + set stop [expr {$at + $iter - 1}] + while {$stop < $len} { + append result [string range $data $at $end] + incr at $iter + incr end $iter + incr stop $iter + } + if {$end < $len} { + append result [string range $data $at $end] + set roffset [expr {$len - $end + 1}] + } elseif {$at < $len} { + append result [string range $data $at end] + set roffset [expr {$len - $at}] + } + return [list $result $roffset] + } + + # # ## ### ##### ######## ############# + + constructor {n space} { + set roffset 0 + set woffset 0 + set delta $n + set spacing $space + set sdelta [string length $spacing] + return + } + + # # ## ### ##### ######## ############# + + variable roffset woffset delta spacing sdelta + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::spacer 1.1 +return diff --git a/src/vendorlib/virtchannel_transform/tcllib_zlib.man b/src/vendorlib/virtchannel_transform/tcllib_zlib.man new file mode 100644 index 0000000..154cb6b --- /dev/null +++ b/src/vendorlib/virtchannel_transform/tcllib_zlib.man @@ -0,0 +1,46 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::zlib n 1.1] +[keywords {channel transformation}] +[keywords compression] +[keywords decompression] +[keywords {reflected channel}] +[keywords {tip 230}] +[keywords {tip 234}] +[keywords transformation] +[keywords {virtual channel}] +[keywords zlib] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {zlib (de)compression}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::zlib [opt 1.1]] +[description] +[para] + +The [package tcl::transform::zlib] package provides a command creating +a channel transformation which zlib compresses the written data, and +decompresses on reading. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::zlib] [arg chan] [opt [arg level]]] + +This command creates a zlib compressor transformation on top of the +channel [arg chan] and returns its handle. + +[para] The [arg level] specifies how much effort is put into the +compression, from [const 0] to [const 9], and defaults to [const 4]. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/vt_base64.man b/src/vendorlib/virtchannel_transform/vt_base64.man new file mode 100644 index 0000000..a67d02f --- /dev/null +++ b/src/vendorlib/virtchannel_transform/vt_base64.man @@ -0,0 +1,44 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::base64 n 1.1] +[keywords base64] +[keywords {channel transformation}] +[keywords {reflected channel}] +[keywords {tip 230}] +[keywords {tip 317}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Base64 encoding transformation}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::base64 [opt 1.1]] +[description] +[para] + +The [package tcl::transform::base64] package provides a command +creating a channel transformation which base64 encodes data written to +it, and decodes the data read from it. + +[para] A related transformations in this module is +[package tcl::transform::hex]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::base64] [arg chan]] + +This command creates a base64 transformation on top of the channel +[arg chan] and returns its handle. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/vt_counter.man b/src/vendorlib/virtchannel_transform/vt_counter.man new file mode 100644 index 0000000..9cd9059 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/vt_counter.man @@ -0,0 +1,68 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::counter n 1.1] +[keywords {channel transformation}] +[keywords counter] +[keywords {reflected channel}] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Counter transformation}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::counter [opt 1.1]] +[description] +[para] + +The [package tcl::transform::counterr] package provides a command +creating a channel transformation which passes the read and written +bytes through unchanged (like [package tcl::transform::identity]), but +additionally counts the bytes it has seen for each direction and +stores these counts in Tcl variables specified at construction time. + +[para] Related transformations in this module are +[package tcl::transform::adler32], +[package tcl::transform::crc32], +[package tcl::transform::identity], and +[package tcl::transform::observe]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::counter] [arg chan] [option -option] [arg value]...] + +This command creates a counter transformation on top of the channel +[arg chan] and returns its handle. The accepted options are + +[list_begin options] +[opt_def -read-variable varname] + +The value of the option is the name of a global or namespaced +variable, the location where the transformation has to store the +byte count of the data read from the channel. + +[para] If not specified, or the empty string, the counter of the read +direction is not saved. + +[opt_def -write-variable varname] + +The value of the option is the name of a global or namespaced +variable, the location where the transformation has to store the +byte count of the data written to the channel. + +[para] If not specified, or the empty string, the counter of the +write direction is not saved. + +[list_end] +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/vt_crc32.man b/src/vendorlib/virtchannel_transform/vt_crc32.man new file mode 100644 index 0000000..112251b --- /dev/null +++ b/src/vendorlib/virtchannel_transform/vt_crc32.man @@ -0,0 +1,70 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::crc32 n 1.1] +[keywords {channel transformation}] +[keywords checksum] +[keywords crc32] +[keywords {reflected channel}] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Crc32 transformation}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::crc32 [opt 1.1]] +[description] +[para] + +The [package tcl::transform::crc32] package provides a command +creating a channel transformation which passes the read and written +bytes through unchanged (like [package tcl::transform::identity]), but +additionally continuously computes the crc32 checksums of the data it +has seen for each direction and stores them in Tcl variables specified +at construction time. The checksum in question is zlib's crc32. + +[para] Related transformations in this module are +[package tcl::transform::adler32], +[package tcl::transform::counter], +[package tcl::transform::identity], and +[package tcl::transform::observe]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::crc32] [arg chan] [option -option] [arg value]...] + +This command creates a crc32 checksumming transformation on top of +the channel [arg chan] and returns its handle. The accepted options are + +[list_begin options] +[opt_def -read-variable varname] + +The value of the option is the name of a global or namespaced +variable, the location where the transformation has to store the +crc32 checksum of the data read from the channel. + +[para] If not specified, or the empty string, the checksum of the read +direction is not saved. + +[opt_def -write-variable varname] + +The value of the option is the name of a global or namespaced +variable, the location where the transformation has to store the +crc32 checksum of the data written to the channel. + +[para] If not specified, or the empty string, the checksum of the +write direction is not saved. + +[list_end] +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/vt_otp.man b/src/vendorlib/virtchannel_transform/vt_otp.man new file mode 100644 index 0000000..05513ff --- /dev/null +++ b/src/vendorlib/virtchannel_transform/vt_otp.man @@ -0,0 +1,53 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin tcl::transform::otp n 1.1] +[keywords {channel transformation}] +[keywords cipher] +[keywords decryption] +[keywords encryption] +[keywords {one time pad}] +[keywords otp] +[keywords {reflected channel}] +[keywords {tip 230}] +[keywords transformation] +[keywords {virtual channel}] +[keywords xor] +[copyright {2009 Andreas Kupries }] +[moddesc {Reflected/virtual channel support}] +[category Channels] +[titledesc {Encryption via one-time pad}] +[require Tcl "8.6 9"] +[require tcl::transform::core [opt 1.1]] +[require tcl::transform::otp [opt 1.1]] +[description] +[para] + +The [package tcl::transform::otp] package provides a command creating +a channel transformation which uses externally provided one-time pads +to perform encryption (on writing) and decryption (on reading). + +[para] A related transformations in this module is +[package tcl::transform::rot]. + +[para] The internal [package TclOO] class implementing the transform +handler is a sub-class of the [package tcl::transform::core] +framework. + +[section API] + +[list_begin definitions] + +[call [cmd ::tcl::transform::otp] [arg chan] [arg keychanw] [arg keychanr]] + +This command creates a one-time pad based encryption transformation on +top of the channel [arg chan] and returns its handle. + +[para] The two channels [arg keychanw] and [arg keychanr] contain the +one-time pads for the write and read directions, respectively. Their +contents are reads and xored with the bytes written to and read from +the channel. + +[list_end] + +[vset CATEGORY virtchannel] +[include ../common-text/feedback.inc] +[manpage_end] diff --git a/src/vendorlib/virtchannel_transform/zlib.tcl b/src/vendorlib/virtchannel_transform/zlib.tcl new file mode 100644 index 0000000..8599f24 --- /dev/null +++ b/src/vendorlib/virtchannel_transform/zlib.tcl @@ -0,0 +1,100 @@ +# -*- tcl -*- +# # ## ### ##### ######## ############# +# (C) 2009 Andreas Kupries + +# @@ Meta Begin +# Package tcl::transform::zlib 1.0.2 +# Meta as::author {Andreas Kupries} +# Meta as::copyright 2009 +# Meta as::license BSD +# Meta as::notes Possibilities for extension: Currently +# Meta as::notes the mapping between read/write and +# Meta as::notes de/compression is fixed. Allow it to be +# Meta as::notes configured at construction time. +# Meta description Implementation of a zlib (de)compressor. +# Meta description Based on Tcl 8.6's transformation +# Meta description reflection support (TIP 230) and zlib +# Meta description support (TIP 234). Compresses on write. +# Meta description Exports a single command adding a new +# Meta description transformation of this type to a channel. +# Meta description Two arguments, the channel to extend, +# Meta description and the compression level. No result. +# Meta platform tcl +# Meta require tcl::transform::core +# Meta require {Tcl 8.6} +# @@ Meta End + +# # ## ### ##### ######## ############# + +package require Tcl 8.6 9 +package require tcl::transform::core + +# # ## ### ##### ######## ############# + +namespace eval ::tcl::transform {} + +proc ::tcl::transform::zlib {chan {level 4}} { + ::chan push $chan [zlib::implementation new $level] + return +} + +oo::class create ::tcl::transform::zlib::implementation { + superclass tcl::transform::core ;# -> initialize, finalize, destructor + + # This transformation is intended for streaming operation. Seeking + # the channel while it is active may cause undesirable + # output. Proper behaviour may require the destruction of the + # transform before seeking. + + method initialize {c mode} { + set compressor [zlib stream deflate -level $level] + set decompressor [zlib stream inflate] + + next $c $mode + } + + method finalize {c} { + $compressor close + $decompressor close + + next $c + } + + method write {c data} { + $compressor put $data + return [$compressor get] + } + + method read {c data} { + $decompressor put $data + return [$decompressor get] + } + + method flush {c} { + $compressor flush + return [$compressor get] + } + + method drain {c} { + $decompressor flush + return [$decompressor get] + } + + # # ## ### ##### ######## ############# + + constructor {thelevel} { + # Should validate input (level in (0 ...9)) + set level $thelevel + return + } + + # # ## ### ##### ######## ############# + + variable level compressor decompressor + + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# +package provide tcl::transform::zlib 1.0.2 +return