51 changed files with 5045 additions and 51 deletions
@ -1,5 +1,5 @@ |
|||||||
if {![package vsatisfies [package provide Tcl] 8.2]} {return} |
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
package ifneeded base64 2.5 [list source [file join $dir base64.tcl]] |
package ifneeded base64 2.6.1 [list source [file join $dir base64.tcl]] |
||||||
package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] |
package ifneeded uuencode 1.1.6 [list source [file join $dir uuencode.tcl]] |
||||||
package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] |
package ifneeded yencode 1.1.4 [list source [file join $dir yencode.tcl]] |
||||||
package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] |
package ifneeded ascii85 1.1.1 [list source [file join $dir ascii85.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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -0,0 +1,173 @@ |
|||||||
|
# -*- 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 |
||||||
|
try { |
||||||
|
package require tcl::oo |
||||||
|
} trap {TCL PACKAGE UNFOUND} {tres topts} { |
||||||
|
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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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]] |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -0,0 +1,126 @@ |
|||||||
|
# -*- 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 |
||||||
|
if {[catch {package require tcl::oo}]} { |
||||||
|
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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -0,0 +1,75 @@ |
|||||||
|
# -*- 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 |
||||||
|
if {[catch {package require tcl::oo}]} { |
||||||
|
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 |
||||||
@ -0,0 +1,156 @@ |
|||||||
|
# -*- 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 |
||||||
|
if {[catch {package require tcl::oo}]} { |
||||||
|
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 |
||||||
@ -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]] |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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]] |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -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 |
||||||
@ -0,0 +1,131 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application zzzload 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license BSD |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
package require Thread |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval zzzload { |
||||||
|
variable loader_tid "" ;#thread id |
||||||
|
proc stacktrace {} { |
||||||
|
set stack "Stack trace:\n" |
||||||
|
for {set i 1} {$i < [info level]} {incr i} { |
||||||
|
set lvl [info level -$i] |
||||||
|
set pname [lindex $lvl 0] |
||||||
|
append stack [string repeat " " $i]$pname |
||||||
|
|
||||||
|
if {![catch {info args $pname} pargs]} { |
||||||
|
foreach value [lrange $lvl 1 end] arg $pargs { |
||||||
|
|
||||||
|
if {$value eq ""} { |
||||||
|
if {$arg != 0} { |
||||||
|
info default $pname $arg value |
||||||
|
} |
||||||
|
} |
||||||
|
append stack " $arg='$value'" |
||||||
|
} |
||||||
|
} else { |
||||||
|
append stack " !unknown vars for $pname" |
||||||
|
} |
||||||
|
|
||||||
|
append stack \n |
||||||
|
} |
||||||
|
return $stack |
||||||
|
} |
||||||
|
proc pkg_require {pkgname args} { |
||||||
|
variable loader_tid |
||||||
|
if {[set ver [package provide twapi]] ne ""} { |
||||||
|
#skip the whole shebazzle if it's already loaded |
||||||
|
return $ver |
||||||
|
} |
||||||
|
if {$loader_tid eq ""} { |
||||||
|
set loader_tid [thread::create -joinable -preserved] |
||||||
|
} |
||||||
|
if {![tsv::exists zzzload_pkg $pkgname]} { |
||||||
|
#puts stderr "zzzload pkg_require $pkgname" |
||||||
|
#puts [stacktrace] |
||||||
|
tsv::set zzzload_pkg $pkgname "loading" |
||||||
|
tsv::set zzzload_pkg_mutex $pkgname [thread::mutex create] |
||||||
|
set cond [thread::cond create] |
||||||
|
tsv::set zzzload_pkg_cond $pkgname $cond |
||||||
|
thread::send -async $loader_tid [string map [list <pkg> $pkgname <cond> $cond] { |
||||||
|
if {![catch {package require <pkg>} returnver]} { |
||||||
|
tsv::set zzzload_pkg <pkg> $returnver |
||||||
|
} else { |
||||||
|
tsv::set zzzload_pkg <pkg> "failed" |
||||||
|
} |
||||||
|
thread::cond notify <cond> |
||||||
|
}] |
||||||
|
return "loading" |
||||||
|
} else { |
||||||
|
return [tsv::get zzzload_pkg $pkgname] |
||||||
|
} |
||||||
|
} |
||||||
|
proc pkg_wait {pkgname} { |
||||||
|
if {[set ver [package provide twapi]] ne ""} { |
||||||
|
return $ver |
||||||
|
} |
||||||
|
|
||||||
|
set pkgstate [tsv::get zzzload_pkg $pkgname] |
||||||
|
if {$pkgstate eq "loading"} { |
||||||
|
set mutex [tsv::get zzzload_pkg_mutex $pkgname] |
||||||
|
thread::mutex lock $mutex |
||||||
|
set cond [tsv::get zzzload_pkg_cond $pkgname] |
||||||
|
while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { |
||||||
|
thread::cond wait $cond $mutex 3000 |
||||||
|
} |
||||||
|
set result [tsv::get zzzload_pkg $pkgname] |
||||||
|
thread::mutex unlock $mutex |
||||||
|
return $result |
||||||
|
} else { |
||||||
|
return $pkgstate |
||||||
|
} |
||||||
|
} |
||||||
|
proc shutdown {} { |
||||||
|
variable loader_tid |
||||||
|
if {[thread::exists $loader_tid]} { |
||||||
|
thread::release $loader_tid |
||||||
|
thread::join $loader_tid |
||||||
|
set loader_tid "" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide zzzload [namespace eval zzzload { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,111 @@ |
|||||||
|
|
||||||
|
wdir="$(pwd)"; [ "$(pwd)" = "/" ] && wdir="" |
||||||
|
case "$0" in |
||||||
|
/*) scriptpath="${0}";; |
||||||
|
*) scriptpath="$wdir/${0#./}";; |
||||||
|
esac |
||||||
|
scriptdir="${scriptpath%/*}" |
||||||
|
scriptdir=$(realpath $scriptdir) |
||||||
|
scriptpath=$(realpath $scriptpath) |
||||||
|
basename=$(basename "$scriptpath") #e.g fetchruntime.bash |
||||||
|
scriptroot="${basename%.*}" #e.g "fetchruntime" |
||||||
|
|
||||||
|
url_kitbase="https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master" |
||||||
|
runtime_available=0 |
||||||
|
if [[ "$OSTYPE" == "linux"* ]]; then |
||||||
|
arch=$(uname -i) |
||||||
|
if [[ "$arch" == "x86_64"* ]]; then |
||||||
|
url="${url_kitbase}/linux-x86_64/tclkit-902-Linux64-intel-dyn" |
||||||
|
archdir="${scriptdir}/runtime/linux-x86_64" |
||||||
|
output="${archdir}/tclkit-902-Linux64-intel-dyn" |
||||||
|
runtime_available=1 |
||||||
|
elif [[ "$arch" == "arm"* ]]; then |
||||||
|
url="${url_kitbase}/linux-arm/tclkit-902-Linux64-arm-dyn" |
||||||
|
archdir="${scriptdir}/runtime/linux-arm" |
||||||
|
output="${archdir}/tclkit-902-Linux64-arm-dyn" |
||||||
|
runtime_available=1 |
||||||
|
fi |
||||||
|
if [[ "$runtime_available" -eq 1 ]]; then |
||||||
|
echo "Please ensure libxFt.so.2 is available" |
||||||
|
echo "e.g on Ubuntu: sudo apt-get install libxft2" |
||||||
|
fi |
||||||
|
os="linux" |
||||||
|
elif [[ "$OSTYPE" == "darwin"* ]]; then |
||||||
|
os="macosx" |
||||||
|
#assumed to be Mach-O 'universal binaries' for both x86-64 and arm? - REVIEW |
||||||
|
url="${url_kitbase}/macosx/tclkit-902-Darwin64-dyn" |
||||||
|
archdir="${scriptdir}/runtime/macosx/" |
||||||
|
output="${archdir}/tclkit-902-Darwin64-dyn" |
||||||
|
runtime_available=1 |
||||||
|
elif [[ "$OSTYPE" == "freebsd"* ]]; then |
||||||
|
os="freebsd" |
||||||
|
elif [[ "$OSTYPE" == "dragonflybsd"* ]]; then |
||||||
|
os="dragonflybsd" |
||||||
|
elif [[ "$OSTYPE" == "netbsd"* ]]; then |
||||||
|
os="netbsd" |
||||||
|
elif [[ "$OSTYPE" == "win32" ]]; then |
||||||
|
os="win32" |
||||||
|
url="${url_kitbase}/win32-x86_64/tclsh902z.exe" |
||||||
|
archdir="${scriptdir}/runtime/win32-x86_64/" |
||||||
|
output="${archdir}/tcsh902z.exe" |
||||||
|
runtime_available=1 |
||||||
|
elif [[ "$OSTYPE" == "msys" ]]; then |
||||||
|
echo MSYS |
||||||
|
os="win32" |
||||||
|
#use 'command -v' (shell builtin preferred over external which) |
||||||
|
interp = `ps -p $$ | awk '$1 != "PID" {print $(NF)}' | tr -d '()' | sed -E 's/^.*\/|^-//'` |
||||||
|
shellpath=`command -v $interp` |
||||||
|
shellfolder="${shellpath%/*}" #avoid dependency on basename or dirname |
||||||
|
#"c:/windows/system32/" is quite likely in the path ahead of msys,git etc. |
||||||
|
#This breaks calls to various unix utils such as sed etc (wsl related?) |
||||||
|
export PATH="$shellfolder${PATH:+:${PATH}}" |
||||||
|
url="${url_kitbase}/win32-x86_64/tclsh902z.exe" |
||||||
|
archdir="${scriptdir}/runtime/win32-x86_64" |
||||||
|
output="${archdir}/tclsh902z.exe" |
||||||
|
runtime_available=1 |
||||||
|
else |
||||||
|
#os="$OSTYPE" |
||||||
|
os="other" |
||||||
|
fi |
||||||
|
|
||||||
|
case "$1" in |
||||||
|
"fetch") |
||||||
|
|
||||||
|
if [[ "$runtime_available" -eq 1 ]]; then |
||||||
|
#test win32 |
||||||
|
mkdir -p $archdir |
||||||
|
echo "Attempting to download $url" |
||||||
|
#wget $url -O $output |
||||||
|
curl -SL --output "$output" "$url" |
||||||
|
if [[ $? -eq 0 ]]; then |
||||||
|
echo "File downloaded to $output" |
||||||
|
chmod +x $output |
||||||
|
else |
||||||
|
echo "Error: Failed to download to $output" |
||||||
|
fi |
||||||
|
else |
||||||
|
echo "No runtime currently available for $os" |
||||||
|
fi |
||||||
|
;; |
||||||
|
"list") |
||||||
|
if [ -d $archdir ]; then |
||||||
|
echo "$(ls $archdir -1 | wc -l) files in $archdir" |
||||||
|
echo $(ls $archdir -1) |
||||||
|
else |
||||||
|
echo "No runtimes available in $archdir\n Use '$0 fetch' to install." |
||||||
|
fi |
||||||
|
;; |
||||||
|
"run") |
||||||
|
#todo - lookup active runtime for os-arch from .toml file |
||||||
|
activeruntime=$(ls $archdir -1 | tail -n 1) |
||||||
|
activeruntime_fullpath="$archdir/$activeruntime" |
||||||
|
echo "using $activeruntime_fullpath" |
||||||
|
shift |
||||||
|
echo "args: $@" |
||||||
|
$activeruntime_fullpath "$@" |
||||||
|
;; |
||||||
|
*) |
||||||
|
echo "Usage: $0 {fetch|list|run}" |
||||||
|
exit 1 |
||||||
|
;; |
||||||
|
esac |
||||||
@ -0,0 +1,184 @@ |
|||||||
|
|
||||||
|
|
||||||
|
function GetDynamicParamDictionary { |
||||||
|
[CmdletBinding()] |
||||||
|
param( |
||||||
|
[Parameter(ValueFromPipeline=$true, Mandatory=$true)] |
||||||
|
[string] $CommandName |
||||||
|
) |
||||||
|
|
||||||
|
begin { |
||||||
|
# Get a list of params that should be ignored (they're common to all advanced functions) |
||||||
|
$CommonParameterNames = [System.Runtime.Serialization.FormatterServices]::GetUninitializedObject([type] [System.Management.Automation.Internal.CommonParameters]) | |
||||||
|
Get-Member -MemberType Properties | |
||||||
|
Select-Object -ExpandProperty Name |
||||||
|
} |
||||||
|
|
||||||
|
process { |
||||||
|
# Create the dictionary that this scriptblock will return: |
||||||
|
$DynParamDictionary = New-Object System.Management.Automation.RuntimeDefinedParameterDictionary |
||||||
|
|
||||||
|
# Convert to object array and get rid of Common params: |
||||||
|
(Get-Command $CommandName | Select-Object -exp Parameters).GetEnumerator() | |
||||||
|
Where-Object { $CommonParameterNames -notcontains $_.Key } | |
||||||
|
ForEach-Object { |
||||||
|
$DynamicParameter = New-Object System.Management.Automation.RuntimeDefinedParameter ( |
||||||
|
$_.Key, |
||||||
|
$_.Value.ParameterType, |
||||||
|
$_.Value.Attributes |
||||||
|
) |
||||||
|
$DynParamDictionary.Add($_.Key, $DynamicParameter) |
||||||
|
} |
||||||
|
|
||||||
|
# Return the dynamic parameters |
||||||
|
return $DynParamDictionary |
||||||
|
} |
||||||
|
} |
||||||
|
function ParameterDefinitions { |
||||||
|
param( |
||||||
|
[Parameter(ValueFromRemainingArguments=$true)] $opts |
||||||
|
) |
||||||
|
} |
||||||
|
|
||||||
|
function psmain { |
||||||
|
[CmdletBinding()] |
||||||
|
#Empty param block (extra params can be added) |
||||||
|
param( |
||||||
|
[Parameter(Mandatory=$false)][string] $action |
||||||
|
) |
||||||
|
dynamicparam { |
||||||
|
if ($action -eq 'list') { |
||||||
|
} elseif ($action -eq 'fetch') { |
||||||
|
#GetDynamicParamDictionary ParameterDefinitions |
||||||
|
$parameterAttribute = [System.Management.Automation.ParameterAttribute]@{ |
||||||
|
ParameterSetName = "fetchruntime" |
||||||
|
Mandatory = $false |
||||||
|
} |
||||||
|
$attributeCollection = [System.Collections.ObjectModel.Collection[System.Attribute]]::new() |
||||||
|
$attributeCollection.Add($parameterAttribute) |
||||||
|
|
||||||
|
$dynParam1 = [System.Management.Automation.RuntimeDefinedParameter]::new( |
||||||
|
'runtime', [string], $attributeCollection |
||||||
|
) |
||||||
|
|
||||||
|
$paramDictionary = [System.Management.Automation.RuntimeDefinedParameterDictionary]::new() |
||||||
|
$paramDictionary.Add('runtime', $dynParam1) |
||||||
|
return $paramDictionary |
||||||
|
} elseif ($action -eq 'run') { |
||||||
|
GetDynamicParamDictionary ParameterDefinitions |
||||||
|
} else { |
||||||
|
} |
||||||
|
} |
||||||
|
process { |
||||||
|
#Called once - we get a single item being our PSBoundParameters dictionary |
||||||
|
#write-host "Bound Parameters:$($PSBoundParameters.Keys)" |
||||||
|
switch ($PSBoundParameters.keys) { |
||||||
|
'action' { |
||||||
|
#write-host "got action " $PSBoundParameters.action |
||||||
|
Set-Variable -Name $_ -Value $PSBoundParameters."$_" |
||||||
|
$known_actions = @("fetch", "list", "run") |
||||||
|
if (-not($known_actions -contains $action)) { |
||||||
|
write-host "fetch '$action' not understood. Known_actions: $known_actions" |
||||||
|
exit 1 |
||||||
|
} |
||||||
|
} |
||||||
|
'opts' { |
||||||
|
#write-warning "Unused parameters: $($PSBoundParameters.$_)" |
||||||
|
} |
||||||
|
Default { |
||||||
|
#write-warning "Unhandled parameter -> [$($_)]" |
||||||
|
} |
||||||
|
} |
||||||
|
#foreach ($boundparam in $PSBoundParameters.Keys) { |
||||||
|
# write-host "k: $boundparam" |
||||||
|
#} |
||||||
|
} |
||||||
|
end { |
||||||
|
# PSBoundParameters |
||||||
|
#write-host "action:'$action'" |
||||||
|
$outbase = $PSScriptRoot |
||||||
|
$outbase = Resolve-Path -Path $outbase |
||||||
|
#expected script location is the bin folder of a punk project |
||||||
|
$rtfolder = Join-Path -Path $outbase -ChildPath "runtime" |
||||||
|
$archfolder = Join-Path -Path $rtfolder -ChildPath "win32-x86_64" |
||||||
|
switch ($action) { |
||||||
|
'fetch' { |
||||||
|
$runtime = "tclsh902z.exe" |
||||||
|
$archurl = "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master/win32-x86_64" |
||||||
|
foreach ($boundparam in $PSBoundParameters.Keys) { |
||||||
|
write-host "fetchopt: $boundparam $($PSBoundParameters[$boundparam])" |
||||||
|
} |
||||||
|
if ( $PSBoundParameters["runtime"].Length ) { |
||||||
|
$runtime = $PSBoundParameters["runtime"] |
||||||
|
} |
||||||
|
$fileurl = "$archurl/$runtime" |
||||||
|
$output = join-path $archfolder $runtime |
||||||
|
|
||||||
|
$container = split-path -Path $output -Parent |
||||||
|
new-item -Path $container -ItemType Directory -force #create with intermediary folders if not already present |
||||||
|
|
||||||
|
if (-not(Test-Path -Path $output -PathType Leaf)) { |
||||||
|
Write-Host "Downloading from $fileurl ..." |
||||||
|
try { |
||||||
|
$response = Invoke-WebRequest -Uri $fileurl -OutFile $output -ErrorAction Stop |
||||||
|
Write-Host "Runtime saved at $output" |
||||||
|
} |
||||||
|
catch { |
||||||
|
Write-Host "An error occurred: $($_.Exception.Message)" |
||||||
|
if ($_.Exception.Response) { |
||||||
|
Write-Host "HTTP Status code: $($_.Exception.Response.StatusCode)" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
Write-Host "Runtime already found at $output" |
||||||
|
} |
||||||
|
} |
||||||
|
'run' { |
||||||
|
#select first (or configured default) runtime and launch, passing arguments |
||||||
|
if (-not(Test-Path -Path $archfolder -PathType Container)) { |
||||||
|
write-host "No runtimes seem to be installed for win32-x86_64`nPlease use 'runtime.cmd fetch' to install" |
||||||
|
} else { |
||||||
|
$dircontents = (get-childItem -Path $archfolder -File | Sort-Object Name) |
||||||
|
if ($dircontents.Count -gt 0) { |
||||||
|
#write-host "run.." |
||||||
|
#write-host "num params: $($PSBoundParameters.opts.count)" |
||||||
|
#foreach ($boundparam in $PSBoundParameters.opts) { |
||||||
|
# write-host $boundparam |
||||||
|
#} |
||||||
|
#todo - use 'active' runtime - need to lookup (PSToml?) |
||||||
|
#when no 'active' runtime for this os-arch - use last item (sorted in dictionary order) |
||||||
|
$active = $dircontents[-1] |
||||||
|
#write-host "using: $active" |
||||||
|
Start-Process -FilePath $active -ArgumentList $PSBoundParameters.opts -NoNewWindow -Wait |
||||||
|
} else { |
||||||
|
write-host "No files found in $archfolder" |
||||||
|
write-host "No runtimes seem to be installed for win32-x86_64`nPlease use 'runtime.cmd fetch' to install." |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
'list' { |
||||||
|
if (test-path -Path $archfolder -Type Container) { |
||||||
|
$dircontents = (get-childItem -Path $archfolder -File) |
||||||
|
write-host "$(${dircontents}.count) files in $archfolder" |
||||||
|
foreach ($f in $dircontents) { |
||||||
|
write-host $f.Name |
||||||
|
} |
||||||
|
} else { |
||||||
|
write-host "No runtimes seem to be installed for win32-x86_64 in $archfolder`nPlase use 'runtime.cmd fetch' to install." |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
$actions = @("fetch", "list", "run") |
||||||
|
write-host "Available actions: $actions" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $PSBoundParameters |
||||||
|
} |
||||||
|
} |
||||||
|
#write-host (psmain @args) |
||||||
|
$returnvalue = psmain @args |
||||||
|
#Write-Host "Function Returned $returnvalue" -ForegroundColor Cyan |
||||||
|
return $returnvalue |
||||||
|
exit 0 |
||||||
|
|
||||||
@ -0,0 +1,20 @@ |
|||||||
|
|
||||||
|
[application] |
||||||
|
template="punk.multishell.cmd" |
||||||
|
as_admin=false |
||||||
|
|
||||||
|
scripts=[ |
||||||
|
"runtime.ps1", |
||||||
|
"runtime.bash" |
||||||
|
] |
||||||
|
|
||||||
|
default_outputfile="runtime.cmd" |
||||||
|
default_nextshellpath="/usr/bin/env bash" |
||||||
|
default_nextshelltype="bash" |
||||||
|
|
||||||
|
#valid nextshelltype entries are: tcl perl powershell bash. |
||||||
|
#nextshellpath entries must be 64 characters or less. |
||||||
|
|
||||||
|
win32.nextshellpath="powershell" |
||||||
|
win32.nextshelltype="powershell" |
||||||
|
win32.outputfile="runtime.cmd" |
||||||
Binary file not shown.
@ -0,0 +1,55 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Tcl package index file, version 1.1 |
||||||
|
# |
||||||
|
|
||||||
|
# Tcl 8.7 interps are only supported on 32-bit platforms. |
||||||
|
# Lower than that is never supported. Bye! |
||||||
|
if {![package vsatisfies [package provide Tcl] 9.0] |
||||||
|
&& ((![package vsatisfies [package provide Tcl] 8.7]) |
||||||
|
|| ($::tcl_platform(pointerSize)!=4))} { |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# All Tcl 8.7+ interps can [load] thread 3.0.2 |
||||||
|
# |
||||||
|
# For interps that are not thread-enabled, we still call [package ifneeded]. |
||||||
|
# This is contrary to the usual convention, but is a good idea because we |
||||||
|
# cannot imagine any other version of thread that might succeed in a |
||||||
|
# thread-disabled interp. There's nothing to gain by yielding to other |
||||||
|
# competing callers of [package ifneeded Thread]. On the other hand, |
||||||
|
# deferring the error has the advantage that a script calling |
||||||
|
# [package require Thread] in a thread-disabled interp gets an error message |
||||||
|
# about a thread-disabled interp, instead of the message |
||||||
|
# "can't find package thread". |
||||||
|
|
||||||
|
package ifneeded [string tolower thread] 3.0.2 \ |
||||||
|
[list load [file join $dir libtcl9thread3.0.2.so] [string totitle thread]] |
||||||
|
package ifneeded [string totitle thread] 3.0.2 \ |
||||||
|
[list package require -exact [string tolower thread] 3.0.2] |
||||||
|
|
||||||
|
# package ttrace uses some support machinery. |
||||||
|
|
||||||
|
# In Tcl 8.7+ interps; use [::apply] |
||||||
|
|
||||||
|
package ifneeded ttrace 3.0.2 [list ::apply {{dir} { |
||||||
|
if {[info exists ::env(TCL_THREAD_LIBRARY)] && |
||||||
|
[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} { |
||||||
|
source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl |
||||||
|
} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} { |
||||||
|
source [file join $dir .. lib ttrace.tcl] |
||||||
|
} elseif {[file readable [file join $dir ttrace.tcl]]} { |
||||||
|
source [file join $dir ttrace.tcl] |
||||||
|
} elseif {[file exists //zipfs:/lib/thread/ttrace.tcl] || |
||||||
|
![catch {zipfs mount [file join $dir libtcl9thread3.0.2.so] //zipfs:/lib/thread}]} { |
||||||
|
source //zipfs:/lib/thread/ttrace.tcl |
||||||
|
} |
||||||
|
if {[namespace which ::ttrace::update] ne ""} { |
||||||
|
::ttrace::update |
||||||
|
} |
||||||
|
}} $dir] |
||||||
|
package ifneeded Ttrace 3.0.2 \ |
||||||
|
[list package require -exact ttrace 3.0.2] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Binary file not shown.
@ -0,0 +1,55 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Tcl package index file, version 1.1 |
||||||
|
# |
||||||
|
|
||||||
|
# Tcl 8.7 interps are only supported on 32-bit platforms. |
||||||
|
# Lower than that is never supported. Bye! |
||||||
|
if {![package vsatisfies [package provide Tcl] 9.0] |
||||||
|
&& ((![package vsatisfies [package provide Tcl] 8.7]) |
||||||
|
|| ($::tcl_platform(pointerSize)!=4))} { |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# All Tcl 8.7+ interps can [load] thread 3.0.2 |
||||||
|
# |
||||||
|
# For interps that are not thread-enabled, we still call [package ifneeded]. |
||||||
|
# This is contrary to the usual convention, but is a good idea because we |
||||||
|
# cannot imagine any other version of thread that might succeed in a |
||||||
|
# thread-disabled interp. There's nothing to gain by yielding to other |
||||||
|
# competing callers of [package ifneeded Thread]. On the other hand, |
||||||
|
# deferring the error has the advantage that a script calling |
||||||
|
# [package require Thread] in a thread-disabled interp gets an error message |
||||||
|
# about a thread-disabled interp, instead of the message |
||||||
|
# "can't find package thread". |
||||||
|
|
||||||
|
package ifneeded [string tolower thread] 3.0.2 \ |
||||||
|
[list load [file join $dir libtcl9thread3.0.2.so] [string totitle thread]] |
||||||
|
package ifneeded [string totitle thread] 3.0.2 \ |
||||||
|
[list package require -exact [string tolower thread] 3.0.2] |
||||||
|
|
||||||
|
# package ttrace uses some support machinery. |
||||||
|
|
||||||
|
# In Tcl 8.7+ interps; use [::apply] |
||||||
|
|
||||||
|
package ifneeded ttrace 3.0.2 [list ::apply {{dir} { |
||||||
|
if {[info exists ::env(TCL_THREAD_LIBRARY)] && |
||||||
|
[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} { |
||||||
|
source $::env(TCL_THREAD_LIBRARY)/ttrace.tcl |
||||||
|
} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} { |
||||||
|
source [file join $dir .. lib ttrace.tcl] |
||||||
|
} elseif {[file readable [file join $dir ttrace.tcl]]} { |
||||||
|
source [file join $dir ttrace.tcl] |
||||||
|
} elseif {[file exists //zipfs:/lib/thread/ttrace.tcl] || |
||||||
|
![catch {zipfs mount [file join $dir libtcl9thread3.0.2.so] //zipfs:/lib/thread}]} { |
||||||
|
source //zipfs:/lib/thread/ttrace.tcl |
||||||
|
} |
||||||
|
if {[namespace which ::ttrace::update] ne ""} { |
||||||
|
::ttrace::update |
||||||
|
} |
||||||
|
}} $dir] |
||||||
|
package ifneeded Ttrace 3.0.2 \ |
||||||
|
[list package require -exact ttrace 3.0.2] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in new issue