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