| 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.7 2004/01/15 06:36:12 andreas_kupries Exp $ |
|---|
| 17 | |
|---|
| 18 | package require Tcl 8.2; # tcl minimum version |
|---|
| 19 | |
|---|
| 20 | catch {package require tcllibc}; # critcl enhancements to tcllib |
|---|
| 21 | #catch {package require crcc}; # critcl enhanced crc module |
|---|
| 22 | |
|---|
| 23 | namespace 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 | # |
|---|
| 41 | proc ::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 | # |
|---|
| 55 | proc ::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 | |
|---|
| 67 | if {[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_SetIntObj(Tcl_GetObjResult(interp), 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_SetIntObj(Tcl_GetObjResult(interp), t & 0xFFFF); |
|---|
| 118 | return r; |
|---|
| 119 | } |
|---|
| 120 | } |
|---|
| 121 | } |
|---|
| 122 | |
|---|
| 123 | # ------------------------------------------------------------------------- |
|---|
| 124 | # Switch from pure tcl to compiled if available. |
|---|
| 125 | # |
|---|
| 126 | if {[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 | |
|---|
| 132 | if {[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 | # |
|---|
| 142 | proc ::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 | # |
|---|
| 153 | proc ::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 | # |
|---|
| 164 | proc ::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 | # |
|---|
| 194 | proc ::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 | |
|---|
| 272 | package provide sum $::crc::sum_version |
|---|
| 273 | |
|---|
| 274 | # ------------------------------------------------------------------------- |
|---|
| 275 | # Local Variables: |
|---|
| 276 | # mode: tcl |
|---|
| 277 | # indent-tabs-mode: nil |
|---|
| 278 | # End: |
|---|
