1# uuencode - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
2#
3# Provide a Tcl only implementation of uuencode and uudecode.
4#
5# -------------------------------------------------------------------------
6# See the file "license.terms" for information on usage and redistribution
7# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
8# -------------------------------------------------------------------------
9# @(#)$Id: uuencode.tcl,v 1.22 2009/05/07 01:10:37 patthoyts Exp $
10
11package require Tcl 8.2;                # tcl minimum version
12
13# Try and get some compiled helper package.
14if {[catch {package require tcllibc}]} {
15    catch {package require Trf}
16}
17
18namespace eval ::uuencode {
19    variable version 1.1.5
20
21    namespace export encode decode uuencode uudecode
22}
23
24proc ::uuencode::Enc {c} {
25    return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]]
26}
27
28proc ::uuencode::Encode {s} {
29    set r {}
30    binary scan $s c* d
31    foreach {c1 c2 c3} $d {
32        if {$c1 == {}} {set c1 0}
33        if {$c2 == {}} {set c2 0}
34        if {$c3 == {}} {set c3 0}
35        append r [Enc [expr {$c1 >> 2}]]
36        append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]]
37        append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]]
38        append r [Enc [expr {($c3 & 077)}]]
39    }
40    return $r
41}
42
43
44proc ::uuencode::Decode {s} {
45    if {[string length $s] == 0} {return ""}
46    set r {}
47    binary scan [pad $s] c* d
48
49    foreach {c0 c1 c2 c3} $d {
50        append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF
51                                   | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]]
52        append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF
53                                   | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]]
54        append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF
55                                   | (($c3-0x20)&0x3F) & 0xFF}]]
56    }
57    return $r
58}
59
60# -------------------------------------------------------------------------
61# C coded version of the Encode/Decode functions for base64c package.
62# -------------------------------------------------------------------------
63if {[package provide critcl] != {}} {
64    namespace eval ::uuencode {
65        critcl::ccode {
66            #include <string.h>
67            static unsigned char Enc(unsigned char c) {
68                return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60;
69            }
70        }
71        critcl::ccommand CEncode {dummy interp objc objv} {
72            Tcl_Obj *inputPtr, *resultPtr;
73            int len, rlen, xtra;
74            unsigned char *input, *p, *r;
75
76            if (objc !=  2) {
77                Tcl_WrongNumArgs(interp, 1, objv, "data");
78                return TCL_ERROR;
79            }
80
81            inputPtr = objv[1];
82            input = Tcl_GetByteArrayFromObj(inputPtr, &len);
83            if ((xtra = (3 - (len % 3))) != 3) {
84                if (Tcl_IsShared(inputPtr))
85                    inputPtr = Tcl_DuplicateObj(inputPtr);
86                input = Tcl_SetByteArrayLength(inputPtr, len + xtra);
87                memset(input + len, 0, xtra);
88                len += xtra;
89            }
90
91            rlen = (len / 3) * 4;
92            resultPtr = Tcl_NewObj();
93            r = Tcl_SetByteArrayLength(resultPtr, rlen);
94            memset(r, 0, rlen);
95
96            for (p = input; p < input + len; p += 3) {
97                char a, b, c;
98                a = *p; b = *(p+1), c = *(p+2);
99                *r++ = Enc(a >> 2);
100                *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017));
101                *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003));
102                *r++ = Enc(c & 077);
103            }
104            Tcl_SetObjResult(interp, resultPtr);
105            return TCL_OK;
106        }
107
108        critcl::ccommand CDecode {dummy interp objc objv} {
109            Tcl_Obj *inputPtr, *resultPtr;
110            int len, rlen, xtra;
111            unsigned char *input, *p, *r;
112
113            if (objc !=  2) {
114                Tcl_WrongNumArgs(interp, 1, objv, "data");
115                return TCL_ERROR;
116            }
117
118            /* if input is not mod 4, extend it with nuls */
119            inputPtr = objv[1];
120            input = Tcl_GetByteArrayFromObj(inputPtr, &len);
121            if ((xtra = (4 - (len % 4))) != 4) {
122                if (Tcl_IsShared(inputPtr))
123                    inputPtr = Tcl_DuplicateObj(inputPtr);
124                input = Tcl_SetByteArrayLength(inputPtr, len + xtra);
125                memset(input + len, 0, xtra);
126                len += xtra;
127            }
128
129            /* output will be 1/3 smaller than input and a multiple of 3 */
130            rlen = (len / 4) * 3;
131            resultPtr = Tcl_NewObj();
132            r = Tcl_SetByteArrayLength(resultPtr, rlen);
133            memset(r, 0, rlen);
134
135            for (p = input; p < input + len; p += 4) {
136                char a, b, c, d;
137                a = *p; b = *(p+1), c = *(p+2), d = *(p+3);
138                *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4);
139                *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2);
140                *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) );
141            }
142            Tcl_SetObjResult(interp, resultPtr);
143            return TCL_OK;
144        }
145    }
146}
147
148# -------------------------------------------------------------------------
149
150# Description:
151#  Permit more tolerant decoding of invalid input strings by padding to
152#  a multiple of 4 bytes with nulls.
153# Result:
154#  Returns the input string - possibly padded with uuencoded null chars.
155#
156proc ::uuencode::pad {s} {
157    if {[set mod [expr {[string length $s] % 4}]] != 0} {
158        append s [string repeat "`" [expr {4 - $mod}]]
159    }
160    return $s
161}
162
163# -------------------------------------------------------------------------
164
165# If the Trf package is available then we shall use this by default but the
166# Tcllib implementations are always visible if needed (ie: for testing)
167if {[info command ::uuencode::CDecode] != {}} {
168    # tcllib critcl package
169    interp alias {} ::uuencode::encode {} ::uuencode::CEncode
170    interp alias {} ::uuencode::decode {} ::uuencode::CDecode
171} elseif {[package provide Trf] != {}} {
172    proc ::uuencode::encode {s} {
173        return [::uuencode -mode encode -- $s]
174    }
175    proc ::uuencode::decode {s} {
176        return [::uuencode -mode decode -- [pad $s]]
177    }
178} else {
179    # pure-tcl then
180    interp alias {} ::uuencode::encode {} ::uuencode::Encode
181    interp alias {} ::uuencode::decode {} ::uuencode::Decode
182}
183
184# -------------------------------------------------------------------------
185
186proc ::uuencode::uuencode {args} {
187    array set opts {mode 0644 filename {} name {}}
188    set wrongargs "wrong \# args: should be\
189            \"uuencode ?-name string? ?-mode octal?\
190            (-file filename | ?--? string)\""
191    while {[string match -* [lindex $args 0]]} {
192        switch -glob -- [lindex $args 0] {
193            -f* {
194                if {[llength $args] < 2} {
195                    return -code error $wrongargs
196                }
197                set opts(filename) [lindex $args 1]
198                set args [lreplace $args 0 0]
199            }
200            -m* {
201                if {[llength $args] < 2} {
202                    return -code error $wrongargs
203                }
204                set opts(mode) [lindex $args 1]
205                set args [lreplace $args 0 0]
206            }
207            -n* {
208                if {[llength $args] < 2} {
209                    return -code error $wrongargs
210                }
211                set opts(name) [lindex $args 1]
212                set args [lreplace $args 0 0]
213            }
214            -- {
215                set args [lreplace $args 0 0]
216                break
217            }
218            default {
219                return -code error "bad option [lindex $args 0]:\
220                      must be -file, -mode, or -name"
221            }
222        }
223        set args [lreplace $args 0 0]
224    }
225
226    if {$opts(name) == {}} {
227        set opts(name) $opts(filename)
228    }
229    if {$opts(name) == {}} {
230        set opts(name) "data.dat"
231    }
232
233    if {$opts(filename) != {}} {
234        set f [open $opts(filename) r]
235        fconfigure $f -translation binary
236        set data [read $f]
237        close $f
238    } else {
239        if {[llength $args] != 1} {
240            return -code error $wrongargs
241        }
242        set data [lindex $args 0]
243    }
244
245    set r {}
246    append r [format "begin %o %s" $opts(mode) $opts(name)] "\n"
247    for {set n 0} {$n < [string length $data]} {incr n 45} {
248        set s [string range $data $n [expr {$n + 44}]]
249        append r [Enc [string length $s]]
250        append r [encode $s] "\n"
251    }
252    append r "`\nend"
253    return $r
254}
255
256# -------------------------------------------------------------------------
257# Description:
258#  Perform uudecoding of a file or data. A file may contain more than one
259#  encoded data section so the result is a list where each element is a
260#  three element list of the provided filename, the suggested mode and the
261#  data itself.
262#
263proc ::uuencode::uudecode {args} {
264    array set opts {mode 0644 filename {}}
265    set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\""
266    while {[string match -* [lindex $args 0]]} {
267        switch -glob -- [lindex $args 0] {
268            -f* {
269                if {[llength $args] < 2} {
270                    return -code error $wrongargs
271                }
272                set opts(filename) [lindex $args 1]
273                set args [lreplace $args 0 0]
274            }
275            -- {
276                set args [lreplace $args 0 0]
277                break
278            }
279            default {
280                return -code error "bad option [lindex $args 0]:\
281                      must be -file"
282            }
283        }
284        set args [lreplace $args 0 0]
285    }
286
287    if {$opts(filename) != {}} {
288        set f [open $opts(filename) r]
289        set data [read $f]
290        close $f
291    } else {
292        if {[llength $args] != 1} {
293            return -code error $wrongargs
294        }
295        set data [lindex $args 0]
296    }
297
298    set state false
299    set result {}
300
301    foreach {line} [split $data "\n"] {
302        switch -exact -- $state {
303            false {
304                if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \
305                         -> opts(mode) opts(name)]} {
306                    set state true
307                    set r {}
308                }
309            }
310
311            true {
312                if {[string match "end" $line]} {
313                    set state false
314                    lappend result [list $opts(name) $opts(mode) $r]
315                } else {
316                    scan $line %c c
317                    set n [expr {($c - 0x21)}]
318                    append r [string range \
319                                  [decode [string range $line 1 end]] 0 $n]
320                }
321            }
322        }
323    }
324
325    return $result
326}
327
328# -------------------------------------------------------------------------
329
330package provide uuencode $::uuencode::version
331
332# -------------------------------------------------------------------------
333#
334# Local variables:
335#   mode: tcl
336#   indent-tabs-mode: nil
337# End:
338
339