diff options
Diffstat (limited to 'tcllib/modules/base32')
21 files changed, 2179 insertions, 0 deletions
diff --git a/tcllib/modules/base32/ChangeLog b/tcllib/modules/base32/ChangeLog new file mode 100644 index 0000000..5ebdf83 --- /dev/null +++ b/tcllib/modules/base32/ChangeLog @@ -0,0 +1,114 @@ +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2008-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base32.pcx: New file. Syntax definitions for the public commands + * base32_core.pcx: of the bibtex package. + * base32_hex.pcx: + +2008-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base32hex.tcl: Added missing implementation of 'Names' for use + by TestAccelInit. + * base32hex.test: Cleaned up to use the standard TestAccel* + commands for handling of accelerators in a testsuite. Moved + loading of base32::core to testing section, as that internal + package is implicitly tested as well. + * base32.test: Moved loading of base32::core to testing section, + as that internal package is implicitly tested as well. + +2008-01-28 Andreas Kupries <andreask@activestate.com> + + * base32hex_c.tcl: Disabled the critcl::debug and critcl::cheaders + * base32_c.tcl: -g definitions + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-03-23 Andreas Kupries <andreask@activestate.com> + + * base32hex.tcl: Added MD hints. + +2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base32.man: Fixed all warnings due to use of now deprecated + * base32core.man: commands. Added a section about how to give + * base32hex.man: feedback. + +2006-10-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base32.test: Rewritten to make use of the new facilities for + * base32.tcl: testing of multiple implementations put into the + test utilities. + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2006-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base32_c.tcl (critcl_decode): Simplified the decoder. + * base32hex_c.tcl (critcl_decode): Use ByteArray, avoids + complex UniChar -> Utf8 conversion on our part. Also moves + the handling of padding out of the decoder loop. + +2006-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * base32.bench: base32 standard encoding, extended hex + * base32.man: encoding. Tcl implementation, Critcl + * base32.tcl: implementation. Switch management. + * base32.test: Support package for Tcl implementation. + * base32.testsuite: Documentation. Benchmarks. Testsuites. + * base32_c.tcl: + * base32_tcl.tcl: + * base32core.man: + * base32core.tcl: + * base32hex.bench: + * base32hex.man: + * base32hex.tcl: + * base32hex.test: + * base32hex.testsuite: + * base32hex_c.tcl: + * base32hex_tcl.tcl: + * pkgIndex.tcl: + + * New module 'base32'. diff --git a/tcllib/modules/base32/base32.bench b/tcllib/modules/base32/base32.bench new file mode 100644 index 0000000..1840148 --- /dev/null +++ b/tcllib/modules/base32/base32.bench @@ -0,0 +1,87 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'base32' module. +# This allow developers to monitor/gauge/track package performance. +# +# Public domain + +# We need at least version 8.4 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.4]} return + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +package forget base32 +package forget base32::core +catch {namespace delete ::base32} + +set self [file join [pwd] [file dirname [info script]]] +set index [file join [file dirname $self] tcllibc pkgIndex.tcl] + +if {[file exists $index]} { + set ::dir [file dirname $index] + uplevel #0 [list source $index] + unset ::dir + package require tcllibc +} + +source [file join $self base32core.tcl] +source [file join $self base32.tcl] + +set bytes \000\010\020\030\001\011\021\031\002\012\022\032\003\013\023\033 +append bytes \004\014\024\034\005\015\025\035\006\016\026\036\007\017\027\037 +append bytes \040\050\060\070\041\051\061\071\042\052\062\072\043\053\063\073 +append bytes \044\054\064\074\045\055\065\075\046\056\066\076\047\057\067\077 +append bytes \100\110\120\130\101\111\121\131\102\112\122\132\103\113\123\133 +append bytes \104\114\124\134\105\115\125\135\106\116\126\136\107\117\127\137 +append bytes \140\150\160\170\141\151\161\171\142\152\162\172\143\153\163\173 +append bytes \144\154\164\174\145\155\165\175\146\156\166\176\147\157\167\177 +append bytes \200\210\220\230\201\211\221\231\202\212\222\232\203\213\223\233 +append bytes \204\214\224\234\205\215\225\235\206\216\226\236\207\217\227\237 +append bytes \240\250\260\270\241\251\261\271\242\252\262\272\243\253\263\273 +append bytes \244\254\264\274\245\255\265\275\246\256\266\276\247\257\267\277 +append bytes \300\310\320\330\301\311\321\331\302\312\322\332\303\313\323\333 +append bytes \304\314\324\334\305\315\325\335\306\316\326\336\307\317\327\337 +append bytes \340\350\360\370\341\351\361\371\342\352\362\372\343\353\363\373 +append bytes \344\354\364\374\345\355\365\375\346\356\366\376\347\357\367\377 + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + +base32::SwitchTo {} +foreach e [base32::KnownImplementations] { + ::base32::LoadAccelerator $e +} + +foreach impl [base32::Implementations] { + base32::SwitchTo $impl + + foreach rem {0 1 2 3 4} { + foreach len {0 10 100 1000 10000} { + set blen $len + incr blen $rem + + set blanks [string repeat { } $blen] + set identic [string repeat A $blen] + set sbytes [string range [string repeat $bytes [expr {1+$blen/256}]] 0 [expr {$blen - 1}]] + + bench -desc "base32-std-${impl}-enc-$rem/${len} blanks" -body {base32::encode $blanks} + bench -desc "base32-std-${impl}-enc-$rem/${len} identi" -body {base32::encode $identic} + bench -desc "base32-std-${impl}-enc-$rem/${len} sbytes" -body {base32::encode $sbytes} + + set blanks [base32::encode $blanks] + set identic [base32::encode $identic] + set sbytes [base32::encode $sbytes] + + bench -desc "base32-std-${impl}-dec-$rem/${len} blanks" -body {base32::decode $blanks} + bench -desc "base32-std-${impl}-dec-$rem/${len} identi" -body {base32::decode $identic} + bench -desc "base32-std-${impl}-dec-$rem/${len} sbytes" -body {base32::decode $sbytes} + } + } +} + +# ### ### ### ######### ######### ######### ########################### +## Complete diff --git a/tcllib/modules/base32/base32.man b/tcllib/modules/base32/base32.man new file mode 100644 index 0000000..6e19d54 --- /dev/null +++ b/tcllib/modules/base32/base32.man @@ -0,0 +1,75 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin base32 n 0.1] +[keywords base32] +[keywords rfc3548] +[copyright {Public domain}] +[moddesc {Base32 encoding}] +[titledesc {base32 standard encoding}] +[category {Text processing}] +[require Tcl 8.4] +[require base32::core [opt 0.1]] +[require base32 [opt 0.1]] +[description] +[para] + +This package provides commands for encoding and decoding of strings +into and out of the standard base32 encoding as specified in RFC 3548. + +[section API] + +[list_begin definitions] + +[call [cmd ::base32::encode] [arg string]] + +This command encodes the given [arg string] in base32 and returns the +encoded string as its result. The result may be padded with the +character [const =] to signal a partial encoding at the end of the +input string. + +[call [cmd ::base32::decode] [arg estring]] + +This commands takes the [arg estring] and decodes it under the +assumption that it is a valid base32 encoded string. The result of the +decoding is returned as the result of the command. + +[para] + +Note that while the encoder will generate only uppercase characters +this decoder accepts input in lowercase as well. + +[para] + +The command will always throw an error whenever encountering +conditions which signal some type of bogus input, namely if + +[list_begin enumerated] +[enum] the input contains characters which are not valid output of a base32 encoder, +[enum] the length of the input is not a multiple of eight, +[enum] padding appears not at the end of input, but in the middle, +[enum] the padding has not of length six, four, three, or one characters, +[list_end] +[list_end] + +[section {Code map}] + +The code map used to convert 5-bit sequences is shown below, with the +numeric id of the bit sequences to the left and the character used to +encode it to the right. It should be noted that the characters "0" and +"1" are not used by the encoding. This is done as these characters can +be easily confused with "O", "o" and "l" (L). + +[example { + 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 +}] + +[vset CATEGORY base32] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/base32/base32.pcx b/tcllib/modules/base32/base32.pcx new file mode 100644 index 0000000..0592336 --- /dev/null +++ b/tcllib/modules/base32/base32.pcx @@ -0,0 +1,40 @@ +# -*- tcl -*- base32.pcx +# Syntax of the commands provided by package base32. +# +# For use by TclDevKit's static syntax checker (v4.1+). +# See http://www.activestate.com/solutions/tcl/ +# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api +# for the specification of the format of the code in this file. +# + +package require pcx +pcx::register base32 +pcx::tcldep 0.1 needs tcl 8.4 + +namespace eval ::base32 {} + +pcx::message invalidStringLength {String is not a multiple of 8 characters long} err +#pcx::scan <VERSION> <NAME> <RULE> + +pcx::check 0.1 std ::base32::decode \ + {checkSimpleArgs 1 1 { + base32::checkEString + }} +pcx::check 0.1 std ::base32::encode \ + {checkSimpleArgs 1 1 { + checkWord + }} + +proc base32::checkEString {t i} { + set w [lindex $t $i] + if {[getLiteral $w str]} { + if {[string length $str] % 8 != 0} { + logError base32::invalidStringLength [getTokenRange $w] + } + } + return [checkWord $t $i] +} + +# Initialization via pcx::init. +# Use a ::base32::init procedure for non-standard initialization. +pcx::complete diff --git a/tcllib/modules/base32/base32.tcl b/tcllib/modules/base32/base32.tcl new file mode 100644 index 0000000..dd73114 --- /dev/null +++ b/tcllib/modules/base32/base32.tcl @@ -0,0 +1,182 @@ +# -*- 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 diff --git a/tcllib/modules/base32/base32.test b/tcllib/modules/base32/base32.test new file mode 100644 index 0000000..445fdd1 --- /dev/null +++ b/tcllib/modules/base32/base32.test @@ -0,0 +1,38 @@ +# -*- tcl -*- Tests for "base32" +# This testsuite is in the public domain. +#__________________________________________ +# RCS: @(#) $Id: base32.test,v 1.4 2008/03/22 23:46:42 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 2.1 + +testing { + useLocal base32core.tcl base32::core + useTcllibC + useLocalKeep base32.tcl base32 + TestAccelInit base32 +} + +set tests [localPath base32.testsuite] + +# ------------------------------------------------------------------------- + +# The global variable 'impl' is part of the public API the testsuite +# (in base32.testsuite) does expect from the environment. + +TestAccelDo base32 impl { + source $tests +} + +# ------------------------------------------------------------------------- + +unset tests +TestAccelExit base32 +testsuiteCleanup +return diff --git a/tcllib/modules/base32/base32.testsuite b/tcllib/modules/base32/base32.testsuite new file mode 100644 index 0000000..ce816d1 --- /dev/null +++ b/tcllib/modules/base32/base32.testsuite @@ -0,0 +1,156 @@ +# -*- tcl -*- +# base32.testsuite: tests for std base32. +# +# Public domain +# +# RCS: @(#) $Id: base32.testsuite,v 1.1 2006/05/27 20:44:36 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +::tcltest::testConstraint base32_critcl [string equal $impl critcl] + +# ------------------------------------------------------------------------- + +test base32-${impl}-1.0 {Encode, wrong#args} -body { + ::base32::encode +} -returnCodes error -result {wrong # args: should be "::base32::encode bitstring"} + +test base32-${impl}-1.1 {Encode, wrong#args} -body { + ::base32::encode a b +} -returnCodes error -result {wrong # args: should be "::base32::encode bitstring"} + +# ------------------------------------------------------------------------- + +test base32-${impl}-2.0 {Decode, wrong#args} -body { + ::base32::decode +} -returnCodes error -result {wrong # args: should be "::base32::decode estring"} + +test base32-${impl}-2.1 {Decode, wrong#args} -body { + ::base32::decode a b +} -returnCodes error -result {wrong # args: should be "::base32::decode estring"} + +# ------------------------------------------------------------------------- +# 0 .. 6 are the official test vectors from RFC 3548 +# 7 .. 12 are the vectors I fot previous, non-conforming, +# implementation, updated for conformance. +# 13 .. are new vectors to cover the whole range of bytes + +# 4-0 00100 000 +# 4-0-16-0 00100 00000 10000 0 +# 4-0-16-2-0 00100 00000 10000 00010 0000 +# 4-0-16-2-0-8-0 00100 00000 10000 00010 00000 01000 00 +# 4-0-16-2-0-8-1-0 00100 00000 10000 00010 00000 01000 00001 00000 + +foreach {n text encoded} { + 0 {} {} + 1 f MY====== + 2 fo MZXQ==== + 3 foo MZXW6=== + 4 foob MZXW6YQ= + 5 fooba MZXW6YTB + 6 foobar MZXW6YTBOI====== + - - - + 7 { } EA====== + 8 { } EAQA==== + 9 { } EAQCA=== + 10 { } EAQCAIA= + 11 { } EAQCAIBA + 12 { } EAQCAIBAEA====== + - - - - - - - - - - - - + 20 \000 AA====== 28 \010 BA====== 36 \020 CA====== 44 \030 DA====== + 21 \001 AE====== 29 \011 BE====== 37 \021 CE====== 45 \031 DE====== + 22 \002 AI====== 30 \012 BI====== 38 \022 CI====== 46 \032 DI====== + 23 \003 AM====== 31 \013 BM====== 39 \023 CM====== 47 \033 DM====== + 24 \004 AQ====== 32 \014 BQ====== 40 \024 CQ====== 48 \034 DQ====== + 25 \005 AU====== 33 \015 BU====== 41 \025 CU====== 49 \035 DU====== + 26 \006 AY====== 34 \016 BY====== 42 \026 CY====== 50 \036 DY====== + 27 \007 A4====== 35 \017 B4====== 43 \027 C4====== 51 \037 D4====== + - - - - - - - - - - - - + 52 \040 EA====== 60 \050 FA====== 68 \060 GA====== 76 \070 HA====== + 53 \041 EE====== 61 \051 FE====== 69 \061 GE====== 77 \071 HE====== + 54 \042 EI====== 62 \052 FI====== 70 \062 GI====== 78 \072 HI====== + 55 \043 EM====== 63 \053 FM====== 71 \063 GM====== 79 \073 HM====== + 56 \044 EQ====== 64 \054 FQ====== 72 \064 GQ====== 80 \074 HQ====== + 57 \045 EU====== 65 \055 FU====== 73 \065 GU====== 81 \075 HU====== + 58 \046 EY====== 66 \056 FY====== 74 \066 GY====== 82 \076 HY====== + 59 \047 E4====== 67 \057 F4====== 75 \067 G4====== 83 \077 H4====== + - - - - - - - - - - - - + a0 \100 IA====== a8 \110 JA====== b6 \120 KA====== c4 \130 LA====== + a1 \101 IE====== a9 \111 JE====== b7 \121 KE====== c5 \131 LE====== + a2 \102 II====== b0 \112 JI====== b8 \122 KI====== c6 \132 LI====== + a3 \103 IM====== b1 \113 JM====== b9 \123 KM====== c7 \133 LM====== + a4 \104 IQ====== b2 \114 JQ====== c0 \124 KQ====== c8 \134 LQ====== + a5 \105 IU====== b3 \115 JU====== c1 \125 KU====== c9 \135 LU====== + a6 \106 IY====== b4 \116 JY====== c2 \126 KY====== d0 \136 LY====== + a7 \107 I4====== b5 \117 J4====== c3 \127 K4====== d1 \137 L4====== + - - - - - - - - - - - - + d2 \140 MA====== e0 \150 NA====== e8 \160 OA====== f6 \170 PA====== + d3 \141 ME====== e1 \151 NE====== e9 \161 OE====== f7 \171 PE====== + d4 \142 MI====== e2 \152 NI====== f0 \162 OI====== f8 \172 PI====== + d5 \143 MM====== e3 \153 NM====== f1 \163 OM====== f9 \173 PM====== + d6 \144 MQ====== e4 \154 NQ====== f2 \164 OQ====== g0 \174 PQ====== + d7 \145 MU====== e5 \155 NU====== f3 \165 OU====== g1 \175 PU====== + d8 \146 MY====== e6 \156 NY====== f4 \166 OY====== g2 \176 PY====== + d9 \147 M4====== e7 \157 N4====== f5 \167 O4====== g3 \177 P4====== + - - - - - - - - - - - - + h0 \200 QA====== h8 \210 RA====== i6 \220 SA====== j4 \230 TA====== + h1 \201 QE====== h9 \211 RE====== i7 \221 SE====== j5 \231 TE====== + h2 \202 QI====== i0 \212 RI====== i8 \222 SI====== j6 \232 TI====== + h3 \203 QM====== i1 \213 RM====== i9 \223 SM====== j7 \233 TM====== + h4 \204 QQ====== i2 \214 RQ====== j0 \224 SQ====== j8 \234 TQ====== + h5 \205 QU====== i3 \215 RU====== j1 \225 SU====== j9 \235 TU====== + h6 \206 QY====== i4 \216 RY====== j2 \226 SY====== k0 \236 TY====== + h7 \207 Q4====== i5 \217 R4====== j3 \227 S4====== k1 \237 T4====== + - - - - - - - - - - - - + k2 \240 UA====== l0 \250 VA====== l8 \260 WA====== m6 \270 XA====== + k3 \241 UE====== l1 \251 VE====== l9 \261 WE====== m7 \271 XE====== + k4 \242 UI====== l2 \252 VI====== m0 \262 WI====== m8 \272 XI====== + k5 \243 UM====== l3 \253 VM====== m1 \263 WM====== m9 \273 XM====== + k6 \244 UQ====== l4 \254 VQ====== m2 \264 WQ====== n0 \274 XQ====== + k7 \245 UU====== l5 \255 VU====== m3 \265 WU====== n1 \275 XU====== + k8 \246 UY====== l6 \256 VY====== m4 \266 WY====== n2 \276 XY====== + k9 \247 U4====== l7 \257 V4====== m5 \267 W4====== n3 \277 X4====== + - - - - - - - - - - - - + o0 \300 YA====== o8 \310 ZA====== p6 \320 2A====== q4 \330 3A====== + o1 \301 YE====== o9 \311 ZE====== p7 \321 2E====== q5 \331 3E====== + o2 \302 YI====== p0 \312 ZI====== p8 \322 2I====== q6 \332 3I====== + o3 \303 YM====== p1 \313 ZM====== p9 \323 2M====== q7 \333 3M====== + o4 \304 YQ====== p2 \314 ZQ====== q0 \324 2Q====== q8 \334 3Q====== + o5 \305 YU====== p3 \315 ZU====== q1 \325 2U====== q9 \335 3U====== + o6 \306 YY====== p4 \316 ZY====== q2 \326 2Y====== r0 \336 3Y====== + o7 \307 Y4====== p5 \317 Z4====== q3 \327 24====== r1 \337 34====== + - - - - - - - - - - - - + r2 \340 4A====== s0 \350 5A====== s8 \360 6A====== t6 \370 7A====== + r3 \341 4E====== s1 \351 5E====== s9 \361 6E====== t7 \371 7E====== + r4 \342 4I====== s2 \352 5I====== t0 \362 6I====== t8 \372 7I====== + r5 \343 4M====== s3 \353 5M====== t1 \363 6M====== t9 \373 7M====== + r6 \344 4Q====== s4 \354 5Q====== t2 \364 6Q====== u0 \374 7Q====== + r7 \345 4U====== s5 \355 5U====== t3 \365 6U====== u1 \375 7U====== + r8 \346 4Y====== s6 \356 5Y====== t4 \366 6Y====== u2 \376 7Y====== + r9 \347 44====== s7 \357 54====== t5 \367 64====== u3 \377 74====== +} { + if {$n == "-"} continue + test base32-${impl}-3.$n "Encode \"$text\"" -body { + ::base32::encode $text + } -result $encoded ; # {} + + test base32-${impl}-4.$n "Decode \"$encoded\"" -body { + ::base32::decode $encoded + } -result $text ; # {} +} + +# ------------------------------------------------------------------------- +# Decoder stress testing bad input + +foreach {n input message} { + 0 abcde0aa {Invalid character at index 5: "0"} + 1 A {Length is not a multiple of 8} + 2 ABCDEFG {Length is not a multiple of 8} + 3 A======= {Invalid padding of length 7} + 4 ACA===== {Invalid padding of length 5} + 5 A=CA==== {Invalid character at index 1: "=" (padding found in the middle of the input)} +} { + test base32-${impl}-5.$n "Decode, bad input \"$input\"" -body { + ::base32::decode $input + } -returnCodes error -result $message ; # {} +} diff --git a/tcllib/modules/base32/base32_c.tcl b/tcllib/modules/base32/base32_c.tcl new file mode 100644 index 0000000..333d73b --- /dev/null +++ b/tcllib/modules/base32/base32_c.tcl @@ -0,0 +1,253 @@ +# base32c.tcl -- +# +# Implementation of a base32 (std) de/encoder for Tcl. +# +# Public domain +# +# RCS: @(#) $Id: base32_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $ + +package require critcl +package require Tcl 8.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 ((char*)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 = (unsigned char*) 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 diff --git a/tcllib/modules/base32/base32_core.pcx b/tcllib/modules/base32/base32_core.pcx new file mode 100644 index 0000000..58feb26 --- /dev/null +++ b/tcllib/modules/base32/base32_core.pcx @@ -0,0 +1,44 @@ +# -*- tcl -*- base32::core.pcx +# Syntax of the commands provided by package base32::core. +# +# For use by TclDevKit's static syntax checker (v4.1+). +# See http://www.activestate.com/solutions/tcl/ +# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api +# for the specification of the format of the code in this file. +# + +package require pcx +pcx::register base32::core +pcx::tcldep 0.1 needs tcl 8.4 + +namespace eval ::base32::core {} + +pcx::message invalidStringLength {String is not a multiple of 8 characters long} err + +pcx::check 0.1 std ::base32::core::define \ + {checkSimpleArgs 4 4 { + checkDict + checkVarNameWrite + checkVarNameWrite + checkVarNameWrite + }} +pcx::check 0.1 std ::base32::core::valid \ + {checkSimpleArgs 3 3 { + base32::core::checkEString + checkRegexp + checkVarNameWrite + }} + +proc base32::core::checkEString {t i} { + set w [lindex $t $i] + if {[getLiteral $w str]} { + if {[string length $str] % 8 != 0} { + logError base32::core::invalidStringLength [getTokenRange $w] + } + } + return [checkWord $t $i] +} + +# Initialization via pcx::init. +# Use a ::base32::core::init procedure for non-standard initialization. +pcx::complete diff --git a/tcllib/modules/base32/base32_hex.pcx b/tcllib/modules/base32/base32_hex.pcx new file mode 100644 index 0000000..54bb193 --- /dev/null +++ b/tcllib/modules/base32/base32_hex.pcx @@ -0,0 +1,40 @@ +# -*- tcl -*- base32::hex.pcx +# Syntax of the commands provided by package base32::hex. +# +# For use by TclDevKit's static syntax checker (v4.1+). +# See http://www.activestate.com/solutions/tcl/ +# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api +# for the specification of the format of the code in this file. +# + +package require pcx +pcx::register base32::hex +pcx::tcldep 0.1 needs tcl 8.4 + +namespace eval ::base32::hex {} + +pcx::message invalidStringLength {String is not a multiple of 8 characters long} err +#pcx::scan <VERSION> <NAME> <RULE> + +pcx::check 0.1 std ::base32::hex::decode \ + {checkSimpleArgs 0 -1 { + base32::hex::checkEString + }} +pcx::check 0.1 std ::base32::hex::encode \ + {checkSimpleArgs 0 -1 { + + }} + +proc base32::hex::checkEString {t i} { + set w [lindex $t $i] + if {[getLiteral $w str]} { + if {[string length $str] % 8 != 0} { + logError base32::hex::invalidStringLength [getTokenRange $w] + } + } + return [checkWord $t $i] +} + +# Initialization via pcx::init. +# Use a ::base32::hex::init procedure for non-standard initialization. +pcx::complete diff --git a/tcllib/modules/base32/base32_tcl.tcl b/tcllib/modules/base32/base32_tcl.tcl new file mode 100644 index 0000000..a8d5033 --- /dev/null +++ b/tcllib/modules/base32/base32_tcl.tcl @@ -0,0 +1,73 @@ +# -*- tcl -*- +# This code is hereby put into the public domain. +# ### ### ### ######### ######### ######### +## Overview +# Base32 encoding and decoding of small strings. + +# ### ### ### ######### ######### ######### +## Notes + +# A binary string is split into groups of 5 bits (2^5 == 32), and each +# group is converted into a printable character as is specified in RFC +# 3548. + +# ### ### ### ######### ######### ######### +## Requisites + +package require base32::core +namespace eval ::base32 {} + +# ### ### ### ######### ######### ######### +## API & Implementation + +proc ::base32::tcl_encode {bitstring} { + variable forward + + binary scan $bitstring B* bits + set len [string length $bits] + set rem [expr {$len % 5}] + if {$rem} {append bits =/$rem} + #puts "($bitstring) => <$bits>" + + return [string map $forward $bits] +} + +proc ::base32::tcl_decode {estring} { + variable backward + variable invalid + + if {![core::valid $estring $invalid msg]} { + return -code error $msg + } + #puts "I<$estring>" + #puts "M<[string map $backward $estring]>" + + return [binary format B* [string map $backward [string toupper $estring]]] +} + +# ### ### ### ######### ######### ######### +## Data structures + +namespace eval ::base32 { + # Initialize the maps + variable forward + variable backward + variable invalid + + core::define { + 0 A 9 J 18 S 27 3 + 1 B 10 K 19 T 28 4 + 2 C 11 L 20 U 29 5 + 3 D 12 M 21 V 30 6 + 4 E 13 N 22 W 31 7 + 5 F 14 O 23 X + 6 G 15 P 24 Y + 7 H 16 Q 25 Z + 8 I 17 R 26 2 + } forward backward invalid ; # {} + # puts ///$forward/// + # puts ///$backward/// +} + +# ### ### ### ######### ######### ######### +## Ok diff --git a/tcllib/modules/base32/base32core.man b/tcllib/modules/base32/base32core.man new file mode 100644 index 0000000..150b754 --- /dev/null +++ b/tcllib/modules/base32/base32core.man @@ -0,0 +1,66 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin base32::core n 0.1] +[keywords base32] +[copyright {Public domain}] +[moddesc {Base32 encoding}] +[titledesc {Expanding basic base32 maps}] +[category {Text processing}] +[require Tcl 8.4] +[require base32::core [opt 0.1]] +[description] +[para] + +This package provides generic commands for the construction of full +base32 mappings from a basic mapping listing just the codes and +associated characters. The full mappings, regular and inverse, created +here map to and from bit sequences, and also handle the partial +mappings at the end of a string. + +[para] + +This is in essence an internal package to be used by implementors of a +base32 en- and decoder. A regular user has no need of this package at +all. + +[section API] + +[list_begin definitions] + +[call [cmd ::base32::core::define] [arg map] [arg forwvar] [arg backwvar] [arg ivar]] + +This command computes full forward and backward (inverse) mappings +from the basic [arg map] and stores them in the variables named by +[arg forwvar] and [arg backwvar] resp. It also constructs a regexp +pattern for the detection of invalid characters in supposedly base32 +encoded input and stores it in the variable named by [arg ivar]. + +[call [cmd ::base32::core::valid] [arg string] [arg pattern] [arg mvar]] + +This command checks if the input [arg string] is a valid base32 +encoded string, based on the [arg pattern] of invalid characters as +generated by [cmd ::base32::core::define], and some other general +rules. + +[para] + +The result of the command is a boolean flag. Its value is [const True] +for a valid [arg string], and [const False] otherwise. In the latter +case an error message describing the problem with the input is stored +into the variable named by [arg mvar]. The variable is not touched if +the input was found to be valid. + +[para] + +The rules checked by the command, beyond rejection of bad characters, +are: + +[list_begin enumerated] +[enum] The length of the input is not a multiple of eight, +[enum] The padding appears not at the end of input, but in the middle, +[enum] The padding has not of length six, four, three, or one characters, +[list_end] +[list_end] + +[vset CATEGORY base32] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/base32/base32core.tcl b/tcllib/modules/base32/base32core.tcl new file mode 100644 index 0000000..aaf7fc8 --- /dev/null +++ b/tcllib/modules/base32/base32core.tcl @@ -0,0 +1,134 @@ +# -*- 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 diff --git a/tcllib/modules/base32/base32hex.bench b/tcllib/modules/base32/base32hex.bench new file mode 100644 index 0000000..47d5c44 --- /dev/null +++ b/tcllib/modules/base32/base32hex.bench @@ -0,0 +1,87 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the 'base32' module. +# This allow developers to monitor/gauge/track package performance. +# +# Public domain + +# We need at least version 8.4 for the package and thus the +# benchmarks. + +if {![package vsatisfies [package provide Tcl] 8.4]} return + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +package forget base32::hex +package forget base32::core +catch {namespace delete ::base32} + +set self [file join [pwd] [file dirname [info script]]] +set index [file join [file dirname $self] tcllibc pkgIndex.tcl] + +if {[file exists $index]} { + set ::dir [file dirname $index] + uplevel #0 [list source $index] + unset ::dir + package require tcllibc +} + +source [file join $self base32core.tcl] +source [file join $self base32hex.tcl] + +set bytes \000\010\020\030\001\011\021\031\002\012\022\032\003\013\023\033 +append bytes \004\014\024\034\005\015\025\035\006\016\026\036\007\017\027\037 +append bytes \040\050\060\070\041\051\061\071\042\052\062\072\043\053\063\073 +append bytes \044\054\064\074\045\055\065\075\046\056\066\076\047\057\067\077 +append bytes \100\110\120\130\101\111\121\131\102\112\122\132\103\113\123\133 +append bytes \104\114\124\134\105\115\125\135\106\116\126\136\107\117\127\137 +append bytes \140\150\160\170\141\151\161\171\142\152\162\172\143\153\163\173 +append bytes \144\154\164\174\145\155\165\175\146\156\166\176\147\157\167\177 +append bytes \200\210\220\230\201\211\221\231\202\212\222\232\203\213\223\233 +append bytes \204\214\224\234\205\215\225\235\206\216\226\236\207\217\227\237 +append bytes \240\250\260\270\241\251\261\271\242\252\262\272\243\253\263\273 +append bytes \244\254\264\274\245\255\265\275\246\256\266\276\247\257\267\277 +append bytes \300\310\320\330\301\311\321\331\302\312\322\332\303\313\323\333 +append bytes \304\314\324\334\305\315\325\335\306\316\326\336\307\317\327\337 +append bytes \340\350\360\370\341\351\361\371\342\352\362\372\343\353\363\373 +append bytes \344\354\364\374\345\355\365\375\346\356\366\376\347\357\367\377 + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + +base32::hex::SwitchTo {} +foreach e [base32::hex::KnownImplementations] { + ::base32::hex::LoadAccelerator $e +} + +foreach impl [base32::hex::Implementations] { + base32::hex::SwitchTo $impl + + foreach rem {0 1 2 3 4} { + foreach len {0 10 100 1000 10000} { + set blen $len + incr blen $rem + + set blanks [string repeat { } $blen] + set identic [string repeat A $blen] + set sbytes [string range [string repeat $bytes [expr {1+$blen/256}]] 0 [expr {$blen - 1}]] + + bench -desc "base32-hex-${impl}-enc-$rem/${len} blanks" -body {base32::hex::encode $blanks} + bench -desc "base32-hex-${impl}-enc-$rem/${len} identi" -body {base32::hex::encode $identic} + bench -desc "base32-hex-${impl}-enc-$rem/${len} sbytes" -body {base32::hex::encode $sbytes} + + set blanks [base32::hex::encode $blanks] + set identic [base32::hex::encode $identic] + set sbytes [base32::hex::encode $sbytes] + + bench -desc "base32-hex-${impl}-dec-$rem/${len} blanks" -body {base32::hex::decode $blanks} + bench -desc "base32-hex-${impl}-dec-$rem/${len} identi" -body {base32::hex::decode $identic} + bench -desc "base32-hex-${impl}-dec-$rem/${len} sbytes" -body {base32::hex::decode $sbytes} + } + } +} + +# ### ### ### ######### ######### ######### ########################### +## Complete diff --git a/tcllib/modules/base32/base32hex.man b/tcllib/modules/base32/base32hex.man new file mode 100644 index 0000000..d38e001 --- /dev/null +++ b/tcllib/modules/base32/base32hex.man @@ -0,0 +1,78 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin base32::hex n 0.1] +[keywords base32] +[keywords hex] +[keywords rfc3548] +[copyright {Public domain}] +[moddesc {Base32 encoding}] +[titledesc {base32 extended hex encoding}] +[category {Text processing}] +[require Tcl 8.4] +[require base32::core [opt 0.1]] +[require base32::hex [opt 0.1]] +[description] +[para] + +This package provides commands for encoding and decoding of strings +into and out of the extended hex base32 encoding as specified in the +RFC 3548bis draft. + +[section API] + +[list_begin definitions] + +[call [cmd ::base32::hex::encode] [arg string]] + +This command encodes the given [arg string] in extended hex base32 and +returns the encoded string as its result. The result may be padded +with the character [const =] to signal a partial encoding at the end +of the input string. + +[call [cmd ::base32::hex::decode] [arg estring]] + +This commands takes the [arg estring] and decodes it under the +assumption that it is a valid extended hex base32 encoded string. The +result of the decoding is returned as the result of the command. + +[para] + +Note that while the encoder will generate only uppercase characters +this decoder accepts input in lowercase as well. + +[para] + +The command will always throw an error whenever encountering +conditions which signal some type of bogus input, namely if + +[list_begin enumerated] +[enum] the input contains characters which are not valid output + of a extended hex base32 encoder, +[enum] the length of the input is not a multiple of eight, +[enum] padding appears not at the end of input, but in the middle, +[enum] the padding has not of length six, four, three, or one characters, +[list_end] +[list_end] + +[section {Code map}] + +The code map used to convert 5-bit sequences is shown below, with the +numeric id of the bit sequences to the left and the character used to +encode it to the right. The important feature of the extended hex +mapping is that the first 16 codes map to the digits and hex +characters. + +[example { + 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 +}] + +[vset CATEGORY base32] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/base32/base32hex.tcl b/tcllib/modules/base32/base32hex.tcl new file mode 100644 index 0000000..6611c4c --- /dev/null +++ b/tcllib/modules/base32/base32hex.tcl @@ -0,0 +1,182 @@ +# -*- tcl -*- +# This code is hereby put into the public domain. +# ### ### ### ######### ######### ######### +## Overview +# Base32 encoding and decoding of small strings. +# +# Management code for switching between Tcl and C accelerated +# implementations. +# +# RCS: @(#) $Id: base32hex.tcl,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $ + +# @mdgen EXCLUDE: base32hex_c.tcl + +package require Tcl 8.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} +} + +proc ::base32::hex::Names {} { + return { + critcl {tcllibc based} + tcl {pure Tcl} + } +} + +# ### ### ### ######### ######### ######### +## Initialization: Data structures. + +namespace eval ::base32::hex { + variable selfdir [file dirname [info script]] + variable loaded {} + + variable accel + array set accel {tcl 0 critcl 0} +} + +# ### ### ### ######### ######### ######### +## Initialization: Choose an implementation, +## most prefered first. Loads only one of the +## possible implementations. And activates it. + +namespace eval ::base32::hex { + variable e + foreach e [KnownImplementations] { + if {[LoadAccelerator $e]} { + SwitchTo $e + break + } + } + unset e + + namespace export encode decode +} + +# ### ### ### ######### ######### ######### +## Ready + +package provide base32::hex 0.1 diff --git a/tcllib/modules/base32/base32hex.test b/tcllib/modules/base32/base32hex.test new file mode 100644 index 0000000..173c266 --- /dev/null +++ b/tcllib/modules/base32/base32hex.test @@ -0,0 +1,38 @@ +# -*- tcl -*- Tests for "base32" +# This testsuite is in the public domain. +#__________________________________________ +# RCS: @(#) $Id: base32hex.test,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.4 +testsNeedTcltest 2.1 + +testing { + useLocal base32core.tcl base32::core + useTcllibC + useLocalKeep base32hex.tcl base32::hex + TestAccelInit base32::hex +} + +set tests [localPath base32hex.testsuite] + +# ------------------------------------------------------------------------- + +# The global variable 'impl' is part of the public API the testsuite +# (in base32hex.testsuite) does expect from the environment. + +TestAccelDo base32::hex impl { + source $tests +} + +# ------------------------------------------------------------------------- + +unset tests +TestAccelExit base32::hex +testsuiteCleanup +return diff --git a/tcllib/modules/base32/base32hex.testsuite b/tcllib/modules/base32/base32hex.testsuite new file mode 100644 index 0000000..bb7b08b --- /dev/null +++ b/tcllib/modules/base32/base32hex.testsuite @@ -0,0 +1,156 @@ +# -*- tcl -*- +# base32hex.testsuite: tests for hex extended base32. +# +# Public domain +# +# RCS: @(#) $Id: base32hex.testsuite,v 1.1 2006/05/27 20:44:36 andreas_kupries Exp $ + +# ------------------------------------------------------------------------- + +::tcltest::testConstraint base32hex_critcl [string equal $impl critcl] + +# ------------------------------------------------------------------------- + +test base32-hex-${impl}-1.0 {Encode, wrong#args} -body { + ::base32::hex::encode +} -returnCodes error -result {wrong # args: should be "::base32::hex::encode bitstring"} + +test base32-hex-${impl}-1.1 {Encode, wrong#args} -body { + ::base32::hex::encode a b +} -returnCodes error -result {wrong # args: should be "::base32::hex::encode bitstring"} + +# ------------------------------------------------------------------------- + +test base32-hex-${impl}-2.0 {Decode, wrong#args} -body { + ::base32::hex::decode +} -returnCodes error -result {wrong # args: should be "::base32::hex::decode estring"} + +test base32-hex-${impl}-2.1 {Decode, wrong#args} -body { + ::base32::hex::decode a b +} -returnCodes error -result {wrong # args: should be "::base32::hex::decode estring"} + +# ------------------------------------------------------------------------- +# 0 .. 6 are the official test vectors from RFC 3548 +# 7 .. 12 are the vectors I fot previous, non-conforming, +# implementation, updated for conformance. +# 13 .. are new vectors to cover the whole range of bytes + +# 4-0 00100 000 +# 4-0-16-0 00100 00000 10000 0 +# 4-0-16-2-0 00100 00000 10000 00010 0000 +# 4-0-16-2-0-8-0 00100 00000 10000 00010 00000 01000 00 +# 4-0-16-2-0-8-1-0 00100 00000 10000 00010 00000 01000 00001 00000 + +foreach {n text encoded} { + 0 {} {} + 1 f CO====== + 2 fo CPNG==== + 3 foo CPNMU=== + 4 foob CPNMUOG= + 5 fooba CPNMUOJ1 + 6 foobar CPNMUOJ1E8====== + - - - + 7 { } 40====== + 8 { } 40G0==== + 9 { } 40G20=== + 10 { } 40G2080= + 11 { } 40G20810 + 12 { } 40G2081040====== + - - - - - - - - - - - - + 20 \000 00====== 28 \010 10====== 36 \020 20====== 44 \030 30====== + 21 \001 04====== 29 \011 14====== 37 \021 24====== 45 \031 34====== + 22 \002 08====== 30 \012 18====== 38 \022 28====== 46 \032 38====== + 23 \003 0C====== 31 \013 1C====== 39 \023 2C====== 47 \033 3C====== + 24 \004 0G====== 32 \014 1G====== 40 \024 2G====== 48 \034 3G====== + 25 \005 0K====== 33 \015 1K====== 41 \025 2K====== 49 \035 3K====== + 26 \006 0O====== 34 \016 1O====== 42 \026 2O====== 50 \036 3O====== + 27 \007 0S====== 35 \017 1S====== 43 \027 2S====== 51 \037 3S====== + - - - - - - - - - - - - + 52 \040 40====== 60 \050 50====== 68 \060 60====== 76 \070 70====== + 53 \041 44====== 61 \051 54====== 69 \061 64====== 77 \071 74====== + 54 \042 48====== 62 \052 58====== 70 \062 68====== 78 \072 78====== + 55 \043 4C====== 63 \053 5C====== 71 \063 6C====== 79 \073 7C====== + 56 \044 4G====== 64 \054 5G====== 72 \064 6G====== 80 \074 7G====== + 57 \045 4K====== 65 \055 5K====== 73 \065 6K====== 81 \075 7K====== + 58 \046 4O====== 66 \056 5O====== 74 \066 6O====== 82 \076 7O====== + 59 \047 4S====== 67 \057 5S====== 75 \067 6S====== 83 \077 7S====== + - - - - - - - - - - - - + a0 \100 80====== a8 \110 90====== b6 \120 A0====== c4 \130 B0====== + a1 \101 84====== a9 \111 94====== b7 \121 A4====== c5 \131 B4====== + a2 \102 88====== b0 \112 98====== b8 \122 A8====== c6 \132 B8====== + a3 \103 8C====== b1 \113 9C====== b9 \123 AC====== c7 \133 BC====== + a4 \104 8G====== b2 \114 9G====== c0 \124 AG====== c8 \134 BG====== + a5 \105 8K====== b3 \115 9K====== c1 \125 AK====== c9 \135 BK====== + a6 \106 8O====== b4 \116 9O====== c2 \126 AO====== d0 \136 BO====== + a7 \107 8S====== b5 \117 9S====== c3 \127 AS====== d1 \137 BS====== + - - - - - - - - - - - - + d2 \140 C0====== e0 \150 D0====== e8 \160 E0====== f6 \170 F0====== + d3 \141 C4====== e1 \151 D4====== e9 \161 E4====== f7 \171 F4====== + d4 \142 C8====== e2 \152 D8====== f0 \162 E8====== f8 \172 F8====== + d5 \143 CC====== e3 \153 DC====== f1 \163 EC====== f9 \173 FC====== + d6 \144 CG====== e4 \154 DG====== f2 \164 EG====== g0 \174 FG====== + d7 \145 CK====== e5 \155 DK====== f3 \165 EK====== g1 \175 FK====== + d8 \146 CO====== e6 \156 DO====== f4 \166 EO====== g2 \176 FO====== + d9 \147 CS====== e7 \157 DS====== f5 \167 ES====== g3 \177 FS====== + - - - - - - - - - - - - + h0 \200 G0====== h8 \210 H0====== i6 \220 I0====== j4 \230 J0====== + h1 \201 G4====== h9 \211 H4====== i7 \221 I4====== j5 \231 J4====== + h2 \202 G8====== i0 \212 H8====== i8 \222 I8====== j6 \232 J8====== + h3 \203 GC====== i1 \213 HC====== i9 \223 IC====== j7 \233 JC====== + h4 \204 GG====== i2 \214 HG====== j0 \224 IG====== j8 \234 JG====== + h5 \205 GK====== i3 \215 HK====== j1 \225 IK====== j9 \235 JK====== + h6 \206 GO====== i4 \216 HO====== j2 \226 IO====== k0 \236 JO====== + h7 \207 GS====== i5 \217 HS====== j3 \227 IS====== k1 \237 JS====== + - - - - - - - - - - - - + k2 \240 K0====== l0 \250 L0====== l8 \260 M0====== m6 \270 N0====== + k3 \241 K4====== l1 \251 L4====== l9 \261 M4====== m7 \271 N4====== + k4 \242 K8====== l2 \252 L8====== m0 \262 M8====== m8 \272 N8====== + k5 \243 KC====== l3 \253 LC====== m1 \263 MC====== m9 \273 NC====== + k6 \244 KG====== l4 \254 LG====== m2 \264 MG====== n0 \274 NG====== + k7 \245 KK====== l5 \255 LK====== m3 \265 MK====== n1 \275 NK====== + k8 \246 KO====== l6 \256 LO====== m4 \266 MO====== n2 \276 NO====== + k9 \247 KS====== l7 \257 LS====== m5 \267 MS====== n3 \277 NS====== + - - - - - - - - - - - - + o0 \300 O0====== o8 \310 P0====== p6 \320 Q0====== q4 \330 R0====== + o1 \301 O4====== o9 \311 P4====== p7 \321 Q4====== q5 \331 R4====== + o2 \302 O8====== p0 \312 P8====== p8 \322 Q8====== q6 \332 R8====== + o3 \303 OC====== p1 \313 PC====== p9 \323 QC====== q7 \333 RC====== + o4 \304 OG====== p2 \314 PG====== q0 \324 QG====== q8 \334 RG====== + o5 \305 OK====== p3 \315 PK====== q1 \325 QK====== q9 \335 RK====== + o6 \306 OO====== p4 \316 PO====== q2 \326 QO====== r0 \336 RO====== + o7 \307 OS====== p5 \317 PS====== q3 \327 QS====== r1 \337 RS====== + - - - - - - - - - - - - + r2 \340 S0====== s0 \350 T0====== s8 \360 U0====== t6 \370 V0====== + r3 \341 S4====== s1 \351 T4====== s9 \361 U4====== t7 \371 V4====== + r4 \342 S8====== s2 \352 T8====== t0 \362 U8====== t8 \372 V8====== + r5 \343 SC====== s3 \353 TC====== t1 \363 UC====== t9 \373 VC====== + r6 \344 SG====== s4 \354 TG====== t2 \364 UG====== u0 \374 VG====== + r7 \345 SK====== s5 \355 TK====== t3 \365 UK====== u1 \375 VK====== + r8 \346 SO====== s6 \356 TO====== t4 \366 UO====== u2 \376 VO====== + r9 \347 SS====== s7 \357 TS====== t5 \367 US====== u3 \377 VS====== +} { + if {$n == "-"} continue + test base32-hex-${impl}-3.$n "Encode \"$text\"" -body { + ::base32::hex::encode $text + } -result $encoded ; # {} + + test base32-hex-${impl}-4.$n "Decode \"$encoded\"" -body { + ::base32::hex::decode $encoded + } -result $text ; # {} +} + +# ------------------------------------------------------------------------- +# Decoder stress testing bad input + +foreach {n input message} { + 0 abcdeZaa {Invalid character at index 5: "Z"} + 1 A {Length is not a multiple of 8} + 2 ABCDEFG {Length is not a multiple of 8} + 3 A======= {Invalid padding of length 7} + 4 ACA===== {Invalid padding of length 5} + 5 A=CA==== {Invalid character at index 1: "=" (padding found in the middle of the input)} +} { + test base32-hex-${impl}-5.$n "Decode, bad input \"$input\"" -body { + ::base32::hex::decode $input + } -returnCodes error -result $message ; # {} +} diff --git a/tcllib/modules/base32/base32hex_c.tcl b/tcllib/modules/base32/base32hex_c.tcl new file mode 100644 index 0000000..5466463 --- /dev/null +++ b/tcllib/modules/base32/base32hex_c.tcl @@ -0,0 +1,253 @@ +# base32hexc.tcl -- +# +# Implementation of a base32 (extended hex) de/encoder for Tcl. +# +# Public domain +# +# RCS: @(#) $Id: base32hex_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $ + +package require critcl +package require Tcl 8.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 ((char*)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 = (unsigned char*) 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 diff --git a/tcllib/modules/base32/base32hex_tcl.tcl b/tcllib/modules/base32/base32hex_tcl.tcl new file mode 100644 index 0000000..f406bc6 --- /dev/null +++ b/tcllib/modules/base32/base32hex_tcl.tcl @@ -0,0 +1,79 @@ +# -*- tcl -*- +# This code is hereby put into the public domain. +# ### ### ### ######### ######### ######### +## Overview +# Base32 encoding and decoding of small strings. + +# ### ### ### ######### ######### ######### +## Notes + +# A binary string is split into groups of 5 bits (2^5 == 32), and each +# group is converted into a printable character as is specified in RFC +# 3548 for the extended hex encoding. + +# ### ### ### ######### ######### ######### +## Requisites + +package require base32::core +namespace eval ::base32::hex {} + +# ### ### ### ######### ######### ######### +## API & Implementation + +proc ::base32::hex::tcl_encode {bitstring} { + variable forward + + binary scan $bitstring B* bits + set len [string length $bits] + set rem [expr {$len % 5}] + if {$rem} {append bits =/$rem} + #puts "($bitstring) => <$bits>" + + return [string map $forward $bits] +} + +proc ::base32::hex::tcl_decode {estring} { + variable backward + variable invalid + + if {![core::valid $estring $invalid msg]} { + return -code error $msg + } + #puts "I<$estring>" + #puts "M<[string map $backward $estring]>" + + return [binary format B* [string map $backward [string toupper $estring]]] +} + +# ### ### ### ######### ######### ######### +## Data structures + +namespace eval ::base32::hex { + namespace eval core { + namespace import ::base32::core::define + namespace import ::base32::core::valid + } + + namespace export encode decode + # Initialize the maps + variable forward + variable backward + variable invalid + + core::define { + 0 0 9 9 18 I 27 R + 1 1 10 A 19 J 28 S + 2 2 11 B 20 K 29 T + 3 3 12 C 21 L 30 U + 4 4 13 D 22 M 31 V + 5 5 14 E 23 N + 6 6 15 F 24 O + 7 7 16 G 25 P + 8 8 17 H 26 Q + } forward backward invalid ; # {} + # puts ///$forward/// + # puts ///$backward/// +} + +# ### ### ### ######### ######### ######### +## Ok diff --git a/tcllib/modules/base32/pkgIndex.tcl b/tcllib/modules/base32/pkgIndex.tcl new file mode 100644 index 0000000..3bccaa7 --- /dev/null +++ b/tcllib/modules/base32/pkgIndex.tcl @@ -0,0 +1,4 @@ +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]] |