# 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 # # stripped versions of the originals to work in 8.0. # # 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.bench,v 1.5 2002/07/24 15:10:37 msofer Exp $ if {[catch {package require Tcl 8.0}]} { return } namespace eval base64 { proc init {} { variable base64 variable base64_en variable base64en {} 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($char) $i set base64_en($i) $char lappend base64en $char incr i } } init namespace export *code* } proc base64::encode {string} { variable base64_en set wrapchar "\n" set maxlen 60 set result {} set state 0 set length 0 foreach {c} [split $string {}] { # 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 } scan $c %c x incr state if {$state == 1} { append result $base64_en([expr {($x >>2) & 0x3F}]) } elseif {$state == 2} { append result \ $base64_en([expr {(($old << 4) & 0x30)|(($x >> 4) & 0xF)}]) } elseif {$state == 3} { append result \ $base64_en([expr {(($old << 2) & 0x3C)|(($x >> 6) & 0x3)}]) append result $base64_en([expr {($x & 0x3F)}]) incr length set state 0 } set old $x incr length } set x 0 # state 0 is OK if {$state == 1} { append result $base64_en([expr {(($old << 4) & 0x30)}])== } elseif {$state == 2} { append result $base64_en([expr {(($old << 2) & 0x3C)}])= } return $result } proc base64::encode2 {string} { variable base64en set wrapchar "\n" set maxlen 60 set result {} set state 0 set length 0 foreach {c} [split $string {}] { # 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 } scan $c %c x incr state if {$state == 1} { append result [lindex $base64en [expr {($x >>2) & 0x3F}]] } elseif {$state == 2} { append result [lindex $base64en \ [expr {(($old << 4) & 0x30)|(($x >> 4) & 0xF)}]] } elseif {$state == 3} { append result [lindex $base64en \ [expr {(($old << 2) & 0x3C)|(($x >> 6) & 0x3)}]] append result [lindex $base64en [expr {($x & 0x3F)}]] incr length set state 0 } set old $x incr length } set x 0 # state 0 is OK if {$state == 1} { append result [lindex $base64en [expr {(($old << 4) & 0x30)}]]== } elseif {$state == 2} { append result [lindex $base64en [expr {(($old << 2) & 0x3C)}]]= } return $result } proc base64::decode {string} { variable base64 set output {} set group 0 set j 18 foreach char [split $string {}] { if {[string compare $char "="]} { # 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. if { ![info exists base64($char)] } { continue } set bits $base64($char) set group [expr {$group | ($bits << $j)}] if {[incr j -6] < 0} { scan [format %06x $group] %2x%2x%2x a b c append output [format %c%c%c $a $b $c] set group 0 set j 18 } } else { # = indicates end of data. Output whatever chars are left. # The encoding algorithm dictates that we can only have 1 or 2 # padding characters. If j is 6, we have 12 bits of input # (enough for 1 8-bit output). If j is 0, we have 18 bits of # input (enough for 2 8-bit outputs). # It is crucial to scan three hex digits even though we # discard c - older code used %04x and scanned 2 hex digits # but really ended up generating 5 or 6 (not 4!) digits and # resulted in alignment errors. scan [format %06x $group] %2x%2x%2x a b c if {$j == 6} { append output [format %c $a] } elseif {$j == 0} { append output [format %c%c $a $b] } break } } return $output } proc base64::decode2 {string} { variable base64 set output {} set group 0 set j 18 foreach char [split $string {}] { if {![string compare $char "="]} { # = indicates end of data. Output whatever chars are left. # The encoding algorithm dictates that we can only have 1 or 2 # padding characters. If j is 6, we have 12 bits of input # (enough for 1 8-bit output). If j is 0, we have 18 bits of # input (enough for 2 8-bit outputs). # It is crucial to scan three hex digits even though we # discard c - older code used %04x and scanned 2 hex digits # but really ended up generating 5 or 6 (not 4!) digits and # resulted in alignment errors. scan [format %06x $group] %2x%2x%2x a b c if {$j == 6} { append output [format %c $a] } elseif {$j == 0} { append output [format %c%c $a $b] } break } elseif {[info exists base64($char)]} { # 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. set group [expr {$group | ($base64($char) << $j)}] if {[incr j -6] < 0} { scan [format %06x $group] %2x%2x%2x a b c append output [format %c%c%c $a $b $c] set group 0 set j 18 } } } return $output } # # This is the code from # tcllib/modules/base64/base64.tcl version 2.2.1 # namespace eval base64_3 { 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_3::encode {args} { set base64_en $::base64_3::base64_en # Set the default wrapchar and maximum line length to match the output # of GNU uuencode 4.2. Various RFC's 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_3::decode {string} { if {[string length $string] == 0} {return ""} set base64 $::base64_3::base64 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 } if { [catch {string repeat "abc" 10}] } { proc str-repeat {str num} { set val {} for {set i 0} {$i < $num} {incr i} { append val $str } set val } } else { proc str-repeat {str num} { string repeat $str $num } } foreach len {10 100 1000 10000} \ iter {100 40 20 10} { # works for 8.2+ only set str [str-repeat "aZA(8)% -a" [expr {$len/10}]] set encstr [base64::encode $str] bench -desc "BASE64 encode $len" -iter $iter \ -body {base64::encode $str} bench -desc "BASE64 encode2 $len" -iter $iter \ -body {base64::encode2 $str} -result $encstr bench -desc "BASE64 encode3 $len" -iter $iter \ -body {base64_3::encode $str} -result $encstr bench -desc "BASE64 decode $len" -iter $iter \ -body {base64::decode $encstr} -result $str bench -desc "BASE64 decode2 $len" -iter $iter \ -body {base64::decode2 $encstr} -result $str bench -desc "BASE64 decode3 $len" -iter $iter \ -body {base64_3::decode $encstr} -result $str }