diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/d_config.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/d_config.tcl deleted file mode 100644 index 911bf05a..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/d_config.tcl +++ /dev/null @@ -1,10 +0,0 @@ -# (c) 2022 Andreas Kupries -# Error wrapper for deprecated package -# Deprecated: -# - doctools::config -# Replacement: -# - struct::map - -error "The package doctools::config is stage 2 deprecated. Use struct::map instead." -package provide doctools::config 0.2 -return diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/d_paths.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/d_paths.tcl deleted file mode 100644 index 09e4bc36..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/d_paths.tcl +++ /dev/null @@ -1,10 +0,0 @@ -# (c) 2019 Andreas Kupries -# Redirection wrapper for deprecated package -# Deprecated: -# - doctools::paths -# Replacement: -# - fileutil::paths - -error "The package doctools::paths is stage 2 deprecated. Use fileutil::paths instead." -package provide doctools::paths 0.2 -return diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/p_config.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/p_config.tcl deleted file mode 100644 index 1987120c..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/p_config.tcl +++ /dev/null @@ -1,10 +0,0 @@ -# (c) 2019 Andreas Kupries -# Redirection wrapper for deprecated package -# Deprecated: -# - configuration -# Replacement: -# - struct::map - -error "The package configuration is stage 2 deprecated. Use struct::map instead." -package provide configuration 1.1 -return diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/p_paths.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/p_paths.tcl deleted file mode 100644 index 91edabed..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/p_paths.tcl +++ /dev/null @@ -1,9 +0,0 @@ -# (c) 2019 Andreas Kupries -# Redirection wrapper for deprecated package -# Deprecated: -# - paths -# Replacement: -# - fileutil::paths - -error "The package paths is stage 2 deprecated. Use fileutil::paths instead." -return diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/pkgIndex.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/pkgIndex.tcl deleted file mode 100644 index 61c5f921..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/0compatibility/pkgIndex.tcl +++ /dev/null @@ -1,26 +0,0 @@ -# Compatibility wrapper for deprecated packages. -## -# Stages -# [D1] Next Release - Noted deprecated, with redirection wrappers -# [D2] Release After - Wrappers become Blockers, throwing error noting redirection -# [D3] Release Beyond - All removed. -## -# Currently in deprecation -# - D1 doctools::path (doctools2base) -# - D1 doctools::config (doctools2base) -# - D1 configuration (pt) -# - D1 paths (pt) -# -# :Attention: -# - Original `doctools::paths` Tcl 8.4 required -# Replacement `fileutilutil::paths` Tcl 8.5 required! - -if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} - -package ifneeded configuration 1.1 [list source [file join $dir p_config.tcl]] -package ifneeded doctools::config 0.2 [list source [file join $dir d_config.tcl]] -package ifneeded doctools::paths 0.2 [list source [file join $dir d_paths.tcl]] -package ifneeded paths 1.1 [list source [file join $dir p_paths.tcl]] - -if {![package vsatisfies [package provide Tcl] 8.6]} {return} - diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/aes/aes.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/aes/aes.tcl deleted file mode 100644 index fcb83cb5..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/aes/aes.tcl +++ /dev/null @@ -1,625 +0,0 @@ -# aes.tcl - -# -# Copyright (c) 2005 Thorsten Schloermann -# Copyright (c) 2005 Pat Thoyts -# Copyright (c) 2013 Andreas Kupries -# -# A Tcl implementation of the Advanced Encryption Standard (US FIPS PUB 197) -# -# AES is a block cipher with a block size of 128 bits and a variable -# key size of 128, 192 or 256 bits. -# The algorithm works on each block as a 4x4 state array. There are 4 steps -# in each round: -# SubBytes a non-linear substitution step using a predefined S-box -# ShiftRows cyclic transposition of rows in the state matrix -# MixColumns transformation upon columns in the state matrix -# AddRoundKey application of round specific sub-key -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- - -package require Tcl 8.5 9 - -namespace eval ::aes { - variable uid - if {![info exists uid]} { set uid 0 } - - namespace export aes - - # constants - - # S-box - variable sbox { - 0x63 0x7c 0x77 0x7b 0xf2 0x6b 0x6f 0xc5 0x30 0x01 0x67 0x2b 0xfe 0xd7 0xab 0x76 - 0xca 0x82 0xc9 0x7d 0xfa 0x59 0x47 0xf0 0xad 0xd4 0xa2 0xaf 0x9c 0xa4 0x72 0xc0 - 0xb7 0xfd 0x93 0x26 0x36 0x3f 0xf7 0xcc 0x34 0xa5 0xe5 0xf1 0x71 0xd8 0x31 0x15 - 0x04 0xc7 0x23 0xc3 0x18 0x96 0x05 0x9a 0x07 0x12 0x80 0xe2 0xeb 0x27 0xb2 0x75 - 0x09 0x83 0x2c 0x1a 0x1b 0x6e 0x5a 0xa0 0x52 0x3b 0xd6 0xb3 0x29 0xe3 0x2f 0x84 - 0x53 0xd1 0x00 0xed 0x20 0xfc 0xb1 0x5b 0x6a 0xcb 0xbe 0x39 0x4a 0x4c 0x58 0xcf - 0xd0 0xef 0xaa 0xfb 0x43 0x4d 0x33 0x85 0x45 0xf9 0x02 0x7f 0x50 0x3c 0x9f 0xa8 - 0x51 0xa3 0x40 0x8f 0x92 0x9d 0x38 0xf5 0xbc 0xb6 0xda 0x21 0x10 0xff 0xf3 0xd2 - 0xcd 0x0c 0x13 0xec 0x5f 0x97 0x44 0x17 0xc4 0xa7 0x7e 0x3d 0x64 0x5d 0x19 0x73 - 0x60 0x81 0x4f 0xdc 0x22 0x2a 0x90 0x88 0x46 0xee 0xb8 0x14 0xde 0x5e 0x0b 0xdb - 0xe0 0x32 0x3a 0x0a 0x49 0x06 0x24 0x5c 0xc2 0xd3 0xac 0x62 0x91 0x95 0xe4 0x79 - 0xe7 0xc8 0x37 0x6d 0x8d 0xd5 0x4e 0xa9 0x6c 0x56 0xf4 0xea 0x65 0x7a 0xae 0x08 - 0xba 0x78 0x25 0x2e 0x1c 0xa6 0xb4 0xc6 0xe8 0xdd 0x74 0x1f 0x4b 0xbd 0x8b 0x8a - 0x70 0x3e 0xb5 0x66 0x48 0x03 0xf6 0x0e 0x61 0x35 0x57 0xb9 0x86 0xc1 0x1d 0x9e - 0xe1 0xf8 0x98 0x11 0x69 0xd9 0x8e 0x94 0x9b 0x1e 0x87 0xe9 0xce 0x55 0x28 0xdf - 0x8c 0xa1 0x89 0x0d 0xbf 0xe6 0x42 0x68 0x41 0x99 0x2d 0x0f 0xb0 0x54 0xbb 0x16 - } - # inverse S-box - variable xobs { - 0x52 0x09 0x6a 0xd5 0x30 0x36 0xa5 0x38 0xbf 0x40 0xa3 0x9e 0x81 0xf3 0xd7 0xfb - 0x7c 0xe3 0x39 0x82 0x9b 0x2f 0xff 0x87 0x34 0x8e 0x43 0x44 0xc4 0xde 0xe9 0xcb - 0x54 0x7b 0x94 0x32 0xa6 0xc2 0x23 0x3d 0xee 0x4c 0x95 0x0b 0x42 0xfa 0xc3 0x4e - 0x08 0x2e 0xa1 0x66 0x28 0xd9 0x24 0xb2 0x76 0x5b 0xa2 0x49 0x6d 0x8b 0xd1 0x25 - 0x72 0xf8 0xf6 0x64 0x86 0x68 0x98 0x16 0xd4 0xa4 0x5c 0xcc 0x5d 0x65 0xb6 0x92 - 0x6c 0x70 0x48 0x50 0xfd 0xed 0xb9 0xda 0x5e 0x15 0x46 0x57 0xa7 0x8d 0x9d 0x84 - 0x90 0xd8 0xab 0x00 0x8c 0xbc 0xd3 0x0a 0xf7 0xe4 0x58 0x05 0xb8 0xb3 0x45 0x06 - 0xd0 0x2c 0x1e 0x8f 0xca 0x3f 0x0f 0x02 0xc1 0xaf 0xbd 0x03 0x01 0x13 0x8a 0x6b - 0x3a 0x91 0x11 0x41 0x4f 0x67 0xdc 0xea 0x97 0xf2 0xcf 0xce 0xf0 0xb4 0xe6 0x73 - 0x96 0xac 0x74 0x22 0xe7 0xad 0x35 0x85 0xe2 0xf9 0x37 0xe8 0x1c 0x75 0xdf 0x6e - 0x47 0xf1 0x1a 0x71 0x1d 0x29 0xc5 0x89 0x6f 0xb7 0x62 0x0e 0xaa 0x18 0xbe 0x1b - 0xfc 0x56 0x3e 0x4b 0xc6 0xd2 0x79 0x20 0x9a 0xdb 0xc0 0xfe 0x78 0xcd 0x5a 0xf4 - 0x1f 0xdd 0xa8 0x33 0x88 0x07 0xc7 0x31 0xb1 0x12 0x10 0x59 0x27 0x80 0xec 0x5f - 0x60 0x51 0x7f 0xa9 0x19 0xb5 0x4a 0x0d 0x2d 0xe5 0x7a 0x9f 0x93 0xc9 0x9c 0xef - 0xa0 0xe0 0x3b 0x4d 0xae 0x2a 0xf5 0xb0 0xc8 0xeb 0xbb 0x3c 0x83 0x53 0x99 0x61 - 0x17 0x2b 0x04 0x7e 0xba 0x77 0xd6 0x26 0xe1 0x69 0x14 0x63 0x55 0x21 0x0c 0x7d - } -} - -# aes::Init -- -# -# Initialise our AES state and calculate the key schedule. An initialization -# vector is maintained in the state for modes that require one. The key must -# be binary data of the correct size and the IV must be 16 bytes. -# -# Nk: columns of the key-array -# Nr: number of rounds (depends on key-length) -# Nb: columns of the text-block, is always 4 in AES -# -proc ::aes::Init {mode key iv} { - switch -exact -- $mode { - ecb - cbc { } - cfb - ofb { - return -code error "$mode mode not implemented" - } - default { - return -code error "invalid mode \"$mode\":\ - must be one of ecb or cbc." - } - } - - set size [expr {[string length $key] << 3}] - switch -exact -- $size { - 128 {set Nk 4; set Nr 10; set Nb 4} - 192 {set Nk 6; set Nr 12; set Nb 4} - 256 {set Nk 8; set Nr 14; set Nb 4} - default { - return -code error "invalid key size \"$size\":\ - must be one of 128, 192 or 256." - } - } - - variable uid - set Key [namespace current]::[incr uid] - upvar #0 $Key state - if {[binary scan $iv Iu4 state(I)] != 1} { - return -code error "invalid initialization vector: must be 16 bytes" - } - array set state [list M $mode K $key Nk $Nk Nr $Nr Nb $Nb W {}] - ExpandKey $Key - return $Key -} - -# aes::Reset -- -# -# Reset the initialization vector for the specified key. This permits the -# key to be reused for encryption or decryption without the expense of -# re-calculating the key schedule. -# -proc ::aes::Reset {Key iv} { - upvar #0 $Key state - if {[binary scan $iv Iu4 state(I)] != 1} { - return -code error "invalid initialization vector: must be 16 bytes" - } - return -} - -# aes::Final -- -# -# Clean up the key state -# -proc ::aes::Final {Key} { - # FRINK: nocheck - unset $Key -} - -# ------------------------------------------------------------------------- - -# 5.1 Cipher: Encipher a single block of 128 bits. -proc ::aes::EncryptBlock {Key block} { - upvar #0 $Key state - if {[binary scan $block Iu4 data] != 1} { - return -code error "invalid block size: blocks must be 16 bytes" - } - - if {$state(M) eq {cbc}} { - # Loop unrolled. - lassign $data d0 d1 d2 d3 - lassign $state(I) s0 s1 s2 s3 - set data [list \ - [expr {$d0 ^ $s0}] \ - [expr {$d1 ^ $s1}] \ - [expr {$d2 ^ $s2}] \ - [expr {$d3 ^ $s3}] ] - } - - set data [AddRoundKey $Key 0 $data] - for {set n 1} {$n < $state(Nr)} {incr n} { - set data [AddRoundKey $Key $n [MixColumns [ShiftRows [SubBytes $data]]]] - } - set data [AddRoundKey $Key $n [ShiftRows [SubBytes $data]]] - - # Bug 2993029: - # Force all elements of data into the 32bit range. - # Loop unrolled - set res [Clamp32 $data] - - set state(I) $res - binary format Iu4 $res -} - -# 5.3: Inverse Cipher: Decipher a single 128 bit block. -proc ::aes::DecryptBlock {Key block} { - upvar #0 $Key state - if {[binary scan $block Iu4 data] != 1} { - return -code error "invalid block size: block must be 16 bytes" - } - set iv $data - - set n $state(Nr) - set data [AddRoundKey $Key $state(Nr) $data] - for {incr n -1} {$n > 0} {incr n -1} { - set data [InvMixColumns [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]]] - } - set data [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]] - - if {$state(M) eq {cbc}} { - lassign $data d0 d1 d2 d3 - lassign $state(I) s0 s1 s2 s3 - set data [list \ - [expr {($d0 ^ $s0) & 0xffffffff}] \ - [expr {($d1 ^ $s1) & 0xffffffff}] \ - [expr {($d2 ^ $s2) & 0xffffffff}] \ - [expr {($d3 ^ $s3) & 0xffffffff}] ] - } else { - # Bug 2993029: - # The integrated clamping we see above only happens for CBC mode. - set data [Clamp32 $data] - } - - set state(I) $iv - binary format Iu4 $data -} - -proc ::aes::Clamp32 {data} { - # Force all elements into 32bit range. - lassign $data d0 d1 d2 d3 - list \ - [expr {$d0 & 0xffffffff}] \ - [expr {$d1 & 0xffffffff}] \ - [expr {$d2 & 0xffffffff}] \ - [expr {$d3 & 0xffffffff}] -} - -# 5.2: KeyExpansion -proc ::aes::ExpandKey {Key} { - upvar #0 $Key state - set Rcon [list 0x00000000 0x01000000 0x02000000 0x04000000 0x08000000 \ - 0x10000000 0x20000000 0x40000000 0x80000000 0x1b000000 \ - 0x36000000 0x6c000000 0xd8000000 0xab000000 0x4d000000] - # Split the key into Nk big-endian words - binary scan $state(K) I* W - set max [expr {$state(Nb) * ($state(Nr) + 1)}] - set i $state(Nk) - set h [expr {$i - 1}] - set j 0 - for {} {$i < $max} {incr i; incr h; incr j} { - set temp [lindex $W $h] - if {($i % $state(Nk)) == 0} { - set sub [SubWord [RotWord $temp]] - set rc [lindex $Rcon [expr {$i/$state(Nk)}]] - set temp [expr {$sub ^ $rc}] - } elseif {$state(Nk) > 6 && ($i % $state(Nk)) == 4} { - set temp [SubWord $temp] - } - lappend W [expr {[lindex $W $j] ^ $temp}] - } - set state(W) $W -} - -# 5.2: Key Expansion: Apply S-box to each byte in the 32 bit word -proc ::aes::SubWord {w} { - variable sbox - set s3 [lindex $sbox [expr {($w >> 24) & 255}]] - set s2 [lindex $sbox [expr {($w >> 16) & 255}]] - set s1 [lindex $sbox [expr {($w >> 8 ) & 255}]] - set s0 [lindex $sbox [expr { $w & 255}]] - return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}] -} - -proc ::aes::InvSubWord {w} { - variable xobs - set s3 [lindex $xobs [expr {($w >> 24) & 255}]] - set s2 [lindex $xobs [expr {($w >> 16) & 255}]] - set s1 [lindex $xobs [expr {($w >> 8 ) & 255}]] - set s0 [lindex $xobs [expr { $w & 255}]] - return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}] -} - -# 5.2: Key Expansion: Rotate a 32bit word by 8 bits -proc ::aes::RotWord {w} { - return [expr {(($w << 8) | (($w >> 24) & 0xff)) & 0xffffffff}] -} - -# 5.1.1: SubBytes() Transformation -proc ::aes::SubBytes {words} { - lassign $words w0 w1 w2 w3 - list [SubWord $w0] [SubWord $w1] [SubWord $w2] [SubWord $w3] -} - -# 5.3.2: InvSubBytes() Transformation -proc ::aes::InvSubBytes {words} { - lassign $words w0 w1 w2 w3 - list [InvSubWord $w0] [InvSubWord $w1] [InvSubWord $w2] [InvSubWord $w3] -} - -# 5.1.2: ShiftRows() Transformation -proc ::aes::ShiftRows {words} { - for {set n0 0} {$n0 < 4} {incr n0} { - set n1 [expr {($n0 + 1) % 4}] - set n2 [expr {($n0 + 2) % 4}] - set n3 [expr {($n0 + 3) % 4}] - lappend r [expr {( [lindex $words $n0] & 0xff000000) - | ([lindex $words $n1] & 0x00ff0000) - | ([lindex $words $n2] & 0x0000ff00) - | ([lindex $words $n3] & 0x000000ff) - }] - } - return $r -} - - -# 5.3.1: InvShiftRows() Transformation -proc ::aes::InvShiftRows {words} { - for {set n0 0} {$n0 < 4} {incr n0} { - set n1 [expr {($n0 + 1) % 4}] - set n2 [expr {($n0 + 2) % 4}] - set n3 [expr {($n0 + 3) % 4}] - lappend r [expr {( [lindex $words $n0] & 0xff000000) - | ([lindex $words $n3] & 0x00ff0000) - | ([lindex $words $n2] & 0x0000ff00) - | ([lindex $words $n1] & 0x000000ff) - }] - } - return $r -} - -# 5.1.3: MixColumns() Transformation -proc ::aes::MixColumns {words} { - set r {} - foreach w $words { - set r0 [expr {(($w >> 24) & 255)}] - set r1 [expr {(($w >> 16) & 255)}] - set r2 [expr {(($w >> 8 ) & 255)}] - set r3 [expr {( $w & 255)}] - - set s0 [expr {[GFMult2 $r0] ^ [GFMult3 $r1] ^ $r2 ^ $r3}] - set s1 [expr {$r0 ^ [GFMult2 $r1] ^ [GFMult3 $r2] ^ $r3}] - set s2 [expr {$r0 ^ $r1 ^ [GFMult2 $r2] ^ [GFMult3 $r3]}] - set s3 [expr {[GFMult3 $r0] ^ $r1 ^ $r2 ^ [GFMult2 $r3]}] - - lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}] - } - return $r -} - -# 5.3.3: InvMixColumns() Transformation -proc ::aes::InvMixColumns {words} { - set r {} - foreach w $words { - set r0 [expr {(($w >> 24) & 255)}] - set r1 [expr {(($w >> 16) & 255)}] - set r2 [expr {(($w >> 8 ) & 255)}] - set r3 [expr {( $w & 255)}] - - set s0 [expr {[GFMult0e $r0] ^ [GFMult0b $r1] ^ [GFMult0d $r2] ^ [GFMult09 $r3]}] - set s1 [expr {[GFMult09 $r0] ^ [GFMult0e $r1] ^ [GFMult0b $r2] ^ [GFMult0d $r3]}] - set s2 [expr {[GFMult0d $r0] ^ [GFMult09 $r1] ^ [GFMult0e $r2] ^ [GFMult0b $r3]}] - set s3 [expr {[GFMult0b $r0] ^ [GFMult0d $r1] ^ [GFMult09 $r2] ^ [GFMult0e $r3]}] - - lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}] - } - return $r -} - -# 5.1.4: AddRoundKey() Transformation -proc ::aes::AddRoundKey {Key round words} { - upvar #0 $Key state - set r {} - set n [expr {$round * $state(Nb)}] - foreach w $words { - lappend r [expr {$w ^ [lindex $state(W) $n]}] - incr n - } - return $r -} - -# ------------------------------------------------------------------------- -# ::aes::GFMult* -# -# some needed functions for multiplication in a Galois-field -# -proc ::aes::GFMult2 {number} { - # this is a tabular representation of xtime (multiplication by 2) - # it is used instead of calculation to prevent timing attacks - set xtime { - 0x00 0x02 0x04 0x06 0x08 0x0a 0x0c 0x0e 0x10 0x12 0x14 0x16 0x18 0x1a 0x1c 0x1e - 0x20 0x22 0x24 0x26 0x28 0x2a 0x2c 0x2e 0x30 0x32 0x34 0x36 0x38 0x3a 0x3c 0x3e - 0x40 0x42 0x44 0x46 0x48 0x4a 0x4c 0x4e 0x50 0x52 0x54 0x56 0x58 0x5a 0x5c 0x5e - 0x60 0x62 0x64 0x66 0x68 0x6a 0x6c 0x6e 0x70 0x72 0x74 0x76 0x78 0x7a 0x7c 0x7e - 0x80 0x82 0x84 0x86 0x88 0x8a 0x8c 0x8e 0x90 0x92 0x94 0x96 0x98 0x9a 0x9c 0x9e - 0xa0 0xa2 0xa4 0xa6 0xa8 0xaa 0xac 0xae 0xb0 0xb2 0xb4 0xb6 0xb8 0xba 0xbc 0xbe - 0xc0 0xc2 0xc4 0xc6 0xc8 0xca 0xcc 0xce 0xd0 0xd2 0xd4 0xd6 0xd8 0xda 0xdc 0xde - 0xe0 0xe2 0xe4 0xe6 0xe8 0xea 0xec 0xee 0xf0 0xf2 0xf4 0xf6 0xf8 0xfa 0xfc 0xfe - 0x1b 0x19 0x1f 0x1d 0x13 0x11 0x17 0x15 0x0b 0x09 0x0f 0x0d 0x03 0x01 0x07 0x05 - 0x3b 0x39 0x3f 0x3d 0x33 0x31 0x37 0x35 0x2b 0x29 0x2f 0x2d 0x23 0x21 0x27 0x25 - 0x5b 0x59 0x5f 0x5d 0x53 0x51 0x57 0x55 0x4b 0x49 0x4f 0x4d 0x43 0x41 0x47 0x45 - 0x7b 0x79 0x7f 0x7d 0x73 0x71 0x77 0x75 0x6b 0x69 0x6f 0x6d 0x63 0x61 0x67 0x65 - 0x9b 0x99 0x9f 0x9d 0x93 0x91 0x97 0x95 0x8b 0x89 0x8f 0x8d 0x83 0x81 0x87 0x85 - 0xbb 0xb9 0xbf 0xbd 0xb3 0xb1 0xb7 0xb5 0xab 0xa9 0xaf 0xad 0xa3 0xa1 0xa7 0xa5 - 0xdb 0xd9 0xdf 0xdd 0xd3 0xd1 0xd7 0xd5 0xcb 0xc9 0xcf 0xcd 0xc3 0xc1 0xc7 0xc5 - 0xfb 0xf9 0xff 0xfd 0xf3 0xf1 0xf7 0xf5 0xeb 0xe9 0xef 0xed 0xe3 0xe1 0xe7 0xe5 - } - lindex $xtime $number -} - -proc ::aes::GFMult3 {number} { - # multliply by 2 (via GFMult2) and add the number again on the result (via XOR) - expr {$number ^ [GFMult2 $number]} -} - -proc ::aes::GFMult09 {number} { - # 09 is: (02*02*02) + 01 - expr {[GFMult2 [GFMult2 [GFMult2 $number]]] ^ $number} -} - -proc ::aes::GFMult0b {number} { - # 0b is: (02*02*02) + 02 + 01 - #return [expr [GFMult2 [GFMult2 [GFMult2 $number]]] ^ [GFMult2 $number] ^ $number] - #set g0 [GFMult2 $number] - expr {[GFMult09 $number] ^ [GFMult2 $number]} -} - -proc ::aes::GFMult0d {number} { - # 0d is: (02*02*02) + (02*02) + 01 - set temp [GFMult2 [GFMult2 $number]] - expr {[GFMult2 $temp] ^ ($temp ^ $number)} -} - -proc ::aes::GFMult0e {number} { - # 0e is: (02*02*02) + (02*02) + 02 - set temp [GFMult2 [GFMult2 $number]] - expr {[GFMult2 $temp] ^ ($temp ^ [GFMult2 $number])} -} - -# ------------------------------------------------------------------------- - -# aes::Encrypt -- -# -# Encrypt a blocks of plain text and returns blocks of cipher text. -# The input data must be a multiple of the block size (16). -# -proc ::aes::Encrypt {Key data} { - set len [string length $data] - if {($len % 16) != 0} { - return -code error "invalid block size: AES requires 16 byte blocks" - } - - set result {} - for {set i 0} {$i < $len} {incr i 1} { - set block [string range $data $i [incr i 15]] - append result [EncryptBlock $Key $block] - } - return $result -} - -# aes::Decrypt -- -# -# Decrypt blocks of cipher text and returns blocks of plain text. -# The input data must be a multiple of the block size (16). -# -proc ::aes::Decrypt {Key data} { - set len [string length $data] - if {($len % 16) != 0} { - return -code error "invalid block size: AES requires 16 byte blocks" - } - - set result {} - for {set i 0} {$i < $len} {incr i 1} { - set block [string range $data $i [incr i 15]] - append result [DecryptBlock $Key $block] - } - return $result -} - -# ------------------------------------------------------------------------- -# chan event handler for chunked file reading. -# -proc ::aes::Chunk {Key in {out {}} {chunksize 4096}} { - upvar #0 $Key state - - #puts ||CHUNK.X||i=$in|o=$out|c=$chunksize|eof=[eof $in] - - if {[eof $in]} { - chan event $in readable {} - set state(reading) 0 - } - - set data [read $in $chunksize] - - #puts ||CHUNK.R||i=$in|o=$out|c=$chunksize|eof=[eof $in]||[string length $data]||$data|| - - # Do nothing when data was read at all. - if {$data eq {}} return - - if {[eof $in]} { - #puts CHUNK.Z - set data [Pad $data 16] - } - - #puts ||CHUNK.P||i=$in|o=$out|c=$chunksize|eof=[eof $in]||[string length $data]||$data|| - - if {$out eq {}} { - append state(output) [$state(cmd) $Key $data] - } else { - puts -nonewline $out [$state(cmd) $Key $data] - } -} - -proc ::aes::SetOneOf {lst item} { - set ndx [lsearch -glob $lst "${item}*"] - if {$ndx == -1} { - set err [join $lst ", "] - return -code error "invalid mode \"$item\": must be one of $err" - } - lindex $lst $ndx -} - -proc ::aes::CheckSize {what size thing} { - if {[string length $thing] != $size} { - return -code error "invalid value for $what: must be $size bytes long" - } - return $thing -} - -proc ::aes::Pad {data blocksize {fill \0}} { - set len [string length $data] - if {$len == 0} { - set data [string repeat $fill $blocksize] - } elseif {($len % $blocksize) != 0} { - set pad [expr {$blocksize - ($len % $blocksize)}] - append data [string repeat $fill $pad] - } - return $data -} - -proc ::aes::Pop {varname {nth 0}} { - upvar 1 $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -proc ::aes::aes {args} { - array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -chunksize 4096 -hex 0} - set opts(-iv) [string repeat \0 16] - set modes {ecb cbc} - set dirs {encrypt decrypt} - while {([llength $args] > 1) && [string match -* [set option [lindex $args 0]]]} { - switch -exact -- $option { - -mode { set opts(-mode) [SetOneOf $modes [Pop args 1]] } - -dir { set opts(-dir) [SetOneOf $dirs [Pop args 1]] } - -iv { set opts(-iv) [CheckSize -iv 16 [Pop args 1]] } - -key { set opts(-key) [Pop args 1] } - -in { set opts(-in) [Pop args 1] } - -out { set opts(-out) [Pop args 1] } - -chunksize { set opts(-chunksize) [Pop args 1] } - -hex { set opts(-hex) 1 } - -- { Pop args ; break } - default { - set err [join [lsort [array names opts]] ", "] - return -code error "bad option \"$option\":\ - must be one of $err" - } - } - Pop args - } - - if {$opts(-key) eq {}} { - return -code error "no key provided: the -key option is required" - } - - set r {} - if {$opts(-in) eq {}} { - - if {[llength $args] != 1} { - return -code error "wrong \# args:\ - should be \"aes ?options...? -key keydata plaintext\"" - } - - set data [Pad [lindex $args 0] 16] - set Key [Init $opts(-mode) $opts(-key) $opts(-iv)] - if {[string equal $opts(-dir) "encrypt"]} { - set r [Encrypt $Key $data] - } else { - set r [Decrypt $Key $data] - } - - if {$opts(-out) ne {}} { - puts -nonewline $opts(-out) $r - set r {} - } - Final $Key - - } else { - - if {[llength $args] != 0} { - return -code error "wrong \# args:\ - should be \"aes ?options...? -key keydata -in channel\"" - } - - set Key [Init $opts(-mode) $opts(-key) $opts(-iv)] - - set readcmd [list [namespace origin Chunk] \ - $Key $opts(-in) $opts(-out) \ - $opts(-chunksize)] - - upvar 1 $Key state - set state(reading) 1 - if {[string equal $opts(-dir) "encrypt"]} { - set state(cmd) Encrypt - } else { - set state(cmd) Decrypt - } - set state(output) "" - chan event $opts(-in) readable $readcmd - if {[info commands ::tkwait] != {}} { - tkwait variable [subst $Key](reading) - } else { - vwait [subst $Key](reading) - } - if {$opts(-out) == {}} { - set r $state(output) - } - Final $Key - } - - if {$opts(-hex)} { - binary scan $r H* r - } - return $r -} - -# ------------------------------------------------------------------------- - -package provide aes 1.2.2 - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/aes/pkgIndex.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/aes/pkgIndex.tcl deleted file mode 100644 index d433abc8..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/aes/pkgIndex.tcl +++ /dev/null @@ -1,5 +0,0 @@ -if {![package vsatisfies [package provide Tcl] 8.5 9]} { - # PRAGMA: returnok - return -} -package ifneeded aes 1.2.2 [list source [file join $dir aes.tcl]] diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/S3.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/S3.tcl deleted file mode 100644 index f7732812..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/S3.tcl +++ /dev/null @@ -1,1960 +0,0 @@ -# S3.tcl -# -###Abstract -# This presents an interface to Amazon's S3 service. -# The Amazon S3 service allows for reliable storage -# and retrieval of data via HTTP. -# -# Copyright (c) 2006,2008 Darren New. All Rights Reserved. -# -###Copyright -# NO WARRANTIES OF ANY TYPE ARE PROVIDED. -# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS. -# -# This software is licensed under essentially the same -# terms as Tcl. See LICENSE.txt for the terms. -# -###Revision String -# SCCS: %Z% %M% %I% %E% %U% -# -###Change history: -# 0.7.2 - added -default-bucket. -# 0.8.0 - fixed bug in getLocal using wrong prefix. -# Upgraded to Tcl 8.5 release version. -# 1.0.0 - added SetAcl, GetAcl, and -acl keep option. -# - -package require Tcl 8.5 9 - -# This is by Darren New too. -# It is a SAX package to format XML for easy retrieval. -# It should be in the same distribution as S3. -package require xsxp - -# These three are required to do the auth, so always require them. -# Note that package registry and package fileutil are required -# by the individual routines that need them. Grep for "package". -package require sha1 -package require md5 -package require base64 - -package provide S3 1.0.4 - -namespace eval S3 { - variable config ; # A dict holding the current configuration. - variable config_orig ; # Holds configuration to "reset" back to. - variable debug 0 ; # Turns on or off S3::debug - variable debuglog 0 ; # Turns on or off debugging into a file - variable bgvar_counter 0 ; # Makes unique names for bgvars. - - set config_orig [dict create \ - -reset false \ - -retries 3 \ - -accesskeyid "" -secretaccesskey "" \ - -service-access-point "s3.amazonaws.com" \ - -slop-seconds 3 \ - -use-tls false \ - -bucket-prefix "TclS3" \ - -default-compare "always" \ - -default-separator "/" \ - -default-acl "" \ - -default-bucket "" \ - ] - - set config $config_orig -} - -# Internal, for development. Print a line, and maybe log it. -proc S3::debuglogline {line} { - variable debuglog - puts $line - if {$debuglog} { - set x [open debuglog.txt a] - puts $x $line - close $x - } -} - -# Internal, for development. Print debug info properly formatted. -proc S3::debug {args} { - variable debug - variable debuglog - if {!$debug} return - set res "" - if {"-hex" == [lindex $args 0]} { - set str [lindex $args 1] - foreach ch [split $str {}] { - scan $ch %c val - append res [format %02x $val] - append res " " - } - debuglogline $res - return - } - if {"-dict" == [lindex $args 0]} { - set dict [lindex $args 1] - debuglogline "DEBUG dict:" - foreach {key val} $dict { - set val [string map [list \ - \r \\r \n \\n \0 \\0 ] $val] - debuglogline "$key=$val" - } - return - } - set x [string map [list \ - \r \\r \n \\n \0 \\0 ] $args] - debuglogline "DEBUG: $x" -} - -# Internal. Throws an error if keys have not been initialized. -proc S3::checkinit {} { - variable config - set error "S3 must be initialized with -accesskeyid and -secretaccesskey before use" - set e1 {S3 usage -accesskeyid "S3 identification not initialized"} - set e2 {S3 usage -secretaccesskey "S3 identification not initialized"} - if {[dict get $config -accesskeyid] eq ""} { - error $error "" $e1 - } - if {[dict get $config -secretaccesskey] eq ""} { - error $error "" $e2 - } -} - -# Internal. Calculates the Content-Type for a given file name. -# Naturally returns application/octet-stream if anything goes wrong. -proc S3::contenttype {fname} { - if {$::tcl_platform(platform) == "windows"} { - set extension [file extension $fname] - uplevel #0 package require registry - set key "\\\\HKEY_CLASSES_ROOT\\" - set key "HKEY_CLASSES_ROOT\\" - if {"." != [string index $extension 0]} {append key .} - append key $extension - set ct "application/octet-stream" - if {$extension != ""} { - catch {set ct [registry get $key {Content Type}]} caught - } - } else { - # Assume something like Unix. - if {[file readable /etc/mime.types]} { - set extension [string trim [file extension $fname] "."] - set f [open /etc/mime.types r] - while {-1 != [gets $f line] && ![info exists c]} { - set line [string trim $line] - if {[string match "#*" $line]} continue - if {0 == [string length $line]} continue - set items [split $line] - for {set i 1} {$i < [llength $items]} {incr i} { - if {[lindex $items $i] eq $extension} { - set c [lindex $items 0] - break - } - } - } - close $f - if {![info exists c]} { - set ct "application/octet-stream" - } else { - set ct [string trim $c] - } - } else { - # No /etc/mime.types here. - if {[catch {exec file -i $fname} res]} { - set ct "application/octet-stream" - } else { - set ct [string range $res [expr {1+[string first : $res]}] end] - if {-1 != [string first ";" $ct]} { - set ct [string range $ct 0 [string first ";" $ct]] - } - set ct [string trim $ct "; "] - } - } - } - return $ct -} - -# Change current configuration. Not object-oriented, so only one -# configuration is tracked per interpreter. -proc S3::Configure {args} { - variable config - variable config_orig - if {[llength $args] == 0} {return $config} - if {[llength $args] == 1 && ![dict exists $config [lindex $args 0]]} { - error "Bad option \"[lindex $args 0]\": must be [join [dict keys $config] ,\ ]" "" [list S3 usage [lindex $args 0] "Bad option to config"] - } - if {[llength $args] == 1} {return [dict get $config [lindex $args 0]]} - if {[llength $args] % 2 != 0} { - error "Config args must be -name val -name val" "" [list S3 usage [lindex $args end] "Odd number of config args"] - } - set new $config - foreach {tag val} $args { - if {![dict exists $new $tag]} { - error "Bad option \"$tag\": must be [join [dict keys $config] ,\ ]" "" [list S3 usage $tag "Bad option to config"] - } - dict set new $tag $val - if {$tag eq "-reset" && $val} { - set new $config_orig - } - } - if {[dict get $config -use-tls]} { - error "TLS for S3 not yet implemented!" "" \ - [list S3 notyet -use-tls $config] - } - set config $new ; # Only update if all went well - return $config -} - -# Suggest a unique bucket name based on usename and config info. -proc S3::SuggestBucket {{usename ""}} { - checkinit - if {$usename eq ""} {set usename [::S3::Configure -bucket-prefix]} - if {$usename eq ""} { - error "S3::SuggestBucket requires name or -bucket-prefix set" \ - "" [list S3 usage -bucket-prefix] - } - return $usename\.[::S3::Configure -accesskeyid] -} - -# Calculate authorization token for REST interaction. -# Doesn't work yet for "Expires" type headers. Hence, only for "REST". -# We specifically don't call checkinit because it's called in all -# callers and we don't want to throw an error inside here. -# Caveat Emptor if you expect otherwise. -# This is internal, but useful enough you might want to invoke it. -proc S3::authREST {verb resource content-type headers args} { - if {[llength $args] != 0} { - set body [lindex $args 0] ; # we use [info exists] later - } - if {${content-type} != "" && [dict exists $headers content-type]} { - set content-type [dict get $headers content-type] - } - dict unset headers content-type - set verb [string toupper $verb] - if {[info exists body]} { - set content-md5 [::base64::encode [::md5::md5 $body]] - dict set headers content-md5 ${content-md5} - dict set headers content-length [string length $body] - } elseif {[dict exists $headers content-md5]} { - set content-md5 [dict get $headers content-md5] - } else { - set content-md5 "" - } - if {[dict exists $headers x-amz-date]} { - set date "" - dict unset headers date - } elseif {[dict exists $headers date]} { - set date [dict get $headers date] - } else { - set date [clock format [clock seconds] -gmt true -format \ - "%a, %d %b %Y %T %Z"] - dict set headers date $date - } - if {${content-type} != ""} { - dict set headers content-type ${content-type} - } - dict set headers host s3.amazonaws.com - set xamz "" - foreach key [lsort [dict keys $headers x-amz-*]] { - # Assume each is seen only once, for now, and is canonical already. - append xamz \n[string trim $key]:[string trim [dict get $headers $key]] - } - set xamz [string trim $xamz] - # Hmmm... Amazon lies. No \n after xamz if xamz is empty. - if {0 != [string length $xamz]} {append xamz \n} - set signthis \ - "$verb\n${content-md5}\n${content-type}\n$date\n$xamz$resource" - S3::debug "Sign this:" $signthis ; S3::debug -hex $signthis - set sig [::sha1::hmac [S3::Configure -secretaccesskey] $signthis] - set sig [binary format H* $sig] - set sig [string trim [::base64::encode $sig]] - dict set headers authorization "AWS [S3::Configure -accesskeyid]:$sig" - return $headers -} - -# Internal. Takes resource and parameters, tacks them together. -# Useful enough you might want to invoke it yourself. -proc S3::to_url {resource parameters} { - if {0 == [llength $parameters]} {return $resource} - if {-1 == [string first "?" $resource]} { - set front ? - } else { - set front & - } - foreach {key value} $parameters { - append resource $front $key "=" $value - set front & - } - return $resource -} - -# Internal. Encode a URL, including utf-8 versions. -# Useful enough you might want to invoke it yourself. -proc S3::encode_url {orig} { - set res "" - set re {[-a-zA-Z0-9/.,_]} - foreach ch [split $orig ""] { - if {[regexp $re $ch]} { - append res $ch - } else { - foreach uch [split [encoding convertto utf-8 $ch] ""] { - append res "%" - binary scan $uch H2 hex - append res $hex - } - } - } - if {$res ne $orig} { - S3::debug "URL Encoded:" $orig $res - } - return $res -} - -# This is used internally to either queue an event-driven -# item or to simply call the next routine, depending on -# whether the current transaction is supposed to be running -# in the background or not. -proc S3::nextdo {routine thunk direction args} { - global errorCode - S3::debug "nextdo" $routine $thunk $direction $args - if {[dict get $thunk blocking]} { - return [S3::$routine $thunk] - } else { - if {[llength $args] == 2} { - # fcopy failed! - S3::fail $thunk "S3 fcopy failed: [lindex $args 1]" "" \ - [list S3 socket $errorCode] - } else { - fileevent [dict get $thunk S3chan] $direction \ - [list S3::$routine $thunk] - if {$direction == "writable"} { - fileevent [dict get $thunk S3chan] readable {} - } else { - fileevent [dict get $thunk S3chan] writable {} - } - } - } -} - -# The proverbial It. Do a REST call to Amazon S3 service. -proc S3::REST {orig} { - variable config - checkinit - set EndPoint [dict get $config -service-access-point] - - # Save the original stuff first. - set thunk [dict create orig $orig] - - # Now add to thunk's top-level the important things - if {[dict exists $thunk orig resultvar]} { - dict set thunk blocking 0 - } else { - dict set thunk blocking 1 - } - if {[dict exists $thunk orig S3chan]} { - dict set thunk S3chan [dict get $thunk orig S3chan] - } elseif {[dict get $thunk blocking]} { - dict set thunk S3chan [socket $EndPoint 80] - } else { - dict set thunk S3chan [socket -async $EndPoint 80] - } - fconfigure [dict get $thunk S3chan] -translation binary -encoding binary - - dict set thunk verb [dict get $thunk orig verb] - dict set thunk resource [S3::encode_url [dict get $thunk orig resource]] - if {[dict exists $orig rtype]} { - dict set thunk resource \ - [dict get $thunk resource]?[dict get $orig rtype] - } - if {[dict exists $orig headers]} { - dict set thunk headers [dict get $orig headers] - } else { - dict set thunk headers [dict create] - } - if {[dict exists $orig infile]} { - dict set thunk infile [dict get $orig infile] - } - if {[dict exists $orig content-type]} { - dict set thunk content-type [dict get $orig content-type] - } else { - if {[dict exists $thunk infile]} { - set zz [dict get $thunk infile] - } else { - set zz [dict get $thunk resource] - } - if {-1 != [string first "?" $zz]} { - set zz [string range $zz 0 [expr {[string first "?" $zz]-1}]] - set zz [string trim $zz] - } - if {$zz != ""} { - catch {dict set thunk content-type [S3::contenttype $zz]} - } else { - dict set thunk content-type application/octet-stream - dict set thunk content-type "" - } - } - set p {} - if {[dict exist $thunk orig parameters]} { - set p [dict get $thunk orig parameters] - } - dict set thunk url [S3::to_url [dict get $thunk resource] $p] - - if {[dict exists $thunk orig inbody]} { - dict set thunk headers [S3::authREST \ - [dict get $thunk verb] [dict get $thunk resource] \ - [dict get $thunk content-type] [dict get $thunk headers] \ - [dict get $thunk orig inbody] ] - } else { - dict set thunk headers [S3::authREST \ - [dict get $thunk verb] [dict get $thunk resource] \ - [dict get $thunk content-type] [dict get $thunk headers] ] - } - # Not the best place to put this code. - if {![info exists body] && [dict exists $thunk infile]} { - set size [file size [dict get $thunk infile]] - set x [dict get $thunk headers] - dict set x content-length $size - dict set thunk headers $x - } - - - # Ready to go! - return [S3::nextdo send_headers $thunk writable] -} - -# Internal. Send the headers to Amazon. Might block if you have -# really small socket buffers, but Amazon doesn't want -# data that big anyway. -proc S3::send_headers {thunk} { - S3::debug "Send-headers" $thunk - set s3 [dict get $thunk S3chan] - puts $s3 "[dict get $thunk verb] [dict get $thunk url] HTTP/1.0" - S3::debug ">> [dict get $thunk verb] [dict get $thunk url] HTTP/1.0" - foreach {key val} [dict get $thunk headers] { - puts $s3 "$key: $val" - S3::debug ">> $key: $val" - } - puts $s3 "" - flush $s3 - return [S3::nextdo send_body $thunk writable] -} - -# Internal. Send the body to Amazon. -proc S3::send_body {thunk} { - global errorCode - set s3 [dict get $thunk S3chan] - if {[dict exists $thunk orig inbody]} { - # Send a string. Let's guess that even in non-blocking - # mode, this is small enough or Tcl's smart enough that - # we don't blow up the buffer. - puts -nonewline $s3 [dict get $thunk orig inbody] - flush $s3 - return [S3::nextdo read_headers $thunk readable] - } elseif {![dict exists $thunk orig infile]} { - # No body, no file, so nothing more to do. - return [S3::nextdo read_headers $thunk readable] - } elseif {[dict get $thunk blocking]} { - # A blocking file copy. Still not too hard. - if {[catch {set inchan [open [dict get $thunk infile] r]} caught]} { - S3::fail $thunk "S3 could not open infile - $caught" "" \ - [list S3 local [dict get $thunk infile] $errorCode] - } - fconfigure $inchan -translation binary -encoding binary - fileevent $s3 readable {} - fileevent $s3 writable {} - if {[catch {fcopy $inchan $s3 ; flush $s3 ; close $inchan} caught]} { - S3::fail $thunk "S3 could not copy infile - $caught" "" \ - [list S3 local [dict get $thunk infile] $errorCode] - } - S3::nextdo read_headers $thunk readable - } else { - # The hard one. Background file copy. - fileevent $s3 readable {} - fileevent $s3 writable {} - if {[catch {set inchan [open [dict get $thunk infile] r]} caught]} { - S3::fail $thunk "S3 could not open infile - $caught" "" \ - [list S3 local [dict get $thunk infile] $errorCode] - } - fconfigure $inchan -buffering none -translation binary -encoding binary - fconfigure $s3 -buffering none -translation binary \ - -encoding binary -blocking 0 ; # Doesn't work without this? - dict set thunk inchan $inchan ; # So we can close it. - fcopy $inchan $s3 -command \ - [list S3::nextdo read_headers $thunk readable] - } -} - -# Internal. The first line has come back. Grab out the -# stuff we care about. -proc S3::parse_status {thunk line} { - # Got the status line - S3::debug "<< $line" - dict set thunk httpstatusline [string trim $line] - dict set thunk outheaders [dict create] - regexp {^HTTP/1.. (...) (.*)$} $line junk code message - dict set thunk httpstatus $code - dict set thunk httpmessage [string trim $message] - return $thunk -} - -# A line of header information has come back. Grab it. -# This probably is unhappy with multiple lines for one -# header. -proc S3::parse_header {thunk line} { - # Got a header line. For now, assume no continuations. - S3::debug "<< $line" - set line [string trim $line] - set left [string range $line 0 [expr {[string first ":" $line]-1}]] - set right [string range $line [expr {[string first ":" $line]+1}] end] - set left [string trim [string tolower $left]] - set right [string trim $right] - dict set thunk outheaders $left $right - return $thunk -} - -# I don't know if HTTP requires a blank line after the headers if -# there's no body. - -# Internal. Read all the headers, and throw if we get EOF before -# we get any headers at all. -proc S3::read_headers {thunk} { - set s3 [dict get $thunk S3chan] - flush $s3 - fconfigure $s3 -blocking [dict get $thunk blocking] - if {[dict get $thunk blocking]} { - # Blocking. Just read to a blank line. Otherwise, - # if we use nextdo here, we wind up nesting horribly. - # If we're not blocking, of course, we're returning - # to the event loop each time, so that's OK. - set count [gets $s3 line] - if {[eof $s3]} { - S3::fail $thunk "S3 EOF during status line read" "" "S3 socket EOF" - } - set thunk [S3::parse_status $thunk $line] - while {[string trim $line] != ""} { - set count [gets $s3 line] - if {$count == -1 && 0 == [dict size [dict get $thunk outheaders]]} { - S3::fail $thunk "S3 EOF during headers read" "" "S3 socket EOF" - } - if {[string trim $line] != ""} { - set thunk [S3::parse_header $thunk $line] - } - } - return [S3::nextdo read_body $thunk readable] - } else { - # Non-blocking, so we have to reenter for each line. - # First, fix up the file handle, tho. - if {[dict exists $thunk inchan]} { - close [dict get $thunk inchan] - dict unset thunk inchan - } - # Now get one header. - set count [gets $s3 line] - if {[eof $s3]} { - fileevent $s3 readable {} - fileevent $s3 writable {} - if {![dict exists $thunk httpstatusline]} { - S3::fail $thunk "S3 EOF during status line read" "" "S3 socket EOF" - } elseif {0 == [dict size [dict get $thunk outheaders]]} { - S3::fail $thunk "S3 EOF during header read" "" "S3 socket EOF" - } - } - if {$count < 0} return ; # Wait for a whole line - set line [string trim $line] - if {![dict exists $thunk httpstatus]} { - set thunk [S3::parse_status $thunk $line] - S3::nextdo read_headers $thunk readable ; # New thunk here. - } elseif {$line != ""} { - set thunk [S3::parse_header $thunk $line] - S3::nextdo read_headers $thunk readable ; # New thunk here. - } else { - # Got an empty line. Switch to copying the body. - S3::nextdo read_body $thunk readable - } - } -} - -# Internal. Read the body of the response. -proc S3::read_body {thunk} { - set s3 [dict get $thunk S3chan] - if {[dict get $thunk blocking]} { - # Easy. Just read it. - if {[dict exists $thunk orig outchan]} { - fcopy $s3 [dict get $thunk orig outchan] - } else { - set x [read $s3] - dict set thunk outbody $x - #S3::debug "Body: $x" -- Disable unconditional wasteful conversion to string - #Need better debug system which does this only when active. - } - return [S3::nextdo all_done $thunk readable] - } else { - # Nonblocking mode. - if {[dict exists $thunk orig outchan]} { - fileevent $s3 readable {} - fileevent $s3 writable {} - fcopy $s3 [dict get $thunk orig outchan] -command \ - [list S3::nextdo all_done $thunk readable] - } else { - dict append thunk outbody [read $s3] - if {[eof $s3]} { - # We're done. - S3::nextdo all_done $thunk readable - } else { - S3::nextdo read_body $thunk readable - } - } - } -} - -# Internal. Convenience function. -proc S3::fail {thunk error errorInfo errorCode} { - S3::all_done $thunk $error $errorInfo $errorCode -} - -# Internal. We're all done the transaction. Clean up everything, -# potentially record errors, close channels, etc etc etc. -proc S3::all_done {thunk {error ""} {errorInfo ""} {errorCode ""}} { - set s3 [dict get $thunk S3chan] - catch { - fileevent $s3 readable {} - fileevent $s3 writable {} - } - if {![dict exists $thunk orig S3chan]} { - catch {close $s3} - } - set res [dict get $thunk orig] - catch { - dict set res httpstatus [dict get $thunk httpstatus] - dict set res httpmessage [dict get $thunk httpmessage] - dict set res outheaders [dict get $thunk outheaders] - } - if {![dict exists $thunk orig outchan]} { - if {[dict exists $thunk outbody]} { - dict set res outbody [dict get $thunk outbody] - } else { - # Probably HTTP failure - dict set rest outbody {} - } - } - if {$error ne ""} { - dict set res error $error - dict set res errorInfo $errorInfo - dict set res errorCode $errorCode - } - if {![dict get $thunk blocking]} { - after 0 [list uplevel #0 \ - [list set [dict get $thunk orig resultvar] $res]] - } - if {$error eq "" || ![dict get $thunk blocking] || \ - ([dict exists $thunk orig throwsocket] && \ - "return" == [dict get $thunk orig throwsocket])} { - return $res - } else { - error $error $errorInfo $errorCode - } -} - -# Internal. Parse the lst and make sure it has only keys from the 'valid' list. -# Used to parse arguments going into the higher-level functions. -proc S3::parseargs1 {lst valid} { - if {[llength $lst] % 2 != 0} { - error "Option list must be even -name val pairs" \ - "" [list S3 usage [lindex $lst end] $lst] - } - foreach {key val} $lst { - # Sadly, lsearch applies -glob to the wrong thing for our needs - set found 0 - foreach v $valid { - if {[string match $v $key]} {set found 1 ; break} - } - if {!$found} { - error "Option list has invalid -key" \ - "" [list S3 usage $key $lst] - } - } - return $lst ; # It seems OK -} - -# Internal. Create a variable for higher-level functions to vwait. -proc S3::bgvar {} { - variable bgvar_counter - incr bgvar_counter - set name ::S3::bgvar$bgvar_counter - return $name -} - -# Internal. Given a request and the arguments, run the S3::REST in -# the foreground or the background as appropriate. Also, do retries -# for internal errors. -proc S3::maybebackground {req myargs} { - variable config - global errorCode errorInfo - set mytries [expr {1+[dict get $config -retries]}] - set delay 2000 - dict set req throwsocket return - while {1} { - if {![dict exists $myargs -blocking] || [dict get $myargs -blocking]} { - set dict [S3::REST $req] - } else { - set res [bgvar] - dict set req resultvar $res - S3::REST $req - vwait $res - set dict [set $res] - unset $res ; # clean up temps - } - if {[dict exists $dict error]} { - set code [dict get $dict errorCode] - if {"S3" != [lindex $code 0] || "socket" != [lindex $code 1]} { - error [dict get $dict error] \ - [dict get $dict errorInfo] \ - [dict get $dict errorCode] - } - } - incr mytries -1 - incr delay $delay ; if {20000 < $delay} {set delay 20000} - if {"500" ne [dict get $dict httpstatus] || $mytries <= 0} { - return $dict - } - if {![dict exists $myargs -blocking] || [dict get $myargs -blocking]} { - after $delay - } else { - set timer [bgvar] - after $delay [list set $timer 1] - vwait $timer - unset $timer - } - } -} - -# Internal. Maybe throw an HTTP error if httpstatus not in 200 range. -proc S3::throwhttp {dict} { - set hs [dict get $dict httpstatus] - if {![string match "2??" $hs]} { - error "S3 received non-OK HTTP result of $hs" "" \ - [list S3 remote $hs $dict] - } -} - -# Public. Returns the list of buckets for this user. -proc S3::ListAllMyBuckets {args} { - checkinit ; # I know this gets done later. - set myargs [S3::parseargs1 $args {-blocking -parse-xml -result-type}] - if {![dict exists $myargs -result-type]} { - dict set myargs -result-type names - } - if {![dict exists $myargs -blocking]} { - dict set myargs -blocking true - } - set restype [dict get $myargs -result-type] - if {$restype eq "REST" && [dict exists $myargs -parse-xml]} { - error "Do not use REST with -parse-xml" "" \ - [list S3 usage -parse-xml $args] - } - if {![dict exists $myargs -parse-xml]} { - # We need to fetch the results. - set req [dict create verb GET resource /] - set dict [S3::maybebackground $req $myargs] - if {$restype eq "REST"} { - return $dict ; #we're done! - } - S3::throwhttp $dict ; #make sure it worked. - set xml [dict get $dict outbody] - } else { - set xml [dict get $myargs -parse-xml] - } - # Here, we either already returned the dict, or the XML is in "xml". - if {$restype eq "xml"} {return $xml} - if {[catch {set pxml [::xsxp::parse $xml]}]} { - error "S3 invalid XML structure" "" [list S3 usage xml $xml] - } - if {$restype eq "pxml"} {return $pxml} - if {$restype eq "dict" || $restype eq "names"} { - set buckets [::xsxp::fetch $pxml "Buckets" %CHILDREN] - set names {} ; set dates {} - foreach bucket $buckets { - lappend names [::xsxp::fetch $bucket "Name" %PCDATA] - lappend dates [::xsxp::fetch $bucket "CreationDate" %PCDATA] - } - if {$restype eq "names"} { - return $names - } else { - return [dict create \ - Owner/ID [::xsxp::fetch $pxml "Owner/ID" %PCDATA] \ - Owner/DisplayName \ - [::xsxp::fetch $pxml "Owner/DisplayName" %PCDATA] \ - Bucket/Name $names Bucket/Date $dates \ - ] - } - } - if {$restype eq "owner"} { - return [list [::xsxp::fetch $pxml Owner/ID %PCDATA] \ - [::xsxp::fetch $pxml Owner/DisplayName %PCDATA] ] - } - error "ListAllMyBuckets requires -result-type to be REST, xml, pxml, dict, owner, or names" "" [list S3 usage -result-type $args] -} - -# Public. Create a bucket. -proc S3::PutBucket {args} { - checkinit - set myargs [S3::parseargs1 $args {-blocking -bucket -acl}] - if {![dict exists $myargs -acl]} { - dict set myargs -acl [S3::Configure -default-acl] - } - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict exists $myargs -bucket]} { - error "PutBucket requires -bucket" "" [list S3 usage -bucket $args] - } - - set req [dict create verb PUT resource /[dict get $myargs -bucket]] - if {[dict exists $myargs -acl]} { - dict set req headers [list x-amz-acl [dict get $myargs -acl]] - } - set dict [S3::maybebackground $req $myargs] - S3::throwhttp $dict - return "" ; # until we decide what to return. -} - -# Public. Delete a bucket. -proc S3::DeleteBucket {args} { - checkinit - set myargs [S3::parseargs1 $args {-blocking -bucket}] - if {![dict exists $myargs -bucket]} { - error "DeleteBucket requires -bucket" "" [list S3 usage -bucket $args] - } - dict set myargs -bucket [string trim [dict get $args -bucket] "/ "] - - set req [dict create verb DELETE resource /[dict get $myargs -bucket]] - set dict [S3::maybebackground $req $myargs] - S3::throwhttp $dict - return "" ; # until we decide what to return. -} - -# Internal. Suck out the one and only answer from the list, if needed. -proc S3::firstif {list myargs} { - if {[dict exists $myargs -max-keys]} { - return [lindex $list 0] - } else { - return $list - } -} - -# Public. Get the list of resources within a bucket. -proc S3::GetBucket {args} { - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -parse-xml -max-keys - -result-type -prefix -delimiter - -TEST - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "GetBucket requires -bucket" "" [list S3 usage -bucket $args] - } - if {[dict get $myargs -bucket] eq ""} { - error "GetBucket requires -bucket nonempty" "" \ - [list S3 usage -bucket $args] - } - if {![dict exists $myargs -result-type]} { - dict set myargs -result-type names - } - if {[dict get $myargs -result-type] eq "REST" && \ - [dict exists $myargs "-parse-xml"]} { - error "GetBucket can't have -parse-xml with REST result" "" \ - [list S3 usage -parse-xml $args] - } - set req [dict create verb GET resource /[dict get $myargs -bucket]] - set parameters {} - # Now, just to make test cases easier... - if {[dict exists $myargs -TEST]} { - dict set parameters max-keys [dict get $myargs -TEST] - } - # Back to your regularly scheduled argument parsing - if {[dict exists $myargs -max-keys]} { - dict set parameters max-keys [dict get $myargs -max-keys] - } - if {[dict exists $myargs -prefix]} { - set p [dict get $myargs -prefix] - if {[string match "/*" $p]} { - set p [string range $p 1 end] - } - dict set parameters prefix $p - } - if {[dict exists $myargs -delimiter]} { - dict set parameters delimiter [dict get $myargs -delimiter] - } - set nextmarker0 {} ; # We use this for -result-type dict. - if {![dict exists $myargs -parse-xml]} { - # Go fetch answers. - # Current xaction in "0" vars, with accumulation in "L" vars. - # Ultimate result of this loop is $RESTL, a list of REST results. - set RESTL [list] - while {1} { - set req0 $req ; dict set req0 parameters $parameters - set REST0 [S3::maybebackground $req0 $myargs] - S3::throwhttp $REST0 - lappend RESTL $REST0 - if {[dict exists $myargs -max-keys]} { - # We were given a limit, so just return the answer. - break - } - set pxml0 [::xsxp::parse [dict get $REST0 outbody]] - set trunc0 [expr "true" eq \ - [::xsxp::fetch $pxml0 IsTruncated %PCDATA]] - if {!$trunc0} { - # We've retrieved the final block, so go parse it. - set nextmarker0 "" ; # For later. - break - } - # Find the highest contents entry. (Would have been - # easier if Amazon always supplied NextMarker.) - set nextmarker0 {} - foreach {only tag} {Contents Key CommonPrefixes Prefix} { - set only0 [::xsxp::only $pxml0 $only] - if {0 < [llength $only0]} { - set k0 [::xsxp::fetch [lindex $only0 end] $tag %PCDATA] - if {[string compare $nextmarker0 $k0] < 0} { - set nextmarker0 $k0 - } - } - } - if {$nextmarker0 eq ""} {error "Internal Error in S3 library"} - # Here we have the next marker, so fetch the next REST - dict set parameters marker $nextmarker0 - # Note - $nextmarker0 is used way down below again! - } - # OK, at this point, the caller did not provide the xml via -parse-xml - # And now we have a list of REST results. So let's process. - if {[dict get $myargs -result-type] eq "REST"} { - return [S3::firstif $RESTL $myargs] - } - set xmlL [list] - foreach entry $RESTL { - lappend xmlL [dict get $entry outbody] - } - unset RESTL ; # just to save memory - } else { - # Well, we've parsed out the XML from the REST, - # so we're ready for -parse-xml - set xmlL [list [dict get $myargs -parse-xml]] - } - if {[dict get $myargs -result-type] eq "xml"} { - return [S3::firstif $xmlL $myargs] - } - set pxmlL [list] - foreach xml $xmlL { - lappend pxmlL [::xsxp::parse $xml] - } - unset xmlL - if {[dict get $myargs -result-type] eq "pxml"} { - return [S3::firstif $pxmlL $myargs] - } - # Here, for result types of "names" and "dict", - # we need to actually parse out all the results. - if {[dict get $myargs -result-type] eq "names"} { - # The easy one. - set names [list] - foreach pxml $pxmlL { - set con0 [::xsxp::only $pxml Contents] - set con1 [::xsxp::only $pxml CommonPrefixes] - lappend names {*}[concat [::xsxp::fetchall $con0 Key %PCDATA] \ - [::xsxp::fetchall $con1 Prefix %PCDATA]] - } - return [lsort $names] - } elseif {[dict get $myargs -result-type] eq "dict"} { - # The harder one. - set last0 [lindex $pxmlL end] - set res [dict create] - foreach thing {Name Prefix Marker MaxKeys IsTruncated} { - dict set res $thing [::xsxp::fetch $last0 $thing %PCDATA?] - } - dict set res NextMarker $nextmarker0 ; # From way up above. - set Prefix [list] - set names {Key LastModified ETag Size Owner/ID Owner/DisplayName StorageClass} - foreach name $names {set $name [list]} - foreach pxml $pxmlL { - foreach tag [::xsxp::only $pxml CommonPrefixes] { - lappend Prefix [::xsxp::fetch $tag Prefix %PCDATA] - } - foreach tag [::xsxp::only $pxml Contents] { - foreach name $names { - lappend $name [::xsxp::fetch $tag $name %PCDATA] - } - } - } - dict set res CommonPrefixes/Prefix $Prefix - foreach name $names {dict set res $name [set $name]} - return $res - } else { - # The hardest one ;-) - error "GetBucket Invalid result type, must be REST, xml, pxml, names, or dict" "" [list S3 usage -result-type $args] - } -} - -# Internal. Compare a resource to a file. -# Returns 1 if they're different, 0 if they're the same. -# Note that using If-Modified-Since and/or If-Match,If-None-Match -# might wind up being more efficient than pulling the head -# and checking. However, this allows for slop, checking both -# the etag and the date, only generating local etag if the -# date and length indicate they're the same, and so on. -# Direction is G or P for Get or Put. -# Assumes the source always exists. Obviously, Get and Put will throw if not, -# but not because of this. -proc S3::compare {myargs direction} { - variable config - global errorInfo - set compare [dict get $myargs -compare] - if {$compare ni {always never exists missing newer date checksum different}} { - error "-compare must be always, never, exists, missing, newer, date, checksum, or different" "" \ - [list S3 usage -compare $myargs] - } - if {"never" eq $compare} {return 0} - if {"always" eq $compare} {return 1} - if {[dict exists $myargs -file] && [file exists [dict get $myargs -file]]} { - set local_exists 1 - } else { - set local_exists 0 - } - # Avoid hitting S3 if we don't need to. - if {$direction eq "G" && "exists" eq $compare} {return $local_exists} - if {$direction eq "G" && "missing" eq $compare} { - return [expr !$local_exists] - } - # We need to get the headers from the resource. - set req [dict create \ - resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \ - verb HEAD ] - set res [S3::maybebackground $req $myargs] - set httpstatus [dict get $res httpstatus] - if {"404" eq $httpstatus} { - set remote_exists 0 - } elseif {[string match "2??" $httpstatus]} { - set remote_exists 1 - } else { - error "S3: Neither 404 or 2xx on conditional compare" "" \ - [list S3 remote $httpstatus $res] - } - if {$direction eq "P"} { - if {"exists" eq $compare} {return $remote_exists} - if {"missing" eq $compare} {return [expr {!$remote_exists}]} - if {!$remote_exists} {return 1} - } elseif {$direction eq "G"} { - # Actually already handled above, but it never hurts... - if {"exists" eq $compare} {return $local_exists} - if {"missing" eq $compare} {return [expr {!$local_exists}]} - } - set outheaders [dict get $res outheaders] - if {[dict exists $outheaders content-length]} { - set remote_length [dict get $outheaders content-length] - } else { - set remote_length -1 - } - if {[dict exists $outheaders etag]} { - set remote_etag [string tolower \ - [string trim [dict get $outheaders etag] \"]] - } else { - set remote_etag "YYY" - } - if {[dict exists $outheaders last-modified]} { - set remote_date [clock scan [dict get $outheaders last-modified]] - } else { - set remote_date -1 - } - if {[dict exists $myargs -content]} { - # Probably should work this out better... - #set local_length [string length [encoding convert-to utf-8 \ - #[dict get $myargs -content]]] - set local_length [string length [dict get $myargs -content]] - } elseif {$local_exists} { - if {[catch {file size [dict get $myargs -file]} local_length]} { - error "S3: Couldn't stat [dict get $myargs -file]" "" \ - [list S3 local $errorInfo] - } - } else { - set local_length -2 - } - if {[dict exists $myargs -content]} { - set local_date [clock seconds] - } elseif {$local_exists} { - set local_date [file mtime [dict get $myargs -file]] - # Shouldn't throw, since [file size] worked. - } else { - set local_date -2 - } - if {$direction eq "P"} { - if {"newer" eq $compare} { - if {$remote_date < $local_date - [dict get $config -slop-seconds]} { - return 1 ; # Yes, local is newer - } else { - return 0 ; # Older, or the same - } - } - } elseif {$direction eq "G"} { - if {"newer" eq $compare} { - if {$local_date < $remote_date - [dict get $config -slop-seconds]} { - return 1 ; # Yes, remote is later. - } else { - return 0 ; # Local is older or same. - } - } - } - if {[dict get $config -slop-seconds] <= abs($local_date - $remote_date)} { - set date_diff 1 ; # Difference is greater - } else { - set date_diff 0 ; # Difference negligible - } - if {"date" eq $compare} {return $date_diff} - if {"different" eq $compare && [dict exists $myargs -file] && $date_diff} { - return 1 - } - # Date's the same, but we're also interested in content, so check the rest - # Only others to handle are checksum and different-with-matching-dates - if {$local_length != $remote_length} {return 1} ; #easy quick case - if {[dict exists $myargs -file] && $local_exists} { - if {[catch { - # Maybe deal with making this backgroundable too? - set local_etag [string tolower \ - [::md5::md5 -hex -filename [dict get $myargs -file]]] - } caught]} { - # Maybe you can stat but not read it? - error "S3 could not hash file" "" \ - [list S3 local [dict get $myargs -file] $errorInfo] - } - } elseif {[dict exists $myargs -content]} { - set local_etag [string tolower \ - [string tolower [::md5::md5 -hex [dict get $myargs -content]]]] - } else { - set local_etag "XXX" - } - # puts "local: $local_etag\nremote: $remote_etag" - if {$local_etag eq $remote_etag} {return 0} {return 1} -} - -# Internal. Calculates the ACL based on file permissions. -proc S3::calcacl {myargs} { - # How would one work this under Windows, then? - # Silly way: invoke [exec cacls $filename], - # parse the result looking for Everyone:F or Everyone:R - # Messy security if someone replaces the cacls.exe or something. - error "S3 Not Yet Implemented" "" [list S3 notyet calcacl $myargs] - set result [S3::Configure -default-acl] - catch { - set chmod [file attributes [dict get $myargs -file] -permissions] - set chmod [expr {$chmod & 6}] - if {$chmod == 0} {set result private} - if {$chmod == 2} {set result public-write} - if {$chmod == 6} {set result public-read-write} - } -} - -# Public. Put a resource into a bucket. -proc S3::Put {args} { - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -file -content -resource -acl - -content-type -x-amz-meta-* -compare - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "Put requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -blocking]} { - dict set myargs -blocking true - } - if {![dict exists $myargs -file] && ![dict exists $myargs -content]} { - error "Put requires -file or -content" "" [list S3 usage -file $args] - } - if {[dict exists $myargs -file] && [dict exists $myargs -content]} { - error "Put says -file, -content mutually exclusive" "" [list S3 usage -file $args] - } - if {![dict exists $myargs -resource]} { - error "Put requires -resource" "" [list S3 usage -resource $args] - } - if {![dict exists $myargs -compare]} { - dict set myargs -compare [S3::Configure -default-compare] - } - if {![dict exists $myargs -acl] && "" ne [S3::Configure -default-acl]} { - dict set myargs -acl [S3::Configure -default-acl] - } - if {[dict exists $myargs -file] && \ - "never" ne [dict get $myargs -compare] && \ - ![file exists [dict get $myargs -file]]} { - error "Put -file doesn't exist: [dict get $myargs -file]" \ - "" [list S3 usage -file $args] - } - # Clean up bucket, and take one leading slash (if any) off resource. - if {[string match "/*" [dict get $myargs -resource]]} { - dict set myargs -resource \ - [string range [dict get $myargs -resource] 1 end] - } - # See if we need to copy it. - set comp [S3::compare $myargs P] - if {!$comp} {return 0} ; # skip it, then. - - # Oookeydookey. At this point, we're actually going to send - # the file, so all we need to do is build the request array. - set req [dict create verb PUT \ - resource /[dict get $myargs -bucket]/[dict get $myargs -resource]] - if {[dict exists $myargs -file]} { - dict set req infile [dict get $myargs -file] - } else { - dict set req inbody [dict get $myargs -content] - } - if {[dict exists $myargs -content-type]} { - dict set req content-type [dict get $myargs -content-type] - } - set headers {} - foreach xhead [dict keys $myargs -x-amz-meta-*] { - dict set headers [string range $xhead 1 end] [dict get $myargs $xhead] - } - set xmlacl "" ; # For calc and keep - if {[dict exists $myargs -acl]} { - if {[dict get $myargs -acl] eq "calc"} { - # We could make this more complicated by - # assigning it to xmlacl after building it. - dict set myargs -acl [S3::calcacl $myargs] - } elseif {[dict get $myargs -acl] eq "keep"} { - dict set myargs -acl [S3::Configure -default-acl] - catch { - set xmlacl [S3::GetAcl \ - -bucket [dict get $myargs -bucket] \ - -resource [dict get $myargs -resource] \ - -blocking [dict get $myargs -blocking] \ - -result-type xml] - } - } - dict set headers x-amz-acl [dict get $myargs -acl] - } - dict set req headers $headers - # That should do it. - set res [S3::maybebackground $req $myargs] - S3::throwhttp $res - if {"<" == [string index $xmlacl 0]} { - # Set the saved ACL back on the new object - S3::PutAcl \ - -bucket [dict get $myargs -bucket] \ - -resource [dict get $myargs -resource] \ - -blocking [dict get $myargs -blocking] \ - -acl $xmlacl - } - return 1 ; # Yep, we copied it! -} - -# Public. Get a resource from a bucket. -proc S3::Get {args} { - global errorCode - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -file -content -resource -timestamp - -headers -compare - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "Get requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -file] && ![dict exists $myargs -content]} { - error "Get requires -file or -content" "" [list S3 usage -file $args] - } - if {[dict exists $myargs -file] && [dict exists $myargs -content]} { - error "Get says -file, -content mutually exclusive" "" [list S3 usage -file $args] - } - if {![dict exists $myargs -resource]} { - error "Get requires -resource" "" [list S3 usage -resource $args] - } - if {![dict exists $myargs -compare]} { - dict set myargs -compare [S3::Configure -default-compare] - } - # Clean up bucket, and take one leading slash (if any) off resource. - if {[string match "/*" [dict get $myargs -resource]]} { - dict set myargs -resource \ - [string range [dict get $myargs -resource] 1 end] - } - # See if we need to copy it. - if {"never" eq [dict get $myargs -compare]} {return 0} - if {[dict exists $myargs -content]} { - set comp 1 - } else { - set comp [S3::compare $myargs G] - } - if {!$comp} {return 0} ; # skip it, then. - - # Oookeydookey. At this point, we're actually going to fetch - # the file, so all we need to do is build the request array. - set req [dict create verb GET \ - resource /[dict get $myargs -bucket]/[dict get $myargs -resource]] - if {[dict exists $myargs -file]} { - set pre_exists [file exists [dict get $myargs -file]] - if {[catch { - set x [open [dict get $myargs -file] w] - fconfigure $x -translation binary -encoding binary - } caught]} { - error "Get could not create file [dict get $myargs -file]" "" \ - [list S3 local -file $errorCode] - } - dict set req outchan $x - } - # That should do it. - set res [S3::maybebackground $req $myargs] - if {[dict exists $req outchan]} { - catch {close [dict get $req outchan]} - if {![string match "2??" [dict get $res httpstatus]] && !$pre_exists} { - catch {file delete -force -- [dict get $myargs -file]} - } - } - S3::throwhttp $res - if {[dict exists $myargs -headers]} { - uplevel 1 \ - [list set [dict get $myargs -headers] [dict get $res outheaders]] - } - if {[dict exists $myargs -content]} { - uplevel 1 \ - [list set [dict get $myargs -content] [dict get $res outbody]] - } - if {[dict exists $myargs -timestamp] && [dict exists $myargs -file]} { - if {"aws" eq [dict get $myargs -timestamp]} { - catch { - set t [dict get $res outheaders last-modified] - set t [clock scan $t -gmt true] - file mtime [dict get $myargs -file] $t - } - } - } - return 1 ; # Yep, we copied it! -} - -# Public. Get information about a resource in a bucket. -proc S3::Head {args} { - global errorCode - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -resource -headers -dict -status - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "Head requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -resource]} { - error "Head requires -resource" "" [list S3 usage -resource $args] - } - # Clean up bucket, and take one leading slash (if any) off resource. - if {[string match "/*" [dict get $myargs -resource]]} { - dict set myargs -resource \ - [string range [dict get $myargs -resource] 1 end] - } - set req [dict create verb HEAD \ - resource /[dict get $myargs -bucket]/[dict get $myargs -resource]] - set res [S3::maybebackground $req $myargs] - if {[dict exists $myargs -dict]} { - uplevel 1 \ - [list set [dict get $myargs -dict] $res] - } - if {[dict exists $myargs -headers]} { - uplevel 1 \ - [list set [dict get $myargs -headers] [dict get $res outheaders]] - } - if {[dict exists $myargs -status]} { - set x [list [dict get $res httpstatus] [dict get $res httpmessage]] - uplevel 1 \ - [list set [dict get $myargs -status] $x] - } - return [string match "2??" [dict get $res httpstatus]] -} - -# Public. Get the full ACL from an object and parse it into something useful. -proc S3::GetAcl {args} { - global errorCode - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -resource -result-type -parse-xml - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {![dict exists $myargs -result-type]} { - dict set myargs -result-type "dict" - } - set restype [dict get $myargs -result-type] - if {$restype eq "REST" && [dict exists $myargs -parse-xml]} { - error "Do not use REST with -parse-xml" "" \ - [list S3 usage -parse-xml $args] - } - if {![dict exists $myargs -parse-xml]} { - # We need to fetch the results. - if {"" eq [dict get $myargs -bucket]} { - error "GetAcl requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -resource]} { - error "GetAcl requires -resource" "" [list S3 usage -resource $args] - } - # Clean up bucket, and take one leading slash (if any) off resource. - if {[string match "/*" [dict get $myargs -resource]]} { - dict set myargs -resource \ - [string range [dict get $myargs -resource] 1 end] - } - set req [dict create verb GET \ - resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \ - rtype acl] - set dict [S3::maybebackground $req $myargs] - if {$restype eq "REST"} { - return $dict ; #we're done! - } - S3::throwhttp $dict ; #make sure it worked. - set xml [dict get $dict outbody] - } else { - set xml [dict get $myargs -parse-xml] - } - if {[dict get $myargs -result-type] == "xml"} { - return $xml - } - set pxml [xsxp::parse $xml] - if {[dict get $myargs -result-type] == "pxml"} { - return $pxml - } - if {[dict get $myargs -result-type] == "dict"} { - array set resdict {} - set owner [xsxp::fetch $pxml Owner/ID %PCDATA] - set grants [xsxp::fetch $pxml AccessControlList %CHILDREN] - foreach grant $grants { - set perm [xsxp::fetch $grant Permission %PCDATA] - set id "" - catch {set id [xsxp::fetch $grant Grantee/ID %PCDATA]} - if {$id == ""} { - set id [xsxp::fetch $grant Grantee/URI %PCDATA] - } - lappend resdict($perm) $id - } - return [dict create owner $owner acl [array get resdict]] - } - error "GetAcl requires -result-type to be REST, xml, pxml or dict" "" [list S3 usage -result-type $args] -} - -# Make one Grant thingie -proc S3::engrant {who what} { - if {$who == "AuthenticatedUsers" || $who == "AllUsers"} { - set who http://acs.amazonaws.com/groups/global/$who - } - if {-1 != [string first "//" $who]} { - set type Group ; set tag URI - } elseif {-1 != [string first "@" $who]} { - set type AmazonCustomerByEmail ; set tag EmailAddress - } else { - set type CanonicalUser ; set tag ID - } - set who [string map {< < > > & &} $who] - set what [string toupper $what] - set xml "<$tag>$who" - append xml "$what" - return $xml -} - -# Make the owner header -proc S3::enowner {owner} { - return "$owner" - return "\n$owner" -} - -proc S3::endacl {} { - return "\n" -} - -# Public. Set the ACL on an existing object. -proc S3::PutAcl {args} { - global errorCode - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -resource -acl -owner - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "PutAcl requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -resource]} { - error "PutAcl requires -resource" "" [list S3 usage -resource $args] - } - if {![dict exists $myargs -acl]} { - dict set myargs -acl [S3::Configure -default-acl] - } - dict set myargs -acl [string trim [dict get $myargs -acl]] - if {[dict get $myargs -acl] == ""} { - dict set myargs -acl [S3::Configure -default-acl] - } - if {[dict get $myargs -acl] == ""} { - error "PutAcl requires -acl" "" [list D3 usage -resource $args] - } - # Clean up bucket, and take one leading slash (if any) off resource. - if {[string match "/*" [dict get $myargs -resource]]} { - dict set myargs -resource \ - [string range [dict get $myargs -resource] 1 end] - } - # Now, figure out the XML to send. - set acl [dict get $myargs -acl] - set owner "" - if {"<" != [string index $acl 0] && ![dict exists $myargs -owner]} { - # Grab the owner off the resource - set req [dict create verb GET \ - resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \ - rtype acl] - set dict [S3::maybebackground $req $myargs] - S3::throwhttp $dict ; #make sure it worked. - set xml [dict get $dict outbody] - set pxml [xsxp::parse $xml] - set owner [xsxp::fetch $pxml Owner/ID %PCDATA] - } - if {[dict exists $myargs -owner]} { - set owner [dict get $myargs -owner] - } - set xml [enowner $owner] - if {"" == $acl || "private" == $acl} { - append xml [engrant $owner FULL_CONTROL] - append xml [endacl] - } elseif {"public-read" == $acl} { - append xml [engrant $owner FULL_CONTROL] - append xml [engrant AllUsers READ] - append xml [endacl] - } elseif {"public-read-write" == $acl} { - append xml [engrant $owner FULL_CONTROL] - append xml [engrant AllUsers READ] - append xml [engrant AllUsers WRITE] - append xml [endacl] - } elseif {"authenticated-read" == $acl} { - append xml [engrant $owner FULL_CONTROL] - append xml [engrant AuthenticatedUsers READ] - append xml [endacl] - } elseif {"<" == [string index $acl 0]} { - set xml $acl - } elseif {[llength $acl] % 2 != 0} { - error "S3::PutAcl -acl must be xml, private, public-read, public-read-write, authenticated-read, or a dictionary" \ - "" [list S3 usage -acl $acl] - } else { - # ACL in permission/ID-list format. - if {[dict exists $acl owner] && [dict exists $acl acl]} { - set xml [S3::enowner [dict get $acl owner]] - set acl [dict get $acl acl] - } - foreach perm {FULL_CONTROL READ READ_ACP WRITE WRITE_ACP} { - if {[dict exists $acl $perm]} { - foreach id [dict get $acl $perm] { - append xml [engrant $id $perm] - } - } - } - append xml [endacl] - } - set req [dict create verb PUT \ - resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \ - inbody $xml \ - rtype acl] - set res [S3::maybebackground $req $myargs] - S3::throwhttp $res ; #make sure it worked. - return $xml -} - -# Public. Delete a resource from a bucket. -proc S3::Delete {args} { - global errorCode - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -resource -status - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "Delete requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -resource]} { - error "Delete requires -resource" "" [list S3 usage -resource $args] - } - # Clean up bucket, and take one leading slash (if any) off resource. - if {[string match "/*" [dict get $myargs -resource]]} { - dict set myargs -resource \ - [string range [dict get $myargs -resource] 1 end] - } - set req [dict create verb DELETE \ - resource /[dict get $myargs -bucket]/[dict get $myargs -resource]] - set res [S3::maybebackground $req $myargs] - if {[dict exists $myargs -status]} { - set x [list [dict get $res httpstatus] [dict get $res httpmessage]] - uplevel 1 \ - [list set [dict get $myargs -status] $x] - } - return [string match "2??" [dict get $res httpstatus]] -} - -# Some helper routines for Push, Pull, and Sync - -# Internal. Filter for fileutil::find. -proc S3::findfilter {dirs name} { - # In particular, skip links, devices, etc. - if {$dirs} { - return [expr {[file isdirectory $name] || [file isfile $name]}] - } else { - return [file isfile $name] - } -} - -# Internal. Get list of local files, appropriately trimmed. -proc S3::getLocal {root dirs} { - # Thanks to Michael Cleverly for this first line... - set base [file normalize [file join [pwd] $root]] - if {![string match "*/" $base]} { - set base $base/ - } - set files {} ; set bl [string length $base] - foreach file [fileutil::find $base [list S3::findfilter $dirs]] { - if {[file isdirectory $file]} { - lappend files [string range $file $bl end]/ - } else { - lappend files [string range $file $bl end] - } - } - set files [lsort $files] - # At this point, $files is a sorted list of all the local files, - # with a trailing / on any directories included in the list. - return $files -} - -# Internal. Get list of remote resources, appropriately trimmed. -proc S3::getRemote {bucket prefix blocking} { - set prefix [string trim $prefix " /"] - if {0 != [string length $prefix]} {append prefix /} - set res [S3::GetBucket -bucket $bucket -prefix $prefix \ - -result-type names -blocking $blocking] - set names {} ; set pl [string length $prefix] - foreach name $res { - lappend names [string range $name $pl end] - } - return [lsort $names] -} - -# Internal. Create any directories we need to put the file in place. -proc S3::makeDirs {directory suffix} { - set sofar {} - set nodes [split $suffix /] - set nodes [lrange $nodes 0 end-1] - foreach node $nodes { - lappend sofar $node - set tocheck [file join $directory {*}$sofar] - if {![file exists $tocheck]} { - catch {file mkdir $tocheck} - } - } -} - -# Internal. Default progress monitor for push, pull, toss. -proc S3::ignore {args} {} ; # default progress monitor - -# Internal. For development and testing. Progress monitor. -proc S3::printargs {args} {puts $args} ; # For testing. - -# Public. Send a local directory tree to S3. -proc S3::Push {args} { - uplevel #0 package require fileutil - global errorCode errorInfo - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -prefix -directory - -compare -x-amz-meta-* -acl -delete -error -progress - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "Push requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -directory]} { - error "Push requires -directory" "" [list S3 usage -directory $args] - } - # Set default values. - set defaults " - -acl \"[S3::Configure -default-acl]\" - -compare [S3::Configure -default-compare] - -prefix {} -delete 0 -error continue -progress ::S3::ignore -blocking 1" - foreach {key val} $defaults { - if {![dict exists $myargs $key]} {dict set myargs $key $val} - } - # Pull out arguments for convenience - foreach i {progress prefix directory bucket blocking} { - set $i [dict get $myargs -$i] - } - set prefix [string trimright $prefix /] - set meta [dict filter $myargs key x-amz-meta-*] - # We're readdy to roll here. - uplevel 1 [list {*}$progress args $myargs] - if {[catch { - set local [S3::getLocal $directory 0] - } caught]} { - error "Push could not walk local directory - $caught" \ - $errorInfo $errorCode - } - uplevel 1 [list {*}$progress local $local] - if {[catch { - set remote [S3::getRemote $bucket $prefix $blocking] - } caught]} { - error "Push could not walk remote directory - $caught" \ - $errorInfo $errorCode - } - uplevel 1 [list {*}$progress remote $remote] - set result [dict create] - set result0 [dict create \ - filescopied 0 bytescopied 0 compareskipped 0 \ - errorskipped 0 filesdeleted 0 filesnotdeleted 0] - foreach suffix $local { - uplevel 1 [list {*}$progress copy $suffix start] - set err [catch { - S3::Put -bucket $bucket -blocking $blocking \ - -file [file join $directory $suffix] \ - -resource $prefix/$suffix \ - -acl [dict get $myargs -acl] \ - {*}$meta \ - -compare [dict get $myargs -compare]} caught] - if {$err} { - uplevel 1 [list {*}$progress copy $suffix $errorCode] - dict incr result0 errorskipped - dict set result $suffix $errorCode - if {[dict get $myargs -error] eq "throw"} { - error "Push failed to Put - $caught" $errorInfo $errorCode - } elseif {[dict get $myargs -error] eq "break"} { - break - } - } else { - if {$caught} { - uplevel 1 [list {*}$progress copy $suffix copied] - dict incr result0 filescopied - dict incr result0 bytescopied \ - [file size [file join $directory $suffix]] - dict set result $suffix copied - } else { - uplevel 1 [list {*}$progress copy $suffix skipped] - dict incr result0 compareskipped - dict set result $suffix skipped - } - } - } - # Now do deletes, if so desired - if {[dict get $myargs -delete]} { - foreach suffix $remote { - if {$suffix ni $local} { - set err [catch { - S3::Delete -bucket $bucket -blocking $blocking \ - -resource $prefix/$suffix } caught] - if {$err} { - uplevel 1 [list {*}$progress delete $suffix $errorCode] - dict incr result0 filesnotdeleted - dict set result $suffix notdeleted - } else { - uplevel 1 [list {*}$progress delete $suffix {}] - dict incr result0 filesdeleted - dict set result $suffix deleted - } - } - } - } - dict set result {} $result0 - uplevel 1 [list {*}$progress finished $result] - return $result -} - -# Public. Fetch a portion of a remote bucket into a local directory tree. -proc S3::Pull {args} { - # This is waaaay to similar to Push for comfort. - # Fold it up later. - uplevel #0 package require fileutil - global errorCode errorInfo - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -prefix -directory - -compare -timestamp -delete -error -progress - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "Pull requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -directory]} { - error "Pull requires -directory" "" [list S3 usage -directory $args] - } - # Set default values. - set defaults " - -timestamp now - -compare [S3::Configure -default-compare] - -prefix {} -delete 0 -error continue -progress ::S3::ignore -blocking 1" - foreach {key val} $defaults { - if {![dict exists $myargs $key]} {dict set myargs $key $val} - } - # Pull out arguments for convenience - foreach i {progress prefix directory bucket blocking} { - set $i [dict get $myargs -$i] - } - set prefix [string trimright $prefix /] - # We're readdy to roll here. - uplevel 1 [list {*}$progress args $myargs] - if {[catch { - set local [S3::getLocal $directory 1] - } caught]} { - error "Pull could not walk local directory - $caught" \ - $errorInfo $errorCode - } - uplevel 1 [list {*}$progress local $local] - if {[catch { - set remote [S3::getRemote $bucket $prefix $blocking] - } caught]} { - error "Pull could not walk remote directory - $caught" \ - $errorInfo $errorCode - } - uplevel 1 [list {*}$progress remote $remote] - set result [dict create] - set result0 [dict create \ - filescopied 0 bytescopied 0 compareskipped 0 \ - errorskipped 0 filesdeleted 0 filesnotdeleted 0] - foreach suffix $remote { - uplevel 1 [list {*}$progress copy $suffix start] - set err [catch { - S3::makeDirs $directory $suffix - S3::Get -bucket $bucket -blocking $blocking \ - -file [file join $directory $suffix] \ - -resource $prefix/$suffix \ - -timestamp [dict get $myargs -timestamp] \ - -compare [dict get $myargs -compare]} caught] - if {$err} { - uplevel 1 [list {*}$progress copy $suffix $errorCode] - dict incr result0 errorskipped - dict set result $suffix $errorCode - if {[dict get $myargs -error] eq "throw"} { - error "Pull failed to Get - $caught" $errorInfo $errorCode - } elseif {[dict get $myargs -error] eq "break"} { - break - } - } else { - if {$caught} { - uplevel 1 [list {*}$progress copy $suffix copied] - dict incr result0 filescopied - dict incr result0 bytescopied \ - [file size [file join $directory $suffix]] - dict set result $suffix copied - } else { - uplevel 1 [list {*}$progress copy $suffix skipped] - dict incr result0 compareskipped - dict set result $suffix skipped - } - } - } - # Now do deletes, if so desired - if {[dict get $myargs -delete]} { - foreach suffix [lsort -decreasing $local] { - # Note, decreasing because we delete empty dirs - if {[string match "*/" $suffix]} { - set f [file join $directory $suffix] - catch {file delete -- $f} - if {![file exists $f]} { - uplevel 1 [list {*}$progress delete $suffix {}] - dict set result $suffix deleted - dict incr result0 filesdeleted - } - } elseif {$suffix ni $remote} { - set err [catch { - file delete [file join $directory $suffix] - } caught] - if {$err} { - uplevel 1 [list {*}$progress delete $suffix $errorCode] - dict incr result0 filesnotdeleted - dict set result $suffix notdeleted - } else { - uplevel 1 [list {*}$progress delete $suffix {}] - dict incr result0 filesdeleted - dict set result $suffix deleted - } - } - } - } - dict set result {} $result0 - uplevel 1 [list {*}$progress finished $result] - return $result -} - -# Public. Delete a collection of resources with the same prefix. -proc S3::Toss {args} { - # This is waaaay to similar to Push for comfort. - # Fold it up later. - global errorCode errorInfo - checkinit - set myargs [S3::parseargs1 $args { - -bucket -blocking -prefix - -error -progress - }] - if {![dict exists $myargs -bucket]} { - dict set myargs -bucket [S3::Configure -default-bucket] - } - dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "] - if {"" eq [dict get $myargs -bucket]} { - error "Toss requires -bucket" "" [list S3 usage -bucket $args] - } - if {![dict exists $myargs -prefix]} { - error "Toss requires -prefix" "" [list S3 usage -directory $args] - } - # Set default values. - set defaults "-error continue -progress ::S3::ignore -blocking 1" - foreach {key val} $defaults { - if {![dict exists $myargs $key]} {dict set myargs $key $val} - } - # Pull out arguments for convenience - foreach i {progress prefix bucket blocking} { - set $i [dict get $myargs -$i] - } - set prefix [string trimright $prefix /] - # We're readdy to roll here. - uplevel 1 [list {*}$progress args $myargs] - if {[catch { - set remote [S3::getRemote $bucket $prefix $blocking] - } caught]} { - error "Toss could not walk remote bucket - $caught" \ - $errorInfo $errorCode - } - uplevel 1 [list {*}$progress remote $remote] - set result [dict create] - set result0 [dict create \ - filescopied 0 bytescopied 0 compareskipped 0 \ - errorskipped 0 filesdeleted 0 filesnotdeleted 0] - # Now do deletes - foreach suffix $remote { - set err [catch { - S3::Delete -bucket $bucket -blocking $blocking \ - -resource $prefix/$suffix } caught] - if {$err} { - uplevel 1 [list {*}$progress delete $suffix $errorCode] - dict incr result0 filesnotdeleted - dict set result $suffix notdeleted - } else { - uplevel 1 [list {*}$progress delete $suffix {}] - dict incr result0 filesdeleted - dict set result $suffix deleted - } - } - dict set result {} $result0 - uplevel 1 [list {*}$progress finished $result] - return $result -} diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/pkgIndex.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/pkgIndex.tcl deleted file mode 100644 index cfc42b43..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/pkgIndex.tcl +++ /dev/null @@ -1,9 +0,0 @@ -# pkgIndex.tcl -- -# Copyright (c) 2006 Darren New -# This is for the Amazon S3 web service packages. - -if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} - -package ifneeded xsxp 1.1 [list source [file join $dir xsxp.tcl]] -package ifneeded S3 1.0.4 [list source [file join $dir S3.tcl]] - diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/xsxp.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/xsxp.tcl deleted file mode 100644 index fe0b0c3a..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/amazon-s3/xsxp.tcl +++ /dev/null @@ -1,254 +0,0 @@ -# xsxp.tcl -- -# -###Abstract -# Extremely Simple XML Parser -# -# This is pretty lame, but I needed something like this for S3, -# and at the time, TclDOM would not work with the new 8.5 Tcl -# due to version number problems. -# -# In addition, this is a pure-value implementation. There is no -# garbage to clean up in the event of a thrown error, for example. -# This simplifies the code for sufficiently small XML documents, -# which is what Amazon's S3 guarantees. -# -###Copyright -# Copyright (c) 2006 Darren New. -# All Rights Reserved. -# NO WARRANTIES OF ANY TYPE ARE PROVIDED. -# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS. -# See the license terms in LICENSE.txt -# -###Revision String -# SCCS: %Z% %M% %I% %E% %U% - -# xsxp::parse $xml -# Returns a parsed XML, or PXML. A pxml is a list. -# The first element is the name of the tag. -# The second element is a list of name/value pairs of the -# associated attribues, if any. -# The third thru final values are recursively PXML values. -# If the first element (element zero, that is) is "%PCDATA", -# then the attributes will be emtpy and the third element -# will be the text of the element. - -# xsxp::fetch $pxml $path ?$part? -# $pxml is a parsed XML, as returned from xsxp::parse. -# $path is a list of elements. Each element is the name of -# a child to look up, optionally followed by a hash ("#") -# and a string of digits. An emtpy list or an initial empty -# element selects $pxml. If no hash sign is present, the -# behavior is as if "#0" had been appended to that element. -# An element of $path scans the children at the indicated -# level for the n'th instance of a child whose tag matches -# the part of the element before the hash sign. If an element -# is simply "#" followed by digits, that indexed child is -# selected, regardless of the tags in the children. So -# an element of #3 will always select the fourth child -# of the node under consideration. -# $part defaults to %ALL. It can be one of the following: -# %ALL - returns the entire selected element. -# %TAGNAME - returns lindex 0 of the selected element. -# %ATTRIBUTES - returns lindex 1 of the selected element. -# %CHILDREN - returns lrange 2 through end of the selected element, -# resulting in a list of elements being returned. -# %PCDATA - returns a concatenation of all the bodies of -# direct children of this node whose tag is %PCDATA. -# Throws an error if no such children are found. That -# is, part=%PCDATA means return the textual content found -# in that node but not its children nodes. -# %PCDATA? - like %PCDATA, but returns an empty string if -# no PCDATA is found. - -# xsxp::fetchall $pxml_list $path ?$part? -# Iterates over each PXML in $pxml_list, selecting the indicated -# path from it, building a new list with the selected data, and -# returning that new list. For example, $pxml_list might be -# the %CHILDREN of a particular element, and the $path and $part -# might select from each child a sub-element in which we're interested. - -# xsxp::only $pxml $tagname -# Iterates over the direct children of $pxml and selects only -# those with $tagname as their tag. Returns a list of matching -# elements. - -# xsxp::prettyprint $pxml -# Outputs to stdout a nested-list notation of the parsed XML. - -package require xml -package provide xsxp 1.1 - -namespace eval xsxp { - - variable Stack - variable Cur - - proc Characterdatacommand {characterdata} { - variable Cur - # puts "characterdatacommand $characterdata" - set x [list %PCDATA {} $characterdata] - lappend Cur $x - } - - proc Elementstartcommand {name attlist args} { - # puts "elementstart $name {$attlist} $args" - variable Stack - variable Cur - lappend Stack $Cur - set Cur [list $name $attlist] - } - - proc Elementendcommand {args} { - # puts "elementend $args" - variable Stack - variable Cur - set x [lindex $Stack end] - lappend x $Cur - set Cur $x - set Stack [lrange $Stack 0 end-1] - } - - proc parse {xml} { - variable Cur - variable Stack - set Cur {} - set Stack {} - set parser [::xml::parser \ - -characterdatacommand [namespace code Characterdatacommand] \ - -elementstartcommand [namespace code Elementstartcommand] \ - -elementendcommand [namespace code Elementendcommand] \ - -ignorewhitespace 1 -final 1 - ] - $parser parse $xml - $parser free - # The following line is needed because the close of the last element - # appends the outermost element to the item on the top of the stack. - # Since there's nothing on the top of the stack at the close of the - # last element, we append the current element to an empty list. - # In essence, since we don't really have a terminating condition - # on the recursion, an empty stack is still treated like an element. - set Cur [lindex $Cur 0] - set Cur [Normalize $Cur] - return $Cur - } - - proc Normalize {pxml} { - # This iterates over pxml recursively, finding entries that - # start with multiple %PCDATA elements, and coalesces their - # content, so if an element contains only %PCDATA, it is - # guaranteed to have only one child. - # Not really necessary, given definition of part=%PCDATA - # However, it makes pretty-prints nicer (for AWS at least) - # and ends up with smaller lists. I have no idea why they - # would put quotes around an MD5 hash in hex, tho. - set dupl 1 - while {$dupl} { - set first [lindex $pxml 2] - set second [lindex $pxml 3] - if {[lindex $first 0] eq "%PCDATA" && [lindex $second 0] eq "%PCDATA"} { - set repl [list %PCDATA {} [lindex $first 2][lindex $second 2]] - set pxml [lreplace $pxml 2 3 $repl] - } else { - set dupl 0 - for {set i 2} {$i < [llength $pxml]} {incr i} { - set pxml [lreplace $pxml $i $i [Normalize [lindex $pxml $i]]] - } - } - } - return $pxml - } - - proc prettyprint {pxml {chan stdout} {indent 0}} { - puts -nonewline $chan [string repeat " " $indent] - if {[lindex $pxml 0] eq "%PCDATA"} { - puts $chan "%PCDATA: [lindex $pxml 2]" - return - } - puts -nonewline $chan "[lindex $pxml 0]" - foreach {name val} [lindex $pxml 1] { - puts -nonewline $chan " $name='$val'" - } - puts $chan "" - foreach node [lrange $pxml 2 end] { - prettyprint $node $chan [expr $indent+1] - } - } - - proc fetch {pxml path {part %ALL}} { - set path [string trim $path /] - if {-1 != [string first / $path]} { - set path [split $path /] - } - foreach element $path { - if {$pxml eq ""} {return ""} - foreach {tag count} [split $element #] { - if {$tag ne ""} { - if {$count eq ""} {set count 0} - set pxml [lrange $pxml 2 end] - while {0 <= $count && 0 != [llength $pxml]} { - if {$tag eq [lindex $pxml 0 0]} { - incr count -1 - if {$count < 0} { - # We're done. Go on to next element. - set pxml [lindex $pxml 0] - } else { - # Not done yet. Throw this away. - set pxml [lrange $pxml 1 end] - } - } else { - # Not what we want. - set pxml [lrange $pxml 1 end] - } - } - } else { # tag eq "" - if {$count eq ""} { - # Just select whole $pxml - } else { - set pxml [lindex $pxml [expr {2+$count}]] - } - } - break - } ; # done the foreach [split] loop - } ; # done all the elements. - if {$part eq "%ALL"} {return $pxml} - if {$part eq "%ATTRIBUTES"} {return [lindex $pxml 1]} - if {$part eq "%TAGNAME"} {return [lindex $pxml 0]} - if {$part eq "%CHILDREN"} {return [lrange $pxml 2 end]} - if {$part eq "%PCDATA" || $part eq "%PCDATA?"} { - set res "" ; set found 0 - foreach elem [lrange $pxml 2 end] { - if {"%PCDATA" eq [lindex $elem 0]} { - append res [lindex $elem 2] - set found 1 - } - } - if {$found || $part eq "%PCDATA?"} { - return $res - } else { - error "xsxp::fetch did not find requested PCDATA" - } - } - return $pxml ; # Don't know what he's after - } - - proc only {pxml tag} { - set res {} - foreach element [lrange $pxml 2 end] { - if {[lindex $element 0] eq $tag} { - lappend res $element - } - } - return $res - } - - proc fetchall {pxml_list path {part %ALL}} { - set res [list] - foreach pxml $pxml_list { - lappend res [fetch $pxml $path $part] - } - return $res - } -} - -namespace export xsxp parse prettyprint fetch - diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/asn/asn.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/asn/asn.tcl deleted file mode 100644 index 1271e429..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/asn/asn.tcl +++ /dev/null @@ -1,1580 +0,0 @@ -#----------------------------------------------------------------------------- -# Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de) -# Copyright (C) 2004-2011 Michael Schlenker (mic42@users.sourceforge.net) -#----------------------------------------------------------------------------- -# -# A partial ASN decoder/encoder implementation in plain Tcl. -# -# See ASN.1 (X.680) and BER (X.690). -# See 'asn_ber_intro.txt' in this directory. -# -# This software is copyrighted by Jochen C. Loewer (loewerj@web.de). The -# following terms apply to all files associated with the software unless -# explicitly disclaimed in individual files. -# -# The authors hereby grant permission to use, copy, modify, distribute, -# and license this software and its documentation for any purpose, provided -# that existing copyright notices are retained in all copies and that this -# notice is included verbatim in any distributions. No written agreement, -# license, or royalty fee is required for any of the authorized uses. -# Modifications to this software may be copyrighted by their authors -# and need not follow the licensing terms described here, provided that -# the new terms are clearly indicated on the first page of each file where -# they apply. -# -# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY -# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY -# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE -# POSSIBILITY OF SUCH DAMAGE. -# -# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, -# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE -# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE -# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR -# MODIFICATIONS. -# -# written by Jochen Loewer -# 3 June, 1999 -# -# $Id: asn.tcl,v 1.20 2011/01/05 22:33:33 mic42 Exp $ -# -#----------------------------------------------------------------------------- - -# needed for using wide() -package require Tcl 8.5 9 - -namespace eval asn { - # Encoder commands - namespace export \ - asnSequence \ - asnSequenceFromList \ - asnSet \ - asnSetFromList \ - asnApplicationConstr \ - asnApplication \ - asnContext\ - asnContextConstr\ - asnChoice \ - asnChoiceConstr \ - asnInteger \ - asnEnumeration \ - asnBoolean \ - asnOctetString \ - asnNull \ - asnUTCTime \ - asnNumericString \ - asnPrintableString \ - asnIA5String\ - asnBMPString\ - asnUTF8String\ - asnBitString \ - asnObjectIdentifer - - # Decoder commands - namespace export \ - asnGetResponse \ - asnGetInteger \ - asnGetEnumeration \ - asnGetOctetString \ - asnGetSequence \ - asnGetSet \ - asnGetApplication \ - asnGetNumericString \ - asnGetPrintableString \ - asnGetIA5String \ - asnGetBMPString \ - asnGetUTF8String \ - asnGetObjectIdentifier \ - asnGetBoolean \ - asnGetUTCTime \ - asnGetBitString \ - asnGetContext - - # general BER utility commands - namespace export \ - asnPeekByte \ - asnGetLength \ - asnRetag \ - asnPeekTag \ - asnTag - -} - -#----------------------------------------------------------------------------- -# Implementation notes: -# -# See the 'asn_ber_intro.txt' in this directory for an introduction -# into BER/DER encoding of ASN.1 information. Bibliography information -# -# A Layman's Guide to a Subset of ASN.1, BER, and DER -# -# An RSA Laboratories Technical Note -# Burton S. Kaliski Jr. -# Revised November 1, 1993 -# -# Supersedes June 3, 1991 version, which was also published as -# NIST/OSI Implementors' Workshop document SEC-SIG-91-17. -# PKCS documents are available by electronic mail to -# . -# -# Copyright (C) 1991-1993 RSA Laboratories, a division of RSA -# Data Security, Inc. License to copy this document is granted -# provided that it is identified as "RSA Data Security, Inc. -# Public-Key Cryptography Standards (PKCS)" in all material -# mentioning or referencing this document. -# 003-903015-110-000-000 -# -#----------------------------------------------------------------------------- - -#----------------------------------------------------------------------------- -# asnLength : Encode some length data. Helper command. -#----------------------------------------------------------------------------- - -proc ::asn::asnLength {len} { - - if {$len < 0} { - return -code error "Negative length octet requested" - } - if {$len < 128} { - # short form: ISO X.690 8.1.3.4 - return [binary format c $len] - } - # long form: ISO X.690 8.1.3.5 - # try to use a minimal encoding, - # even if not required by BER, but it is required by DER - # take care for signed vs. unsigned issues - if {$len < 256 } { - return [binary format H2c 81 [expr {$len - 256}]] - } - if {$len < 32769} { - # two octet signed value - return [binary format H2S 82 $len] - } - if {$len < 65536} { - return [binary format H2S 82 [expr {$len - 65536}]] - } - if {$len < 8388608} { - # three octet signed value - return [binary format H2cS 83 [expr {$len >> 16}] [expr {($len & 0xFFFF) - 65536}]] - } - if {$len < 16777216} { - # three octet signed value - return [binary format H2cS 83 [expr {($len >> 16) -256}] [expr {($len & 0xFFFF) -65536}]] - } - if {$len < 2147483649} { - # four octet signed value - return [binary format H2I 84 $len] - } - if {$len < 4294967296} { - # four octet unsigned value - return [binary format H2I 84 [expr {$len - 4294967296}]] - } - if {$len < 1099511627776} { - # five octet unsigned value - return [binary format H2 85][string range [binary format W $len] 3 end] - } - if {$len < 281474976710656} { - # six octet unsigned value - return [binary format H2 86][string range [binary format W $len] 2 end] - } - if {$len < 72057594037927936} { - # seven octet value - return [binary format H2 87][string range [binary format W $len] 1 end] - } - - # must be a 64-bit wide signed value - return [binary format H2W 88 $len] -} - -#----------------------------------------------------------------------------- -# asnSequence : Assumes that the arguments are already ASN encoded. -#----------------------------------------------------------------------------- - -proc ::asn::asnSequence {args} { - asnSequenceFromList $args -} - -proc ::asn::asnSequenceFromList {lst} { - # The sequence tag is 0x30. The length is arbitrary and thus full - # length coding is required. The arguments have to be BER encoded - # already. Constructed value, definite-length encoding. - - set out "" - foreach part $lst { - append out $part - } - set len [string length $out] - return [binary format H2a*a$len 30 [asnLength $len] $out] -} - - -#----------------------------------------------------------------------------- -# asnSet : Assumes that the arguments are already ASN encoded. -#----------------------------------------------------------------------------- - -proc ::asn::asnSet {args} { - asnSetFromList $args -} - -proc ::asn::asnSetFromList {lst} { - # The set tag is 0x31. The length is arbitrary and thus full - # length coding is required. The arguments have to be BER encoded - # already. - - set out "" - foreach part $lst { - append out $part - } - set len [string length $out] - return [binary format H2a*a$len 31 [asnLength $len] $out] -} - - -#----------------------------------------------------------------------------- -# asnApplicationConstr -#----------------------------------------------------------------------------- - -proc ::asn::asnApplicationConstr {appNumber args} { - # Packs the arguments into a constructed value with application tag. - - set out "" - foreach part $args { - append out $part - } - set code [expr {0x060 + $appNumber}] - set len [string length $out] - return [binary format ca*a$len $code [asnLength $len] $out] -} - -#----------------------------------------------------------------------------- -# asnApplication -#----------------------------------------------------------------------------- - -proc ::asn::asnApplication {appNumber data} { - # Packs the arguments into a constructed value with application tag. - - set code [expr {0x040 + $appNumber}] - set len [string length $data] - return [binary format ca*a$len $code [asnLength $len] $data] -} - -#----------------------------------------------------------------------------- -# asnContextConstr -#----------------------------------------------------------------------------- - -proc ::asn::asnContextConstr {contextNumber args} { - # Packs the arguments into a constructed value with application tag. - - set out "" - foreach part $args { - append out $part - } - set code [expr {0x0A0 + $contextNumber}] - set len [string length $out] - return [binary format ca*a$len $code [asnLength $len] $out] -} - -#----------------------------------------------------------------------------- -# asnContext -#----------------------------------------------------------------------------- - -proc ::asn::asnContext {contextNumber data} { - # Packs the arguments into a constructed value with application tag. - set code [expr {0x080 + $contextNumber}] - set len [string length $data] - return [binary format ca*a$len $code [asnLength $len] $data] -} -#----------------------------------------------------------------------------- -# asnChoice -#----------------------------------------------------------------------------- - -proc ::asn::asnChoice {appNumber args} { - # Packs the arguments into a choice construction. - - set out "" - foreach part $args { - append out $part - } - set code [expr {0x080 + $appNumber}] - set len [string length $out] - return [binary format ca*a$len $code [asnLength $len] $out] -} - -#----------------------------------------------------------------------------- -# asnChoiceConstr -#----------------------------------------------------------------------------- - -proc ::asn::asnChoiceConstr {appNumber args} { - # Packs the arguments into a choice construction. - - set out "" - foreach part $args { - append out $part - } - set code [expr {0x0A0 + $appNumber}] - set len [string length $out] - return [binary format ca*a$len $code [asnLength $len] $out] -} - -#----------------------------------------------------------------------------- -# asnInteger : Encode integer value. -#----------------------------------------------------------------------------- - -proc ::asn::asnInteger {number} { - asnIntegerOrEnum 02 $number -} - -#----------------------------------------------------------------------------- -# asnEnumeration : Encode enumeration value. -#----------------------------------------------------------------------------- - -proc ::asn::asnEnumeration {number} { - asnIntegerOrEnum 0a $number -} - -#----------------------------------------------------------------------------- -# asnIntegerOrEnum : Common code for Integers and Enumerations -# No Bignum version, as we do not expect large Enums. -#----------------------------------------------------------------------------- - -proc ::asn::asnIntegerOrEnum {tag number} { - # The integer tag is 0x02 , the Enum Tag 0x0a otherwise identical. - # The length is 1, 2, 3, or 4, coded in a - # single byte. This can be done directly, no need to go through - # asnLength. The value itself is written in big-endian. - - # Known bug/issue: The command cannot handle very wide integers, i.e. - # anything above 8 bytes length. Use asnBignumInteger for those. - - # check if we really have an int - set num $number - incr num - - if {($number >= -128) && ($number < 128)} { - return [binary format H2H2c $tag 01 $number] - } - if {($number >= -32768) && ($number < 32768)} { - return [binary format H2H2S $tag 02 $number] - } - if {($number >= -8388608) && ($number < 8388608)} { - set numberb [expr {$number & 0xFFFF}] - set numbera [expr {($number >> 16) & 0xFF}] - return [binary format H2H2cS $tag 03 $numbera $numberb] - } - if {($number >= -2147483648) && ($number < 2147483648)} { - return [binary format H2H2I $tag 04 $number] - } - if {($number >= -549755813888) && ($number < 549755813888)} { - set numberb [expr {$number & 0xFFFFFFFF}] - set numbera [expr {($number >> 32) & 0xFF}] - return [binary format H2H2cI $tag 05 $numbera $numberb] - } - if {($number >= -140737488355328) && ($number < 140737488355328)} { - set numberb [expr {$number & 0xFFFFFFFF}] - set numbera [expr {($number >> 32) & 0xFFFF}] - return [binary format H2H2SI $tag 06 $numbera $numberb] - } - if {($number >= -36028797018963968) && ($number < 36028797018963968)} { - set numberc [expr {$number & 0xFFFFFFFF}] - set numberb [expr {($number >> 32) & 0xFFFF}] - set numbera [expr {($number >> 48) & 0xFF}] - return [binary format H2H2cSI $tag 07 $numbera $numberb $numberc] - } - if {($number >= -9223372036854775808) && ($number <= 9223372036854775807)} { - return [binary format H2H2W $tag 08 $number] - } - return -code error "Integer value to large to encode, use asnBigInteger" -} - -#----------------------------------------------------------------------------- -# asnBigInteger : Encode a long integer value using math::bignum -#----------------------------------------------------------------------------- - -proc ::asn::asnBigInteger {bignum} { - # require math::bignum only if it is used - package require math::bignum - - # this is a hack to check for bignum... - if {[llength $bignum] < 2 || ([lindex $bignum 0] ne "bignum")} { - return -code error "expected math::bignum value got \"$bignum\"" - } - if {[math::bignum::sign $bignum]} { - # generate two's complement form - set bits [math::bignum::bits $bignum] - set padding [expr {$bits % 8}] - set len [expr {int(ceil($bits / 8.0))}] - if {$padding == 0} { - # we need a complete extra byte for the sign - # unless this is a base 2 multiple - set test [math::bignum::fromstr 0] - math::bignum::setbit test [expr {$bits-1}] - if {[math::bignum::ne [math::bignum::abs $bignum] $test]} { - incr len - } - } - set exp [math::bignum::pow \ - [math::bignum::fromstr 256] \ - [math::bignum::fromstr $len]] - set bignum [math::bignum::add $bignum $exp] - set hex [math::bignum::tostr $bignum 16] - } else { - set bits [math::bignum::bits $bignum] - if {($bits % 8) == 0 && $bits > 0} { - set pad "00" - } else { - set pad "" - } - set hex $pad[math::bignum::tostr $bignum 16] - } - if {[string length $hex]%2} { - set hex "0$hex" - } - set octets [expr {(([string length $hex]+1)/2)}] - return [binary format H2a*H* 02 [asnLength $octets] $hex] -} - - -#----------------------------------------------------------------------------- -# asnBoolean : Encode a boolean value. -#----------------------------------------------------------------------------- - -proc ::asn::asnBoolean {bool} { - # The boolean tag is 0x01. The length is always 1, coded in - # a single byte. This can be done directly, no need to go through - # asnLength. The value itself is written in big-endian. - - return [binary format H2H2c 01 01 [expr {$bool ? 0x0FF : 0x0}]] -} - -#----------------------------------------------------------------------------- -# asnOctetString : Encode a string of arbitrary bytes -#----------------------------------------------------------------------------- - -proc ::asn::asnOctetString {string} { - # The octet tag is 0x04. The length is arbitrary, so we need - # 'asnLength' for full coding of the length. - - set len [string length $string] - return [binary format H2a*a$len 04 [asnLength $len] $string] -} - -#----------------------------------------------------------------------------- -# asnNull : Encode a null value -#----------------------------------------------------------------------------- - -proc ::asn::asnNull {} { - # Null has only one valid encoding - return \x05\x00 -} - -#----------------------------------------------------------------------------- -# asnBitstring : Encode a Bit String value -#----------------------------------------------------------------------------- - -proc ::asn::asnBitString {bitstring} { - # The bit string tag is 0x03. - # Bit strings can be either simple or constructed - # we always use simple encoding - - set bitlen [string length $bitstring] - set padding [expr {(8 - ($bitlen % 8)) % 8}] - set len [expr {($bitlen / 8) + 1}] - if {$padding != 0} { incr len } - - return [binary format H2a*cB* 03 [asnLength $len] $padding $bitstring] -} - -#----------------------------------------------------------------------------- -# asnUTCTime : Encode an UTC time string -#----------------------------------------------------------------------------- - -proc ::asn::asnUTCTime {UTCtimestring} { - # the utc time tag is 0x17. - # - # BUG: we do not check the string for well formedness - - set ascii [encoding convertto ascii $UTCtimestring] - set len [string length $ascii] - return [binary format H2a*a* 17 [asnLength $len] $ascii] -} - -#----------------------------------------------------------------------------- -# asnPrintableString : Encode a printable string -#----------------------------------------------------------------------------- -namespace eval asn { - variable nonPrintableChars {[^ A-Za-z0-9'()+,.:/?=-]} -} -proc ::asn::asnPrintableString {string} { - # the printable string tag is 0x13 - variable nonPrintableChars - # it is basically a restricted ascii string - if {[regexp $nonPrintableChars $string ]} { - return -code error "Illegal character in PrintableString." - } - - # check characters - set ascii [encoding convertto ascii $string] - return [asnEncodeString 13 $ascii] -} - -#----------------------------------------------------------------------------- -# asnIA5String : Encode an Ascii String -#----------------------------------------------------------------------------- -proc ::asn::asnIA5String {string} { - # the IA5 string tag is 0x16 - # check for extended charachers - if {[string length $string]!=[string length [encoding convertto utf-8 $string]]} { - return -code error "Illegal character in IA5String" - } - set ascii [encoding convertto ascii $string] - return [asnEncodeString 16 $ascii] -} - -#----------------------------------------------------------------------------- -# asnNumericString : Encode a Numeric String type -#----------------------------------------------------------------------------- -namespace eval asn { - variable nonNumericChars {[^0-9 ]} -} -proc ::asn::asnNumericString {string} { - # the Numeric String type has tag 0x12 - variable nonNumericChars - if {[regexp $nonNumericChars $string]} { - return -code error "Illegal character in Numeric String." - } - - return [asnEncodeString 12 $string] -} -#---------------------------------------------------------------------- -# asnBMPString: Encode a Tcl string as Basic Multinligval (UCS2) string -#----------------------------------------------------------------------- -proc asn::asnBMPString {string} { - if {$::tcl_platform(byteOrder) eq "littleEndian"} { - set bytes "" - foreach {lo hi} [split [encoding convertto unicode $string] ""] { - append bytes $hi $lo - } - } else { - set bytes [encoding convertto unicode $string] - } - return [asnEncodeString 1e $bytes] -} -#--------------------------------------------------------------------------- -# asnUTF8String: encode tcl string as UTF8 String -#---------------------------------------------------------------------------- -proc asn::asnUTF8String {string} { - return [asnEncodeString 0c [encoding convertto utf-8 $string]] -} -#----------------------------------------------------------------------------- -# asnEncodeString : Encode an RestrictedCharacter String -#----------------------------------------------------------------------------- -proc ::asn::asnEncodeString {tag string} { - set len [string length $string] - return [binary format H2a*a$len $tag [asnLength $len] $string] -} - -#----------------------------------------------------------------------------- -# asnObjectIdentifier : Encode an Object Identifier value -#----------------------------------------------------------------------------- -proc ::asn::asnObjectIdentifier {oid} { - # the object identifier tag is 0x06 - - if {[llength $oid] < 2} { - return -code error "OID must have at least two subidentifiers." - } - - # basic check that it is valid - foreach identifier $oid { - if {$identifier < 0} { - return -code error \ - "Malformed OID. Identifiers must be positive Integers." - } - } - - if {[lindex $oid 0] > 2} { - return -code error "First subidentifier must be 0,1 or 2" - } - if {[lindex $oid 1] > 39} { - return -code error \ - "Second subidentifier must be between 0 and 39" - } - - # handle the special cases directly - switch [llength $oid] { - 2 { return [binary format H2H2c 06 01 \ - [expr {[lindex $oid 0]*40+[lindex $oid 1]}]] } - default { - # This can probably be written much shorter. - # Just a first try that works... - # - set octets [binary format c \ - [expr {[lindex $oid 0]*40+[lindex $oid 1]}]] - foreach identifier [lrange $oid 2 end] { - set d 128 - if {$identifier < 128} { - set subidentifier [list $identifier] - } else { - set subidentifier [list] - # find the largest divisor - - while {($identifier / $d) >= 128} { - set d [expr {$d * 128}] - } - # and construct the subidentifiers - set remainder $identifier - while {$d >= 128} { - set coefficient [expr {($remainder / $d) | 0x80}] - set remainder [expr {$remainder % $d}] - set d [expr {$d / 128}] - lappend subidentifier $coefficient - } - lappend subidentifier $remainder - } - append octets [binary format c* $subidentifier] - } - return [binary format H2a*a* 06 \ - [asnLength [string length $octets]] $octets] - } - } - -} - -#----------------------------------------------------------------------------- -# asnGetResponse : Read a ASN response from a channel. -#----------------------------------------------------------------------------- - -proc ::asn::asnGetResponse {sock data_var} { - upvar 1 $data_var data - - # We expect a sequence here (tag 0x30). The code below is an - # inlined replica of 'asnGetSequence', modified for reading from a - # channel instead of a string. - - set tag [read $sock 1] - - if {$tag == "\x30"} { - # The following code is a replica of 'asnGetLength', modified - # for reading the bytes from the channel instead of a string. - - set len1 [read $sock 1] - binary scan $len1 c num - set length [expr {($num + 0x100) % 0x100}] - - if {$length >= 0x080} { - # The byte the read is not the length, but a prefix, and - # the lower nibble tells us how many bytes follow. - - set len_length [expr {$length & 0x7f}] - - # BUG: We should not perform the value extraction for an - # BUG: improper length. It wastes cycles, and here it can - # BUG: cause us trouble, reading more data than there is - # BUG: on the channel. Depending on the channel - # BUG: configuration an attacker can induce us to block, - # BUG: causing a denial of service. - set lengthBytes [read $sock $len_length] - - switch $len_length { - 1 { - binary scan $lengthBytes c length - set length [expr {($length + 0x100) % 0x100}] - } - 2 { binary scan $lengthBytes S length } - 3 { binary scan \x00$lengthBytes I length } - 4 { binary scan $lengthBytes I length } - default { - return -code error \ - "length information too long ($len_length)" - } - } - } - - # Now that the length is known we get the remainder, - # i.e. payload, and construct proper in-memory BER encoded - # sequence. - - set rest [read $sock $length] - set data [binary format aa*a$length $tag [asnLength $length] $rest] - } else { - # Generate an error message if the data is not a sequence as - # we expected. - - set tag_hex "" - binary scan $tag H2 tag_hex - return -code error "unknown start tag [string length $tag] $tag_hex" - } -} - -if {[package vsatisfies [package present Tcl] 8.5.0 9]} { -############################################################################## -# Code for 8.5 -############################################################################## -#----------------------------------------------------------------------------- -# asnGetByte (8.5 version) : Retrieve a single byte from the data (unsigned) -#----------------------------------------------------------------------------- - -proc ::asn::asnGetByte {data_var byte_var} { - upvar 1 $data_var data $byte_var byte - - binary scan [string index $data 0] cu byte - set data [string range $data 1 end] - - return -} - -#----------------------------------------------------------------------------- -# asnPeekByte (8.5 version) : Retrieve a single byte from the data (unsigned) -# without removing it. -#----------------------------------------------------------------------------- - -proc ::asn::asnPeekByte {data_var byte_var {offset 0}} { - upvar 1 $data_var data $byte_var byte - - binary scan [string index $data $offset] cu byte - - return -} - -#----------------------------------------------------------------------------- -# asnGetLength (8.5 version) : Decode an ASN length value (See notes) -#----------------------------------------------------------------------------- - -proc ::asn::asnGetLength {data_var length_var} { - upvar 1 $data_var data $length_var length - - asnGetByte data length - if {$length == 0x080} { - return -code error "Indefinite length BER encoding not yet supported" - } - if {$length > 0x080} { - # The retrieved byte is a prefix value, and the integer in the - # lower nibble tells us how many bytes were used to encode the - # length data following immediately after this prefix. - - set len_length [expr {$length & 0x7f}] - - if {[string length $data] < $len_length} { - return -code error \ - "length information invalid, not enough octets left" - } - - asnGetBytes data $len_length lengthBytes - - switch $len_length { - 1 { binary scan $lengthBytes cu length } - 2 { binary scan $lengthBytes Su length } - 3 { binary scan \x00$lengthBytes Iu length } - 4 { binary scan $lengthBytes Iu length } - default { - binary scan $lengthBytes H* hexstr - scan $hexstr %llx length - } - } - } - return -} - -} else { -############################################################################## -# Code for Tcl 8.4 -############################################################################## -#----------------------------------------------------------------------------- -# asnGetByte : Retrieve a single byte from the data (unsigned) -#----------------------------------------------------------------------------- - -proc ::asn::asnGetByte {data_var byte_var} { - upvar 1 $data_var data $byte_var byte - - binary scan [string index $data 0] c byte - set byte [expr {($byte + 0x100) % 0x100}] - set data [string range $data 1 end] - - return -} - -#----------------------------------------------------------------------------- -# asnPeekByte : Retrieve a single byte from the data (unsigned) -# without removing it. -#----------------------------------------------------------------------------- - -proc ::asn::asnPeekByte {data_var byte_var {offset 0}} { - upvar 1 $data_var data $byte_var byte - - binary scan [string index $data $offset] c byte - set byte [expr {($byte + 0x100) % 0x100}] - - return -} - -#----------------------------------------------------------------------------- -# asnGetLength : Decode an ASN length value (See notes) -#----------------------------------------------------------------------------- - -proc ::asn::asnGetLength {data_var length_var} { - upvar 1 $data_var data $length_var length - - asnGetByte data length - if {$length == 0x080} { - return -code error "Indefinite length BER encoding not yet supported" - } - if {$length > 0x080} { - # The retrieved byte is a prefix value, and the integer in the - # lower nibble tells us how many bytes were used to encode the - # length data following immediately after this prefix. - - set len_length [expr {$length & 0x7f}] - - if {[string length $data] < $len_length} { - return -code error \ - "length information invalid, not enough octets left" - } - - asnGetBytes data $len_length lengthBytes - - switch $len_length { - 1 { - # Efficiently coded data will not go through this - # path, as small length values can be coded directly, - # without a prefix. - - binary scan $lengthBytes c length - set length [expr {($length + 0x100) % 0x100}] - } - 2 { binary scan $lengthBytes S length - set length [expr {($length + 0x10000) % 0x10000}] - } - 3 { binary scan \x00$lengthBytes I length - set length [expr {($length + 0x1000000) % 0x1000000}] - } - 4 { binary scan $lengthBytes I length - set length [expr {(wide($length) + 0x100000000) % 0x100000000}] - } - default { - binary scan $lengthBytes H* hexstr - # skip leading zeros which are allowed by BER - set hexlen [string trimleft $hexstr 0] - # check if it fits into a 64-bit signed integer - if {[string length $hexlen] > 16} { - return -code error -errorcode {ARITH IOVERFLOW - {Length value too large for normal use, try asnGetBigLength}} \ - "Length value to large" - } elseif { [string length $hexlen] == 16 \ - && ([string index $hexlen 0] & 0x8)} { - # check most significant bit, if set we need bignum - return -code error -errorcode {ARITH IOVERFLOW - {Length value too large for normal use, try asnGetBigLength}} \ - "Length value to large" - } else { - scan $hexstr "%lx" length - } - } - } - } - return -} - -} - -#----------------------------------------------------------------------------- -# asnRetag: Remove an explicit tag with the real newTag -# -#----------------------------------------------------------------------------- -proc ::asn::asnRetag {data_var newTag} { - upvar 1 $data_var data - set tag "" - set type "" - set len [asnPeekTag data tag type dummy] - asnGetBytes data $len tagbytes - set data [binary format c* $newTag]$data -} - -#----------------------------------------------------------------------------- -# asnGetBytes : Retrieve a block of 'length' bytes from the data. -#----------------------------------------------------------------------------- - -proc ::asn::asnGetBytes {data_var length bytes_var} { - upvar 1 $data_var data $bytes_var bytes - - incr length -1 - set bytes [string range $data 0 $length] - incr length - set data [string range $data $length end] - - return -} - -#----------------------------------------------------------------------------- -# asnPeekTag : Decode the tag value -#----------------------------------------------------------------------------- - -proc ::asn::asnPeekTag {data_var tag_var tagtype_var constr_var} { - upvar 1 $data_var data $tag_var tag $tagtype_var tagtype $constr_var constr - - set type 0 - set offset 0 - asnPeekByte data type $offset - # check if we have a simple tag, < 31, which fits in one byte - - set tval [expr {$type & 0x1f}] - if {$tval == 0x1f} { - # long tag, max 64-bit with Tcl 8.4, unlimited with 8.5 bignum - asnPeekByte data tagbyte [incr offset] - set tval [expr {wide($tagbyte & 0x7f)}] - while {($tagbyte & 0x80)} { - asnPeekByte data tagbyte [incr offset] - set tval [expr {($tval << 7) + ($tagbyte & 0x7f)}] - } - } - - set tagtype [lindex {UNIVERSAL APPLICATION CONTEXT PRIVATE} \ - [expr {($type & 0xc0) >>6}]] - set tag $tval - set constr [expr {($type & 0x20) > 0}] - - return [incr offset] -} - -#----------------------------------------------------------------------------- -# asnTag : Build a tag value -#----------------------------------------------------------------------------- - -proc ::asn::asnTag {tagnumber {class UNIVERSAL} {tagstyle P}} { - set first 0 - if {$tagnumber < 31} { - # encode everything in one byte - set first $tagnumber - set bytes [list] - } else { - # multi-byte tag - set first 31 - set bytes [list [expr {$tagnumber & 0x7f}]] - set tagnumber [expr {$tagnumber >> 7}] - while {$tagnumber > 0} { - lappend bytes [expr {($tagnumber & 0x7f)+0x80}] - set tagnumber [expr {$tagnumber >>7}] - } - - } - - if {$tagstyle eq "C" || $tagstyle == 1 } {incr first 32} - switch -glob -- $class { - U* { ;# UNIVERSAL } - A* { incr first 64 ;# APPLICATION } - C* { incr first 128 ;# CONTEXT } - P* { incr first 192 ;# PRIVATE } - default { - return -code error "Unknown tag class \"$class\"" - } - } - if {[llength $bytes] > 0} { - # long tag - set rbytes [list] - for {set i [expr {[llength $bytes]-1}]} {$i >= 0} {incr i -1} { - lappend rbytes [lindex $bytes $i] - } - return [binary format cc* $first $rbytes ] - } - return [binary format c $first] -} - - - -#----------------------------------------------------------------------------- -# asnGetBigLength : Retrieve a length that can not be represented in 63-bit -#----------------------------------------------------------------------------- - -proc ::asn::asnGetBigLength {data_var biglength_var} { - - # Does any real world code really need this? - # If we encounter this, we are doomed to fail anyway, - # (there would be an Exabyte inside the data_var, ) - # - # So i implement it just for completeness. - # - package require math::bignum - - upvar 1 $data_var data $biglength_var length - - asnGetByte data length - if {$length == 0x080} { - return -code error "Indefinite length BER encoding not yet supported" - } - if {$length > 0x080} { - # The retrieved byte is a prefix value, and the integer in the - # lower nibble tells us how many bytes were used to encode the - # length data following immediately after this prefix. - - set len_length [expr {$length & 0x7f}] - - if {[string length $data] < $len_length} { - return -code error \ - "length information invalid, not enough octets left" - } - - asnGetBytes data $len_length lengthBytes - binary scan $lengthBytes H* hexlen - set length [math::bignum::fromstr $hexlen 16] - } - return -} - -#----------------------------------------------------------------------------- -# asnGetInteger : Retrieve integer. -#----------------------------------------------------------------------------- - -proc ::asn::asnGetInteger {data_var int_var} { - # Tag is 0x02. - - upvar 1 $data_var data $int_var int - - asnGetByte data tag - - if {$tag != 0x02} { - return -code error \ - [format "Expected Integer (0x02), but got %02x" $tag] - } - - asnGetLength data len - asnGetBytes data $len integerBytes - - set int ? - - switch $len { - 1 { binary scan $integerBytes c int } - 2 { binary scan $integerBytes S int } - 3 { - # check for negative int and pad - scan [string index $integerBytes 0] %c byte - if {$byte & 128} { - binary scan \xff$integerBytes I int - } else { - binary scan \x00$integerBytes I int - } - } - 4 { binary scan $integerBytes I int } - 5 - - 6 - - 7 - - 8 { - # check for negative int and pad - scan [string index $integerBytes 0] %c byte - if {$byte & 128} { - set pad [string repeat \xff [expr {8-$len}]] - } else { - set pad [string repeat \x00 [expr {8-$len}]] - } - binary scan $pad$integerBytes W int - } - default { - # Too long, or prefix coding was used. - return -code error "length information too long" - } - } - return -} - -#----------------------------------------------------------------------------- -# asnGetBigInteger : Retrieve a big integer. -#----------------------------------------------------------------------------- - -proc ::asn::asnGetBigInteger {data_var bignum_var} { - # require math::bignum only if it is used - package require math::bignum - - # Tag is 0x02. We expect that the length of the integer is coded with - # maximal efficiency, i.e. without a prefix 0x81 prefix. If a prefix - # is used this decoder will fail. - - upvar $data_var data $bignum_var bignum - - asnGetByte data tag - - if {$tag != 0x02} { - return -code error \ - [format "Expected Integer (0x02), but got %02x" $tag] - } - - asnGetLength data len - asnGetBytes data $len integerBytes - - binary scan [string index $integerBytes 0] H* hex_head - set head [expr 0x$hex_head] - set replacement_head [expr {$head & 0x7f}] - set integerBytes [string replace $integerBytes 0 0 [format %c $replacement_head]] - - binary scan $integerBytes H* hex - - set bignum [math::bignum::fromstr $hex 16] - - if {($head >> 7) && 1} { - set bigsub [math::bignum::pow [::math::bignum::fromstr 2] [::math::bignum::fromstr [expr {($len * 8) - 1}]]] - set bignum [math::bignum::sub $bignum $bigsub] - } - - return $bignum -} - - - - -#----------------------------------------------------------------------------- -# asnGetEnumeration : Retrieve an enumeration id -#----------------------------------------------------------------------------- - -proc ::asn::asnGetEnumeration {data_var enum_var} { - # This is like 'asnGetInteger', except for a different tag. - - upvar 1 $data_var data $enum_var enum - - asnGetByte data tag - - if {$tag != 0x0a} { - return -code error \ - [format "Expected Enumeration (0x0a), but got %02x" $tag] - } - - asnGetLength data len - asnGetBytes data $len integerBytes - set enum ? - - switch $len { - 1 { binary scan $integerBytes c enum } - 2 { binary scan $integerBytes S enum } - 3 { binary scan \x00$integerBytes I enum } - 4 { binary scan $integerBytes I enum } - default { - return -code error "length information too long" - } - } - return -} - -#----------------------------------------------------------------------------- -# asnGetOctetString : Retrieve arbitrary string. -#----------------------------------------------------------------------------- - -proc ::asn::asnGetOctetString {data_var string_var} { - # Here we need the full decoder for length data. - - upvar 1 $data_var data $string_var string - - asnGetByte data tag - if {$tag != 0x04} { - return -code error \ - [format "Expected Octet String (0x04), but got %02x" $tag] - } - asnGetLength data length - asnGetBytes data $length temp - set string $temp - return -} - -#----------------------------------------------------------------------------- -# asnGetSequence : Retrieve Sequence data for further decoding. -#----------------------------------------------------------------------------- - -proc ::asn::asnGetSequence {data_var sequence_var} { - # Here we need the full decoder for length data. - - upvar 1 $data_var data $sequence_var sequence - - asnGetByte data tag - if {$tag != 0x030} { - return -code error \ - [format "Expected Sequence (0x30), but got %02x" $tag] - } - asnGetLength data length - asnGetBytes data $length temp - set sequence $temp - return -} - -#----------------------------------------------------------------------------- -# asnGetSet : Retrieve Set data for further decoding. -#----------------------------------------------------------------------------- - -proc ::asn::asnGetSet {data_var set_var} { - # Here we need the full decoder for length data. - - upvar 1 $data_var data $set_var set - - asnGetByte data tag - if {$tag != 0x031} { - return -code error \ - [format "Expected Set (0x31), but got %02x" $tag] - } - asnGetLength data length - asnGetBytes data $length temp - set set $temp - return -} - -#----------------------------------------------------------------------------- -# asnGetApplication -#----------------------------------------------------------------------------- - -proc ::asn::asnGetApplication {data_var appNumber_var {content_var {}} {encodingType_var {}} } { - upvar 1 $data_var data $appNumber_var appNumber - - asnGetByte data tag - asnGetLength data length - - if {($tag & 0xC0) != 0x40} { - return -code error \ - [format "Expected Application, but got %02x" $tag] - } - if {$encodingType_var != {}} { - upvar 1 $encodingType_var encodingType - set encodingType [expr {($tag & 0x20) > 0}] - } - set appNumber [expr {$tag & 0x1F}] - if {[string length $content_var]} { - upvar 1 $content_var content - asnGetBytes data $length content - } - return -} - -#----------------------------------------------------------------------------- -# asnGetBoolean: decode a boolean value -#----------------------------------------------------------------------------- - -proc asn::asnGetBoolean {data_var bool_var} { - upvar 1 $data_var data $bool_var bool - - asnGetByte data tag - if {$tag != 0x01} { - return -code error \ - [format "Expected Boolean (0x01), but got %02x" $tag] - } - - asnGetLength data length - asnGetByte data byte - set bool [expr {$byte == 0 ? 0 : 1}] - return -} - -#----------------------------------------------------------------------------- -# asnGetUTCTime: Extract an UTC Time string from the data. Returns a string -# representing an UTC Time. -# -#----------------------------------------------------------------------------- - -proc asn::asnGetUTCTime {data_var utc_var} { - upvar 1 $data_var data $utc_var utc - - asnGetByte data tag - if {$tag != 0x17} { - return -code error \ - [format "Expected UTCTime (0x17), but got %02x" $tag] - } - - asnGetLength data length - asnGetBytes data $length bytes - - # this should be ascii, make it explicit - set bytes [encoding convertfrom ascii $bytes] - binary scan $bytes a* utc - - return -} - - -#----------------------------------------------------------------------------- -# asnGetBitString: Extract a Bit String value (a string of 0/1s) from the -# ASN.1 data. -# -#----------------------------------------------------------------------------- - -proc asn::asnGetBitString {data_var bitstring_var} { - upvar 1 $data_var data $bitstring_var bitstring - - asnGetByte data tag - if {$tag != 0x03} { - return -code error \ - [format "Expected Bit String (0x03), but got %02x" $tag] - } - - asnGetLength data length - # get the number of padding bits used at the end - asnGetByte data padding - incr length -1 - asnGetBytes data $length bytes - binary scan $bytes B* bits - - # cut off the padding bits - set bits [string range $bits 0 end-$padding] - set bitstring $bits -} - -#----------------------------------------------------------------------------- -# asnGetObjectIdentifier: Decode an ASN.1 Object Identifier (OID) into -# a Tcl list of integers. -#----------------------------------------------------------------------------- - -proc asn::asnGetObjectIdentifier {data_var oid_var} { - upvar 1 $data_var data $oid_var oid - - asnGetByte data tag - if {$tag != 0x06} { - return -code error \ - [format "Expected Object Identifier (0x06), but got %02x" $tag] - } - asnGetLength data length - - # the first byte encodes the OID parts in position 0 and 1 - asnGetByte data val - set oid [expr {$val / 40}] - lappend oid [expr {$val % 40}] - incr length -1 - - # the next bytes encode the remaining parts of the OID - set bytes [list] - set incomplete 0 - while {$length} { - asnGetByte data octet - incr length -1 - if {$octet < 128} { - set oidval $octet - set mult 128 - foreach byte $bytes { - if {$byte != {}} { - incr oidval [expr {$mult*$byte}] - set mult [expr {$mult*128}] - } - } - lappend oid $oidval - set bytes [list] - set incomplete 0 - } else { - set byte [expr {$octet-128}] - set bytes [concat [list $byte] $bytes] - set incomplete 1 - } - } - if {$incomplete} { - return -code error "OID Data is incomplete, not enough octets." - } - return -} - -#----------------------------------------------------------------------------- -# asnGetContext: Decode an explicit context tag -# -#----------------------------------------------------------------------------- - -proc ::asn::asnGetContext {data_var contextNumber_var {content_var {}} {encodingType_var {}}} { - upvar 1 $data_var data $contextNumber_var contextNumber - - asnGetByte data tag - asnGetLength data length - - if {($tag & 0xC0) != 0x80} { - return -code error \ - [format "Expected Context, but got %02x" $tag] - } - if {$encodingType_var != {}} { - upvar 1 $encodingType_var encodingType - set encodingType [expr {($tag & 0x20) > 0}] - } - set contextNumber [expr {$tag & 0x1F}] - if {[string length $content_var]} { - upvar 1 $content_var content - asnGetBytes data $length content - } - return -} - - -#----------------------------------------------------------------------------- -# asnGetNumericString: Decode a Numeric String from the data -#----------------------------------------------------------------------------- - -proc ::asn::asnGetNumericString {data_var print_var} { - upvar 1 $data_var data $print_var print - - asnGetByte data tag - if {$tag != 0x12} { - return -code error \ - [format "Expected Numeric String (0x12), but got %02x" $tag] - } - asnGetLength data length - asnGetBytes data $length string - set print [encoding convertfrom ascii $string] - return -} - -#----------------------------------------------------------------------------- -# asnGetPrintableString: Decode a Printable String from the data -#----------------------------------------------------------------------------- - -proc ::asn::asnGetPrintableString {data_var print_var} { - upvar 1 $data_var data $print_var print - - asnGetByte data tag - if {$tag != 0x13} { - return -code error \ - [format "Expected Printable String (0x13), but got %02x" $tag] - } - asnGetLength data length - asnGetBytes data $length string - set print [encoding convertfrom ascii $string] - return -} - -#----------------------------------------------------------------------------- -# asnGetIA5String: Decode a IA5(ASCII) String from the data -#----------------------------------------------------------------------------- - -proc ::asn::asnGetIA5String {data_var print_var} { - upvar 1 $data_var data $print_var print - - asnGetByte data tag - if {$tag != 0x16} { - return -code error \ - [format "Expected IA5 String (0x16), but got %02x" $tag] - } - asnGetLength data length - asnGetBytes data $length string - set print [encoding convertfrom ascii $string] - return -} -#------------------------------------------------------------------------ -# asnGetBMPString: Decode Basic Multiningval (UCS2 string) from data -#------------------------------------------------------------------------ -proc asn::asnGetBMPString {data_var print_var} { - upvar 1 $data_var data $print_var print - asnGetByte data tag - if {$tag != 0x1e} { - return -code error \ - [format "Expected BMP String (0x1e), but got %02x" $tag] - } - asnGetLength data length - asnGetBytes data $length string - if {$::tcl_platform(byteOrder) eq "littleEndian"} { - set str2 "" - foreach {hi lo} [split $string ""] { - append str2 $lo $hi - } - } else { - set str2 $string - } - set print [encoding convertfrom unicode $str2] - return -} -#------------------------------------------------------------------------ -# asnGetUTF8String: Decode UTF8 string from data -#------------------------------------------------------------------------ -proc asn::asnGetUTF8String {data_var print_var} { - upvar 1 $data_var data $print_var print - asnGetByte data tag - if {$tag != 0x0c} { - return -code error \ - [format "Expected UTF8 String (0x0c), but got %02x" $tag] - } - asnGetLength data length - asnGetBytes data $length string - #there should be some error checking to see if input is - #properly-formatted utf8 - set print [encoding convertfrom utf-8 $string] - - return -} -#----------------------------------------------------------------------------- -# asnGetNull: decode a NULL value -#----------------------------------------------------------------------------- - -proc ::asn::asnGetNull {data_var} { - upvar 1 $data_var data - - asnGetByte data tag - if {$tag != 0x05} { - return -code error \ - [format "Expected NULL (0x05), but got %02x" $tag] - } - - asnGetLength data length - asnGetBytes data $length bytes - - # we do not check the null data, all bytes must be 0x00 - - return -} - -#---------------------------------------------------------------------------- -# MultiType string routines -#---------------------------------------------------------------------------- - -namespace eval asn { - variable stringTypes - array set stringTypes { - 12 NumericString - 13 PrintableString - 16 IA5String - 1e BMPString - 0c UTF8String - 14 T61String - 15 VideotexString - 1a VisibleString - 1b GeneralString - 1c UniversalString - } - variable defaultStringType UTF8 -} -#--------------------------------------------------------------------------- -# asnGetString - get readable string automatically detecting its type -#--------------------------------------------------------------------------- -proc ::asn::asnGetString {data_var print_var {type_var {}}} { - variable stringTypes - upvar 1 $data_var data $print_var print - asnPeekByte data tag - set tag [format %02x $tag] - if {![info exists stringTypes($tag)]} { - return -code error "Expected one of string types, but got $tag" - } - asnGet$stringTypes($tag) data print - if {[string length $type_var]} { - upvar $type_var type - set type $stringTypes($tag) - } -} -#--------------------------------------------------------------------- -# defaultStringType - set or query default type for unrestricted strings -#--------------------------------------------------------------------- -proc ::asn::defaultStringType {{type {}}} { - variable defaultStringType - if {![string length $type]} { - return $defaultStringType - } - if {$type ne "BMP" && $type ne "UTF8"} { - return -code error "Invalid default string type. Should be one of BMP, UTF8" - } - set defaultStringType $type - return -} - -#--------------------------------------------------------------------------- -# asnString - encode readable string into most restricted type possible -#--------------------------------------------------------------------------- - -proc ::asn::asnString {string} { - variable nonPrintableChars - variable nonNumericChars - if {[string length $string]!=[string length [encoding convertto utf-8 $string]]} { - # There are non-ascii character - variable defaultStringType - return [asn${defaultStringType}String $string] - } elseif {![regexp $nonNumericChars $string]} { - return [asnNumericString $string] - } elseif {![regexp $nonPrintableChars $string]} { - return [asnPrintableString $string] - } else { - return [asnIA5String $string] - } -} - -#----------------------------------------------------------------------------- -package provide asn 0.8.5 - diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/asn/pkgIndex.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/asn/pkgIndex.tcl deleted file mode 100644 index b9fdabb8..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/asn/pkgIndex.tcl +++ /dev/null @@ -1,4 +0,0 @@ -# Tcl package index file, version 1.1 - -if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} -package ifneeded asn 0.8.5 [list source [file join $dir asn.tcl]] diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32.tcl deleted file mode 100644 index eb71c54f..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32.tcl +++ /dev/null @@ -1,182 +0,0 @@ -# -*- tcl -*- -# This code is hereby put into the public domain. -# ### ### ### ######### ######### ######### -## Overview -# Base32 encoding and decoding of small strings. -# -# Management code for switching between Tcl and C accelerated -# implementations. -# -# RCS: @(#) $Id: base32.tcl,v 1.2 2006/10/13 05:39:49 andreas_kupries Exp $ - -# @mdgen EXCLUDE: base32_c.tcl - -package require Tcl 8.5 9 - -namespace eval ::base32 {} - -# ### ### ### ######### ######### ######### -## Management of base32 std implementations. - -# ::base32::LoadAccelerator -- -# -# Loads a named implementation, if possible. -# -# Arguments: -# key Name of the implementation to load. -# -# Results: -# A boolean flag. True if the implementation -# was successfully loaded; and False otherwise. - -proc ::base32::LoadAccelerator {key} { - variable accel - set isok 0 - switch -exact -- $key { - critcl { - # Critcl implementation of base32 requires Tcl 8.4. - if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} - if {[catch {package require tcllibc}]} {return 0} - set isok [llength [info commands ::base32::critcl_encode]] - } - tcl { - variable selfdir - if {[catch {source [file join $selfdir base32_tcl.tcl]}]} {return 0} - set isok [llength [info commands ::base32::tcl_encode]] - } - default { - return -code error "invalid accelerator $key:\ - must be one of [join [KnownImplementations] {, }]" - } - } - set accel($key) $isok - return $isok -} - -# ::base32::SwitchTo -- -# -# Activates a loaded named implementation. -# -# Arguments: -# key Name of the implementation to activate. -# -# Results: -# None. - -proc ::base32::SwitchTo {key} { - variable accel - variable loaded - - if {[string equal $key $loaded]} { - # No change, nothing to do. - return - } elseif {![string equal $key ""]} { - # Validate the target implementation of the switch. - - if {![info exists accel($key)]} { - return -code error "Unable to activate unknown implementation \"$key\"" - } elseif {![info exists accel($key)] || !$accel($key)} { - return -code error "Unable to activate missing implementation \"$key\"" - } - } - - # Deactivate the previous implementation, if there was any. - - if {![string equal $loaded ""]} { - foreach c {encode decode} { - rename ::base32::$c ::base32::${loaded}_$c - } - } - - # Activate the new implementation, if there is any. - - if {![string equal $key ""]} { - foreach c {encode decode} { - rename ::base32::${key}_$c ::base32::$c - } - } - - # Remember the active implementation, for deactivation by future - # switches. - - set loaded $key - return -} - -# ::base32::Implementations -- -# -# Determines which implementations are -# present, i.e. loaded. -# -# Arguments: -# None. -# -# Results: -# A list of implementation keys. - -proc ::base32::Implementations {} { - variable accel - set res {} - foreach n [array names accel] { - if {!$accel($n)} continue - lappend res $n - } - return $res -} - -# ::base32::KnownImplementations -- -# -# Determines which implementations are known -# as possible implementations. -# -# Arguments: -# None. -# -# Results: -# A list of implementation keys. In the order -# of preference, most prefered first. - -proc ::base32::KnownImplementations {} { - return {critcl tcl} -} - -proc ::base32::Names {} { - return { - critcl {tcllibc based} - tcl {pure Tcl} - } -} - -# ### ### ### ######### ######### ######### -## Initialization: Data structures. - -namespace eval ::base32 { - variable selfdir [file dirname [info script]] - variable loaded {} - - variable accel - array set accel {tcl 0 critcl 0} -} - -# ### ### ### ######### ######### ######### -## Initialization: Choose an implementation, -## most prefered first. Loads only one of the -## possible implementations. And activates it. - -namespace eval ::base32 { - variable e - foreach e [KnownImplementations] { - if {[LoadAccelerator $e]} { - SwitchTo $e - break - } - } - unset e - - namespace export encode decode -} - -# ### ### ### ######### ######### ######### -## Ready - -package provide base32 0.1 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32_c.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32_c.tcl deleted file mode 100644 index 3741c3fd..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32_c.tcl +++ /dev/null @@ -1,254 +0,0 @@ -# base32c.tcl -- -# -# Implementation of a base32 (std) de/encoder for Tcl. -# -# Public domain -# -# RCS: @(#) $Id: base32_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $ - -package require critcl -package require Tcl 8.5 9 - -namespace eval ::base32 { - # Supporting code for the main command. - catch { - #critcl::cheaders -g - #critcl::debug memory symbols - } - - # Main commands, encoder & decoder - - critcl::ccommand critcl_encode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_encode string - */ - - unsigned char* buf; - Tcl_Size nbuf; - - unsigned char* out; - unsigned char* at; - int nout; - - /* - * The array used for encoding - */ /* 123456789 123456789 123456789 12 */ - static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"; - -#define USAGEE "bitstring" - - if (objc != 2) { - Tcl_WrongNumArgs (interp, 1, objv, USAGEE); /* OK tcl9 */ - return TCL_ERROR; - } - - buf = Tcl_GetBytesFromObj (interp, objv[1], &nbuf); /* OK tcl9 */ - if (buf == NULL) return TCL_ERROR; - nout = ((nbuf+4)/5)*8; - out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); - - for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) { - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; - *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; - *(at++) = map [ 0x1f & (buf[3]>>2) ]; - *(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ]; - *(at++) = map [ 0x1f & (buf[4]) ]; - } - if (nbuf > 0) { - /* Process partials at end. */ - switch (nbuf) { - case 1: - /* |01234567| 2, padding 6 - * xxxxx - * xxx 00 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & (buf[0]<<2) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 2: /* x3/=4 */ - /* |01234567|01234567| 4, padding 4 - * xxxxx - * xxx xx - * xxxxx - * x 0000 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & (buf[1]<<4) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 3: - /* |01234567|01234567|01234567| 5, padding 3 - * xxxxx - * xxx xx - * xxxxx - * x xxxx - * xxxx 0 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; - *(at++) = map [ 0x1f & (buf[2]<<1) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 4: - /* |01234567|01234567|01234567|012334567| 7, padding 1 - * xxxxx - * xxx xx - * xxxxx - * x xxxx - * xxxx - * xxxxx - * xxxx 0 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; - *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; - *(at++) = map [ 0x1f & (buf[3]>>2) ]; - *(at++) = map [ 0x1f & (buf[3]<<3) ]; - *(at++) = '='; - break; - } - } - - Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); /* OK tcl9 */ - Tcl_Free ((char*) out); - return TCL_OK; - } - - - critcl::ccommand critcl_decode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_decode estring - */ - - unsigned char* buf; - Tcl_Size nbuf; - - unsigned char* out; - unsigned char* at; - unsigned char x [8]; - int nout; - - int i, j, a, pad, nx; - - /* - * An array for translating single base-32 characters into a value. - * Disallowed input characters have a value of 64. Upper and lower - * case is the same. Only 128 chars, as everything above char(127) - * is 64. - */ - static const char map [] = { - /* \00 */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - /* DLE */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - /* SPC */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - /* '0' */ 64, 64, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, - /* '@' */ 64, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, - /* 'P' */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64, - /* '`' */ 64, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, - /* 'p' */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64 - }; - -#define USAGED "estring" - - if (objc != 2) { - Tcl_WrongNumArgs (interp, 1, objv, USAGED); /* OK tcl9 */ - return TCL_ERROR; - } - - buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); /* OK tcl9 */ - - if (nbuf % 8) { - Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); /* OK tcl9 */ - return TCL_ERROR; - } - - nout = (nbuf/8)*5 *TCL_UTF_MAX; - out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); - -#define HIGH(x) (((x) & 0x80) != 0) -#define BADC(x) ((x) == 64) -#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)])) - - for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){ - for (j=0; j < 8; j++){ - a = buf [j]; - - if (a == '=') { - x[j] = 0; - pad++; - continue; - } else if (pad) { - char msg [120]; - sprintf (msg, - "Invalid character at index %d: \"=\" (padding found in the middle of the input)", - j-1); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ - return TCL_ERROR; - } - - if (BADCHAR (a,j)) { - char msg [100]; - sprintf (msg,"Invalid character at index %d: \"%c\"",j,a); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ - return TCL_ERROR; - } - } - - *(at++) = (x[0]<<3) | (x[1]>>2) ; - *(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4); - *(at++) = (x[3]<<4) | (x[4]>>1) ; - *(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3); - *(at++) = (x[6]<<5) | x[7] ; - } - - if (pad) { - if (pad == 1) { - at -= 1; - } else if (pad == 3) { - at -= 2; - } else if (pad == 4) { - at -= 3; - } else if (pad == 6) { - at -= 4; - } else { - char msg [100]; - sprintf (msg,"Invalid padding of length %d",pad); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ - return TCL_ERROR; - } - } - - Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); /* OK tcl9 */ - Tcl_Free ((char*) out); - return TCL_OK; - } -} - -# ### ### ### ######### ######### ######### -## Ready diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32_tcl.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32_tcl.tcl deleted file mode 100644 index a8d50335..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32_tcl.tcl +++ /dev/null @@ -1,73 +0,0 @@ -# -*- tcl -*- -# This code is hereby put into the public domain. -# ### ### ### ######### ######### ######### -## Overview -# Base32 encoding and decoding of small strings. - -# ### ### ### ######### ######### ######### -## Notes - -# A binary string is split into groups of 5 bits (2^5 == 32), and each -# group is converted into a printable character as is specified in RFC -# 3548. - -# ### ### ### ######### ######### ######### -## Requisites - -package require base32::core -namespace eval ::base32 {} - -# ### ### ### ######### ######### ######### -## API & Implementation - -proc ::base32::tcl_encode {bitstring} { - variable forward - - binary scan $bitstring B* bits - set len [string length $bits] - set rem [expr {$len % 5}] - if {$rem} {append bits =/$rem} - #puts "($bitstring) => <$bits>" - - return [string map $forward $bits] -} - -proc ::base32::tcl_decode {estring} { - variable backward - variable invalid - - if {![core::valid $estring $invalid msg]} { - return -code error $msg - } - #puts "I<$estring>" - #puts "M<[string map $backward $estring]>" - - return [binary format B* [string map $backward [string toupper $estring]]] -} - -# ### ### ### ######### ######### ######### -## Data structures - -namespace eval ::base32 { - # Initialize the maps - variable forward - variable backward - variable invalid - - core::define { - 0 A 9 J 18 S 27 3 - 1 B 10 K 19 T 28 4 - 2 C 11 L 20 U 29 5 - 3 D 12 M 21 V 30 6 - 4 E 13 N 22 W 31 7 - 5 F 14 O 23 X - 6 G 15 P 24 Y - 7 H 16 Q 25 Z - 8 I 17 R 26 2 - } forward backward invalid ; # {} - # puts ///$forward/// - # puts ///$backward/// -} - -# ### ### ### ######### ######### ######### -## Ok diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32core.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32core.tcl deleted file mode 100644 index dd18e5a2..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32core.tcl +++ /dev/null @@ -1,134 +0,0 @@ -# -*- tcl -*- -# This code is hereby put into the public domain. -# ### ### ### ######### ######### ######### -#= Overview - -# Fundamental handling of base32 conversion tables. Expansion of a -# basic mapping into a full mapping and its inverse mapping. - -# ### ### ### ######### ######### ######### -#= Requisites - -namespace eval ::base32::core {} - -# ### ### ### ######### ######### ######### -#= API & Implementation - -proc ::base32::core::define {map fv bv iv} { - variable bits - upvar 1 $fv forward $bv backward $iv invalid - - # bytes - bits - padding - tail | bits - padding - tail - # 0 - 0 - "" - "xxxxxxxx" | 0 - "" - "" - # 1 - 8 - "======" - "xx======" | 3 - "======" - "x======" - # 2 - 16 - "====" - "xxxx====" | 1 - "====" - "x====" - # 3 - 24 - "===" - "xxxxx===" | 4 - "===" - "x===" - # 4 - 32 - "=" - "xxxxxxx=" | 2 - "=" - "x=" - - array set _ $bits - - set invalid "\[^=" - set forward {} - set btmp {} - - foreach {code char} $map { - set b $_($code) - - append invalid [string tolower $char][string toupper $char] - - # 5 bit remainder - lappend forward $b $char - lappend btmp [list $char $b] - - # 4 bit remainder - if {$code%2} continue - set b [string range $b 0 end-1] - lappend forward ${b}=/4 ${char}=== - lappend btmp [list ${char}=== $b] - - # 3 bit remainder - if {$code%4} continue - set b [string range $b 0 end-1] - lappend forward ${b}=/3 ${char}====== - lappend btmp [list ${char}====== $b] - - # 2 bit remainder - if {$code%8} continue - set b [string range $b 0 end-1] - lappend forward ${b}=/2 ${char}= - lappend btmp [list ${char}= $b] - - # 1 bit remainder - if {$code%16} continue - set b [string range $b 0 end-1] - lappend forward ${b}=/1 ${char}==== - lappend btmp [list ${char}==== $b] - } - - set backward {} - foreach item [lsort -index 0 -decreasing $btmp] { - foreach {c b} $item break - lappend backward $c $b - } - - append invalid "\]" - return -} - -proc ::base32::core::valid {estring pattern mv} { - upvar 1 $mv message - - if {[string length $estring] % 8} { - set message "Length is not a multiple of 8" - return 0 - } elseif {[regexp -indices $pattern $estring where]} { - foreach {s e} $where break - set message "Invalid character at index $s: \"[string index $estring $s]\"" - return 0 - } elseif {[regexp {(=+)$} $estring -> pad]} { - set padlen [string length $pad] - if { - ($padlen != 6) && - ($padlen != 4) && - ($padlen != 3) && - ($padlen != 1) - } { - set message "Invalid padding of length $padlen" - return 0 - } - } - - # Remove the brackets and ^= from the pattern, to construct the - # class of valid characters which must not follow the padding. - - set badp "=\[[string range $pattern 3 end-1]\]" - if {[regexp -indices $badp $estring where]} { - foreach {s e} $where break - set message "Invalid character at index $s: \"[string index $estring $s]\" (padding found in the middle of the input)" - return 0 - } - return 1 -} - -# ### ### ### ######### ######### ######### -## Data structures - -namespace eval ::base32::core { - namespace export define valid - - variable bits { - 0 00000 1 00001 2 00010 3 00011 - 4 00100 5 00101 6 00110 7 00111 - 8 01000 9 01001 10 01010 11 01011 - 12 01100 13 01101 14 01110 15 01111 - 16 10000 17 10001 18 10010 19 10011 - 20 10100 21 10101 22 10110 23 10111 - 24 11000 25 11001 26 11010 27 11011 - 28 11100 29 11101 30 11110 31 11111 - } -} - -# ### ### ### ######### ######### ######### -#= Registration - -package provide base32::core 0.2 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex.tcl deleted file mode 100644 index c270f6a0..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex.tcl +++ /dev/null @@ -1,182 +0,0 @@ -# -*- tcl -*- -# This code is hereby put into the public domain. -# ### ### ### ######### ######### ######### -## Overview -# Base32 encoding and decoding of small strings. -# -# Management code for switching between Tcl and C accelerated -# implementations. -# -# RCS: @(#) $Id: base32hex.tcl,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $ - -# @mdgen EXCLUDE: base32hex_c.tcl - -package require Tcl 8.5 9 - -namespace eval ::base32::hex {} - -# ### ### ### ######### ######### ######### -## Management of base32 std implementations. - -# ::base32::hex::LoadAccelerator -- -# -# Loads a named implementation, if possible. -# -# Arguments: -# key Name of the implementation to load. -# -# Results: -# A boolean flag. True if the implementation -# was successfully loaded; and False otherwise. - -proc ::base32::hex::LoadAccelerator {key} { - variable accel - set isok 0 - switch -exact -- $key { - critcl { - # Critcl implementation of base32 requires Tcl 8.4. - if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} - if {[catch {package require tcllibc}]} {return 0} - set isok [llength [info commands ::base32::hex::critcl_encode]] - } - tcl { - variable selfdir - if {[catch {source [file join $selfdir base32hex_tcl.tcl]}]} {return 0} - set isok [llength [info commands ::base32::hex::tcl_encode]] - } - default { - return -code error "invalid accelerator $key:\ - must be one of [join [KnownImplementations] {, }]" - } - } - set accel($key) $isok - return $isok -} - -# ::base32::hex::SwitchTo -- -# -# Activates a loaded named implementation. -# -# Arguments: -# key Name of the implementation to activate. -# -# Results: -# None. - -proc ::base32::hex::SwitchTo {key} { - variable accel - variable loaded - - if {[string equal $key $loaded]} { - # No change, nothing to do. - return - } elseif {![string equal $key ""]} { - # Validate the target implementation of the switch. - - if {![info exists accel($key)]} { - return -code error "Unable to activate unknown implementation \"$key\"" - } elseif {![info exists accel($key)] || !$accel($key)} { - return -code error "Unable to activate missing implementation \"$key\"" - } - } - - # Deactivate the previous implementation, if there was any. - - if {![string equal $loaded ""]} { - foreach c {encode decode} { - rename ::base32::hex::$c ::base32::hex::${loaded}_$c - } - } - - # Activate the new implementation, if there is any. - - if {![string equal $key ""]} { - foreach c {encode decode} { - rename ::base32::hex::${key}_$c ::base32::hex::$c - } - } - - # Remember the active implementation, for deactivation by future - # switches. - - set loaded $key - return -} - -# ::base32::hex::Implementations -- -# -# Determines which implementations are -# present, i.e. loaded. -# -# Arguments: -# None. -# -# Results: -# A list of implementation keys. - -proc ::base32::hex::Implementations {} { - variable accel - set res {} - foreach n [array names accel] { - if {!$accel($n)} continue - lappend res $n - } - return $res -} - -# ::base32::hex::KnownImplementations -- -# -# Determines which implementations are known -# as possible implementations. -# -# Arguments: -# None. -# -# Results: -# A list of implementation keys. In the order -# of preference, most prefered first. - -proc ::base32::hex::KnownImplementations {} { - return {critcl tcl} -} - -proc ::base32::hex::Names {} { - return { - critcl {tcllibc based} - tcl {pure Tcl} - } -} - -# ### ### ### ######### ######### ######### -## Initialization: Data structures. - -namespace eval ::base32::hex { - variable selfdir [file dirname [info script]] - variable loaded {} - - variable accel - array set accel {tcl 0 critcl 0} -} - -# ### ### ### ######### ######### ######### -## Initialization: Choose an implementation, -## most prefered first. Loads only one of the -## possible implementations. And activates it. - -namespace eval ::base32::hex { - variable e - foreach e [KnownImplementations] { - if {[LoadAccelerator $e]} { - SwitchTo $e - break - } - } - unset e - - namespace export encode decode -} - -# ### ### ### ######### ######### ######### -## Ready - -package provide base32::hex 0.2 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex_c.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex_c.tcl deleted file mode 100644 index 20e50021..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex_c.tcl +++ /dev/null @@ -1,254 +0,0 @@ -# base32hexc.tcl -- -# -# Implementation of a base32 (extended hex) de/encoder for Tcl. -# -# Public domain -# -# RCS: @(#) $Id: base32hex_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $ - -package require critcl -package require Tcl 8.5 9 - -namespace eval ::base32::hex { - # Supporting code for the main command. - catch { - #critcl::cheaders -g - #critcl::debug memory symbols - } - - # Main commands, encoder & decoder - - critcl::ccommand critcl_encode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_encode string - */ - - unsigned char* buf; - Tcl_Size nbuf; - - unsigned char* out; - unsigned char* at; - int nout; - - /* - * The array used for encoding - */ /* 123456789 123456789 123456789 12 */ - static const char map[] = "0123456789ABCDEFGHIJKLMNOPQRSTUV"; - -#define USAGEE "bitstring" - - if (objc != 2) { - Tcl_WrongNumArgs (interp, 1, objv, USAGEE); /* OK tcl9 */ - return TCL_ERROR; - } - - buf = Tcl_GetBytesFromObj (interp, objv[1], &nbuf); /* OK tcl9 */ - if (buf == NULL) return TCL_ERROR; - nout = ((nbuf+4)/5)*8; - out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); - - for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) { - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; - *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; - *(at++) = map [ 0x1f & (buf[3]>>2) ]; - *(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ]; - *(at++) = map [ 0x1f & (buf[4]) ]; - } - if (nbuf > 0) { - /* Process partials at end. */ - switch (nbuf) { - case 1: - /* |01234567| 2, padding 6 - * xxxxx - * xxx 00 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & (buf[0]<<2) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 2: /* x3/=4 */ - /* |01234567|01234567| 4, padding 4 - * xxxxx - * xxx xx - * xxxxx - * x 0000 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & (buf[1]<<4) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 3: - /* |01234567|01234567|01234567| 5, padding 3 - * xxxxx - * xxx xx - * xxxxx - * x xxxx - * xxxx 0 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; - *(at++) = map [ 0x1f & (buf[2]<<1) ]; - *(at++) = '='; - *(at++) = '='; - *(at++) = '='; - break; - case 4: - /* |01234567|01234567|01234567|012334567| 7, padding 1 - * xxxxx - * xxx xx - * xxxxx - * x xxxx - * xxxx - * xxxxx - * xxxx 0 - */ - - *(at++) = map [ (buf[0]>>3) ]; - *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; - *(at++) = map [ 0x1f & (buf[1]>>1) ]; - *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; - *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; - *(at++) = map [ 0x1f & (buf[3]>>2) ]; - *(at++) = map [ 0x1f & (buf[3]<<3) ]; - *(at++) = '='; - break; - } - } - - Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); /* OK tcl9 */ - Tcl_Free ((char*) out); - return TCL_OK; - } - - - critcl::ccommand critcl_decode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_decode estring - */ - - unsigned char* buf; - Tcl_Size nbuf; - - unsigned char* out; - unsigned char* at; - unsigned char x [8]; - int nout; - - int i, j, a, pad, nx; - - /* - * An array for translating single base-32 characters into a value. - * Disallowed input characters have a value of 64. Upper and lower - * case is the same. Only 128 chars, as everything above char(127) - * is 64. - */ - static const char map [] = { - /* \00 */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - /* DLE */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - /* SPC */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, - /* '0' */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 64, 64, 64, 64, 64, 64, - /* '@' */ 64, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, - /* 'P' */ 25, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, 64, - /* '`' */ 64, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, - /* 'p' */ 25, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, 64 - }; - -#define USAGED "estring" - - if (objc != 2) { - Tcl_WrongNumArgs (interp, 1, objv, USAGED); /* OK tcl9 */ - return TCL_ERROR; - } - - buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); /* OK tcl9 */ - - if (nbuf % 8) { - Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); /* OK tcl9 */ - return TCL_ERROR; - } - - nout = (nbuf/8)*5 *TCL_UTF_MAX; - out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); - -#define HIGH(x) (((x) & 0x80) != 0) -#define BADC(x) ((x) == 64) -#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)])) - - for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){ - for (j=0; j < 8; j++){ - a = buf [j]; - - if (a == '=') { - x[j] = 0; - pad++; - continue; - } else if (pad) { - char msg [120]; - sprintf (msg, - "Invalid character at index %d: \"=\" (padding found in the middle of the input)", - j-1); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ - return TCL_ERROR; - } - - if (BADCHAR (a,j)) { - char msg [100]; - sprintf (msg,"Invalid character at index %d: \"%c\"",j,a); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ - return TCL_ERROR; - } - } - - *(at++) = (x[0]<<3) | (x[1]>>2) ; - *(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4); - *(at++) = (x[3]<<4) | (x[4]>>1) ; - *(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3); - *(at++) = (x[6]<<5) | x[7] ; - } - - if (pad) { - if (pad == 1) { - at -= 1; - } else if (pad == 3) { - at -= 2; - } else if (pad == 4) { - at -= 3; - } else if (pad == 6) { - at -= 4; - } else { - char msg [100]; - sprintf (msg,"Invalid padding of length %d",pad); - Tcl_Free ((char*) out); - Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ - return TCL_ERROR; - } - } - - Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); /* OK tcl9 */ - Tcl_Free ((char*) out); - return TCL_OK; - } -} - -# ### ### ### ######### ######### ######### -## Ready diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex_tcl.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex_tcl.tcl deleted file mode 100644 index f406bc6d..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/base32hex_tcl.tcl +++ /dev/null @@ -1,79 +0,0 @@ -# -*- tcl -*- -# This code is hereby put into the public domain. -# ### ### ### ######### ######### ######### -## Overview -# Base32 encoding and decoding of small strings. - -# ### ### ### ######### ######### ######### -## Notes - -# A binary string is split into groups of 5 bits (2^5 == 32), and each -# group is converted into a printable character as is specified in RFC -# 3548 for the extended hex encoding. - -# ### ### ### ######### ######### ######### -## Requisites - -package require base32::core -namespace eval ::base32::hex {} - -# ### ### ### ######### ######### ######### -## API & Implementation - -proc ::base32::hex::tcl_encode {bitstring} { - variable forward - - binary scan $bitstring B* bits - set len [string length $bits] - set rem [expr {$len % 5}] - if {$rem} {append bits =/$rem} - #puts "($bitstring) => <$bits>" - - return [string map $forward $bits] -} - -proc ::base32::hex::tcl_decode {estring} { - variable backward - variable invalid - - if {![core::valid $estring $invalid msg]} { - return -code error $msg - } - #puts "I<$estring>" - #puts "M<[string map $backward $estring]>" - - return [binary format B* [string map $backward [string toupper $estring]]] -} - -# ### ### ### ######### ######### ######### -## Data structures - -namespace eval ::base32::hex { - namespace eval core { - namespace import ::base32::core::define - namespace import ::base32::core::valid - } - - namespace export encode decode - # Initialize the maps - variable forward - variable backward - variable invalid - - core::define { - 0 0 9 9 18 I 27 R - 1 1 10 A 19 J 28 S - 2 2 11 B 20 K 29 T - 3 3 12 C 21 L 30 U - 4 4 13 D 22 M 31 V - 5 5 14 E 23 N - 6 6 15 F 24 O - 7 7 16 G 25 P - 8 8 17 H 26 Q - } forward backward invalid ; # {} - # puts ///$forward/// - # puts ///$backward/// -} - -# ### ### ### ######### ######### ######### -## Ok diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/pkgIndex.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/pkgIndex.tcl deleted file mode 100644 index 3edf2638..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base32/pkgIndex.tcl +++ /dev/null @@ -1,4 +0,0 @@ -if {![package vsatisfies [package provide Tcl] 8.5 9]} return -package ifneeded base32 0.1 [list source [file join $dir base32.tcl]] -package ifneeded base32::hex 0.2 [list source [file join $dir base32hex.tcl]] -package ifneeded base32::core 0.2 [list source [file join $dir base32core.tcl]] diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/ascii85.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/ascii85.tcl deleted file mode 100644 index caba1272..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/ascii85.tcl +++ /dev/null @@ -1,271 +0,0 @@ -# ascii85.tcl -- -# -# Encode/Decode ascii85 for a string -# -# Copyright (c) Emiliano Gavilan -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -package require Tcl 8.5 9 - -namespace eval ascii85 { - namespace export encode encodefile decode - # default values for encode options - variable options - array set options [list -wrapchar \n -maxlen 76] -} - -# ::ascii85::encode -- -# -# Ascii85 encode a given string. -# -# Arguments: -# args ?-maxlen maxlen? ?-wrapchar wrapchar? string -# -# If maxlen is 0, the output is not wrapped. -# -# Results: -# A Ascii85 encoded version of $string, wrapped at $maxlen characters -# by $wrapchar. - -proc ascii85::encode {args} { - variable options - - set alen [llength $args] - if {$alen != 1 && $alen != 3 && $alen != 5} { - return -code error "wrong # args:\ - should be \"[lindex [info level 0] 0]\ - ?-maxlen maxlen?\ - ?-wrapchar wrapchar? string\"" - } - - set data [lindex $args end] - array set opts [array get options] - array set opts [lrange $args 0 end-1] - foreach key [array names opts] { - if {[lsearch -exact [array names options] $key] == -1} { - return -code error "unknown option \"$key\":\ - must be -maxlen or -wrapchar" - } - } - - if {![string is integer -strict $opts(-maxlen)] - || $opts(-maxlen) < 0} { - return -code error "expected positive integer but got\ - \"$opts(-maxlen)\"" - } - - # perform this check early - if {[string length $data] == 0} { - return "" - } - - # shorten the names - set ml $opts(-maxlen) - set wc $opts(-wrapchar) - - # if maxlen is zero, don't wrap the output - if {$ml == 0} { - set wc "" - } - - set encoded {} - - binary scan $data c* X - set len [llength $X] - set rest [expr {$len % 4}] - set lastidx [expr {$len - $rest - 1}] - - foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] { - # calculate the 32 bit value - # this is an inlined version of the [encode4bytes] proc - # included here for performance reasons - set val [expr { - ( (($b1 & 0xff) << 24) - |(($b2 & 0xff) << 16) - |(($b3 & 0xff) << 8) - | ($b4 & 0xff) - ) & 0xffffffff }] - - if {$val == 0} { - # four \0 bytes encodes as "z" instead of "!!!!!" - append current "z" - } else { - # no magic numbers here. - # 52200625 -> 85 ** 4 - # 614125 -> 85 ** 3 - # 7225 -> 85 ** 2 - append current [binary format ccccc \ - [expr { ( $val / 52200625) + 33 }] \ - [expr { (($val % 52200625) / 614125) + 33 }] \ - [expr { (($val % 614125) / 7225) + 33 }] \ - [expr { (($val % 7225) / 85) + 33 }] \ - [expr { ( $val % 85) + 33 }]] - } - - if {[string length $current] >= $ml} { - append encoded [string range $current 0 [expr {$ml - 1}]] $wc - set current [string range $current $ml end] - } - } - - if { $rest } { - # there are remaining bytes. - # pad with \0 and encode not using the "z" convention. - # finally, add ($rest + 1) chars. - set val 0 - foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break - append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest] - } - append encoded [regsub -all -- ".{$ml}" $current "&$wc"] - - return $encoded -} - -proc ascii85::encode4bytes {b1 b2 b3 b4} { - set val [expr { - ( (($b1 & 0xff) << 24) - |(($b2 & 0xff) << 16) - |(($b3 & 0xff) << 8) - | ($b4 & 0xff) - ) & 0xffffffff }] - return [binary format ccccc \ - [expr { ( $val / 52200625) + 33 }] \ - [expr { (($val % 52200625) / 614125) + 33 }] \ - [expr { (($val % 614125) / 7225) + 33 }] \ - [expr { (($val % 7225) / 85) + 33 }] \ - [expr { ( $val % 85) + 33 }]] -} - -# ::ascii85::encodefile -- -# -# Ascii85 encode the contents of a file using default values -# for maxlen and wrapchar parameters. -# -# Arguments: -# fname The name of the file to encode. -# -# Results: -# An Ascii85 encoded version of the contents of the file. -# This is a convenience command - -proc ascii85::encodefile {fname} { - set fd [open $fname] - fconfigure $fd -encoding binary -translation binary - return [encode [read $fd]][close $fd] -} - -# ::ascii85::decode -- -# -# Ascii85 decode a given string. -# -# Arguments: -# string The string to decode. -# Leading spaces and tabs are removed, along with trailing newlines -# -# Results: -# The decoded value. - -proc ascii85::decode {data} { - # get rid of leading spaces/tabs and trailing newlines - set data [string map [list \n {} \t {} { } {}] $data] - set len [string length $data] - - # perform this ckeck early - if {! $len} { - return "" - } - - set decoded {} - set count 0 - set group [list] - binary scan $data c* X - - foreach char $X { - # we must check that every char is in the allowed range - if {$char < 33 || $char > 117 } { - # "z" is an exception - if {$char == 122} { - if {$count == 0} { - # if a "z" char appears at the beggining of a group, - # it decodes as four null bytes - append decoded \x00\x00\x00\x00 - continue - } else { - # if not, is an error - return -code error \ - "error decoding data: \"z\" char misplaced" - } - } - # char is not in range and not a "z" at the beggining of a group - return -code error \ - "error decoding data: chars outside the allowed range" - } - - lappend group $char - incr count - if {$count == 5} { - # this is an inlined version of the [decode5chars] proc - # included here for performance reasons - set val [expr { - ([lindex $group 0] - 33) * wide(52200625) + - ([lindex $group 1] - 33) * 614125 + - ([lindex $group 2] - 33) * 7225 + - ([lindex $group 3] - 33) * 85 + - ([lindex $group 4] - 33) }] - if {$val > 0xffffffff} { - return -code error "error decoding data: decoded group overflow" - } else { - append decoded [binary format I $val] - incr count -5 - set group [list] - } - } - } - - set len [llength $group] - switch -- $len { - 0 { - # all input has been consumed - # do nothing - } - 1 { - # a single char is a condition error, there should be at least 2 - return -code error \ - "error decoding data: trailing char" - } - default { - # pad with "u"s, decode and add ($len - 1) bytes - append decoded [string range \ - [decode5chars [pad $group 5 122]] \ - 0 \ - [expr {$len - 2}]] - } - } - - return $decoded -} - -proc ascii85::decode5chars {group} { - set val [expr { - ([lindex $group 0] - 33) * wide(52200625) + - ([lindex $group 1] - 33) * 614125 + - ([lindex $group 2] - 33) * 7225 + - ([lindex $group 3] - 33) * 85 + - ([lindex $group 4] - 33) }] - if {$val > 0xffffffff} { - return -code error "error decoding data: decoded group overflow" - } - - return [binary format I $val] -} - -proc ascii85::pad {chars len padchar} { - while {[llength $chars] < $len} { - lappend chars $padchar - } - - return $chars -} - -package provide ascii85 1.1 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/base64.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/base64.tcl deleted file mode 100644 index fb32c557..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/base64.tcl +++ /dev/null @@ -1,410 +0,0 @@ -# base64.tcl -- -# -# Encode/Decode base64 for a string -# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems -# The decoder was done for exmh by Chris Garrigues -# -# Copyright (c) 1998-2000 by Ajuba Solutions. -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -# Version 1.0 implemented Base64_Encode, Base64_Decode -# Version 2.0 uses the base64 namespace -# Version 2.1 fixes various decode bugs and adds options to encode -# Version 2.2 is much faster, Tcl8.0 compatible -# Version 2.2.1 bugfixes -# Version 2.2.2 bugfixes -# Version 2.3 bugfixes and extended to support Trf -# Version 2.4.x bugfixes - -# @mdgen EXCLUDE: base64c.tcl - -package require Tcl 8.5 9 -namespace eval ::base64 { - namespace export encode decode -} - -package provide base64 2.6 - -if {[package vsatisfies [package require Tcl] 8.6 9]} { - proc ::base64::encode {args} { - binary encode base64 -maxlen 76 {*}$args - } - - proc ::base64::decode {string} { - # Tcllib is strict with respect to end of input, yet lax for - # invalid characters outside of that. - regsub -all -- {[^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/]} $string {} string - binary decode base64 -strict $string - } - - return -} - -if {![catch {package require Trf 2.0}]} { - # Trf is available, so implement the functionality provided here - # in terms of calls to Trf for speed. - - # ::base64::encode -- - # - # Base64 encode a given string. - # - # Arguments: - # args ?-maxlen maxlen? ?-wrapchar wrapchar? string - # - # If maxlen is 0, the output is not wrapped. - # - # Results: - # A Base64 encoded version of $string, wrapped at $maxlen characters - # by $wrapchar. - - proc ::base64::encode {args} { - # Set the default wrapchar and maximum line length to match - # the settings for MIME encoding (RFC 3548, RFC 2045). These - # are the settings used by Trf as well. Various RFCs allow for - # different wrapping characters and wraplengths, so these may - # be overridden by command line options. - set wrapchar "\n" - set maxlen 76 - - if { [llength $args] == 0 } { - error "wrong # args: should be \"[lindex [info level 0] 0]\ - ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" - } - - set optionStrings [list "-maxlen" "-wrapchar"] - for {set i 0} {$i < [llength $args] - 1} {incr i} { - set arg [lindex $args $i] - set index [lsearch -glob $optionStrings "${arg}*"] - if { $index == -1 } { - error "unknown option \"$arg\": must be -maxlen or -wrapchar" - } - incr i - if { $i >= [llength $args] - 1 } { - error "value for \"$arg\" missing" - } - set val [lindex $args $i] - - # The name of the variable to assign the value to is extracted - # from the list of known options, all of which have an - # associated variable of the same name as the option without - # a leading "-". The [string range] command is used to strip - # of the leading "-" from the name of the option. - # - # FRINK: nocheck - set [string range [lindex $optionStrings $index] 1 end] $val - } - - # [string is] requires Tcl8.2; this works with 8.0 too - if {[catch {expr {$maxlen % 2}}]} { - return -code error "expected integer but got \"$maxlen\"" - } elseif {$maxlen < 0} { - return -code error "expected positive integer but got \"$maxlen\"" - } - - set string [lindex $args end] - set result [::base64 -mode encode -- $string] - - # Trf's encoder implicitly uses the settings -maxlen 76, - # -wrapchar \n for its output. We may have to reflow this for - # the settings chosen by the user. A second difference is that - # Trf closes the output with the wrap char sequence, - # always. The code here doesn't. Therefore 'trimright' is - # needed in the fast cases. - - if {($maxlen == 76) && [string equal $wrapchar \n]} { - # Both maxlen and wrapchar are identical to Trf's - # settings. This is the super-fast case, because nearly - # nothing has to be done. Only thing to do is strip a - # terminating wrapchar. - set result [string trimright $result] - } elseif {$maxlen == 76} { - # wrapchar has to be different here, length is the - # same. We can use 'string map' to transform the wrap - # information. - set result [string map [list \n $wrapchar] \ - [string trimright $result]] - } elseif {$maxlen == 0} { - # Have to reflow the output to no wrapping. Another fast - # case using only 'string map'. 'trimright' is not needed - # here. - - set result [string map [list \n ""] $result] - } else { - # Have to reflow the output from 76 to the chosen maxlen, - # and possibly change the wrap sequence as well. - - # Note: After getting rid of the old wrap sequence we - # extract the relevant segments from the string without - # modifying the string. Modification, i.e. removal of the - # processed part, means 'shifting down characters in - # memory', making the algorithm O(n^2). By avoiding the - # modification we stay in O(n). - - set result [string map [list \n ""] $result] - set l [expr {[string length $result]-$maxlen}] - for {set off 0} {$off < $l} {incr off $maxlen} { - append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar - } - append res [string range $result $off end] - set result $res - } - - return $result - } - - # ::base64::decode -- - # - # Base64 decode a given string. - # - # Arguments: - # string The string to decode. Characters not in the base64 - # alphabet are ignored (e.g., newlines) - # - # Results: - # The decoded value. - - proc ::base64::decode {string} { - regsub -all {\s} $string {} string - ::base64 -mode decode -- $string - } - -} else { - # Without Trf use a pure tcl implementation - - namespace eval base64 { - variable base64 {} - variable base64_en {} - - # We create the auxiliary array base64_tmp, it will be unset later. - variable base64_tmp - variable i - - set i 0 - foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \ - a b c d e f g h i j k l m n o p q r s t u v w x y z \ - 0 1 2 3 4 5 6 7 8 9 + /} { - set base64_tmp($char) $i - lappend base64_en $char - incr i - } - - # - # Create base64 as list: to code for instance C<->3, specify - # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded - # ascii chars get a {}. we later use the fact that lindex on a - # non-existing index returns {}, and that [expr {} < 0] is true - # - - # the last ascii char is 'z' - variable char - variable len - variable val - - scan z %c len - for {set i 0} {$i <= $len} {incr i} { - set char [format %c $i] - set val {} - if {[info exists base64_tmp($char)]} { - set val $base64_tmp($char) - } else { - set val {} - } - lappend base64 $val - } - - # code the character "=" as -1; used to signal end of message - scan = %c i - set base64 [lreplace $base64 $i $i -1] - - # remove unneeded variables - unset base64_tmp i char len val - - namespace export encode decode - } - - # ::base64::encode -- - # - # Base64 encode a given string. - # - # Arguments: - # args ?-maxlen maxlen? ?-wrapchar wrapchar? string - # - # If maxlen is 0, the output is not wrapped. - # - # Results: - # A Base64 encoded version of $string, wrapped at $maxlen characters - # by $wrapchar. - - proc ::base64::encode {args} { - set base64_en $::base64::base64_en - - # Set the default wrapchar and maximum line length to match - # the settings for MIME encoding (RFC 3548, RFC 2045). These - # are the settings used by Trf as well. Various RFCs allow for - # different wrapping characters and wraplengths, so these may - # be overridden by command line options. - set wrapchar "\n" - set maxlen 76 - - if { [llength $args] == 0 } { - error "wrong # args: should be \"[lindex [info level 0] 0]\ - ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" - } - - set optionStrings [list "-maxlen" "-wrapchar"] - for {set i 0} {$i < [llength $args] - 1} {incr i} { - set arg [lindex $args $i] - set index [lsearch -glob $optionStrings "${arg}*"] - if { $index == -1 } { - error "unknown option \"$arg\": must be -maxlen or -wrapchar" - } - incr i - if { $i >= [llength $args] - 1 } { - error "value for \"$arg\" missing" - } - set val [lindex $args $i] - - # The name of the variable to assign the value to is extracted - # from the list of known options, all of which have an - # associated variable of the same name as the option without - # a leading "-". The [string range] command is used to strip - # of the leading "-" from the name of the option. - # - # FRINK: nocheck - set [string range [lindex $optionStrings $index] 1 end] $val - } - - # [string is] requires Tcl8.2; this works with 8.0 too - if {[catch {expr {$maxlen % 2}}]} { - return -code error "expected integer but got \"$maxlen\"" - } elseif {$maxlen < 0} { - return -code error "expected positive integer but got \"$maxlen\"" - } - - set string [lindex $args end] - - set result {} - set state 0 - set length 0 - - - # Process the input bytes 3-by-3 - - binary scan $string c* X - - foreach {x y z} $X { - ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] - if {$y != {}} { - ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] - if {$z != {}} { - ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] - ADD [lindex $base64_en [expr {($z & 0x3F)}]] - } else { - set state 2 - break - } - } else { - set state 1 - break - } - } - if {$state == 1} { - ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] - ADD = - ADD = - } elseif {$state == 2} { - ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] - ADD = - } - return $result - } - - proc ::base64::ADD {x} { - # The line length check is always done before appending so - # that we don't get an extra newline if the output is a - # multiple of $maxlen chars long. - - upvar 1 maxlen maxlen length length result result wrapchar wrapchar - if {$maxlen && $length >= $maxlen} { - append result $wrapchar - set length 0 - } - append result $x - incr length - return - } - - # ::base64::decode -- - # - # Base64 decode a given string. - # - # Arguments: - # string The string to decode. Characters not in the base64 - # alphabet are ignored (e.g., newlines) - # - # Results: - # The decoded value. - - proc ::base64::decode {string} { - if {[string length $string] == 0} {return ""} - - set base64 $::base64::base64 - set output "" ; # Fix for [Bug 821126] - set nums {} - - binary scan $string c* X - lappend X 61 ;# force a terminator - foreach x $X { - set bits [lindex $base64 $x] - if {$bits >= 0} { - if {[llength [lappend nums $bits]] == 4} { - foreach {v w z y} $nums break - set a [expr {($v << 2) | ($w >> 4)}] - set b [expr {(($w & 0xF) << 4) | ($z >> 2)}] - set c [expr {(($z & 0x3) << 6) | $y}] - append output [binary format ccc $a $b $c] - set nums {} - } - } elseif {$bits == -1} { - # = indicates end of data. Output whatever chars are - # left, if any. - if {![llength $nums]} break - # The encoding algorithm dictates that we can only - # have 1 or 2 padding characters. If x=={}, we must - # (*) have 12 bits of input (enough for 1 8-bit - # output). If x!={}, we have 18 bits of input (enough - # for 2 8-bit outputs). - # - # (*) If we don't then the input is broken (bug 2976290). - - foreach {v w z} $nums break - - # Bug 2976290 - if {$w == {}} { - return -code error "Not enough data to process padding" - } - - set a [expr {($v << 2) | (($w & 0x30) >> 4)}] - if {$z == {}} { - append output [binary format c $a ] - } else { - set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] - append output [binary format cc $a $b] - } - break - } else { - # RFC 2045 says that line breaks and other characters not part - # of the Base64 alphabet must be ignored, and that the decoder - # can optionally emit a warning or reject the message. We opt - # not to do so, but to just ignore the character. - continue - } - } - return $output - } -} - -# # ## ### ##### ######## ############# ##################### -return - diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/base64c.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/base64c.tcl deleted file mode 100644 index 49a88711..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/base64c.tcl +++ /dev/null @@ -1,19 +0,0 @@ -# base64c - Copyright (C) 2003 Pat Thoyts -# -# This package is a place-holder for the critcl enhanced code present in -# the tcllib base64 module. -# -# Normally this code will become part of the tcllibc library. -# - -# @sak notprovided base64c -package require critcl -package provide base64c 0.1.1 - -namespace eval ::base64c { - variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} - - critcl::ccode { - /* no code required in this file */ - } -} diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/pkgIndex.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/pkgIndex.tcl deleted file mode 100644 index 76f14d2d..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/pkgIndex.tcl +++ /dev/null @@ -1,5 +0,0 @@ -if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} -package ifneeded base64 2.6 [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 [list source [file join $dir ascii85.tcl]] diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/uuencode.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/uuencode.tcl deleted file mode 100644 index 2b2a9ee3..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/uuencode.tcl +++ /dev/null @@ -1,337 +0,0 @@ -# uuencode - Copyright (C) 2002 Pat Thoyts -# -# Provide a Tcl only implementation of uuencode and uudecode. -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- - -package require Tcl 8.5 9; # tcl minimum version - -# Try and get some compiled helper package. -if {[catch {package require tcllibc}]} { - catch {package require Trf} -} - -namespace eval ::uuencode { - namespace export encode decode uuencode uudecode -} - -proc ::uuencode::Enc {c} { - return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] -} - -proc ::uuencode::Encode {s} { - set r {} - binary scan $s c* d - foreach {c1 c2 c3} $d { - if {$c1 == {}} {set c1 0} - if {$c2 == {}} {set c2 0} - if {$c3 == {}} {set c3 0} - append r [Enc [expr {$c1 >> 2}]] - append r [Enc [expr {(($c1 << 4) & 0o060) | (($c2 >> 4) & 0o017)}]] - append r [Enc [expr {(($c2 << 2) & 0o074) | (($c3 >> 6) & 0o003)}]] - append r [Enc [expr {($c3 & 0o077)}]] - } - return $r -} - - -proc ::uuencode::Decode {s} { - if {[string length $s] == 0} {return ""} - set r {} - binary scan [pad $s] c* d - - foreach {c0 c1 c2 c3} $d { - append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF - | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]] - append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF - | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]] - append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF - | (($c3-0x20)&0x3F) & 0xFF}]] - } - return $r -} - -# ------------------------------------------------------------------------- -# C coded version of the Encode/Decode functions for base64c package. -# ------------------------------------------------------------------------- -if {[package provide critcl] != {}} { - namespace eval ::uuencode { - critcl::ccode { - #include - static unsigned char Enc(unsigned char c) { - return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; - } - } - critcl::ccommand CEncode {dummy interp objc objv} { - Tcl_Obj *inputPtr, *resultPtr; - Tcl_Size len, rlen, xtra; - unsigned char *input, *p, *r; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ - return TCL_ERROR; - } - - inputPtr = objv[1]; - input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ - if (input == NULL) return TCL_ERROR; - if ((xtra = (3 - (len % 3))) != 3) { - if (Tcl_IsShared(inputPtr)) - inputPtr = Tcl_DuplicateObj(inputPtr); - input = Tcl_SetByteArrayLength(inputPtr, len + xtra); /* OK tcl9 */ - memset(input + len, 0, xtra); - len += xtra; - } - - rlen = (len / 3) * 4; - resultPtr = Tcl_NewObj(); - r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ - memset(r, 0, rlen); - - for (p = input; p < input + len; p += 3) { - char a, b, c; - a = *p; b = *(p+1), c = *(p+2); - *r++ = Enc(a >> 2); - *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); - *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); - *r++ = Enc(c & 077); - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; - } - - critcl::ccommand CDecode {dummy interp objc objv} { - Tcl_Obj *inputPtr, *resultPtr; - Tcl_Size len, rlen, xtra; - unsigned char *input, *p, *r; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ - return TCL_ERROR; - } - - /* if input is not mod 4, extend it with nuls */ - inputPtr = objv[1]; - input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ - if (input == NULL) return TCL_ERROR; - if ((xtra = (4 - (len % 4))) != 4) { - if (Tcl_IsShared(inputPtr)) - inputPtr = Tcl_DuplicateObj(inputPtr); - input = Tcl_SetByteArrayLength(inputPtr, len + xtra); /* OK tcl9 */ - memset(input + len, 0, xtra); - len += xtra; - } - - /* output will be 1/3 smaller than input and a multiple of 3 */ - rlen = (len / 4) * 3; - resultPtr = Tcl_NewObj(); - r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ - memset(r, 0, rlen); - - for (p = input; p < input + len; p += 4) { - char a, b, c, d; - a = *p; b = *(p+1), c = *(p+2), d = *(p+3); - *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); - *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); - *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; - } - } -} - -# ------------------------------------------------------------------------- - -# Description: -# Permit more tolerant decoding of invalid input strings by padding to -# a multiple of 4 bytes with nulls. -# Result: -# Returns the input string - possibly padded with uuencoded null chars. -# -proc ::uuencode::pad {s} { - if {[set mod [expr {[string length $s] % 4}]] != 0} { - append s [string repeat "`" [expr {4 - $mod}]] - } - return $s -} - -# ------------------------------------------------------------------------- - -# If the Trf package is available then we shall use this by default but the -# Tcllib implementations are always visible if needed (ie: for testing) -if {[info commands ::uuencode::CDecode] != {}} { - # tcllib critcl package - interp alias {} ::uuencode::encode {} ::uuencode::CEncode - interp alias {} ::uuencode::decode {} ::uuencode::CDecode -} elseif {[package provide Trf] != {}} { - proc ::uuencode::encode {s} { - return [::uuencode -mode encode -- $s] - } - proc ::uuencode::decode {s} { - return [::uuencode -mode decode -- [pad $s]] - } -} else { - # pure-tcl then - interp alias {} ::uuencode::encode {} ::uuencode::Encode - interp alias {} ::uuencode::decode {} ::uuencode::Decode -} - -# ------------------------------------------------------------------------- - -proc ::uuencode::uuencode {args} { - array set opts {mode 0o0644 filename {} name {}} - set wrongargs "wrong \# args: should be\ - \"uuencode ?-name string? ?-mode octal?\ - (-file filename | ?--? string)\"" - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -f* { - if {[llength $args] < 2} { - return -code error $wrongargs - } - set opts(filename) [lindex $args 1] - set args [lreplace $args 0 0] - } - -m* { - if {[llength $args] < 2} { - return -code error $wrongargs - } - set opts(mode) [lindex $args 1] - set args [lreplace $args 0 0] - } - -n* { - if {[llength $args] < 2} { - return -code error $wrongargs - } - set opts(name) [lindex $args 1] - set args [lreplace $args 0 0] - } - -- { - set args [lreplace $args 0 0] - break - } - default { - return -code error "bad option [lindex $args 0]:\ - must be -file, -mode, or -name" - } - } - set args [lreplace $args 0 0] - } - - if {$opts(name) == {}} { - set opts(name) $opts(filename) - } - if {$opts(name) == {}} { - set opts(name) "data.dat" - } - - if {$opts(filename) != {}} { - set f [open $opts(filename) r] - fconfigure $f -translation binary - set data [read $f] - close $f - } else { - if {[llength $args] != 1} { - return -code error $wrongargs - } - set data [lindex $args 0] - } - - set r {} - append r [format "begin %o %s" $opts(mode) $opts(name)] "\n" - for {set n 0} {$n < [string length $data]} {incr n 45} { - set s [string range $data $n [expr {$n + 44}]] - append r [Enc [string length $s]] - append r [encode $s] "\n" - } - append r "`\nend" - return $r -} - -# ------------------------------------------------------------------------- -# Description: -# Perform uudecoding of a file or data. A file may contain more than one -# encoded data section so the result is a list where each element is a -# three element list of the provided filename, the suggested mode and the -# data itself. -# -proc ::uuencode::uudecode {args} { - array set opts {mode 0o0644 filename {}} - set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -f* { - if {[llength $args] < 2} { - return -code error $wrongargs - } - set opts(filename) [lindex $args 1] - set args [lreplace $args 0 0] - } - -- { - set args [lreplace $args 0 0] - break - } - default { - return -code error "bad option [lindex $args 0]:\ - must be -file" - } - } - set args [lreplace $args 0 0] - } - - if {$opts(filename) != {}} { - set f [open $opts(filename) r] - set data [read $f] - close $f - } else { - if {[llength $args] != 1} { - return -code error $wrongargs - } - set data [lindex $args 0] - } - - set state false - set result {} - - foreach {line} [split $data "\n"] { - switch -exact -- $state { - false { - if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \ - -> opts(mode) opts(name)]} { - set state true - set r {} - } - } - - true { - if {[string match "end" $line]} { - set state false - lappend result [list $opts(name) $opts(mode) $r] - } else { - scan $line %c c - set n [expr {($c - 0x21)}] - append r [string range \ - [decode [string range $line 1 end]] 0 $n] - } - } - } - } - - return $result -} - -# ------------------------------------------------------------------------- - -package provide uuencode 1.1.6 - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: - diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/yencode.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/yencode.tcl deleted file mode 100644 index 017085db..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/base64/yencode.tcl +++ /dev/null @@ -1,309 +0,0 @@ -# yencode.tcl - Copyright (C) 2002 Pat Thoyts -# -# Provide a Tcl only implementation of yEnc encoding algorithm -# -# ------------------------------------------------------------------------- -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# ------------------------------------------------------------------------- - -# FUTURE: Rework to allow switching between the tcl/critcl implementations. - -package require Tcl 8.5 9; # tcl minimum version -catch {package require crc32}; # tcllib 1.1 -catch {package require tcllibc}; # critcl enhancements for tcllib - -namespace eval ::yencode { - namespace export encode decode yencode ydecode -} - -# ------------------------------------------------------------------------- - -proc ::yencode::Encode {s} { - set r {} - binary scan $s c* d - foreach {c} $d { - set v [expr {($c + 42) % 256}] - if {$v == 0x00 || $v == 0x09 || $v == 0x0A - || $v == 0x0D || $v == 0x3D} { - append r "=" - set v [expr {($v + 64) % 256}] - } - append r [format %c $v] - } - return $r -} - -proc ::yencode::Decode {s} { - if {[string length $s] == 0} {return ""} - set r {} - set esc 0 - binary scan $s c* d - foreach c $d { - if {$c == 61 && $esc == 0} { - set esc 1 - continue - } - set v [expr {($c - 42) % 256}] - if {$esc} { - set v [expr {($v - 64) % 256}] - set esc 0 - } - append r [format %c $v] - } - return $r -} - -# ------------------------------------------------------------------------- -# C coded versions for critcl built base64c package -# ------------------------------------------------------------------------- - -if {[package provide critcl] != {}} { - namespace eval ::yencode { - critcl::ccode { - #include - } - critcl::ccommand CEncode {dummy interp objc objv} { - Tcl_Obj *inputPtr, *resultPtr; - Tcl_Size len, rlen, xtra; - unsigned char *input, *p, *r, v; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ - return TCL_ERROR; - } - - /* fetch the input data */ - inputPtr = objv[1]; - input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ - if (input == NULL) return TCL_ERROR; - - /* calculate the length of the encoded result */ - rlen = len; - for (p = input; p < input + len; p++) { - v = (*p + 42) % 256; - if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) - rlen++; - } - - /* allocate the output buffer */ - resultPtr = Tcl_NewObj(); - r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ - - /* encode the input */ - for (p = input; p < input + len; p++) { - v = (*p + 42) % 256; - if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) { - *r++ = '='; - v = (v + 64) % 256; - } - *r++ = v; - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; - } - - critcl::ccommand CDecode {dummy interp objc objv} { - Tcl_Obj *inputPtr, *resultPtr; - Tcl_Size len, rlen, esc; - unsigned char *input, *p, *r, v; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ - return TCL_ERROR; - } - - /* fetch the input data */ - inputPtr = objv[1]; - input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ - if (input == NULL) return TCL_ERROR; - - /* allocate the output buffer */ - resultPtr = Tcl_NewObj(); - r = Tcl_SetByteArrayLength(resultPtr, len); /* OK tcl9 */ - - /* encode the input */ - for (p = input, esc = 0, rlen = 0; p < input + len; p++) { - if (*p == 61 && esc == 0) { - esc = 1; - continue; - } - v = (*p - 42) % 256; - if (esc) { - v = (v - 64) % 256; - esc = 0; - } - *r++ = v; - rlen++; - } - Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; - } - } -} - -if {[info commands ::yencode::CEncode] != {}} { - interp alias {} ::yencode::encode {} ::yencode::CEncode - interp alias {} ::yencode::decode {} ::yencode::CDecode -} else { - interp alias {} ::yencode::encode {} ::yencode::Encode - interp alias {} ::yencode::decode {} ::yencode::Decode -} - -# ------------------------------------------------------------------------- -# Description: -# Pop the nth element off a list. Used in options processing. -# -proc ::yencode::Pop {varname {nth 0}} { - upvar $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -# ------------------------------------------------------------------------- - -proc ::yencode::yencode {args} { - array set opts {mode 0644 filename {} name {} line 128 crc32 1} - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -f* { set opts(filename) [Pop args 1] } - -m* { set opts(mode) [Pop args 1] } - -n* { set opts(name) [Pop args 1] } - -l* { set opts(line) [Pop args 1] } - -c* { set opts(crc32) [Pop args 1] } - -- { Pop args ; break } - default { - set options [join [lsort [array names opts]] ", -"] - return -code error "bad option [lindex $args 0]:\ - must be -$options" - } - } - Pop args - } - - if {$opts(name) == {}} { - set opts(name) $opts(filename) - } - if {$opts(name) == {}} { - set opts(name) "data.dat" - } - if {! [string is boolean $opts(crc32)]} { - return -code error "bad option -crc32: argument must be true or false" - } - - if {$opts(filename) != {}} { - set f [open $opts(filename) rb] - fconfigure $f -translation binary - set data [read $f] - close $f - } else { - if {[llength $args] != 1} { - return -code error "wrong \# args: should be\ - \"yencode ?options? -file name | data\"" - } - set data [lindex $args 0] - } - - set opts(size) [string length $data] - - set r {} - append r [format "=ybegin line=%d size=%d name=%s" \ - $opts(line) $opts(size) $opts(name)] "\n" - - set ndx 0 - while {$ndx < $opts(size)} { - set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]] - set enc [encode $pln] - incr ndx [string length $pln] - append r $enc "\r\n" - } - - append r [format "=yend size=%d" $ndx] - if {$opts(crc32)} { - append r " crc32=" [crc::crc32 -format %x $data] - } - return $r -} - -# ------------------------------------------------------------------------- -# Description: -# Perform ydecoding of a file or data. A file may contain more than one -# encoded data section so the result is a list where each element is a -# three element list of the provided filename, the file size and the -# data itself. -# -proc ::yencode::ydecode {args} { - array set opts {mode 0644 filename {} name default.bin} - while {[string match -* [lindex $args 0]]} { - switch -glob -- [lindex $args 0] { - -f* { set opts(filename) [Pop args 1] } - -- { Pop args ; break; } - default { - set options [join [lsort [array names opts]] ", -"] - return -code error "bad option [lindex $args 0]:\ - must be -$opts" - } - } - Pop args - } - - if {$opts(filename) != {}} { - set f [open $opts(filename) r] - set data [read $f] - close $f - } else { - if {[llength $args] != 1} { - return -code error "wrong \# args: should be\ - \"ydecode ?options? -file name | data\"" - } - set data [lindex $args 0] - } - - set state false - set result {} - - foreach {line} [split $data "\n"] { - set line [string trimright $line "\r\n"] - switch -exact -- $state { - false { - if {[string match "=ybegin*" $line]} { - regexp {line=(\d+)} $line -> opts(line) - regexp {size=(\d+)} $line -> opts(size) - regexp {name=(\d+)} $line -> opts(name) - - if {$opts(name) == {}} { - set opts(name) default.bin - } - - set state true - set r {} - } - } - - true { - if {[string match "=yend*" $line]} { - set state false - lappend result [list $opts(name) $opts(size) $r] - } else { - append r [decode $line] - } - } - } - } - - return $result -} - -# ------------------------------------------------------------------------- - -package provide yencode 1.1.4 - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: - diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bee/bee.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bee/bee.tcl deleted file mode 100644 index 722101bb..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bee/bee.tcl +++ /dev/null @@ -1,990 +0,0 @@ -# bee.tcl -- -# -# BitTorrent Bee de- and encoder. -# -# Copyright (c) 2004 by Andreas Kupries -# See the file license.terms. - -package require Tcl 8.5 9 - -namespace eval ::bee { - # Encoder commands - namespace export \ - encodeString encodeNumber \ - encodeListArgs encodeList \ - encodeDictArgs encodeDict - - # Decoder commands. - namespace export \ - decode \ - decodeChannel \ - decodeCancel \ - decodePush - - # Channel decoders, reference to state information, keyed by - # channel handle. - - variable bee - array set bee {} - - # Counter for generation of names for the state variables. - - variable count 0 - - # State information for the channel decoders. - - # stateN, with N an integer number counting from 0 on up. - # ...(chan) Handle of channel the decoder is for. - # ...(cmd) Command prefix, completion callback - # ...(exact) Boolean flag, set for exact processing. - # ...(read) Buffer for new characters to process. - # ...(type) Type of current value (integer, string, list, dict) - # ...(value) Buffer for assembling the current value. - # ...(pend) Stack of pending 'value' buffers, for nested - # containers. - # ...(state) Current state of the decoding state machine. - - # States of the finite automaton ... - # intro - One char, type of value, or 'e' as stop of container. - # signum - sign or digit, for integer. - # idigit - digit, for integer, or 'e' as stop - # ldigit - digit, for length of string, or : - # data - string data, 'get' characters. - # Containers via 'pend'. - - #Debugging help, nesting level - #variable X 0 -} - - -# ::bee::encodeString -- -# -# Encode a string to bee-format. -# -# Arguments: -# string The string to encode. -# -# Results: -# The bee-encoded form of the string. - -proc ::bee::encodeString {string} { - return "[string length $string]:$string" -} - - -# ::bee::encodeNumber -- -# -# Encode an integer number to bee-format. -# -# Arguments: -# num The integer number to encode. -# -# Results: -# The bee-encoded form of the integer number. - -proc ::bee::encodeNumber {num} { - if {![string is integer -strict $num]} { - return -code error "Expected integer number, got \"$num\"" - } - - # The reformatting deals with hex, octal and other tcl - # representation of the value. In other words we normalize the - # string representation of the input value. - - set num [format %d $num] - return "i${num}e" -} - - -# ::bee::encodeList -- -# -# Encode a list of bee-coded values to bee-format. -# -# Arguments: -# list The list to encode. -# -# Results: -# The bee-encoded form of the list. - -proc ::bee::encodeList {list} { - return "l[join $list ""]e" -} - - -# ::bee::encodeListArgs -- -# -# Encode a variable list of bee-coded values to bee-format. -# -# Arguments: -# args The values to encode. -# -# Results: -# The bee-encoded form of the list of values. - -proc ::bee::encodeListArgs {args} { - return [encodeList $args] -} - - -# ::bee::encodeDict -- -# -# Encode a dictionary of keys and bee-coded values to bee-format. -# -# Arguments: -# dict The dictionary to encode. -# -# Results: -# The bee-encoded form of the dictionary. - -proc ::bee::encodeDict {dict} { - if {([llength $dict] % 2) == 1} { - return -code error "Expected even number of elements, got \"[llength $dict]\"" - } - set temp [list] - foreach {k v} $dict { - lappend temp [list $k $v] - } - set res "d" - foreach item [lsort -index 0 $temp] { - foreach {k v} $item break - append res [encodeString $k]$v - } - append res "e" - return $res -} - - -# ::bee::encodeDictArgs -- -# -# Encode a variable dictionary of keys and bee-coded values to bee-format. -# -# Arguments: -# args The keys and values to encode. -# -# Results: -# The bee-encoded form of the dictionary. - -proc ::bee::encodeDictArgs {args} { - return [encodeDict $args] -} - - -# ::bee::decode -- -# -# Decode a bee-encoded value and returns the embedded tcl -# value. For containers this recurses into the contained value. -# -# Arguments: -# value The string containing the bee-encoded value to decode. -# evar Optional. If set the name of the variable to store the -# index of the first character after the decoded value to. -# start Optional. If set the index of the first character of the -# value to decode. Defaults to 0, i.e. the beginning of the -# string. -# -# Results: -# The tcl value embedded in the encoded string. - -proc ::bee::decode {value {evar {}} {start 0}} { - #variable X - #puts -nonewline "[string repeat " " $X]decode @$start" ; flush stdout - - if {$evar ne ""} {upvar 1 $evar end} else {set end _} - - if {[string length $value] < ($start+2)} { - # This checked that the 'start' index is still in the string, - # and the end of the value most likely as well. Note that each - # encoded value consists of at least two characters (the - # bracketing characters for integer, list, and dict, and for - # string at least one digit length and the colon). - - #puts \t[string length $value]\ <\ ($start+2) - return -code error "String not large enough for value" - } - - set type [string index $value $start] - - #puts -nonewline " $type=" ; flush stdout - - if {$type eq "i"} { - # Extract integer - #puts -nonewline integer ; flush stdout - - incr start ; # Skip over intro 'i'. - set end [string first e $value $start] - if {$end < 0} { - return -code error "End of integer number not found" - } - incr end -1 ; # Get last character before closing 'e'. - set num [string range $value $start $end] - if { - [regexp {^-0+$} $num] || - ![string is integer -strict $num] || - (([string length $num] > 1) && [string match 0* $num]) - } { - return -code error "Expected integer number, got \"$num\"" - } - incr end 2 ; # Step after closing 'e' to the beginning of - # ........ ; # the next bee-value behind the current one. - - #puts " ($num) @$end" - return $num - - } elseif {($type eq "l") || ($type eq "d")} { - #puts -nonewline $type\n ; flush stdout - - # Extract list or dictionary, recursively each contained - # element. From the perspective of the decoder this is the - # same, the tcl representation of both is a list, and for a - # dictionary keys and values are also already in the correct - # order. - - set result [list] - incr start ; # Step over intro 'e' to beginning of the first - # ........ ; # contained value, or behind the container (if - # ........ ; # empty). - - set end $start - #incr X - while {[string index $value $start] ne "e"} { - lappend result [decode $value end $start] - set start $end - } - #incr X -1 - incr end - - #puts "[string repeat " " $X]($result) @$end" - - if {$type eq "d" && ([llength $result] % 2 == 1)} { - return -code error "Dictionary has to be of even length" - } - return $result - - } elseif {[string match {[0-9]} $type]} { - #puts -nonewline string ; flush stdout - - # Extract string. First the length, bounded by a colon, then - # the appropriate number of characters. - - set end [string first : $value $start] - if {$end < 0} { - return -code error "End of string length not found" - } - incr end -1 - set length [string range $value $start $end] - incr end 2 ;# Skip to beginning of the string after the colon - - if {![string is integer -strict $length]} { - return -code error "Expected integer number for string length, got \"$length\"" - } elseif {$length < 0} { - # This cannot happen. To happen "-" has to be first character, - # and this is caught as unknown bee-type. - return -code error "Illegal negative string length" - } elseif {($end + $length) > [string length $value]} { - return -code error "String not large enough for value" - } - - #puts -nonewline \[$length\] ; flush stdout - if {$length > 0} { - set start $end - incr end $length - incr end -1 - set result [string range $value $start $end] - incr end - } else { - set result "" - } - - #puts " ($result) @$end" - return $result - - } else { - return -code error "Unknown bee-type \"$type\"" - } -} - -# ::bee::decodeIndices -- -# -# Similar to 'decode', but does not return the decoded tcl values, -# but a structure containing the start- and end-indices for all -# values in the structure. -# -# Arguments: -# value The string containing the bee-encoded value to decode. -# evar Optional. If set the name of the variable to store the -# index of the first character after the decoded value to. -# start Optional. If set the index of the first character of the -# value to decode. Defaults to 0, i.e. the beginning of the -# string. -# -# Results: -# The structure of the value, with indices and types for all -# contained elements. - -proc ::bee::decodeIndices {value {evar {}} {start 0}} { - #variable X - #puts -nonewline "[string repeat " " $X]decode @$start" ; flush stdout - - if {$evar ne ""} {upvar 1 $evar end} else {set end _} - - if {[string length $value] < ($start+2)} { - # This checked that the 'start' index is still in the string, - # and the end of the value most likely as well. Note that each - # encoded value consists of at least two characters (the - # bracketing characters for integer, list, and dict, and for - # string at least one digit length and the colon). - - #puts \t[string length $value]\ <\ ($start+2) - return -code error "String not large enough for value" - } - - set type [string index $value $start] - - #puts -nonewline " $type=" ; flush stdout - - if {$type eq "i"} { - # Extract integer - #puts -nonewline integer ; flush stdout - - set begin $start - - incr start ; # Skip over intro 'i'. - set end [string first e $value $start] - if {$end < 0} { - return -code error "End of integer number not found" - } - incr end -1 ; # Get last character before closing 'e'. - set num [string range $value $start $end] - if { - [regexp {^-0+$} $num] || - ![string is integer -strict $num] || - (([string length $num] > 1) && [string match 0* $num]) - } { - return -code error "Expected integer number, got \"$num\"" - } - incr end - set stop $end - incr end 1 ; # Step after closing 'e' to the beginning of - # ........ ; # the next bee-value behind the current one. - - #puts " ($num) @$end" - return [list integer $begin $stop] - - } elseif {$type eq "l"} { - #puts -nonewline $type\n ; flush stdout - - # Extract list, recursively each contained element. - - set result [list] - - lappend result list $start @ - - incr start ; # Step over intro 'e' to beginning of the first - # ........ ; # contained value, or behind the container (if - # ........ ; # empty). - - set end $start - #incr X - - set contained [list] - while {[string index $value $start] ne "e"} { - lappend contained [decodeIndices $value end $start] - set start $end - } - lappend result $contained - #incr X -1 - set stop $end - incr end - - #puts "[string repeat " " $X]($result) @$end" - - return [lreplace $result 2 2 $stop] - - } elseif {($type eq "l") || ($type eq "d")} { - #puts -nonewline $type\n ; flush stdout - - # Extract dictionary, recursively each contained element. - - set result [list] - - lappend result dict $start @ - - incr start ; # Step over intro 'e' to beginning of the first - # ........ ; # contained value, or behind the container (if - # ........ ; # empty). - - set end $start - set atkey 1 - #incr X - - set contained [list] - set val [list] - while {[string index $value $start] ne "e"} { - if {$atkey} { - lappend contained [decode $value {} $start] - lappend val [decodeIndices $value end $start] - set atkey 0 - } else { - lappend val [decodeIndices $value end $start] - lappend contained $val - set val [list] - set atkey 1 - } - set start $end - } - lappend result $contained - #incr X -1 - set stop $end - incr end - - #puts "[string repeat " " $X]($result) @$end" - - if {[llength $result] % 2 == 1} { - return -code error "Dictionary has to be of even length" - } - return [lreplace $result 2 2 $stop] - - } elseif {[string match {[0-9]} $type]} { - #puts -nonewline string ; flush stdout - - # Extract string. First the length, bounded by a colon, then - # the appropriate number of characters. - - set end [string first : $value $start] - if {$end < 0} { - return -code error "End of string length not found" - } - incr end -1 - set length [string range $value $start $end] - incr end 2 ;# Skip to beginning of the string after the colon - - if {![string is integer -strict $length]} { - return -code error "Expected integer number for string length, got \"$length\"" - } elseif {$length < 0} { - # This cannot happen. To happen "-" has to be first character, - # and this is caught as unknown bee-type. - return -code error "Illegal negative string length" - } elseif {($end + $length) > [string length $value]} { - return -code error "String not large enough for value" - } - - #puts -nonewline \[$length\] ; flush stdout - incr end -1 - if {$length > 0} { - incr end $length - set stop $end - } else { - set stop $end - } - incr end - - #puts " ($result) @$end" - return [list string $start $stop] - - } else { - return -code error "Unknown bee-type \"$type\"" - } -} - - -# ::bee::decodeChannel -- -# -# Attach decoder for a bee-value to a channel. See the -# documentation for details. -# -# Arguments: -# chan Channel to attach to. -# -command cmdprefix Completion callback. Required. -# -exact Keep running after completion. -# -prefix data Seed for decode buffer. -# -# Results: -# A token to use when referring to the decoder. -# For example when canceling it. - -proc ::bee::decodeChannel {chan args} { - variable bee - if {[info exists bee($chan)]} { - return -code error "bee-Decoder already active for channel" - } - - # Create state and token. - - variable count - variable [set st state$count] - array set $st {} - set bee($chan) $st - upvar 0 $st state - incr count - - # Initialize the decoder state, process the options. When - # encountering errors here destroy the half-baked state before - # throwing the message. - - set state(chan) $chan - array set state { - exact 0 - type ? - read {} - value {} - pend {} - state intro - get 1 - } - - while {[llength $args]} { - set option [lindex $args 0] - set args [lrange $args 1 end] - if {$option eq "-command"} { - if {![llength $args]} { - unset bee($chan) - unset state - return -code error "Missing value for option -command." - } - set state(cmd) [lindex $args 0] - set args [lrange $args 1 end] - - } elseif {$option eq "-prefix"} { - if {![llength $args]} { - unset bee($chan) - unset state - return -code error "Missing value for option -prefix." - } - set state(read) [lindex $args 0] - set args [lrange $args 1 end] - - } elseif {$option eq "-exact"} { - set state(exact) 1 - } else { - unset bee($chan) - unset state - return -code error "Illegal option \"$option\",\ - expected \"-command\", \"-prefix\", or \"-keep\"" - } - } - - if {![info exists state(cmd)]} { - unset bee($chan) - unset state - return -code error "Missing required completion callback." - } - - # Set up the processing of incoming data. - - fileevent $chan readable [list ::bee::Process $chan $bee($chan)] - - # Return the name of the state array as token. - return $bee($chan) -} - -# ::bee::Parse -- -# -# Internal helper. Fileevent handler for a decoder. -# Parses input and handles both error and eof conditions. -# -# Arguments: -# token The decoder to run on its input. -# -# Results: -# None. - -proc ::bee::Process {chan token} { - if {[catch {Parse $token} msg]} { - # Something failed. Destroy and report. - Command $token error $msg - return - } - - if {[eof $chan]} { - # Having data waiting, either in the input queue, or in the - # output stack (of nested containers) is a failure. Report - # this instead of the eof. - - variable $token - upvar 0 $token state - - if { - [string length $state(read)] || - [llength $state(pend)] || - [string length $state(value)] || - ($state(state) ne "intro") - } { - Command $token error "Incomplete value at end of channel" - } else { - Command $token eof - } - } - return -} - -# ::bee::Parse -- -# -# Internal helper. Reading from the channel and parsing the input. -# Uses a hardwired state machine. -# -# Arguments: -# token The decoder to run on its input. -# -# Results: -# None. - -proc ::bee::Parse {token} { - variable $token - upvar 0 $token state - upvar 0 state(state) current - upvar 0 state(read) input - upvar 0 state(type) type - upvar 0 state(value) value - upvar 0 state(pend) pend - upvar 0 state(exact) exact - upvar 0 state(get) get - set chan $state(chan) - - #puts Parse/$current - - if {!$exact} { - # Add all waiting characters to the buffer so that we can process as - # much as is possible in one go. - append input [read $chan] - } else { - # Exact reading. Usually one character, but when in the data - # section for a string value we know for how many characters - # we are looking for. - - append input [read $chan $get] - } - - # We got nothing, do nothing. - if {![string length $input]} return - - - if {$current eq "data"} { - # String data, this can be done faster, as we read longer - # sequences of characters for this. - set l [string length $input] - if {$l < $get} { - # Not enough, wait for more. - append value $input - incr get -$l - return - } elseif {$l == $get} { - # Got all, exactly. Prepare state machine for next value. - - if {[Complete $token $value$input]} return - - set current intro - set get 1 - set value "" - set input "" - - return - } else { - # Got more than required (only for !exact). - - incr get -1 - if {[Complete $token $value[string range $input 0 $get]]} {return} - - incr get - set input [string range $input $get end] - set get 1 - set value "" - set current intro - # This now falls into the loop below. - } - } - - set where 0 - set n [string length $input] - - #puts Parse/$n - - while {$where < $n} { - # Hardwired state machine. Get current character. - set ch [string index $input $where] - - #puts Parse/@$where/$current/$ch/ - if {$current eq "intro"} { - # First character of a value. - - if {$ch eq "i"} { - # Begin reading integer. - set type integer - set current signum - } elseif {$ch eq "l"} { - # Begin a list. - set type list - lappend pend list {} - #set current intro - - } elseif {$ch eq "d"} { - # Begin a dictionary. - set type dict - lappend pend dict {} - #set current intro - - } elseif {$ch eq "e"} { - # Close a container. Throw an error if there is no - # container to close. - - if {![llength $pend]} { - return -code error "End of container outside of container." - } - - set v [lindex $pend end] - set t [lindex $pend end-1] - set pend [lrange $pend 0 end-2] - - if {$t eq "dict" && ([llength $v] % 2 == 1)} { - return -code error "Dictionary has to be of even length" - } - - if {[Complete $token $v]} {return} - set current intro - - } elseif {[string match {[0-9]} $ch]} { - # Begin reading a string, length section first. - set type string - set current ldigit - set value $ch - - } else { - # Unknown type. Throw error. - return -code error "Unknown bee-type \"$ch\"" - } - - # To next character. - incr where - } elseif {$current eq "signum"} { - # Integer number, a minus sign, or a digit. - if {[string match {[-0-9]} $ch]} { - append value $ch - set current idigit - } else { - return -code error "Syntax error in integer,\ - expected sign or digit, got \"$ch\"" - } - incr where - - } elseif {$current eq "idigit"} { - # Integer number, digit or closing 'e'. - - if {[string match {[-0-9]} $ch]} { - append value $ch - } elseif {$ch eq "e"} { - # Integer closes. Validate and report. - #puts validate - if { - [regexp {^-0+$} $value] || - ![string is integer -strict $value] || - (([string length $value] > 1) && [string match 0* $value]) - } { - return -code error "Expected integer number, got \"$value\"" - } - - if {[Complete $token $value]} {return} - set value "" - set current intro - } else { - return -code error "Syntax error in integer,\ - expected digit, or 'e', got \"$ch\"" - } - incr where - - } elseif {$current eq "ldigit"} { - # String, length section, digit, or : - - if {[string match {[-0-9]} $ch]} { - append value $ch - - } elseif {$ch eq ":"} { - # Length section closes, validate, - # then perform data processing. - - set num $value - if { - [regexp {^-0+$} $num] || - ![string is integer -strict $num] || - (([string length $num] > 1) && [string match 0* $num]) - } { - return -code error "Expected integer number as string length, got \"$num\"" - } - - set value "" - - # We may have already part of the data in - # memory. Process that piece before looking for more. - - incr where - set have [expr {$n - $where}] - if {$num < $have} { - # More than enough in the buffer. - - set end $where - incr end $num - incr end -1 - - if {[Complete $token [string range $input $where $end]]} {return} - - set where $end ;# Further processing behind the string. - set current intro - - } elseif {$num == $have} { - # Just enough. - - if {[Complete $token [string range $input $where end]]} {return} - - set where $n - set current intro - } else { - # Not enough. Initialize value with the data we - # have (after the colon) and stop processing for - # now. - - set value [string range $input $where end] - set current data - set get $num - set input "" - return - } - } else { - return -code error "Syntax error in string length,\ - expected digit, or ':', got \"$ch\"" - } - incr where - } else { - # unknown state = internal error - return -code error "Unknown decoder state \"$current\", internal error" - } - } - - set input "" - return -} - -# ::bee::Command -- -# -# Internal helper. Runs the decoder command callback. -# -# Arguments: -# token The decoder invoking its callback -# how Which method to invoke (value, error, eof) -# args Arguments for the method. -# -# Results: -# A boolean flag. Set if further processing has to stop. - -proc ::bee::Command {token how args} { - variable $token - upvar 0 $token state - - #puts Report/$token/$how/$args/ - - set cmd $state(cmd) - set chan $state(chan) - - # We catch the fileevents because they will fail when this is - # called from the 'Close'. The channel will already be gone in - # that case. - - set stop 0 - if {($how eq "error") || ($how eq "eof")} { - variable bee - - set stop 1 - fileevent $chan readable {} - unset bee($chan) - unset state - - if {$how eq "eof"} { - #puts \tclosing/$chan - close $chan - } - } - - lappend cmd $how $token - foreach a $args {lappend cmd $a} - uplevel #0 $cmd - - if {![info exists state]} { - # The decoder token was killed by the callback, stop - # processing. - set stop 1 - } - - #puts /$stop/[file channels] - return $stop -} - -# ::bee::Complete -- -# -# Internal helper. Reports a completed value. -# -# Arguments: -# token The decoder reporting the value. -# value The value to report. -# -# Results: -# A boolean flag. Set if further processing has to stop. - -proc ::bee::Complete {token value} { - variable $token - upvar 0 $token state - upvar 0 state(pend) pend - - if {[llength $pend]} { - # The value is part of a container. Add the value to its end - # and keep processing. - - set pend [lreplace $pend end end \ - [linsert [lindex $pend end] end \ - $value]] - - # Don't stop. - return 0 - } - - # The value is at the top, report it. The callback determines if - # we keep processing. - - return [Command $token value $value] -} - -# ::bee::decodeCancel -- -# -# Destroys the decoder referenced by the token. -# -# Arguments: -# token The decoder to destroy. -# -# Results: -# None. - -proc ::bee::decodeCancel {token} { - variable bee - variable $token - upvar 0 $token state - unset bee($state(chan)) - unset state - return -} - -# ::bee::decodePush -- -# -# Push data into the decoder input buffer. -# -# Arguments: -# token The decoder to extend. -# string The characters to add. -# -# Results: -# None. - -proc ::bee::decodePush {token string} { - variable $token - upvar 0 $token state - append state(read) $string - return -} - - -package provide bee 0.2 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bee/pkgIndex.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bee/pkgIndex.tcl deleted file mode 100644 index 2f16df61..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bee/pkgIndex.tcl +++ /dev/null @@ -1,4 +0,0 @@ -# Tcl package index file, version 1.1 - -if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} -package ifneeded bee 0.2 [list source [file join $dir bee.tcl]] diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench.tcl deleted file mode 100644 index 98b95eb7..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench.tcl +++ /dev/null @@ -1,551 +0,0 @@ -# bench.tcl -- -# -# Management of benchmarks. -# -# Copyright (c) 2005-2008 by Andreas Kupries -# library derived from runbench.tcl application (C) Jeff Hobbs. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: bench.tcl,v 1.14 2008/10/08 03:30:48 andreas_kupries Exp $ - -# ### ### ### ######### ######### ######### ########################### -## Requisites - Packages and namespace for the commands and data. - -package require Tcl 8.5 9 -package require logger -package require csv -package require struct::matrix -package require report - -namespace eval ::bench {} -namespace eval ::bench::out {} - -# @mdgen OWNER: libbench.tcl - -# ### ### ### ######### ######### ######### ########################### -## Public API - Benchmark execution - -# ::bench::run -- -# -# Run a series of benchmarks. -# -# Arguments: -# ... -# -# Results: -# Dictionary. - -proc ::bench::run {args} { - log::debug [linsert $args 0 ::bench::run] - - # -errors 0|1 default 1, propagate errors in benchmarks - # -threads default 0, no threads, #threads to use - # -match only run tests matching this pattern - # -rmatch only run tests matching this pattern - # -iters default 1000, max#iterations for any benchmark - # -pkgdir Defaults to nothing, regular bench invokation. - - # interps - dict (path -> version) - # files - list (of files) - - # Process arguments ...................................... - # Defaults first, then overides by the user - - set errors 1 ; # Propagate errors - set threads 0 ; # Do not use threads - set match {} ; # Do not exclude benchmarks based on glob pattern - set rmatch {} ; # Do not exclude benchmarks based on regex pattern - set iters 1000 ; # Limit #iterations for any benchmark - set pkgdirs {} ; # List of dirs to put in front of auto_path in the - # bench interpreters. Default: nothing. - - while {[string match "-*" [set opt [lindex $args 0]]]} { - set val [lindex $args 1] - switch -exact -- $opt { - -errors { - if {![string is boolean -strict $val]} { - return -code error "Expected boolean, got \"$val\"" - } - set errors $val - } - -threads { - if {![string is int -strict $val] || ($val < 0)} { - return -code error "Expected int >= 0, got \"$val\"" - } - set threads [lindex $args 1] - } - -match { - set match [lindex $args 1] - } - -rmatch { - set rmatch [lindex $args 1] - } - -iters { - if {![string is int -strict $val] || ($val <= 0)} { - return -code error "Expected int > 0, got \"$val\"" - } - set iters [lindex $args 1] - } - -pkgdir { - CheckPkgDirArg $val - lappend pkgdirs $val - } - default { - return -code error "Unknown option \"$opt\", should -errors, -threads, -match, -rmatch, or -iters" - } - } - set args [lrange $args 2 end] - } - if {[llength $args] != 2} { - return -code error "wrong\#args, should be: ?options? interp files" - } - foreach {interps files} $args break - - # Run the benchmarks ..................................... - - array set DATA {} - - if {![llength $pkgdirs]} { - # No user specified package directories => Simple run. - foreach {ip ver} $interps { - Invoke $ip $ver {} ;# DATA etc passed via upvar. - } - } else { - # User specified package directories. - foreach {ip ver} $interps { - foreach pkgdir $pkgdirs { - Invoke $ip $ver $pkgdir ;# DATA etc passed via upvar. - } - } - } - - # Benchmark data ... Structure, dict (key -> value) - # - # Key || Value - # ============ ++ ========================================= - # interp IP -> Version. Shell IP was used to run benchmarks. IP is - # the path to the shell. - # - # desc DESC -> "". DESC is description of an executed benchmark. - # - # usec DESC IP -> Result. Result of benchmark DESC when run by the - # shell IP. Usually time in microseconds, but can be - # a special code as well (ERR, BAD_RES). - # ============ ++ ========================================= - - return [array get DATA] -} - -# ::bench::locate -- -# -# Locate interpreters on the pathlist, based on a pattern. -# -# Arguments: -# ... -# -# Results: -# List of paths. - -proc ::bench::locate {pattern paths} { - # Cache of executables already found. - array set var {} - set res {} - - foreach path $paths { - foreach ip [glob -nocomplain [file join $path $pattern]] { - set ip [file normalize $ip] - - # Follow soft-links to the actual executable. - while {[string equal link [file type $ip]]} { - set link [file readlink $ip] - if {[string match relative [file pathtype $link]]} { - set ip [file join [file dirname $ip] $link] - } else { - set ip $link - } - } - - if { - [file executable $ip] && ![info exists var($ip)] - } { - if {[catch {exec $ip << "exit"} dummy]} { - log::debug "$ip: $dummy" - continue - } - set var($ip) . - lappend res $ip - } - } - } - - return $res -} - -# ::bench::versions -- -# -# Take list of interpreters, find their versions. -# Removes all interps for which it cannot do so. -# -# Arguments: -# List of interpreters (paths) -# -# Results: -# dictionary: interpreter -> version. - -proc ::bench::versions {interps} { - set res {} - foreach ip $interps { - if {[catch { - exec $ip << {puts [info patchlevel] ; exit} - } patchlevel]} { - log::debug "$ip: $patchlevel" - continue - } - - lappend res [list $patchlevel $ip] - } - - # -uniq 8.4-ism, replaced with use of array. - array set tmp {} - set resx {} - foreach item [lsort -dictionary -decreasing -index 0 $res] { - foreach {p ip} $item break - if {[info exists tmp($p)]} continue - set tmp($p) . - lappend resx $ip $p - } - - return $resx -} - -# ::bench::merge -- -# -# Take the data of several benchmark runs and merge them into -# one data set. -# -# Arguments: -# One or more data sets to merge -# -# Results: -# The merged data set. - -proc ::bench::merge {args} { - if {[llength $args] == 1} { - return [lindex $args 0] - } - - array set DATA {} - foreach data $args { - array set DATA $data - } - return [array get DATA] -} - -# ::bench::norm -- -# -# Normalize the time data in the dataset, using one of the -# columns as reference. -# -# Arguments: -# Data to normalize -# Index of reference column -# -# Results: -# The normalized data set. - -proc ::bench::norm {data col} { - - if {![string is integer -strict $col]} { - return -code error "Ref.column: Expected integer, but got \"$col\"" - } - if {$col < 1} { - return -code error "Ref.column out of bounds" - } - - array set DATA $data - set ipkeys [array names DATA interp*] - - if {$col > [llength $ipkeys]} { - return -code error "Ref.column out of bounds" - } - incr col -1 - set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] - - foreach key [array names DATA] { - if {[string match "desc*" $key]} continue - if {[string match "interp*" $key]} continue - - foreach {_ desc ip} $key break - if {[string equal $ip $refip]} continue - - set v $DATA($key) - if {![string is double -strict $v]} continue - - if {![info exists DATA([list usec $desc $refip])]} { - # We cannot normalize, we do not keep the time value. - # The row will be shown, empty. - set DATA($key) "" - continue - } - set vref $DATA([list usec $desc $refip]) - - if {![string is double -strict $vref]} continue - - set DATA($key) [expr {$v/double($vref)}] - } - - foreach key [array names DATA [list * $refip]] { - if {![string is double -strict $DATA($key)]} continue - set DATA($key) 1 - } - - return [array get DATA] -} - -# ::bench::edit -- -# -# Change the 'path' of an interp to a user-defined value. -# -# Arguments: -# Data to edit -# Index of column to change -# The value replacing the current path -# -# Results: -# The changed data set. - -proc ::bench::edit {data col new} { - - if {![string is integer -strict $col]} { - return -code error "Ref.column: Expected integer, but got \"$col\"" - } - if {$col < 1} { - return -code error "Ref.column out of bounds" - } - - array set DATA $data - set ipkeys [array names DATA interp*] - - if {$col > [llength $ipkeys]} { - return -code error "Ref.column out of bounds" - } - incr col -1 - set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] - - if {[string equal $new $refip]} { - # No change, quick return - return $data - } - - set refkey [list interp $refip] - set DATA([list interp $new]) $DATA($refkey) - unset DATA($refkey) - - foreach key [array names DATA [list * $refip]] { - if {![string equal [lindex $key 0] "usec"]} continue - foreach {__ desc ip} $key break - set DATA([list usec $desc $new]) $DATA($key) - unset DATA($key) - } - - return [array get DATA] -} - -# ::bench::del -- -# -# Remove the data for an interp. -# -# Arguments: -# Data to edit -# Index of column to remove -# -# Results: -# The changed data set. - -proc ::bench::del {data col} { - - if {![string is integer -strict $col]} { - return -code error "Ref.column: Expected integer, but got \"$col\"" - } - if {$col < 1} { - return -code error "Ref.column out of bounds" - } - - array set DATA $data - set ipkeys [array names DATA interp*] - - if {$col > [llength $ipkeys]} { - return -code error "Ref.column out of bounds" - } - incr col -1 - set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] - - unset DATA([list interp $refip]) - - # Do not use 'array unset'. Keep 8.2 clean. - foreach key [array names DATA [list * $refip]] { - if {![string equal [lindex $key 0] "usec"]} continue - unset DATA($key) - } - - return [array get DATA] -} - -# ### ### ### ######### ######### ######### ########################### -## Public API - Result formatting. - -# ::bench::out::raw -- -# -# Format the result of a benchmark run. -# Style: Raw data. -# -# Arguments: -# DATA dict -# -# Results: -# String containing the formatted DATA. - -proc ::bench::out::raw {data} { - return $data -} - -# ### ### ### ######### ######### ######### ########################### -## Internal commands - -proc ::bench::CheckPkgDirArg {path {expected {}}} { - # Allow empty string, special. - if {![string length $path]} return - - if {![file isdirectory $path]} { - return -code error \ - "The path \"$path\" is not a directory." - } - if {![file readable $path]} { - return -code error \ - "The path \"$path\" is not readable." - } -} - -proc ::bench::Invoke {ip ver pkgdir} { - variable self - # Import remainder of the current configuration/settings. - - upvar 1 DATA DATA match match rmatch rmatch \ - iters iters errors errors threads threads \ - files files - - if {[string length $pkgdir]} { - log::info "Benchmark $ver ($pkgdir) $ip" - set idstr "$ip ($pkgdir)" - } else { - log::info "Benchmark $ver $ip" - set idstr $ip - } - - set DATA([list interp $idstr]) $ver - - set cmd [list $ip [file join $self libbench.tcl] \ - -match $match \ - -rmatch $rmatch \ - -iters $iters \ - -interp $ip \ - -errors $errors \ - -threads $threads \ - -pkgdir $pkgdir \ - ] - - # Determine elapsed time per file, logged. - set start [clock seconds] - - array set tmp {} - - if {$threads} { - foreach f $files { lappend cmd $f } - if {[catch { - close [Process [open |$cmd r+]] - } output]} { - if {$errors} { - error $::errorInfo - } - } - } else { - foreach file $files { - log::info [file tail $file] - if {[catch { - close [Process [open |[linsert $cmd end $file] r+]] - } output]} { - if {$errors} { - error $::errorInfo - } else { - continue - } - } - } - } - - foreach desc [array names tmp] { - set DATA([list desc $desc]) {} - set DATA([list usec $desc $idstr]) $tmp($desc) - } - - unset tmp - set elapsed [expr {[clock seconds] - $start}] - - set hour [expr {$elapsed / 3600}] - set min [expr {$elapsed / 60}] - set sec [expr {$elapsed % 60}] - log::info " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed" - return -} - - -proc ::bench::Process {pipe} { - while {1} { - if {[eof $pipe]} break - if {[gets $pipe line] < 0} break - # AK: FUTURE: Log all lines?! - #puts |$line| - set line [string trim $line] - if {[string equal $line ""]} continue - - Result - Feedback - # Unknown lines are printed. Future: Callback?! - log::info $line - } - return $pipe -} - -proc ::bench::Result {} { - upvar 1 line line - if {[lindex $line 0] ne "RESULT"} return - upvar 2 tmp tmp - foreach {_ desc result} $line break - set tmp($desc) $result - return -code continue -} - -proc ::bench::Feedback {} { - upvar 1 line line - if {[lindex $line 0] ne "LOG"} return - # AK: Future - Run through callback?! - log::info [lindex $line 1] - return -code continue -} - -# ### ### ### ######### ######### ######### ########################### -## Initialize internal data structures. - -namespace eval ::bench { - variable self [file join [pwd] [file dirname [info script]]] - - logger::init bench - logger::import -force -all -namespace log bench -} - -# ### ### ### ######### ######### ######### ########################### -## Ready to run - -package provide bench 0.5 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_read.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_read.tcl deleted file mode 100644 index 5098b95f..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_read.tcl +++ /dev/null @@ -1,162 +0,0 @@ -# bench_read.tcl -- -# -# Management of benchmarks, reading results in various formats. -# -# Copyright (c) 2005 by Andreas Kupries -# library derived from runbench.tcl application (C) Jeff Hobbs. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: bench_read.tcl,v 1.3 2006/06/13 23:20:30 andreas_kupries Exp $ - -# ### ### ### ######### ######### ######### ########################### -## Requisites - Packages and namespace for the commands and data. - -package require Tcl 8.5 9 -package require csv - -namespace eval ::bench::in {} - -# ### ### ### ######### ######### ######### ########################### -## Public API - Result reading - -# ::bench::in::read -- -# -# Read a bench result in any of the raw/csv/text formats -# -# Arguments: -# path to file to read -# -# Results: -# DATA dictionary, internal representation of the bench results. - -proc ::bench::in::read {file} { - - set f [open $file r] - set head [gets $f] - - if {![string match "# -\\*- tcl -\\*- bench/*" $head]} { - return -code error "Bad file format, not a benchmark file" - } else { - regexp {bench/(.*)$} $head -> format - - switch -exact -- $format { - raw - csv - text { - set res [RD$format $f] - } - default { - return -code error "Bad format \"$val\", expected text, csv, or raw" - } - } - } - close $f - return $res -} - -# ### ### ### ######### ######### ######### ########################### -## Internal commands - -proc ::bench::in::RDraw {chan} { - return [string trimright [::read $chan]] -} - -proc ::bench::in::RDcsv {chan} { - # Lines Format - # First line is number of interpreters #n. int - # Next to 1+n is interpreter data. id,ver,path - # Beyond is benchmark results. id,desc,res1,...,res#n - - array set DATA {} - - # #Interp ... - - set nip [lindex [csv::split [gets $chan]] 0] - - # Interp data ... - - set iplist {} - for {set i 0} {$i < $nip} {incr i} { - foreach {__ ver ip} [csv::split [gets $chan]] break - - set DATA([list interp $ip]) $ver - lappend iplist $ip - } - - # Benchmark data ... - - while {[gets $chan line] >= 0} { - set line [string trim $line] - if {$line == {}} break - set line [csv::split $line] - set desc [lindex $line 1] - - set DATA([list desc $desc]) {} - foreach val [lrange $line 2 end] ip $iplist { - if {$val == {}} continue - set DATA([list usec $desc $ip]) $val - } - } - - return [array get DATA] -} - -proc ::bench::in::RDtext {chan} { - array set DATA {} - - # Interp data ... - - # Empty line - ignore - # "id: ver path" - interp data. - # Empty line - separator before benchmark data. - - set n 0 - set iplist {} - while {[gets $chan line] >= 0} { - set line [string trim $line] - if {$line == {}} { - incr n - if {$n == 2} break - continue - } - - regexp {[^:]+: ([^ ]+) (.*)$} $line -> ver ip - set DATA([list interp $ip]) $ver - lappend iplist $ip - } - - # Benchmark data ... - - # '---' -> Ignore. - # '|' column separators. Remove spaces around it. Then treat line - # as CSV data with a particular separator. - # Ignore the INTERP line. - - while {[gets $chan line] >= 0} { - set line [string trim $line] - if {$line == {}} continue - if {[string match "+---*" $line]} continue - if {[string match "*INTERP*" $line]} continue - - regsub -all "\\| +" $line {|} line - regsub -all " +\\|" $line {|} line - set line [csv::split [string trim $line |] |] - set desc [lindex $line 1] - - set DATA([list desc $desc]) {} - foreach val [lrange $line 2 end] ip $iplist { - if {$val == {}} continue - set DATA([list usec $desc $ip]) $val - } - } - - return [array get DATA] -} - -# ### ### ### ######### ######### ######### ########################### -## Initialize internal data structures. - -# ### ### ### ######### ######### ######### ########################### -## Ready to run - -package provide bench::in 0.2 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_wcsv.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_wcsv.tcl deleted file mode 100644 index 321997f6..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_wcsv.tcl +++ /dev/null @@ -1,101 +0,0 @@ -# bench_wtext.tcl -- -# -# Management of benchmarks, formatted text. -# -# Copyright (c) 2005 by Andreas Kupries -# library derived from runbench.tcl application (C) Jeff Hobbs. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: bench_wcsv.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $ - -# ### ### ### ######### ######### ######### ########################### -## Requisites - Packages and namespace for the commands and data. - -package require Tcl 8.5 9 -package require csv - -namespace eval ::bench::out {} - -# ### ### ### ######### ######### ######### ########################### -## Public API - Benchmark execution - -# ### ### ### ######### ######### ######### ########################### -## Public API - Result formatting. - -# ::bench::out::csv -- -# -# Format the result of a benchmark run. -# Style: CSV -# -# Arguments: -# DATA dict -# -# Results: -# String containing the formatted DATA. - -proc ::bench::out::csv {data} { - array set DATA $data - set CSV {} - - # 1st record: #shells - # 2nd record to #shells+1: Interpreter data (id, version, path) - # #shells+2 to end: Benchmark data (id,desc,result1,...,result#shells) - - # --- --- ---- - # #interpreters used - - set ipkeys [array names DATA interp*] - lappend CSV [csv::join [list [llength $ipkeys]]] - - # --- --- ---- - # Table 1: Interpreter information. - - set n 1 - set iplist {} - foreach key [lsort -dict $ipkeys] { - set ip [lindex $key 1] - lappend CSV [csv::join [list $n $DATA($key) $ip]] - set DATA($key) $n - incr n - lappend iplist $ip - } - - # --- --- ---- - # Table 2: Benchmark information - - set dlist {} - foreach key [lsort -dict -index 1 [array names DATA desc*]] { - lappend dlist [lindex $key 1] - } - - set n 1 - foreach desc $dlist { - set record {} - lappend record $n - lappend record $desc - foreach ip $iplist { - if {[catch { - lappend record $DATA([list usec $desc $ip]) - }]} { - lappend record {} - } - } - lappend CSV [csv::join $record] - incr n - } - - return [join $CSV \n] -} - -# ### ### ### ######### ######### ######### ########################### -## Internal commands - -# ### ### ### ######### ######### ######### ########################### -## Initialize internal data structures. - -# ### ### ### ######### ######### ######### ########################### -## Ready to run - -package provide bench::out::csv 0.1.3 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_wtext.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_wtext.tcl deleted file mode 100644 index 8c16b21a..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/bench_wtext.tcl +++ /dev/null @@ -1,165 +0,0 @@ -# bench_wtext.tcl -- -# -# Management of benchmarks, formatted text. -# -# Copyright (c) 2005 by Andreas Kupries -# library derived from runbench.tcl application (C) Jeff Hobbs. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: bench_wtext.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $ - -# ### ### ### ######### ######### ######### ########################### -## Requisites - Packages and namespace for the commands and data. - -package require Tcl 8.5 9 -package require struct::matrix -package require report - -namespace eval ::bench::out {} - -# ### ### ### ######### ######### ######### ########################### -## Public API - Result formatting. - -# ::bench::out::text -- -# -# Format the result of a benchmark run. -# Style: TEXT -# -# General structure like CSV, but nicely formatted and aligned -# columns. -# -# Arguments: -# DATA dict -# -# Results: -# String containing the formatted DATA. - -proc ::bench::out::text {data} { - array set DATA $data - set LINES {} - - # 1st line to #shells: Interpreter data (id, version, path) - # #shells+1 to end: Benchmark data (id,desc,result1,...,result#shells) - - lappend LINES {} - - # --- --- ---- - # Table 1: Interpreter information. - - set ipkeys [array names DATA interp*] - set n 1 - set iplist {} - set vlen 0 - foreach key [lsort -dict $ipkeys] { - lappend iplist [lindex $key 1] - incr n - set l [string length $DATA($key)] - if {$l > $vlen} {set vlen $l} - } - set idlen [string length $n] - - set dlist {} - set n 1 - foreach key [lsort -dict -index 1 [array names DATA desc*]] { - lappend dlist [lindex $key 1] - incr n - } - set didlen [string length $n] - - set n 1 - set record [list "" INTERP] - foreach ip $iplist { - set v $DATA([list interp $ip]) - lappend LINES " [PADL $idlen $n]: [PADR $vlen $v] $ip" - lappend record $n - incr n - } - - lappend LINES {} - - # --- --- ---- - # Table 2: Benchmark information - - set m [struct::matrix m] - $m add columns [expr {2 + [llength $iplist]}] - $m add row $record - - set n 1 - foreach desc $dlist { - set record [list $n] - lappend record $desc - - foreach ip $iplist { - if {[catch { - set val $DATA([list usec $desc $ip]) - }]} { - set val {} - } - if {[string is double -strict $val]} { - lappend record [format %.2f $val] - } else { - lappend record [format %s $val] - } - } - $m add row $record - incr n - } - - ::report::defstyle simpletable {} { - data set [split "[string repeat "| " [columns]]|"] - top set [split "[string repeat "+ - " [columns]]+"] - bottom set [top get] - top enable - bottom enable - - set c [columns] - justify 0 right - pad 0 both - - if {$c > 1} { - justify 1 left - pad 1 both - } - for {set i 2} {$i < $c} {incr i} { - justify $i right - pad $i both - } - } - ::report::defstyle captionedtable {{n 1}} { - simpletable - topdata set [data get] - topcapsep set [top get] - topcapsep enable - tcaption $n - } - - set r [report::report r [$m columns] style captionedtable] - lappend LINES [$m format 2string $r] - $m destroy - $r destroy - - return [join $LINES \n] -} - -# ### ### ### ######### ######### ######### ########################### -## Internal commands - -proc ::bench::out::PADL {max str} { - format "%${max}s" $str - #return "[PAD $max $str]$str" -} - -proc ::bench::out::PADR {max str} { - format "%-${max}s" $str - #return "$str[PAD $max $str]" -} - -# ### ### ### ######### ######### ######### ########################### -## Initialize internal data structures. - -# ### ### ### ######### ######### ######### ########################### -## Ready to run - -package provide bench::out::text 0.1.3 diff --git a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/libbench.tcl b/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/libbench.tcl deleted file mode 100644 index ebf9f716..00000000 --- a/src/vfs/punk9ubuntu.vfs/lib_tcl9/tcllib2.0/bench/libbench.tcl +++ /dev/null @@ -1,561 +0,0 @@ -# -*- tcl -*- -# libbench.tcl ?(