Index: tolsh/tolsh.vfs/lib/app-tolsh/tolsh.tcl =================================================================== --- tolsh/tolsh.vfs/lib/app-tolsh/tolsh.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ tolsh/tolsh.vfs/lib/app-tolsh/tolsh.tcl (revision 6d7779d88a35f4606432b88f2eceba8b66c4516b) @@ -30,13 +30,10 @@ # By default load initLibrary # - set options(lang) "" + set options(lang) 0 set options(initlib) 1 - set options(iniproject) 1 - set options(defaultpackages) 1 set options(compile) "" set options(vmode) "" set options(out,enabled) no set options(runmode) "" - set options(tolversion) "" } @@ -48,5 +45,4 @@ # # -i --> do not include initLibrary -# -np --> do not load _iniproject.tol # -c"..." --> compile a tol expression # -c "..." --> compile a tol expression @@ -64,6 +60,5 @@ # -e?n? --> use english language # -s?p? --> use spanish language -# -tolversion ver --> specify an strict tol version to start with -# -server [port] --> start tol as a server tolsvc..log will be the log +# -server [port] --> start tol as a server tolsvc..log will be the log # [port] is the port number where the serve will be listening. # @@ -75,6 +70,4 @@ proc ::tolsh::getoptions { cmdline } { variable options - - logtmp "entering ::tolsh::getoptions $cmdline" # cmdline could be a bad list so the next sentence could fail. @@ -84,20 +77,15 @@ set i 0 while {$i < $num} { - logtmp "set item [lindex $cmdline $i]" set item [lindex $cmdline $i] if {[string index $item 0] eq "-"} { set opt [string range $item 1 end] if {$opt eq "e" || $opt eq "en"} { - set options(lang) "en" + set $options(lang) 0 } elseif {$opt eq "s" || $opt eq "sp"} { - set options(lang) "es" + set $options(lang) 1 } elseif {$opt eq "i"} { # initLibrary should not be loaded # set options(initlib) 0 - } elseif {$opt eq "ndp"} { - set options(defaultpackages) 0 - } elseif {$opt eq "np"} { - set options(iniproject) 0 } elseif {[string index $opt 0] eq "c"} { if {[string length $opt]>1} { @@ -143,7 +131,4 @@ } set options(runmode) "interactive" - } elseif {$opt eq "tolversion"} { - incr i - set options(tolversion) [lindex $cmdline $i] } elseif {$opt eq "server"} { # check if next argument is the port number @@ -165,24 +150,4 @@ exit } - } elseif {$opt eq "slave"} { - # the next argument is the port number - set options(server,port) [lindex $cmdline [expr {$i+1}]] - incr i - if {$options(runmode) ne "" && $options(runmode) ne "slave"} { - puts "Replacing previous run mode '$options(runmode)' with 'slave'" - } - set options(runmode) "slave" - } elseif {$opt eq "shared"} { - # the next argument is the port number - set options(shared,port) [lindex $cmdline [expr {$i+1}]] - incr i - if {$options(runmode) ne "" && $options(runmode) ne "shared"} { - puts "Replacing previous run mode '$options(runmode)' with 'shared'" - } - set options(runmode) "shared" - } elseif {$opt eq "shport"} { - # the next argument is the port number - set options(shared,port) [lindex $cmdline [expr {$i+1}]] - incr i } else { append delayed_msg "\nignoring unknown option: '$item'" @@ -234,5 +199,5 @@ puts { -i file --> include a file but not initLibrary - -np --> do not load _iniproject.tol + -c"..." --> compile a tol expression -c "..." --> compile a tol expression -v?A? --> enable all output @@ -249,7 +214,6 @@ -e?n? --> use english language -s?p? --> use spanish language - -tolversion --> specify an strict tol version to start with - -server [port] --> start tol as a server tolsvc..log will be the log - [port] is the port number where the serve will be listening. + -server [port] --> start tol as a server tolsvc..log will be the log + [port] is the port number where the serve will be listening. Multiple verbose mode is accepted in one option, for instance, @@ -284,13 +248,5 @@ } -#puts "starkit = [namespace exist ::starkit]" -#puts "topdir = [file dir $starkit::topdir]" -#puts "info script = [info script]" -#puts "starkit::startup = [starkit::startup]" -#puts "[ info commands starkit::* ]" -#puts "argv0 = $argv0" - proc ::tolsh::setup_pkg { pkg } { - #puts ":tolsh::setup_pkg $pkg [namespace exist ::starkit] " if {[lsearch [package names] $pkg]==-1} { if {[namespace exist ::starkit]} { @@ -300,13 +256,4 @@ if {[llength $pkg_dirs]} { lappend ::auto_path [file normalize $libdir] - } elseif { $::tcl_platform(platform) eq "unix" } { - set activeTcl "/opt/ActiveTcl-8.4/lib" - if { [ file exists $activeTcl ] && - [ lsearch $::auto_path $activeTcl ] == -1 } { - lappend ::auto_path $activeTcl - } - if { [ lsearch $::auto_path "/usr/lib" ] == -1 } { - lappend ::auto_path "/usr/lib" - } } else { set tclsh [auto_execok tclsh] @@ -320,5 +267,5 @@ } } - } + } tclPkgUnknown ${pkg}+1 "" } else { @@ -342,31 +289,7 @@ ############################################################################### proc ::tolsh::setup_autopath { } { - logtmp "entering ::tolsh::setup_autopath" - setup_pkg toltcl setup_pkg tolcomm setup_pkg tlogger - setup_pkg tequila - setup_pkg tequilas - - logtmp "auto_path = $::auto_path" - logtmp "leaving ::tolsh::setup_autopath" -} - -proc GetHomeDir { } { - global env - # Check if we're using windows - if { $::tcl_platform(platform) eq "windows" } { - package require registry 1.0 - set key1 {HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders} - set key2 {Personal} - set env_home [ registry get $key1 $key2 ] - if {[string match %USERPROFILE%* $env_home]} { - set env_home [string replace $env_home 0 12 $env(USERPROFILE)] - } - } else { - set env_home $env(HOME) - } - return $env_home } @@ -379,82 +302,63 @@ variable options - #logtmp "user : [ exec whoami ]" - logtmp "entering run with cmdline = $cmdline" # Process command line options # getoptions $cmdline - logtmp "options(compile): $options(compile)" - logtmp "options(runmode): $options(runmode)" if {![something_to_compile] && ($options(runmode) eq "")} { show_usage return } + + # Ensure Toltcl is found + # + setup_autopath + + # Load Toltcl (+tol) + # + package require Toltcl + tol::initkernel $options(lang) $options(vmode) + + # Load initLibrary if required + # + if {$options(initlib)} { + tol::initlibrary + } + + set appdata [string trim \ + [lindex [::tol::info var Text TolAppDataPath] 0] \"] + + set tolcomm_dir [file join $appdata tolcomm] + file mkdir $tolcomm_dir + + # load rmtps_client + # + if {[catch {package require rmtps_client} msg]} { + std "could not load rmtps_client: $msg" + } else { + ::rmtps_client::init [file join $tolcomm_dir "rmtps_client.log"] + if {[catch rmtps_client::define_TOLAPI msg]} { + std "could not load tol code for rmtps_client: $msg" + } + } - logtmp "pase getoptions" - - # Ensure Toltcl is found - # - setup_autopath - - # Load Toltcl (+tol) and initLibrary if required - # - if {$options(runmode) != "server" && $options(runmode) != "shared"} { - package require -exact Toltcl 3.3 - #puts "tol::initkernel $options(lang) $options(vmode)" - tol::initkernel $options(lang) $options(vmode) - - if {$options(initlib)} { - tol::initlibrary -initproject $options(iniproject) \ - -defaultpackages $options(defaultpackages) + # load tolclient + # + if {[catch {package require tolclient} msg]} { + std "could not load tolclient: $msg" + } else { + ::tolclient::init [file join $tolcomm_dir "tolclient.log"] + if {[catch ::tolclient::define_TOLAPI msg]} { + std "could not load tol code for rmtps_client: $msg" } - # why should I do that? - if { $options(lang) ne "" } { - ::tol::language $options(lang) + } + + # Compile expression and tol file provided in the command line + # + foreach item $options(compile) { + if {[lindex $item 0] eq "expr"} { + tol::console eval [lindex $item 1] + } elseif {[lindex $item 0] eq "file"} { + tol::include [lindex $item 1] } - set appdata [string trim \ - [lindex [::tol::info var [list Text TolAppDataPath]] 2] \"] - logtmp "appdata = $appdata" - } - - set tolcomm_dir [file join [GetHomeDir] ".tol" "tolcomm"] - file mkdir $tolcomm_dir - - # load rmtps_client and tolclient if required - # - if {$options(runmode) != "server" && $options(runmode) != "shared"} { - - if {[catch {package require rmtps_client} msg]} { - std "could not load rmtps_client: $msg" - } else { - ::rmtps_client::init [file join $tolcomm_dir "rmtps_client.log"] - if {[catch rmtps_client::define_TOLAPI msg]} { - std "could not load tol code for rmtps_client: $msg" - } - } - - if {[catch {package require tolclient} msg]} { - std "could not load tolclient: $msg" - } else { - ::tolclient::init [file join $tolcomm_dir "tolclient.log"] - if {[catch ::tolclient::define_TOLAPI msg]} { - std "could not load tol code for rmtps_client: $msg" - } - } - - } - - # Compile expression and tol file provided in the command line if required - # - if {$options(runmode) != "server" && $options(runmode) != "shared" \ - && $options(runmode) != "slave" } { - - foreach item $options(compile) { - if {[lindex $item 0] eq "expr"} { - tol::console eval [lindex $item 1] - } elseif {[lindex $item 0] eq "file"} { - tol::include [lindex $item 1] - } - } - } @@ -467,81 +371,11 @@ # enter the tcl event loop vwait __forever__ - } elseif {$options(runmode) eq "server"} { - #puts "runmode=server" - run_as_server $tolcomm_dir - - } elseif {$options(runmode) eq "shared"} { - #puts "runmode=shared" - run_as_shared $tolcomm_dir - - } elseif {$options(runmode) eq "slave"} { - #puts "runmode=slave" - run_as_slave $tolcomm_dir - } -} - -proc ::tolsh::run_as_server {tolcomm_dir} { - variable options - package require tolserver - - set shared_port [ clone ] - tolserver::start -port $options(server,port) \ - -shport $shared_port \ - -logfile [file join $tolcomm_dir "tolserver.log"] \ - -compile $options(compile) - vwait __forever__ -} - -proc ::tolsh::find_shared_port { port } { - puts "::tolsh::find_shared_port $port" - set i 0 - while { $i < 100 } { - if { [ catch { socket localhost $port } fd ] } { - puts "find_shared_port OK = $port" - return $port - } - incr port - incr i - } - puts "find_shared_port FAIL!" - return 0 -} - -proc ::tolsh::clone {} { - variable options - - puts "::tolsh::clone" - set tolsh [list [info nameofexecutable] ] - if { $starkit::tolsh_mode ne "starpack" } { - lappend tolsh $::argv0 - } - set shared_port [ find_shared_port 20458 ] - if { !$shared_port } { - puts "::tolsh::clone: could not find a valid port for shared data" - exit - } - eval exec $tolsh -shared $shared_port & - after 5000 ;# wait for data sharing are created by 'shared' - puts "exec slave" - eval exec $tolsh -slave $options(server,port) -shport $shared_port & - return $shared_port -} - -proc ::tolsh::run_as_shared { tolcomm_dir } { - package require tolshared - variable options - - tolshared::start $options(shared,port) $tolcomm_dir -} - -proc ::tolsh::run_as_slave { tolcomm_dir } { - variable options - package require tolslave - - tolslave::start -port $options(server,port) -shport $options(shared,port) \ - -logfile [file join $tolcomm_dir "tolslave.log"] - vwait __forever__ -} + package require tolserver + tolserver::start -port $options(server,port) \ + -logfile [file join $tolcomm_dir "tolserver.log"] + vwait __forever__ + } +} proc ::tolsh::console_cmd { cmd } { @@ -582,12 +416,3 @@ } -proc logtmp { msg } { - return - set user $::tcl_platform(user) - set fd [ open "/tmp/tolsh.${user}.log" a ] - puts $fd $msg - flush $fd - close $fd -} - ::tolsh::run $argv Index: tolsh/tolsh.vfs/lib/base64/base64.tcl =================================================================== --- tolsh/tolsh.vfs/lib/base64/base64.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,326 +1,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. -# -# RCS: @(#) $Id: base64.tcl,v 1.27 2005/12/09 18:27:15 andreas_kupries Exp $ - -# 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 - -# @mdgen EXCLUDE: base64c.tcl - -package require Tcl 8.2 -namespace eval ::base64 { - namespace export encode decode -} - -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 output - # of GNU uuencode 4.2. Various RFCs allow for different wrapping - # characters and wraplengths, so these may be overridden by command line - # options. - set wrapchar "\n" - set maxlen 60 - - 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}}]} { - error "expected integer but got \"$maxlen\"" - } - - set string [lindex $args end] - set result [::base64 -mode encode -- $string] - set result [string map [list \n ""] $result] - - if {$maxlen > 0} { - set res "" - set edge [expr {$maxlen - 1}] - while {[string length $result] > $maxlen} { - append res [string range $result 0 $edge]$wrapchar - set result [string range $result $maxlen end] - } - if {[string length $result] > 0} { - append res $result - } - 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. - - 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' - 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 output - # of GNU uuencode 4.2. Various RFCs allow for different wrapping - # characters and wraplengths, so these may be overridden by command line - # options. - set wrapchar "\n" - set maxlen 60 - - 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}}]} { - error "expected 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 { - # Do the line length check before appending so that we don't get an - # extra newline if the output is a multiple of $maxlen chars long. - if {$maxlen && $length >= $maxlen} { - append result $wrapchar - set length 0 - } - - append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] - if {$y != {}} { - append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] - if {$z != {}} { - append result \ - [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] - append result [lindex $base64_en [expr {($z & 0x3F)}]] - } else { - set state 2 - break - } - } else { - set state 1 - break - } - incr length 4 - } - if {$state == 1} { - append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== - } elseif {$state == 2} { - append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]= - } - 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} { - if {[string length $string] == 0} {return ""} - - set base64 $::base64::base64 - set output "" ; # Fix for [Bug 821126] - - binary scan $string c* X - 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. - # The encoding algorithm dictates that we can only have 1 or 2 - # padding characters. If x=={}, we 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). - - foreach {v w z} $nums break - 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 - } -} - -package provide base64 2.3.2 Index: tolsh/tolsh.vfs/lib/base64/base64c.tcl =================================================================== --- tolsh/tolsh.vfs/lib/base64/base64c.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,18 +1,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. -# - -package require critcl -package provide base64c 0.1.0 - -namespace eval ::base64c { - variable base64c_rcsid {$Id: base64c.tcl,v 1.4 2006/11/04 15:20:36 patthoyts Exp $} - - critcl::ccode { - /* no code required in this file */ - } -} Index: tolsh/tolsh.vfs/lib/base64/pkgIndex.tcl =================================================================== --- tolsh/tolsh.vfs/lib/base64/pkgIndex.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,4 +1,0 @@ -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded base64 2.3.2 [list source [file join $dir base64.tcl]] -package ifneeded uuencode 1.1.4 [list source [file join $dir uuencode.tcl]] -package ifneeded yencode 1.1.1 [list source [file join $dir yencode.tcl]] Index: tolsh/tolsh.vfs/lib/base64/uuencode.tcl =================================================================== --- tolsh/tolsh.vfs/lib/base64/uuencode.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,346 +1,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. -# ------------------------------------------------------------------------- -# @(#)$Id: uuencode.tcl,v 1.21 2006/10/14 06:30:55 andreas_kupries Exp $ - -package require Tcl 8.2; # tcl minimum version - -# Try and get some compiled helper package. -if {[catch {package require tcllibc}]} { - catch {package require Trf} -} - -namespace eval ::uuencode { - variable version 1.1.4 - - 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) & 060) | (($c2 >> 4) & 017)}]] - append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] - append r [Enc [expr {($c3 & 077)}]] - } - 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; - int len, rlen, xtra; - unsigned char *input, *p, *r; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); - if ((xtra = (3 - (len % 3))) != 3) { - if (Tcl_IsShared(inputPtr)) - inputPtr = Tcl_DuplicateObj(inputPtr); - input = Tcl_SetByteArrayLength(inputPtr, len + xtra); - memset(input + len, 0, xtra); - len += xtra; - } - - rlen = (len / 3) * 4; - resultPtr = Tcl_GetObjResult(interp); - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - r = Tcl_SetByteArrayLength(resultPtr, rlen); - 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); - } - - return TCL_OK; - } - - critcl::ccommand CDecode {dummy interp objc objv} { - Tcl_Obj *inputPtr, *resultPtr; - int len, rlen, xtra; - unsigned char *input, *p, *r; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - /* if input is not mod 4, extend it with nuls */ - inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); - if ((xtra = (4 - (len % 4))) != 4) { - if (Tcl_IsShared(inputPtr)) - inputPtr = Tcl_DuplicateObj(inputPtr); - input = Tcl_SetByteArrayLength(inputPtr, len + xtra); - 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_GetObjResult(interp); - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - r = Tcl_SetByteArrayLength(resultPtr, rlen); - 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) ); - } - - 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 command ::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 0644 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 0644 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 $::uuencode::version - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: - Index: tolsh/tolsh.vfs/lib/base64/yencode.tcl =================================================================== --- tolsh/tolsh.vfs/lib/base64/yencode.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,315 +1,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. -# ------------------------------------------------------------------------- -# @(#)$Id: yencode.tcl,v 1.11 2005/09/28 04:51:19 andreas_kupries Exp $ - -package require Tcl 8.2; # tcl minimum version -catch {package require crc32}; # tcllib 1.1 -catch {package require tcllibc}; # critcl enhancements for tcllib - -namespace eval ::yencode { - variable version 1.1.1 - 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 + 42) % 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 - 42) % 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; - int len, rlen, xtra; - unsigned char *input, *p, *r, v; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - /* fetch the input data */ - inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); - - /* 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_GetObjResult(interp); - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - r = Tcl_SetByteArrayLength(resultPtr, rlen); - - /* 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 + 42) % 256; - } - *r++ = v; - } - - return TCL_OK; - } - - critcl::ccommand CDecode {dummy interp objc objv} { - Tcl_Obj *inputPtr, *resultPtr; - int len, rlen, esc; - unsigned char *input, *p, *r, v; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - /* fetch the input data */ - inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); - - /* allocate the output buffer */ - resultPtr = Tcl_GetObjResult(interp); - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - r = Tcl_SetByteArrayLength(resultPtr, len); - - /* 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 - 42) % 256; - esc = 0; - } - *r++ = v; - rlen++; - } - Tcl_SetByteArrayLength(resultPtr, rlen); - - return TCL_OK; - } - } -} - -if {[info command ::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) r] - 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 $::yencode::version - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: - Index: tolsh/tolsh.vfs/lib/tcllib1.10/aes/aes.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/aes/aes.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,595 +1,0 @@ -# aes.tcl - -# -# Copyright (c) 2005 Thorsten Schloermann -# Copyright (c) 2005 Pat Thoyts -# -# 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.2 - -namespace eval ::aes { - variable version 1.0.0 - variable rcsid {$Id: aes.tcl,v 1.5 2005/09/04 17:15:56 patthoyts Exp $} - 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 - array set state [list M $mode K $key I $iv 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 - set state(I) $iv - 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 I4 data] != 1} { - return -code error "invalid block size: blocks must be 16 bytes" - } - - if {[string equal $state(M) cbc]} { - if {[binary scan $state(I) I4 iv] != 1} { - return -code error "invalid initialization vector: must be 16 bytes" - } - for {set n 0} {$n < 4} {incr n} { - lappend data2 [expr {[lindex $data $n] ^ [lindex $iv $n]}] - } - set data $data2 - } - - 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]]] - return [set state(I) [binary format I4 $data]] -} - -# 5.3: Inverse Cipher: Decipher a single 128 bit block. -proc ::aes::DecryptBlock {Key block} { - upvar #0 $Key state - if {[binary scan $block I4 data] != 1} { - return -code error "invalid block size: block must be 16 bytes" - } - - 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 {[string equal $state(M) cbc]} { - if {[binary scan $state(I) I4 iv] != 1} { - return -code error "invalid initialization vector: must be 16 bytes" - } - for {set n 0} {$n < 4} {incr n} { - lappend data2 [expr {[lindex $data $n] ^ [lindex $iv $n]}] - } - set data $data2 - } - - set state(I) $block - return [binary format I4 $data] -} - -# 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 $state(Nk) ; incr h -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 - return -} - -# 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} { - set r {} - foreach w $words { - lappend r [SubWord $w] - } - return $r -} - -# 5.3.2: InvSubBytes() Transformation -proc ::aes::InvSubBytes {words} { - set r {} - foreach w $words { - lappend r [InvSubWord $w] - } - return $r -} - -# 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 - } - return [lindex $xtime $number] -} - -proc ::aes::GFMult3 {number} { - # multliply by 2 (via GFMult2) and add the number again on the result (via XOR) - return [expr {$number ^ [GFMult2 $number]}] -} - -proc ::aes::GFMult09 {number} { - # 09 is: (02*02*02) + 01 - return [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] - return [expr {[GFMult09 $number] ^ [GFMult2 $number]}] -} - -proc ::aes::GFMult0d {number} { - # 0d is: (02*02*02) + (02*02) + 01 - set temp [GFMult2 [GFMult2 $number]] - return [expr {[GFMult2 $temp] ^ ($temp ^ $number)}] -} - -proc ::aes::GFMult0e {number} { - # 0e is: (02*02*02) + (02*02) + 02 - set temp [GFMult2 [GFMult2 $number]] - return [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::DecryptBlock -- -# -# Decrypt a 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 -} - -# ------------------------------------------------------------------------- -# Fileevent handler for chunked file reading. -# -proc ::aes::Chunk {Key in {out {}} {chunksize 4096}} { - upvar #0 $Key state - - if {[eof $in]} { - fileevent $in readable {} - set state(reading) 0 - } - - set data [read $in $chunksize] - # FIX ME: we should ony pad after eof - set data [Pad $data 16] - - if {$out == {}} { - 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" - } - return [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 $varname args - set r [lindex $args $nth] - set args [lreplace $args $nth $nth] - return $r -} - -proc ::aes::Hex {data} { - binary scan $data H* r - 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 {[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) == {}} { - return -code error "no key provided: the -key option is required" - } - - set r {} - if {$opts(-in) == {}} { - - 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) != {}} { - 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)] - upvar $Key state - set state(reading) 1 - if {[string equal $opts(-dir) "encrypt"]} { - set state(cmd) Encrypt - } else { - set state(cmd) Decrypt - } - set state(output) "" - fileevent $opts(-in) readable \ - [list [namespace origin Chunk] \ - $Key $opts(-in) $opts(-out) $opts(-chunksize)] - 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)} { - set r [Hex $r] - } - return $r -} - -# ------------------------------------------------------------------------- - -package provide aes $::aes::version - -# ------------------------------------------------------------------------- -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: Index: tolsh/tolsh.vfs/lib/tcllib1.10/aes/pkgIndex.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/aes/pkgIndex.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,5 +1,0 @@ -if {![package vsatisfies [package provide Tcl] 8.2]} { - # PRAGMA: returnok - return -} -package ifneeded aes 1.0.0 [list source [file join $dir aes.tcl]] Index: tolsh/tolsh.vfs/lib/tcllib1.10/asn/asn.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/asn/asn.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,1498 +1,0 @@ -#----------------------------------------------------------------------------- -# Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de) -# Copyright (C) 2004-2007 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.17 2007/04/21 12:35:14 mic42 Exp $ -# -#----------------------------------------------------------------------------- - -# needed for using wide() -package require Tcl 8.4 - -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*B* 03 [asnLength $len] $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 bytelength $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" - } -} - -#----------------------------------------------------------------------------- -# asnGetByte : Retrieve a single byte from the data (unsigned) -#----------------------------------------------------------------------------- - -proc ::asn::asnGetByte {data_var byte_var} { - upvar $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 -} - -#----------------------------------------------------------------------------- -# 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] -} - -#----------------------------------------------------------------------------- -# 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 -} - - -#----------------------------------------------------------------------------- -# 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 completness. - # - 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 1 $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 $integerBytes H* hex - set bignum [math::bignum::fromstr $hex 16] - set bits [math::bignum::bits $bignum] - set exp [math::bignum::pow \ - [math::bignum::fromstr 2] \ - [math::bignum::fromstr $bits]] - set big [math::bignum::sub $bignum $exp] - set bignum $big - - return -} - - - -#----------------------------------------------------------------------------- -# 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 bytelength $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.1 - Index: tolsh/tolsh.vfs/lib/tcllib1.10/asn/pkgIndex.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/asn/pkgIndex.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,4 +1,0 @@ -# Tcl package index file, version 1.1 - -if {![package vsatisfies [package provide Tcl] 8.4]} {return} -package ifneeded asn 0.8.1 [list source [file join $dir asn.tcl]] Index: tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,182 +1,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.4 - -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 Index: tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32_c.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32_c.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,253 +1,0 @@ -# base32c.tcl -- -# -# Implementation of a base32 (std) de/encoder for Tcl. -# -# Public domain -# -# RCS: @(#) $Id: base32_c.tcl,v 1.2 2006/05/28 04:29:09 andreas_kupries Exp $ - -package require critcl -package require Tcl 8.4 - -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; - int 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); - return TCL_ERROR; - } - - buf = Tcl_GetByteArrayFromObj (objv[1], &nbuf); - 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 (out, nout)); - Tcl_Free ((char*) out); - return TCL_OK; - } - - - critcl::ccommand critcl_decode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_decode estring - */ - - unsigned char* buf; - int 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); - return TCL_ERROR; - } - - buf = Tcl_GetStringFromObj (objv[1], &nbuf); - - if (nbuf % 8) { - Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); - 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)); - 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)); - 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)); - return TCL_ERROR; - } - } - - Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); - Tcl_Free ((char*) out); - return TCL_OK; - } -} - -# ### ### ### ######### ######### ######### -## Ready Index: tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32_tcl.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32_tcl.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,73 +1,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 Index: tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32core.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32core.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,134 +1,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.1 Index: tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32hex.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32hex.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,175 +1,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.2 2007/03/23 17:31:17 andreas_kupries Exp $ - -# @mdgen EXCLUDE: base32hex_c.tcl - -package require Tcl 8.4 - -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} -} - -# ### ### ### ######### ######### ######### -## 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.1 Index: tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32hex_c.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32hex_c.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,253 +1,0 @@ -# base32hexc.tcl -- -# -# Implementation of a base32 (extended hex) de/encoder for Tcl. -# -# Public domain -# -# RCS: @(#) $Id: base32hex_c.tcl,v 1.2 2006/05/28 04:29:09 andreas_kupries Exp $ - -package require critcl -package require Tcl 8.4 - -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; - int 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); - return TCL_ERROR; - } - - buf = Tcl_GetByteArrayFromObj (objv[1], &nbuf); - 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 (out, nout)); - Tcl_Free ((char*) out); - return TCL_OK; - } - - - critcl::ccommand critcl_decode {dummy interp objc objv} { - /* Syntax -*- c -*- - * critcl_decode estring - */ - - unsigned char* buf; - int 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); - return TCL_ERROR; - } - - buf = Tcl_GetStringFromObj (objv[1], &nbuf); - - if (nbuf % 8) { - Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); - 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)); - 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)); - 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)); - return TCL_ERROR; - } - } - - Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); - Tcl_Free ((char*) out); - return TCL_OK; - } -} - -# ### ### ### ######### ######### ######### -## Ready Index: tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32hex_tcl.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base32/base32hex_tcl.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,79 +1,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 Index: tolsh/tolsh.vfs/lib/tcllib1.10/base32/pkgIndex.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base32/pkgIndex.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,4 +1,0 @@ -if {![package vsatisfies [package provide Tcl] 8.4]} return -package ifneeded base32 0.1 [list source [file join $dir base32.tcl]] -package ifneeded base32::hex 0.1 [list source [file join $dir base32hex.tcl]] -package ifneeded base32::core 0.1 [list source [file join $dir base32core.tcl]] Index: tolsh/tolsh.vfs/lib/tcllib1.10/base64/base64.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base64/base64.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,326 +1,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. -# -# RCS: @(#) $Id: base64.tcl,v 1.27 2005/12/09 18:27:15 andreas_kupries Exp $ - -# 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 - -# @mdgen EXCLUDE: base64c.tcl - -package require Tcl 8.2 -namespace eval ::base64 { - namespace export encode decode -} - -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 output - # of GNU uuencode 4.2. Various RFCs allow for different wrapping - # characters and wraplengths, so these may be overridden by command line - # options. - set wrapchar "\n" - set maxlen 60 - - 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}}]} { - error "expected integer but got \"$maxlen\"" - } - - set string [lindex $args end] - set result [::base64 -mode encode -- $string] - set result [string map [list \n ""] $result] - - if {$maxlen > 0} { - set res "" - set edge [expr {$maxlen - 1}] - while {[string length $result] > $maxlen} { - append res [string range $result 0 $edge]$wrapchar - set result [string range $result $maxlen end] - } - if {[string length $result] > 0} { - append res $result - } - 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. - - 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' - 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 output - # of GNU uuencode 4.2. Various RFCs allow for different wrapping - # characters and wraplengths, so these may be overridden by command line - # options. - set wrapchar "\n" - set maxlen 60 - - 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}}]} { - error "expected 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 { - # Do the line length check before appending so that we don't get an - # extra newline if the output is a multiple of $maxlen chars long. - if {$maxlen && $length >= $maxlen} { - append result $wrapchar - set length 0 - } - - append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] - if {$y != {}} { - append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] - if {$z != {}} { - append result \ - [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] - append result [lindex $base64_en [expr {($z & 0x3F)}]] - } else { - set state 2 - break - } - } else { - set state 1 - break - } - incr length 4 - } - if {$state == 1} { - append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== - } elseif {$state == 2} { - append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]= - } - 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} { - if {[string length $string] == 0} {return ""} - - set base64 $::base64::base64 - set output "" ; # Fix for [Bug 821126] - - binary scan $string c* X - 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. - # The encoding algorithm dictates that we can only have 1 or 2 - # padding characters. If x=={}, we 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). - - foreach {v w z} $nums break - 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 - } -} - -package provide base64 2.3.2 Index: tolsh/tolsh.vfs/lib/tcllib1.10/base64/base64c.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base64/base64c.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,18 +1,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. -# - -package require critcl -package provide base64c 0.1.0 - -namespace eval ::base64c { - variable base64c_rcsid {$Id: base64c.tcl,v 1.4 2006/11/04 15:20:36 patthoyts Exp $} - - critcl::ccode { - /* no code required in this file */ - } -} Index: tolsh/tolsh.vfs/lib/tcllib1.10/base64/pkgIndex.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base64/pkgIndex.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,4 +1,0 @@ -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded base64 2.3.2 [list source [file join $dir base64.tcl]] -package ifneeded uuencode 1.1.4 [list source [file join $dir uuencode.tcl]] -package ifneeded yencode 1.1.1 [list source [file join $dir yencode.tcl]] Index: tolsh/tolsh.vfs/lib/tcllib1.10/base64/uuencode.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base64/uuencode.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,346 +1,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. -# ------------------------------------------------------------------------- -# @(#)$Id: uuencode.tcl,v 1.21 2006/10/14 06:30:55 andreas_kupries Exp $ - -package require Tcl 8.2; # tcl minimum version - -# Try and get some compiled helper package. -if {[catch {package require tcllibc}]} { - catch {package require Trf} -} - -namespace eval ::uuencode { - variable version 1.1.4 - - 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) & 060) | (($c2 >> 4) & 017)}]] - append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] - append r [Enc [expr {($c3 & 077)}]] - } - 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; - int len, rlen, xtra; - unsigned char *input, *p, *r; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); - if ((xtra = (3 - (len % 3))) != 3) { - if (Tcl_IsShared(inputPtr)) - inputPtr = Tcl_DuplicateObj(inputPtr); - input = Tcl_SetByteArrayLength(inputPtr, len + xtra); - memset(input + len, 0, xtra); - len += xtra; - } - - rlen = (len / 3) * 4; - resultPtr = Tcl_GetObjResult(interp); - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - r = Tcl_SetByteArrayLength(resultPtr, rlen); - 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); - } - - return TCL_OK; - } - - critcl::ccommand CDecode {dummy interp objc objv} { - Tcl_Obj *inputPtr, *resultPtr; - int len, rlen, xtra; - unsigned char *input, *p, *r; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - /* if input is not mod 4, extend it with nuls */ - inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); - if ((xtra = (4 - (len % 4))) != 4) { - if (Tcl_IsShared(inputPtr)) - inputPtr = Tcl_DuplicateObj(inputPtr); - input = Tcl_SetByteArrayLength(inputPtr, len + xtra); - 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_GetObjResult(interp); - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - r = Tcl_SetByteArrayLength(resultPtr, rlen); - 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) ); - } - - 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 command ::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 0644 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 0644 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 $::uuencode::version - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: - Index: tolsh/tolsh.vfs/lib/tcllib1.10/base64/yencode.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/base64/yencode.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,315 +1,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. -# ------------------------------------------------------------------------- -# @(#)$Id: yencode.tcl,v 1.11 2005/09/28 04:51:19 andreas_kupries Exp $ - -package require Tcl 8.2; # tcl minimum version -catch {package require crc32}; # tcllib 1.1 -catch {package require tcllibc}; # critcl enhancements for tcllib - -namespace eval ::yencode { - variable version 1.1.1 - 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 + 42) % 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 - 42) % 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; - int len, rlen, xtra; - unsigned char *input, *p, *r, v; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - /* fetch the input data */ - inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); - - /* 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_GetObjResult(interp); - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - r = Tcl_SetByteArrayLength(resultPtr, rlen); - - /* 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 + 42) % 256; - } - *r++ = v; - } - - return TCL_OK; - } - - critcl::ccommand CDecode {dummy interp objc objv} { - Tcl_Obj *inputPtr, *resultPtr; - int len, rlen, esc; - unsigned char *input, *p, *r, v; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - /* fetch the input data */ - inputPtr = objv[1]; - input = Tcl_GetByteArrayFromObj(inputPtr, &len); - - /* allocate the output buffer */ - resultPtr = Tcl_GetObjResult(interp); - if (Tcl_IsShared(resultPtr)) { - resultPtr = Tcl_DuplicateObj(resultPtr); - Tcl_SetObjResult(interp, resultPtr); - } - r = Tcl_SetByteArrayLength(resultPtr, len); - - /* 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 - 42) % 256; - esc = 0; - } - *r++ = v; - rlen++; - } - Tcl_SetByteArrayLength(resultPtr, rlen); - - return TCL_OK; - } - } -} - -if {[info command ::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) r] - 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 $::yencode::version - -# ------------------------------------------------------------------------- -# -# Local variables: -# mode: tcl -# indent-tabs-mode: nil -# End: - Index: tolsh/tolsh.vfs/lib/tcllib1.10/bee/bee.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/bee/bee.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,990 +1,0 @@ -# bee.tcl -- -# -# BitTorrent Bee de- and encoder. -# -# Copyright (c) 2004 by Andreas Kupries -# See the file license.terms. - -package require Tcl 8.4 - -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.1 Index: tolsh/tolsh.vfs/lib/tcllib1.10/bee/pkgIndex.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/bee/pkgIndex.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,4 +1,0 @@ -# Tcl package index file, version 1.1 - -if {![package vsatisfies [package provide Tcl] 8.4]} {return} -package ifneeded bee 0.1 [list source [file join $dir bee.tcl]] Index: tolsh/tolsh.vfs/lib/tcllib1.10/bench/bench.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/bench/bench.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,524 +1,0 @@ -# bench.tcl -- -# -# Management of benchmarks. -# -# Copyright (c) 2005-2007 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.12 2007/08/23 17:35:10 andreas_kupries Exp $ - -# ### ### ### ######### ######### ######### ########################### -## Requisites - Packages and namespace for the commands and data. - -package require Tcl 8.2 -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]] { - if {[package vsatisfies [package provide Tcl] 8.4]} { - 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} { - if {[catch { - eval exec $cmd $files - } output]} { - if {$errors} { - error $::errorInfo - } - } else { - array set tmp $output - } - } else { - foreach file $files { - log::info [file tail $file] - if {[catch { - eval exec [linsert $cmd end $file] - } output]} { - if {$errors} { - error $::errorInfo - } else { - continue - } - } else { - array set tmp $output - } - } - } - - catch {unset tmp(Sourcing)} - catch {unset tmp(__THREADED)} - - 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 -} - -# ### ### ### ######### ######### ######### ########################### -## 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.3.1 Index: tolsh/tolsh.vfs/lib/tcllib1.10/bench/bench_read.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/bench/bench_read.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,162 +1,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.2 -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.1 Index: tolsh/tolsh.vfs/lib/tcllib1.10/bench/bench_wcsv.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/bench/bench_wcsv.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,101 +1,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.2 -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.2 Index: tolsh/tolsh.vfs/lib/tcllib1.10/bench/bench_wtext.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/bench/bench_wtext.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,165 +1,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.2 -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.2 Index: tolsh/tolsh.vfs/lib/tcllib1.10/bench/libbench.tcl =================================================================== --- tolsh/tolsh.vfs/lib/tcllib1.10/bench/libbench.tcl (revision 1b5b24e974d86af9fe62a4722f3cb84c5cff2d2a) +++ (revision ) @@ -1,540 +1,0 @@ -# -*- tcl -*- -# libbench.tcl ?(