51 changed files with 5045 additions and 51 deletions
@ -1,5 +1,5 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.2]} {return} |
||||
package ifneeded base64 2.5 [list source [file join $dir base64.tcl]] |
||||
package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] |
||||
package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] |
||||
package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] |
||||
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||
package ifneeded base64 2.6.1 [list source [file join $dir base64.tcl]] |
||||
package ifneeded uuencode 1.1.6 [list source [file join $dir uuencode.tcl]] |
||||
package ifneeded yencode 1.1.4 [list source [file join $dir yencode.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