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