]> wagner.pp.ru Git - openssl-gost/engine.git/blob - tcl_tests/base64.tcl
Update Copyright lines after registration rework
[openssl-gost/engine.git] / 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