Tcl/Tk Benchmark Suite And Tools
Artifact Content
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2018 Conference, Houston/TX, US, Oct 15-19
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Aug 20.

Artifact 29069fb82832edc7d06477ed0b8aa6a1436325a5:


# 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
}