tcl_tests/base64.tcl

   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.1 2012-04-04 10:50:38 igus 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