1# ascii85.tcl --
2#
3# Encode/Decode ascii85 for a string
4#
5# Copyright (c) Emiliano Gavilan
6# See the file "license.terms" for information on usage and redistribution
7# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
8
9package require Tcl 8.4
10
11namespace eval ascii85 {
12    namespace export encode encodefile decode
13    # default values for encode options
14    variable options
15    array set options [list -wrapchar \n -maxlen 76]
16}
17
18# ::ascii85::encode --
19#
20#   Ascii85 encode a given string.
21#
22# Arguments:
23#   args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
24#
25#   If maxlen is 0, the output is not wrapped.
26#
27# Results:
28#   A Ascii85 encoded version of $string, wrapped at $maxlen characters
29#   by $wrapchar.
30
31proc ascii85::encode {args} {
32    variable options
33
34    set alen [llength $args]
35    if {$alen != 1 && $alen != 3 && $alen != 5} {
36        return -code error "wrong # args:\
37            should be \"[lindex [info level 0] 0]\
38            ?-maxlen maxlen?\
39            ?-wrapchar wrapchar? string\""
40    }
41
42    set data [lindex $args end]
43    array set opts [array get options]
44    array set opts [lrange $args 0 end-1]
45    foreach key [array names opts] {
46        if {[lsearch -exact [array names options] $key] == -1} {
47            return -code error "unknown option \"$key\":\
48                must be -maxlen or -wrapchar"
49        }
50    }
51
52    if {![string is integer -strict $opts(-maxlen)]
53        || $opts(-maxlen) < 0} {
54        return -code error "expected positive integer but got\
55            \"$opts(-maxlen)\""
56    }
57
58    # perform this check early
59    if {[string length $data] == 0} {
60        return ""
61    }
62
63    # shorten the names
64    set ml $opts(-maxlen)
65    set wc $opts(-wrapchar)
66
67    # if maxlen is zero, don't wrap the output
68    if {$ml == 0} {
69        set wc ""
70    }
71
72    set encoded {}
73
74    binary scan $data c* X
75    set len      [llength $X]
76    set rest     [expr {$len % 4}]
77    set lastidx  [expr {$len - $rest - 1}]
78
79    foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] {
80        # calculate the 32 bit value
81        # this is an inlined version of the [encode4bytes] proc
82        # included here for performance reasons
83        set val [expr {
84            (  (($b1 & 0xff) << 24)
85              |(($b2 & 0xff) << 16)
86              |(($b3 & 0xff) << 8)
87              | ($b4 & 0xff)
88            ) & 0xffffffff }]
89
90        if {$val == 0} {
91            # four \0 bytes encodes as "z" instead of "!!!!!"
92            append current "z"
93        } else {
94            # no magic numbers here.
95            # 52200625 -> 85 ** 4
96            # 614125   -> 85 ** 3
97            # 7225     -> 85 ** 2
98            append current [binary format ccccc \
99                [expr { ( $val / 52200625) + 33 }] \
100                [expr { (($val % 52200625) / 614125) + 33 }] \
101                [expr { (($val % 614125) / 7225) + 33 }] \
102                [expr { (($val % 7225) / 85) + 33 }] \
103                [expr { ( $val % 85) + 33 }]]
104        }
105
106        if {[string length $current] >= $ml} {
107            append encoded [string range $current 0 [expr {$ml - 1}]] $wc
108            set current    [string range $current $ml end]
109        }
110    }
111
112    if { $rest } {
113        # there are remaining bytes.
114        # pad with \0 and encode not using the "z" convention.
115        # finally, add ($rest + 1) chars.
116        set val 0
117        foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break
118        append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest]
119    }
120    append encoded [regsub -all -- ".{$ml}" $current "&$wc"]
121
122    return $encoded
123}
124
125proc ascii85::encode4bytes {b1 b2 b3 b4} {
126    set val [expr {
127        (  (($b1 & 0xff) << 24)
128          |(($b2 & 0xff) << 16)
129          |(($b3 & 0xff) << 8)
130          | ($b4 & 0xff)
131        ) & 0xffffffff }]
132    return [binary format ccccc \
133            [expr { ( $val / 52200625) + 33 }] \
134            [expr { (($val % 52200625) / 614125) + 33 }] \
135            [expr { (($val % 614125) / 7225) + 33 }] \
136            [expr { (($val % 7225) / 85) + 33 }] \
137            [expr { ( $val % 85) + 33 }]]
138}
139
140# ::ascii85::encodefile --
141#
142#   Ascii85 encode the contents of a file using default values
143#   for maxlen and wrapchar parameters.
144#
145# Arguments:
146#   fname    The name of the file to encode.
147#
148# Results:
149#   An Ascii85 encoded version of the contents of the file.
150#   This is a convenience command
151
152proc ascii85::encodefile {fname} {
153    set fd [open $fname]
154    fconfigure $fd -encoding binary -translation binary
155    return [encode [read $fd]][close $fd]
156}
157
158# ::ascii85::decode --
159#
160#   Ascii85 decode a given string.
161#
162# Arguments:
163#   string      The string to decode.
164# Leading spaces and tabs are removed, along with trailing newlines
165#
166# Results:
167#   The decoded value.
168
169proc ascii85::decode {data} {
170    # get rid of leading spaces/tabs and trailing newlines
171    set data [string map [list \n {} \t {} { } {}] $data]
172    set len [string length $data]
173
174    # perform this ckeck early
175    if {! $len} {
176        return ""
177    }
178
179    set decoded {}
180    set count 0
181    set group [list]
182    binary scan $data c* X
183
184    foreach char $X {
185        # we must check that every char is in the allowed range
186        if {$char < 33 || $char > 117 } {
187            # "z" is an exception
188            if {$char == 122} {
189                if {$count == 0} {
190                    # if a "z" char appears at the beggining of a group,
191                    # it decodes as four null bytes
192                    append decoded \x00\x00\x00\x00
193                    continue
194                } else {
195                    # if not, is an error
196                    return -code error \
197                        "error decoding data: \"z\" char misplaced"
198                }
199            }
200            # char is not in range and not a "z" at the beggining of a group
201            return -code error \
202                "error decoding data: chars outside the allowed range"
203        }
204
205        lappend group $char
206        incr count
207        if {$count == 5} {
208            # this is an inlined version of the [decode5chars] proc
209            # included here for performance reasons
210            set val [expr {
211                ([lindex $group 0] - 33) * wide(52200625) +
212                ([lindex $group 1] - 33) * 614125 +
213                ([lindex $group 2] - 33) * 7225 +
214                ([lindex $group 3] - 33) * 85 +
215                ([lindex $group 4] - 33) }]
216            if {$val > 0xffffffff} {
217                return -code error "error decoding data: decoded group overflow"
218            } else {
219                append decoded [binary format I $val]
220                incr count -5
221                set group [list]
222            }
223        }
224    }
225
226    set len [llength $group]
227    switch -- $len {
228        0 {
229            # all input has been consumed
230            # do nothing
231        }
232        1 {
233            # a single char is a condition error, there should be at least 2
234            return -code error \
235                "error decoding data: trailing char"
236        }
237        default {
238            # pad with "u"s, decode and add ($len - 1) bytes
239            append decoded [string range \
240                    [decode5chars [pad $group 5 122]] \
241                    0 \
242                    [expr {$len - 2}]]
243        }
244    }
245
246    return $decoded
247}
248
249proc ascii85::decode5chars {group} {
250    set val [expr {
251        ([lindex $group 0] - 33) * wide(52200625) +
252        ([lindex $group 1] - 33) * 614125 +
253        ([lindex $group 2] - 33) * 7225 +
254        ([lindex $group 3] - 33) * 85 +
255        ([lindex $group 4] - 33) }]
256    if {$val > 0xffffffff} {
257        return -code error "error decoding data: decoded group overflow"
258    }
259
260    return [binary format I $val]
261}
262
263proc ascii85::pad {chars len padchar} {
264    while {[llength $chars] < $len} {
265        lappend chars $padchar
266    }
267
268    return $chars
269}
270
271package provide ascii85 1.0
272