| 1 | # base64.tcl -- |
|---|
| 2 | # |
|---|
| 3 | # Encode/Decode base64 for a string |
|---|
| 4 | # Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems |
|---|
| 5 | # The decoder was done for exmh by Chris Garrigues |
|---|
| 6 | # |
|---|
| 7 | # Copyright (c) 1998-2000 by Ajuba Solutions. |
|---|
| 8 | # See the file "license.terms" for information on usage and redistribution |
|---|
| 9 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|---|
| 10 | # |
|---|
| 11 | # RCS: @(#) $Id: base64.tcl,v 1.27 2005/12/09 18:27:15 andreas_kupries Exp $ |
|---|
| 12 | |
|---|
| 13 | # Version 1.0 implemented Base64_Encode, Base64_Decode |
|---|
| 14 | # Version 2.0 uses the base64 namespace |
|---|
| 15 | # Version 2.1 fixes various decode bugs and adds options to encode |
|---|
| 16 | # Version 2.2 is much faster, Tcl8.0 compatible |
|---|
| 17 | # Version 2.2.1 bugfixes |
|---|
| 18 | # Version 2.2.2 bugfixes |
|---|
| 19 | # Version 2.3 bugfixes and extended to support Trf |
|---|
| 20 | |
|---|
| 21 | # @mdgen EXCLUDE: base64c.tcl |
|---|
| 22 | |
|---|
| 23 | package require Tcl 8.2 |
|---|
| 24 | namespace eval ::base64 { |
|---|
| 25 | namespace export encode decode |
|---|
| 26 | } |
|---|
| 27 | |
|---|
| 28 | if {![catch {package require Trf 2.0}]} { |
|---|
| 29 | # Trf is available, so implement the functionality provided here |
|---|
| 30 | # in terms of calls to Trf for speed. |
|---|
| 31 | |
|---|
| 32 | # ::base64::encode -- |
|---|
| 33 | # |
|---|
| 34 | # Base64 encode a given string. |
|---|
| 35 | # |
|---|
| 36 | # Arguments: |
|---|
| 37 | # args ?-maxlen maxlen? ?-wrapchar wrapchar? string |
|---|
| 38 | # |
|---|
| 39 | # If maxlen is 0, the output is not wrapped. |
|---|
| 40 | # |
|---|
| 41 | # Results: |
|---|
| 42 | # A Base64 encoded version of $string, wrapped at $maxlen characters |
|---|
| 43 | # by $wrapchar. |
|---|
| 44 | |
|---|
| 45 | proc ::base64::encode {args} { |
|---|
| 46 | # Set the default wrapchar and maximum line length to match the output |
|---|
| 47 | # of GNU uuencode 4.2. Various RFCs allow for different wrapping |
|---|
| 48 | # characters and wraplengths, so these may be overridden by command line |
|---|
| 49 | # options. |
|---|
| 50 | set wrapchar "\n" |
|---|
| 51 | set maxlen 60 |
|---|
| 52 | |
|---|
| 53 | if { [llength $args] == 0 } { |
|---|
| 54 | error "wrong # args: should be \"[lindex [info level 0] 0]\ |
|---|
| 55 | ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" |
|---|
| 56 | } |
|---|
| 57 | |
|---|
| 58 | set optionStrings [list "-maxlen" "-wrapchar"] |
|---|
| 59 | for {set i 0} {$i < [llength $args] - 1} {incr i} { |
|---|
| 60 | set arg [lindex $args $i] |
|---|
| 61 | set index [lsearch -glob $optionStrings "${arg}*"] |
|---|
| 62 | if { $index == -1 } { |
|---|
| 63 | error "unknown option \"$arg\": must be -maxlen or -wrapchar" |
|---|
| 64 | } |
|---|
| 65 | incr i |
|---|
| 66 | if { $i >= [llength $args] - 1 } { |
|---|
| 67 | error "value for \"$arg\" missing" |
|---|
| 68 | } |
|---|
| 69 | set val [lindex $args $i] |
|---|
| 70 | |
|---|
| 71 | # The name of the variable to assign the value to is extracted |
|---|
| 72 | # from the list of known options, all of which have an |
|---|
| 73 | # associated variable of the same name as the option without |
|---|
| 74 | # a leading "-". The [string range] command is used to strip |
|---|
| 75 | # of the leading "-" from the name of the option. |
|---|
| 76 | # |
|---|
| 77 | # FRINK: nocheck |
|---|
| 78 | set [string range [lindex $optionStrings $index] 1 end] $val |
|---|
| 79 | } |
|---|
| 80 | |
|---|
| 81 | # [string is] requires Tcl8.2; this works with 8.0 too |
|---|
| 82 | if {[catch {expr {$maxlen % 2}}]} { |
|---|
| 83 | error "expected integer but got \"$maxlen\"" |
|---|
| 84 | } |
|---|
| 85 | |
|---|
| 86 | set string [lindex $args end] |
|---|
| 87 | set result [::base64 -mode encode -- $string] |
|---|
| 88 | set result [string map [list \n ""] $result] |
|---|
| 89 | |
|---|
| 90 | if {$maxlen > 0} { |
|---|
| 91 | set res "" |
|---|
| 92 | set edge [expr {$maxlen - 1}] |
|---|
| 93 | while {[string length $result] > $maxlen} { |
|---|
| 94 | append res [string range $result 0 $edge]$wrapchar |
|---|
| 95 | set result [string range $result $maxlen end] |
|---|
| 96 | } |
|---|
| 97 | if {[string length $result] > 0} { |
|---|
| 98 | append res $result |
|---|
| 99 | } |
|---|
| 100 | set result $res |
|---|
| 101 | } |
|---|
| 102 | |
|---|
| 103 | return $result |
|---|
| 104 | } |
|---|
| 105 | |
|---|
| 106 | # ::base64::decode -- |
|---|
| 107 | # |
|---|
| 108 | # Base64 decode a given string. |
|---|
| 109 | # |
|---|
| 110 | # Arguments: |
|---|
| 111 | # string The string to decode. Characters not in the base64 |
|---|
| 112 | # alphabet are ignored (e.g., newlines) |
|---|
| 113 | # |
|---|
| 114 | # Results: |
|---|
| 115 | # The decoded value. |
|---|
| 116 | |
|---|
| 117 | proc ::base64::decode {string} { |
|---|
| 118 | regsub -all {\s} $string {} string |
|---|
| 119 | ::base64 -mode decode -- $string |
|---|
| 120 | } |
|---|
| 121 | |
|---|
| 122 | } else { |
|---|
| 123 | # Without Trf use a pure tcl implementation |
|---|
| 124 | |
|---|
| 125 | namespace eval base64 { |
|---|
| 126 | variable base64 {} |
|---|
| 127 | variable base64_en {} |
|---|
| 128 | |
|---|
| 129 | # We create the auxiliary array base64_tmp, it will be unset later. |
|---|
| 130 | |
|---|
| 131 | set i 0 |
|---|
| 132 | 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 \ |
|---|
| 133 | 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 \ |
|---|
| 134 | 0 1 2 3 4 5 6 7 8 9 + /} { |
|---|
| 135 | set base64_tmp($char) $i |
|---|
| 136 | lappend base64_en $char |
|---|
| 137 | incr i |
|---|
| 138 | } |
|---|
| 139 | |
|---|
| 140 | # |
|---|
| 141 | # Create base64 as list: to code for instance C<->3, specify |
|---|
| 142 | # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded |
|---|
| 143 | # ascii chars get a {}. we later use the fact that lindex on a |
|---|
| 144 | # non-existing index returns {}, and that [expr {} < 0] is true |
|---|
| 145 | # |
|---|
| 146 | |
|---|
| 147 | # the last ascii char is 'z' |
|---|
| 148 | scan z %c len |
|---|
| 149 | for {set i 0} {$i <= $len} {incr i} { |
|---|
| 150 | set char [format %c $i] |
|---|
| 151 | set val {} |
|---|
| 152 | if {[info exists base64_tmp($char)]} { |
|---|
| 153 | set val $base64_tmp($char) |
|---|
| 154 | } else { |
|---|
| 155 | set val {} |
|---|
| 156 | } |
|---|
| 157 | lappend base64 $val |
|---|
| 158 | } |
|---|
| 159 | |
|---|
| 160 | # code the character "=" as -1; used to signal end of message |
|---|
| 161 | scan = %c i |
|---|
| 162 | set base64 [lreplace $base64 $i $i -1] |
|---|
| 163 | |
|---|
| 164 | # remove unneeded variables |
|---|
| 165 | unset base64_tmp i char len val |
|---|
| 166 | |
|---|
| 167 | namespace export encode decode |
|---|
| 168 | } |
|---|
| 169 | |
|---|
| 170 | # ::base64::encode -- |
|---|
| 171 | # |
|---|
| 172 | # Base64 encode a given string. |
|---|
| 173 | # |
|---|
| 174 | # Arguments: |
|---|
| 175 | # args ?-maxlen maxlen? ?-wrapchar wrapchar? string |
|---|
| 176 | # |
|---|
| 177 | # If maxlen is 0, the output is not wrapped. |
|---|
| 178 | # |
|---|
| 179 | # Results: |
|---|
| 180 | # A Base64 encoded version of $string, wrapped at $maxlen characters |
|---|
| 181 | # by $wrapchar. |
|---|
| 182 | |
|---|
| 183 | proc ::base64::encode {args} { |
|---|
| 184 | set base64_en $::base64::base64_en |
|---|
| 185 | |
|---|
| 186 | # Set the default wrapchar and maximum line length to match the output |
|---|
| 187 | # of GNU uuencode 4.2. Various RFCs allow for different wrapping |
|---|
| 188 | # characters and wraplengths, so these may be overridden by command line |
|---|
| 189 | # options. |
|---|
| 190 | set wrapchar "\n" |
|---|
| 191 | set maxlen 60 |
|---|
| 192 | |
|---|
| 193 | if { [llength $args] == 0 } { |
|---|
| 194 | error "wrong # args: should be \"[lindex [info level 0] 0]\ |
|---|
| 195 | ?-maxlen maxlen? ?-wrapchar wrapchar? string\"" |
|---|
| 196 | } |
|---|
| 197 | |
|---|
| 198 | set optionStrings [list "-maxlen" "-wrapchar"] |
|---|
| 199 | for {set i 0} {$i < [llength $args] - 1} {incr i} { |
|---|
| 200 | set arg [lindex $args $i] |
|---|
| 201 | set index [lsearch -glob $optionStrings "${arg}*"] |
|---|
| 202 | if { $index == -1 } { |
|---|
| 203 | error "unknown option \"$arg\": must be -maxlen or -wrapchar" |
|---|
| 204 | } |
|---|
| 205 | incr i |
|---|
| 206 | if { $i >= [llength $args] - 1 } { |
|---|
| 207 | error "value for \"$arg\" missing" |
|---|
| 208 | } |
|---|
| 209 | set val [lindex $args $i] |
|---|
| 210 | |
|---|
| 211 | # The name of the variable to assign the value to is extracted |
|---|
| 212 | # from the list of known options, all of which have an |
|---|
| 213 | # associated variable of the same name as the option without |
|---|
| 214 | # a leading "-". The [string range] command is used to strip |
|---|
| 215 | # of the leading "-" from the name of the option. |
|---|
| 216 | # |
|---|
| 217 | # FRINK: nocheck |
|---|
| 218 | set [string range [lindex $optionStrings $index] 1 end] $val |
|---|
| 219 | } |
|---|
| 220 | |
|---|
| 221 | # [string is] requires Tcl8.2; this works with 8.0 too |
|---|
| 222 | if {[catch {expr {$maxlen % 2}}]} { |
|---|
| 223 | error "expected integer but got \"$maxlen\"" |
|---|
| 224 | } |
|---|
| 225 | |
|---|
| 226 | set string [lindex $args end] |
|---|
| 227 | |
|---|
| 228 | set result {} |
|---|
| 229 | set state 0 |
|---|
| 230 | set length 0 |
|---|
| 231 | |
|---|
| 232 | |
|---|
| 233 | # Process the input bytes 3-by-3 |
|---|
| 234 | |
|---|
| 235 | binary scan $string c* X |
|---|
| 236 | foreach {x y z} $X { |
|---|
| 237 | # Do the line length check before appending so that we don't get an |
|---|
| 238 | # extra newline if the output is a multiple of $maxlen chars long. |
|---|
| 239 | if {$maxlen && $length >= $maxlen} { |
|---|
| 240 | append result $wrapchar |
|---|
| 241 | set length 0 |
|---|
| 242 | } |
|---|
| 243 | |
|---|
| 244 | append result [lindex $base64_en [expr {($x >>2) & 0x3F}]] |
|---|
| 245 | if {$y != {}} { |
|---|
| 246 | append result [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] |
|---|
| 247 | if {$z != {}} { |
|---|
| 248 | append result \ |
|---|
| 249 | [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] |
|---|
| 250 | append result [lindex $base64_en [expr {($z & 0x3F)}]] |
|---|
| 251 | } else { |
|---|
| 252 | set state 2 |
|---|
| 253 | break |
|---|
| 254 | } |
|---|
| 255 | } else { |
|---|
| 256 | set state 1 |
|---|
| 257 | break |
|---|
| 258 | } |
|---|
| 259 | incr length 4 |
|---|
| 260 | } |
|---|
| 261 | if {$state == 1} { |
|---|
| 262 | append result [lindex $base64_en [expr {(($x << 4) & 0x30)}]]== |
|---|
| 263 | } elseif {$state == 2} { |
|---|
| 264 | append result [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]= |
|---|
| 265 | } |
|---|
| 266 | return $result |
|---|
| 267 | } |
|---|
| 268 | |
|---|
| 269 | # ::base64::decode -- |
|---|
| 270 | # |
|---|
| 271 | # Base64 decode a given string. |
|---|
| 272 | # |
|---|
| 273 | # Arguments: |
|---|
| 274 | # string The string to decode. Characters not in the base64 |
|---|
| 275 | # alphabet are ignored (e.g., newlines) |
|---|
| 276 | # |
|---|
| 277 | # Results: |
|---|
| 278 | # The decoded value. |
|---|
| 279 | |
|---|
| 280 | proc ::base64::decode {string} { |
|---|
| 281 | if {[string length $string] == 0} {return ""} |
|---|
| 282 | |
|---|
| 283 | set base64 $::base64::base64 |
|---|
| 284 | set output "" ; # Fix for [Bug 821126] |
|---|
| 285 | |
|---|
| 286 | binary scan $string c* X |
|---|
| 287 | foreach x $X { |
|---|
| 288 | set bits [lindex $base64 $x] |
|---|
| 289 | if {$bits >= 0} { |
|---|
| 290 | if {[llength [lappend nums $bits]] == 4} { |
|---|
| 291 | foreach {v w z y} $nums break |
|---|
| 292 | set a [expr {($v << 2) | ($w >> 4)}] |
|---|
| 293 | set b [expr {(($w & 0xF) << 4) | ($z >> 2)}] |
|---|
| 294 | set c [expr {(($z & 0x3) << 6) | $y}] |
|---|
| 295 | append output [binary format ccc $a $b $c] |
|---|
| 296 | set nums {} |
|---|
| 297 | } |
|---|
| 298 | } elseif {$bits == -1} { |
|---|
| 299 | # = indicates end of data. Output whatever chars are left. |
|---|
| 300 | # The encoding algorithm dictates that we can only have 1 or 2 |
|---|
| 301 | # padding characters. If x=={}, we have 12 bits of input |
|---|
| 302 | # (enough for 1 8-bit output). If x!={}, we have 18 bits of |
|---|
| 303 | # input (enough for 2 8-bit outputs). |
|---|
| 304 | |
|---|
| 305 | foreach {v w z} $nums break |
|---|
| 306 | set a [expr {($v << 2) | (($w & 0x30) >> 4)}] |
|---|
| 307 | if {$z == {}} { |
|---|
| 308 | append output [binary format c $a ] |
|---|
| 309 | } else { |
|---|
| 310 | set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] |
|---|
| 311 | append output [binary format cc $a $b] |
|---|
| 312 | } |
|---|
| 313 | break |
|---|
| 314 | } else { |
|---|
| 315 | # RFC 2045 says that line breaks and other characters not part |
|---|
| 316 | # of the Base64 alphabet must be ignored, and that the decoder |
|---|
| 317 | # can optionally emit a warning or reject the message. We opt |
|---|
| 318 | # not to do so, but to just ignore the character. |
|---|
| 319 | continue |
|---|
| 320 | } |
|---|
| 321 | } |
|---|
| 322 | return $output |
|---|
| 323 | } |
|---|
| 324 | } |
|---|
| 325 | |
|---|
| 326 | package provide base64 2.3.2 |
|---|
