1# sum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
2#
3# Provides a Tcl only implementation of the unix sum(1) command. There are
4# a number of these and they use differing algorithms to get a checksum of
5# the input data. We provide two: one using the BSD algorithm and the other
6# using the SysV algorithm. More consistent results across multiple
7# implementations can be obtained by using cksum(1).
8#
9# These commands have been checked against the GNU sum program from the GNU
10# textutils package version 2.0 to ensure the same results.
11#
12# -------------------------------------------------------------------------
13# See the file "license.terms" for information on usage and redistribution
14# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15# -------------------------------------------------------------------------
16# $Id: sum.tcl,v 1.8 2009/05/07 00:39:49 patthoyts Exp $
17
18package require Tcl 8.2;                # tcl minimum version
19
20catch {package require tcllibc};        # critcl enhancements to tcllib
21#catch {package require crcc};           # critcl enhanced crc module
22
23namespace eval ::crc {
24    variable sum_version 1.1.0
25    namespace export sum
26
27    variable uid
28    if {![info exists uid]} {
29        set uid 0
30    }
31}
32
33# -------------------------------------------------------------------------
34# Description:
35#  The SysV algorithm is fairly naive. The byte values are summed and any
36#  overflow is discarded. The lowest 16 bits are returned as the checksum.
37# Notes:
38#  Input with the same content but different ordering will give the same
39#  result.
40#
41proc ::crc::SumSysV {s {seed 0}} {
42    set t $seed
43    binary scan $s c* r
44    foreach n $r {
45        incr t [expr {$n & 0xFF}]
46    }
47    return [expr {$t % 0xFFFF}]
48}
49
50# -------------------------------------------------------------------------
51# Description:
52#  This algorithm is similar to the SysV version but includes a bit rotation
53#  step which provides a dependency on the order of the data values.
54#
55proc ::crc::SumBsd {s {seed 0}} {
56    set t $seed
57    binary scan $s c* r
58    foreach n $r {
59        set t [expr {($t & 1) ? (($t >> 1) + 0x8000) : ($t >> 1)}]
60        set t [expr {($t + ($n & 0xFF)) & 0xFFFF}]
61    }
62    return $t
63}
64
65# -------------------------------------------------------------------------
66
67if {[package provide critcl] != {}} {
68    namespace eval ::crc {
69        critcl::ccommand SumSysV_c {dummy interp objc objv} {
70            int r = TCL_OK;
71            unsigned int t = 0;
72
73            if (objc < 2 || objc > 3) {
74                Tcl_WrongNumArgs(interp, 1, objv, "data ?seed?");
75                return TCL_ERROR;
76            }
77
78            if (objc == 3)
79                r = Tcl_GetIntFromObj(interp, objv[2], (int *)&t);
80
81            if (r == TCL_OK) {
82                int cn, size;
83                unsigned char *data;
84
85                data = Tcl_GetByteArrayFromObj(objv[1], &size);
86                for (cn = 0; cn < size; cn++)
87                    t += data[cn];
88            }
89
90            Tcl_SetObjResult(interp, Tcl_NewIntObj(t & 0xFFFF));
91            return r;
92        }
93
94        critcl::ccommand SumBsd_c {dummy interp objc objv} {
95            int r = TCL_OK;
96            unsigned int t = 0;
97
98            if (objc < 2 || objc > 3) {
99                Tcl_WrongNumArgs(interp, 1, objv, "data ?seed?");
100                return TCL_ERROR;
101            }
102
103            if (objc == 3)
104                r = Tcl_GetIntFromObj(interp, objv[2], (int *)&t);
105
106            if (r == TCL_OK) {
107                int cn, size;
108                unsigned char *data;
109
110                data = Tcl_GetByteArrayFromObj(objv[1], &size);
111                for (cn = 0; cn < size; cn++) {
112                    t = (t & 1) ? ((t >> 1) + 0x8000) : (t >> 1);
113                    t = (t + data[cn]) & 0xFFFF;
114                }
115            }
116
117            Tcl_SetObjResult(interp, Tcl_NewIntObj(t & 0xFFFF));
118            return r;
119        }
120    }
121}
122
123# -------------------------------------------------------------------------
124# Switch from pure tcl to compiled if available.
125#
126if {[info command ::crc::SumBsd_c] == {}} {
127    interp alias {} ::crc::sum-bsd  {} ::crc::SumBsd
128} else {
129    interp alias {} ::crc::sum-bsd  {} ::crc::SumBsd_c
130}
131
132if {[info command ::crc::SumSysV_c] == {}} {
133    interp alias {} ::crc::sum-sysv {} ::crc::SumSysV
134} else {
135    interp alias {} ::crc::sum-sysv {} ::crc::SumSysV_c
136}
137
138# -------------------------------------------------------------------------
139# Description:
140#  Pop the nth element off a list. Used in options processing.
141#
142proc ::crc::Pop {varname {nth 0}} {
143    upvar $varname args
144    set r [lindex $args $nth]
145    set args [lreplace $args $nth $nth]
146    return $r
147}
148
149# -------------------------------------------------------------------------
150# timeout handler for the chunked file handling
151# This avoids us waiting for ever
152#
153proc ::crc::SumTimeout {token} {
154    # FRINK: nocheck
155    variable $token
156    upvar 0 $token state
157    set state(error) "operation timed out"
158    set state(reading) 0
159}
160
161# -------------------------------------------------------------------------
162# fileevent handler for chunked file handling.
163#
164proc ::crc::SumChunk {token channel} {
165    # FRINK: nocheck
166    variable $token
167    upvar 0 $token state
168
169    if {[eof $channel]} {
170        fileevent $channel readable {}
171        set state(reading) 0
172    }
173
174    after cancel $state(after)
175    set state(after) [after $state(timeout) \
176                          [list [namespace origin SumTimeout] $token]]
177    set state(result) [$state(algorithm) \
178                           [read $channel $state(chunksize)] \
179                           $state(result)]
180}
181
182# -------------------------------------------------------------------------
183# Description:
184#  Provide a Tcl equivalent of the unix sum(1) command. We default to the
185#  BSD algorithm and return a checkum for the input string unless a filename
186#  has been provided. Using sum on a file should give the same results as
187#  the unix sum command with equivalent algorithm.
188# Options:
189#  -bsd           - use the BSD algorithm to calculate the checksum (default)
190#  -sysv          - use the SysV algorithm to calculate the checksum
191#  -filename name - return a checksum for the specified file
192#  -format string - return the checksum using this format string
193#
194proc ::crc::sum {args} {
195    array set opts [list -filename {} -channel {} -chunksize 4096 \
196                        -timeout 30000 -bsd 1 -sysv 0 -format %u \
197                        algorithm [namespace origin sum-bsd]]
198    while {[string match -* [set option [lindex $args 0]]]} {
199        switch -glob -- $option {
200            -bsd    { set opts(-bsd) 1 ; set opts(-sysv) 0 }
201            -sysv   { set opts(-bsd) 0 ; set opts(-sysv) 1 }
202            -file*  { set opts(-filename) [Pop args 1] }
203            -for*   { set opts(-format) [Pop args 1] }
204            -chan*  { set opts(-channel) [Pop args 1] }
205            -chunk* { set opts(-chunksize) [Pop args 1] }
206            -time*  { set opts(-timeout) [Pop args 1] }
207            --      { Pop args ; break }
208            default {
209                set err [join [lsort [array names opts -*]] ", "]
210                return -code error "bad option $option:\
211                    must be one of $err"
212            }
213        }
214        Pop args
215    }
216
217    # Set the correct sum algorithm
218    if {$opts(-sysv)} {
219        set opts(algorithm) [namespace origin sum-sysv]
220    }
221
222    # If a file was given - open it for binary reading.
223    if {$opts(-filename) != {}} {
224        set opts(-channel) [open $opts(-filename) r]
225        fconfigure $opts(-channel) -translation binary
226    }
227
228    if {$opts(-channel) == {}} {
229
230        if {[llength $args] != 1} {
231            return -code error "wrong # args: should be \
232                 \"sum ?-bsd|-sysv? ?-format string? ?-chunksize size? \
233                 ?-timeout ms? -file name | -channel chan | data\""
234        }
235        set r [$opts(algorithm) [lindex $args 0]]
236
237    } else {
238
239        # Create a unique token for the event handling
240        variable uid
241        set token [namespace current]::[incr uid]
242        upvar #0 $token tok
243        array set tok [list reading 1 result 0 timeout $opts(-timeout) \
244                           chunksize $opts(-chunksize) \
245                           algorithm $opts(algorithm)]
246        set tok(after) [after $tok(timeout) \
247                            [list [namespace origin SumTimeout] $token]]
248
249        fileevent $opts(-channel) readable \
250            [list [namespace origin SumChunk] $token $opts(-channel)]
251        vwait [subst $token](reading)
252
253        # If we opened the channel we must close it too.
254        if {$opts(-filename) != {}} {
255            close $opts(-channel)
256        }
257
258        # Extract the result or error message if there was a problem.
259        set r $tok(result)
260        if {[info exists tok(error)]} {
261            return -code error $tok(error)
262        }
263
264        unset tok
265    }
266
267    return [format $opts(-format) $r]
268}
269
270# -------------------------------------------------------------------------
271
272package provide sum $::crc::sum_version
273
274# -------------------------------------------------------------------------
275# Local Variables:
276#   mode: tcl
277#   indent-tabs-mode: nil
278# End:
279