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 1ee2bfd2b76cc111fb278505bb3dca012f59439c:


# ascii85.tcl --
#
# Encode/Decode ascii85 for a string
#
# Copyright (c) Emiliano Gavilan
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {[catch {package require Tcl 8.4}]} {
    # uses eq and 8.4 regsub features
    return
}

namespace eval ascii85 {
    namespace export encode encodefile decode 
    # default values for encode options
    variable options
    array set options [list -wrapchar \n -maxlen 76]
}

# ::ascii85::encode --
#
#   Ascii85 encode a given string.
#
# Arguments:
#   args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
#
#   If maxlen is 0, the output is not wrapped.
#
# Results:
#   A Ascii85 encoded version of $string, wrapped at $maxlen characters
#   by $wrapchar.

proc ascii85::encode {args} {
    variable options

    set alen [llength $args]
    if {$alen != 1 && $alen != 3 && $alen != 5} {
        return -code error "wrong # args:\
            should be \"[lindex [info level 0] 0]\
            ?-maxlen maxlen?\
            ?-wrapchar wrapchar? string\""
    }

    set data [lindex $args end]
    array set opts [array get options]
    array set opts [lrange $args 0 end-1]
    foreach key [array names opts] {
        if {[lsearch -exact [array names options] $key] == -1} {
            return -code error "unknown option \"$key\":\
                must be -maxlen or -wrapchar"
        }
    }

    if {![string is integer -strict $opts(-maxlen)]
        || $opts(-maxlen) < 0 } {
        return -code error "expected positive integer but got\
            \"$opts(-maxlen)\""
    }

    # perform this check early
    if {[string length $data] == 0} {
        return ""
    }

    # shorten the names
    set ml $opts(-maxlen)
    set wc $opts(-wrapchar)

    # if maxlen is zero, don't wrap the output
    if {$ml == 0} {set wc ""}

    set encoded {}

    binary scan $data c* X
    set len      [llength $X]
    set rest     [expr {$len % 4}]
    set lastidx  [expr {$len - $rest - 1}]

    foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] {
        append current [encode4bytes [expr {
            (     (($b1 & 0xff) << 24) 
                | (($b2 & 0xff) << 16) 
                | (($b3 & 0xff) << 8) 
                | ($b4 & 0xff)
            ) & 0xffffffff }]]
        if {[string length $current] >= $ml} {
            append encoded [string range $current 0 [expr {$ml - 1}]] $wc
            set current    [string range $current $ml end]
        }
    }

    if { $rest } {
        set val 0
        foreach byte  [lrange $X [incr lastidx] end] shift {24 16 8 0} {
            set val [expr {
		($byte eq "") ?
                $val : 
                ($val | (($byte & 0xff) << $shift)) & 0xffffffff
            }]
        }
        append current [string range [binary format ccccc \
            [expr { ( $val / 52200625) + 33 }] \
            [expr { (($val % 52200625) / 614125) + 33 }] \
            [expr { (($val % 614125) / 7225) + 33 }] \
            [expr { (($val % 7225) / 85) + 33 }] \
            [expr { ( $val % 85) + 33 }]
        ] 0 $rest]
    }
    append encoded [regsub -all -- ".{$ml}" $current "&$wc"]

    return $encoded
}

proc ascii85::encode4bytes {val} {
    if {$val == 0} {return z}
    return [binary format ccccc \
        [expr { ( $val / 52200625) + 33 }] \
        [expr { (($val % 52200625) / 614125) + 33 }] \
        [expr { (($val % 614125) / 7225) + 33 }] \
        [expr { (($val % 7225) / 85) + 33 }] \
        [expr { ( $val % 85) + 33 }]]
}

# ::ascii85::encodefile --
#
#   Ascii85 encode the contents of a file using default values
#   for maxlen and wrapchar parameters.
#
# Arguments:
#   fname    The name of the file to encode.
#
# Results:
#   A Ascii85 encoded version of the contents of the file.

proc ascii85::encodefile {fname} {
    set fd [open $fname]
    fconfigure $fd -encoding binary -translation binary
    return [encode [read $fd]][close $fd]
}

# ::ascii85::decode --
#
#   Ascii85 decode a given string.
#
# Arguments:
#   string      The string to decode.
# Leading spaces and tabs are removed, along with trailing newlines
#
# Results:
#   The decoded value.

proc ascii85::decode {data} {
    # get rid of leading spaces/tabs and trailing newlines
    set data [string map [list \n {} \t {} { } {}] $data]

    set decoded {}
    set idx0 0
    set idx1 4
    set len [string length $data]

    # perform this ckeck early
    if {! $len} {
        return ""
    }

    # can't process this as a list like encoding does, since we have
    # to check for the "z" char; in that case advance only one position
    while {[string length [set 5b [string range $data $idx0 $idx1]]] == 5} {
        if {[string index $5b 0] eq "z"} {
            # the first char is a "z"; append four null bytes
            append decoded \x00\x00\x00\x00
            incr idx0 1
            incr idx1 1
            continue
        }
        # check that all bytes lie between ascii 33 ("!")
        # and ascii 117 ("u")
        checkrange $5b

        # the string is legal: decode it
        append decoded [decode5bytes $5b]
        incr idx0 5
        incr idx1 5
    }

    if {[string length $5b] == 0} {
        return $decoded
    }

    # ok, there are less than 5 chars in the string.
    # chomp leading "z"s first
    while {[string index $5b 0] eq "z"} {
        append decoded \x00\x00\x00\x00
        set 5b [string range $5b 1 end]
    }

    # if there is only one char left, is an error
    if {[string length $5b] == 1} {
        return -code error \
            "error decoding data: trailing char"
    }

    # check the range of the last chars
    checkrange $5b

    # pad with "u"s, decode and add ([string length $5b] - 1) bytes
    append decoded \
        [string range \
            [decode5bytes [pad $5b 5 u]] \
            0 \
            [expr {[string length $5b] - 2}]
        ]

    return $decoded
}

proc ascii85::decode5bytes {data} {
    binary scan $data ccccc b1 b2 b3 b4 b5
    return [binary format I [expr {
        ($b1 - 33) * wide(52200625) +
        ($b2 - 33) * 614125 +
        ($b3 - 33) * 7225 +
        ($b4 - 33) * 85 +
        ($b5 - 33) }]]
}

proc ascii85::checkrange {chars} {
    foreach char [split $chars {} ] {
        if {$char > "u" || $char < "!" } {
            return -code error \
                "error decoding data: wrong chars range \"$chars\""
        }
    }
}

proc ascii85::pad {chars len padchar} {
    while {[string length $chars] < $len} {
        append chars $padchar
    }
    return $chars
}

#package provide ascii85 1.0

# this test string appears on wikipedia
set str "Man is distinguished, not only by his reason, but by this\
singular passion from other animals, which is a lust of the mind, that\
by a perseverance of delight in the continued and indefatigable generation\
of knowledge, exceeds the short vehemence of any carnal pleasure."

if {[info commands bench] == ""} {
    puts "Tcl [info patchlevel]"
    set enc [ascii85::encode $str]
    puts "Encoded:\n$enc"
    set dec [ascii85::decode $enc]
    puts "Decoded:\n$dec"
} else {
    foreach len  {10 100} iter {100 40} {
        set str [string repeat $str $len]
        bench -desc "ascii85 strlen [string length $str]" -iter $iter \
            -body {::ascii85::encode $str}
    }
}