1# yencode.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
2#
3# Provide a Tcl only implementation of yEnc encoding algorithm
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
10# FUTURE: Rework to allow switching between the tcl/critcl implementations.
11
12package require Tcl 8.2;                # tcl minimum version
13catch {package require crc32};          # tcllib 1.1
14catch {package require tcllibc};        # critcl enhancements for tcllib
15
16namespace eval ::yencode {
17    namespace export encode decode yencode ydecode
18}
19
20# -------------------------------------------------------------------------
21
22proc ::yencode::Encode {s} {
23    set r {}
24    binary scan $s c* d
25    foreach {c} $d {
26        set v [expr {($c + 42) % 256}]
27        if {$v == 0x00 || $v == 0x09 || $v == 0x0A
28            || $v == 0x0D || $v == 0x3D} {
29            append r "="
30            set v [expr {($v + 64) % 256}]
31        }
32        append r [format %c $v]
33    }
34    return $r
35}
36
37proc ::yencode::Decode {s} {
38    if {[string length $s] == 0} {return ""}
39    set r {}
40    set esc 0
41    binary scan $s c* d
42    foreach c $d {
43        if {$c == 61 && $esc == 0} {
44            set esc 1
45            continue
46        }
47        set v [expr {($c - 42) % 256}]
48        if {$esc} {
49            set v [expr {($v - 64) % 256}]
50            set esc 0
51        }
52        append r [format %c $v]
53    }
54    return $r
55}
56
57# -------------------------------------------------------------------------
58# C coded versions for critcl built base64c package
59# -------------------------------------------------------------------------
60
61if {[package provide critcl] != {}} {
62    namespace eval ::yencode {
63        critcl::ccode {
64            #include <string.h>
65        }
66        critcl::ccommand CEncode {dummy interp objc objv} {
67            Tcl_Obj *inputPtr, *resultPtr;
68            int len, rlen, xtra;
69            unsigned char *input, *p, *r, v;
70
71            if (objc !=  2) {
72                Tcl_WrongNumArgs(interp, 1, objv, "data");
73                return TCL_ERROR;
74            }
75
76            /* fetch the input data */
77            inputPtr = objv[1];
78            input = Tcl_GetByteArrayFromObj(inputPtr, &len);
79
80            /* calculate the length of the encoded result */
81            rlen = len;
82            for (p = input; p < input + len; p++) {
83                v = (*p + 42) % 256;
84                if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D)
85                   rlen++;
86            }
87
88            /* allocate the output buffer */
89            resultPtr = Tcl_NewObj();
90            r = Tcl_SetByteArrayLength(resultPtr, rlen);
91
92            /* encode the input */
93            for (p = input; p < input + len; p++) {
94                v = (*p + 42) % 256;
95                if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) {
96                    *r++ = '=';
97                    v = (v + 64) % 256;
98                }
99                *r++ = v;
100            }
101            Tcl_SetObjResult(interp, resultPtr);
102            return TCL_OK;
103        }
104
105        critcl::ccommand CDecode {dummy interp objc objv} {
106            Tcl_Obj *inputPtr, *resultPtr;
107            int len, rlen, esc;
108            unsigned char *input, *p, *r, v;
109
110            if (objc !=  2) {
111                Tcl_WrongNumArgs(interp, 1, objv, "data");
112                return TCL_ERROR;
113            }
114
115            /* fetch the input data */
116            inputPtr = objv[1];
117            input = Tcl_GetByteArrayFromObj(inputPtr, &len);
118
119            /* allocate the output buffer */
120            resultPtr = Tcl_NewObj();
121            r = Tcl_SetByteArrayLength(resultPtr, len);
122
123            /* encode the input */
124            for (p = input, esc = 0, rlen = 0; p < input + len; p++) {
125                if (*p == 61 && esc == 0) {
126                    esc = 1;
127                    continue;
128                }
129                v = (*p - 42) % 256;
130                if (esc) {
131                    v = (v - 64) % 256;
132                    esc = 0;
133                }
134                *r++ = v;
135                rlen++;
136            }
137            Tcl_SetByteArrayLength(resultPtr, rlen);
138            Tcl_SetObjResult(interp, resultPtr);
139            return TCL_OK;
140        }
141    }
142}
143
144if {[info commands ::yencode::CEncode] != {}} {
145    interp alias {} ::yencode::encode {} ::yencode::CEncode
146    interp alias {} ::yencode::decode {} ::yencode::CDecode
147} else {
148    interp alias {} ::yencode::encode {} ::yencode::Encode
149    interp alias {} ::yencode::decode {} ::yencode::Decode
150}
151
152# -------------------------------------------------------------------------
153# Description:
154#  Pop the nth element off a list. Used in options processing.
155#
156proc ::yencode::Pop {varname {nth 0}} {
157    upvar $varname args
158    set r [lindex $args $nth]
159    set args [lreplace $args $nth $nth]
160    return $r
161}
162
163# -------------------------------------------------------------------------
164
165proc ::yencode::yencode {args} {
166    array set opts {mode 0644 filename {} name {} line 128 crc32 1}
167    while {[string match -* [lindex $args 0]]} {
168        switch -glob -- [lindex $args 0] {
169            -f* { set opts(filename) [Pop args 1] }
170            -m* { set opts(mode) [Pop args 1] }
171            -n* { set opts(name) [Pop args 1] }
172            -l* { set opts(line) [Pop args 1] }
173            -c* { set opts(crc32) [Pop args 1] }
174            --  { Pop args ; break }
175            default {
176                set options [join [lsort [array names opts]] ", -"]
177                return -code error "bad option [lindex $args 0]:\
178                      must be -$options"
179            }
180        }
181        Pop args
182    }
183
184    if {$opts(name) == {}} {
185        set opts(name) $opts(filename)
186    }
187    if {$opts(name) == {}} {
188        set opts(name) "data.dat"
189    }
190    if {! [string is boolean $opts(crc32)]} {
191        return -code error "bad option -crc32: argument must be true or false"
192    }
193
194    if {$opts(filename) != {}} {
195        set f [open $opts(filename) r]
196        fconfigure $f -translation binary
197        set data [read $f]
198        close $f
199    } else {
200        if {[llength $args] != 1} {
201            return -code error "wrong \# args: should be\
202                  \"yencode ?options? -file name | data\""
203        }
204        set data [lindex $args 0]
205    }
206
207    set opts(size) [string length $data]
208
209    set r {}
210    append r [format "=ybegin line=%d size=%d name=%s" \
211                  $opts(line) $opts(size) $opts(name)] "\n"
212
213    set ndx 0
214    while {$ndx < $opts(size)} {
215        set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]]
216        set enc [encode $pln]
217        incr ndx [string length $pln]
218        append r $enc "\r\n"
219    }
220
221    append r [format "=yend size=%d" $ndx]
222    if {$opts(crc32)} {
223        append r " crc32=" [crc::crc32 -format %x $data]
224    }
225    return $r
226}
227
228# -------------------------------------------------------------------------
229# Description:
230#  Perform ydecoding of a file or data. A file may contain more than one
231#  encoded data section so the result is a list where each element is a
232#  three element list of the provided filename, the file size and the
233#  data itself.
234#
235proc ::yencode::ydecode {args} {
236    array set opts {mode 0644 filename {} name default.bin}
237    while {[string match -* [lindex $args 0]]} {
238        switch -glob -- [lindex $args 0] {
239            -f* { set opts(filename) [Pop args 1] }
240            -- { Pop args ; break; }
241            default {
242                set options [join [lsort [array names opts]] ", -"]
243                return -code error "bad option [lindex $args 0]:\
244                      must be -$opts"
245            }
246        }
247        Pop args
248    }
249
250    if {$opts(filename) != {}} {
251        set f [open $opts(filename) r]
252        set data [read $f]
253        close $f
254    } else {
255        if {[llength $args] != 1} {
256            return -code error "wrong \# args: should be\
257                  \"ydecode ?options? -file name | data\""
258        }
259        set data [lindex $args 0]
260    }
261
262    set state false
263    set result {}
264
265    foreach {line} [split $data "\n"] {
266        set line [string trimright $line "\r\n"]
267        switch -exact -- $state {
268            false {
269                if {[string match "=ybegin*" $line]} {
270                    regexp {line=(\d+)} $line -> opts(line)
271                    regexp {size=(\d+)} $line -> opts(size)
272                    regexp {name=(\d+)} $line -> opts(name)
273
274                    if {$opts(name) == {}} {
275                        set opts(name) default.bin
276                    }
277
278                    set state true
279                    set r {}
280                }
281            }
282
283            true {
284                if {[string match "=yend*" $line]} {
285                    set state false
286                    lappend result [list $opts(name) $opts(size) $r]
287                } else {
288                    append r [decode $line]
289                }
290            }
291        }
292    }
293
294    return $result
295}
296
297# -------------------------------------------------------------------------
298
299package provide yencode 1.1.3
300
301# -------------------------------------------------------------------------
302#
303# Local variables:
304#   mode: tcl
305#   indent-tabs-mode: nil
306# End:
307
308