1# crc32.tcl -- Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# CRC32 Cyclic Redundancy Check. 4# (for algorithm see http://www.rad.com/networks/1994/err_con/crc.htm) 5# 6# From http://mini.net/tcl/2259.tcl 7# Written by Wayland Augur and Pat Thoyts. 8# 9# ------------------------------------------------------------------------- 10# See the file "license.terms" for information on usage and redistribution 11# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12# ------------------------------------------------------------------------- 13# $Id: crc32.tcl,v 1.22 2009/05/06 22:41:08 patthoyts Exp $ 14 15package require Tcl 8.2 16 17namespace eval ::crc { 18 variable crc32_version 1.3.1 19 variable accel 20 array set accel {critcl 0 trf 0} 21 22 namespace export crc32 23 24 variable crc32_tbl [list 0x00000000 0x77073096 0xEE0E612C 0x990951BA \ 25 0x076DC419 0x706AF48F 0xE963A535 0x9E6495A3 \ 26 0x0EDB8832 0x79DCB8A4 0xE0D5E91E 0x97D2D988 \ 27 0x09B64C2B 0x7EB17CBD 0xE7B82D07 0x90BF1D91 \ 28 0x1DB71064 0x6AB020F2 0xF3B97148 0x84BE41DE \ 29 0x1ADAD47D 0x6DDDE4EB 0xF4D4B551 0x83D385C7 \ 30 0x136C9856 0x646BA8C0 0xFD62F97A 0x8A65C9EC \ 31 0x14015C4F 0x63066CD9 0xFA0F3D63 0x8D080DF5 \ 32 0x3B6E20C8 0x4C69105E 0xD56041E4 0xA2677172 \ 33 0x3C03E4D1 0x4B04D447 0xD20D85FD 0xA50AB56B \ 34 0x35B5A8FA 0x42B2986C 0xDBBBC9D6 0xACBCF940 \ 35 0x32D86CE3 0x45DF5C75 0xDCD60DCF 0xABD13D59 \ 36 0x26D930AC 0x51DE003A 0xC8D75180 0xBFD06116 \ 37 0x21B4F4B5 0x56B3C423 0xCFBA9599 0xB8BDA50F \ 38 0x2802B89E 0x5F058808 0xC60CD9B2 0xB10BE924 \ 39 0x2F6F7C87 0x58684C11 0xC1611DAB 0xB6662D3D \ 40 0x76DC4190 0x01DB7106 0x98D220BC 0xEFD5102A \ 41 0x71B18589 0x06B6B51F 0x9FBFE4A5 0xE8B8D433 \ 42 0x7807C9A2 0x0F00F934 0x9609A88E 0xE10E9818 \ 43 0x7F6A0DBB 0x086D3D2D 0x91646C97 0xE6635C01 \ 44 0x6B6B51F4 0x1C6C6162 0x856530D8 0xF262004E \ 45 0x6C0695ED 0x1B01A57B 0x8208F4C1 0xF50FC457 \ 46 0x65B0D9C6 0x12B7E950 0x8BBEB8EA 0xFCB9887C \ 47 0x62DD1DDF 0x15DA2D49 0x8CD37CF3 0xFBD44C65 \ 48 0x4DB26158 0x3AB551CE 0xA3BC0074 0xD4BB30E2 \ 49 0x4ADFA541 0x3DD895D7 0xA4D1C46D 0xD3D6F4FB \ 50 0x4369E96A 0x346ED9FC 0xAD678846 0xDA60B8D0 \ 51 0x44042D73 0x33031DE5 0xAA0A4C5F 0xDD0D7CC9 \ 52 0x5005713C 0x270241AA 0xBE0B1010 0xC90C2086 \ 53 0x5768B525 0x206F85B3 0xB966D409 0xCE61E49F \ 54 0x5EDEF90E 0x29D9C998 0xB0D09822 0xC7D7A8B4 \ 55 0x59B33D17 0x2EB40D81 0xB7BD5C3B 0xC0BA6CAD \ 56 0xEDB88320 0x9ABFB3B6 0x03B6E20C 0x74B1D29A \ 57 0xEAD54739 0x9DD277AF 0x04DB2615 0x73DC1683 \ 58 0xE3630B12 0x94643B84 0x0D6D6A3E 0x7A6A5AA8 \ 59 0xE40ECF0B 0x9309FF9D 0x0A00AE27 0x7D079EB1 \ 60 0xF00F9344 0x8708A3D2 0x1E01F268 0x6906C2FE \ 61 0xF762575D 0x806567CB 0x196C3671 0x6E6B06E7 \ 62 0xFED41B76 0x89D32BE0 0x10DA7A5A 0x67DD4ACC \ 63 0xF9B9DF6F 0x8EBEEFF9 0x17B7BE43 0x60B08ED5 \ 64 0xD6D6A3E8 0xA1D1937E 0x38D8C2C4 0x4FDFF252 \ 65 0xD1BB67F1 0xA6BC5767 0x3FB506DD 0x48B2364B \ 66 0xD80D2BDA 0xAF0A1B4C 0x36034AF6 0x41047A60 \ 67 0xDF60EFC3 0xA867DF55 0x316E8EEF 0x4669BE79 \ 68 0xCB61B38C 0xBC66831A 0x256FD2A0 0x5268E236 \ 69 0xCC0C7795 0xBB0B4703 0x220216B9 0x5505262F \ 70 0xC5BA3BBE 0xB2BD0B28 0x2BB45A92 0x5CB36A04 \ 71 0xC2D7FFA7 0xB5D0CF31 0x2CD99E8B 0x5BDEAE1D \ 72 0x9B64C2B0 0xEC63F226 0x756AA39C 0x026D930A \ 73 0x9C0906A9 0xEB0E363F 0x72076785 0x05005713 \ 74 0x95BF4A82 0xE2B87A14 0x7BB12BAE 0x0CB61B38 \ 75 0x92D28E9B 0xE5D5BE0D 0x7CDCEFB7 0x0BDBDF21 \ 76 0x86D3D2D4 0xF1D4E242 0x68DDB3F8 0x1FDA836E \ 77 0x81BE16CD 0xF6B9265B 0x6FB077E1 0x18B74777 \ 78 0x88085AE6 0xFF0F6A70 0x66063BCA 0x11010B5C \ 79 0x8F659EFF 0xF862AE69 0x616BFFD3 0x166CCF45 \ 80 0xA00AE278 0xD70DD2EE 0x4E048354 0x3903B3C2 \ 81 0xA7672661 0xD06016F7 0x4969474D 0x3E6E77DB \ 82 0xAED16A4A 0xD9D65ADC 0x40DF0B66 0x37D83BF0 \ 83 0xA9BCAE53 0xDEBB9EC5 0x47B2CF7F 0x30B5FFE9 \ 84 0xBDBDF21C 0xCABAC28A 0x53B39330 0x24B4A3A6 \ 85 0xBAD03605 0xCDD70693 0x54DE5729 0x23D967BF \ 86 0xB3667A2E 0xC4614AB8 0x5D681B02 0x2A6F2B94 \ 87 0xB40BBE37 0xC30C8EA1 0x5A05DF1B 0x2D02EF8D] 88 89 # calculate the sign bit for the current platform. 90 variable signbit 91 if {![info exists signbit]} { 92 variable v 93 for {set v 1} {int($v) != 0} {set signbit $v; set v [expr {$v<<1}]} {} 94 unset v 95 } 96 97 variable uid ; if {![info exists uid]} {set uid 0} 98} 99 100# ------------------------------------------------------------------------- 101 102# crc::Crc32Init -- 103# 104# Create and initialize a crc32 context. This is cleaned up 105# when we we call Crc32Final to obtain the result. 106# 107proc ::crc::Crc32Init {{seed 0xFFFFFFFF}} { 108 variable uid 109 variable accel 110 set token [namespace current]::[incr uid] 111 upvar #0 $token state 112 array set state [list sum $seed] 113 # If the initial seed is set to some other value we cannot use Trf. 114 if {$accel(trf) && $seed == 0xFFFFFFFF} { 115 set s {} 116 switch -exact -- $::tcl_platform(platform) { 117 windows { set s [open NUL w] } 118 unix { set s [open /dev/null w] } 119 } 120 if {$s != {}} { 121 fconfigure $s -translation binary -buffering none 122 ::crc-zlib -attach $s -mode write \ 123 -write-type variable \ 124 -write-destination ${token}(trfwrite) 125 array set state [list trfread 0 trfwrite 0 trf $s] 126 } 127 } 128 return $token 129} 130 131# crc::Crc32Update -- 132# 133# This is called to add more data into the checksum. You may 134# call this as many times as you require. Note that passing in 135# "ABC" is equivalent to passing these letters in as separate 136# calls -- hence this proc permits summing of chunked data. 137# 138# If we have a C-based implementation available, then we will 139# use it here in preference to the pure-Tcl implementation. 140# 141proc ::crc::Crc32Update {token data} { 142 variable accel 143 upvar #0 $token state 144 set sum $state(sum) 145 if {$accel(critcl)} { 146 set sum [Crc32_c $data $sum] 147 } elseif {[info exists state(trf)]} { 148 puts -nonewline $state(trf) $data 149 return 150 } else { 151 set sum [Crc32_tcl $data $sum] 152 } 153 set state(sum) [expr {$sum ^ 0xFFFFFFFF}] 154 return 155} 156 157# crc::Crc32Final -- 158# 159# This procedure is used to close the context and returns the 160# checksum value. Once this procedure has been called the checksum 161# context is freed and cannot be used again. 162# 163proc ::crc::Crc32Final {token} { 164 upvar #0 $token state 165 if {[info exists state(trf)]} { 166 close $state(trf) 167 binary scan $state(trfwrite) i sum 168 set sum [expr {$sum & 0xFFFFFFFF}] 169 } else { 170 set sum [expr {($state(sum) ^ 0xFFFFFFFF) & 0xFFFFFFFF}] 171 } 172 unset state 173 return $sum 174} 175 176# crc::Crc32_tcl -- 177# 178# The pure-Tcl implementation of a table based CRC-32 checksum. 179# The seed should always be 0xFFFFFFFF to begin with, but for 180# successive chunks of data the seed should be set to the result 181# of the last chunk. 182# 183proc ::crc::Crc32_tcl {data {seed 0xFFFFFFFF}} { 184 variable crc32_tbl 185 variable signbit 186 set signmask [expr {~$signbit>>7}] 187 set crcval $seed 188 189 binary scan $data c* nums 190 foreach {n} $nums { 191 set ndx [expr {($crcval ^ $n) & 0xFF}] 192 set lkp [lindex $crc32_tbl $ndx] 193 set crcval [expr {($lkp ^ ($crcval >> 8 & $signmask)) & 0xFFFFFFFF}] 194 } 195 196 return [expr {$crcval ^ 0xFFFFFFFF}] 197} 198 199# crc::Crc32_c -- 200# 201# A C version of the CRC-32 code using the same table. This is 202# designed to be compiled using critcl. 203# 204if {[package provide critcl] != {}} { 205 namespace eval ::crc { 206 critcl::ccommand Crc32_c {dummy interp objc objv} { 207 int r = TCL_OK; 208 unsigned long t = 0xFFFFFFFFL; 209 210 if (objc < 2 || objc > 3) { 211 Tcl_WrongNumArgs(interp, 1, objv, "data ?seed?"); 212 return TCL_ERROR; 213 } 214 215 if (objc == 3) { 216 r = Tcl_GetLongFromObj(interp, objv[2], (long *)&t); 217 } 218 219 if (r == TCL_OK) { 220 int cn, size, ndx; 221 unsigned char *data; 222 unsigned long lkp; 223 Tcl_Obj *tblPtr, *lkpPtr; 224 225 tblPtr = Tcl_GetVar2Ex(interp, "::crc::crc32_tbl", NULL, 226 TCL_LEAVE_ERR_MSG ); 227 if (tblPtr == NULL) { 228 r = TCL_ERROR; 229 } 230 if (r == TCL_OK) { 231 data = Tcl_GetByteArrayFromObj(objv[1], &size); 232 } 233 for (cn = 0; r == TCL_OK && cn < size; cn++) { 234 ndx = (t ^ data[cn]) & 0xFF; 235 r = Tcl_ListObjIndex(interp, tblPtr, ndx, &lkpPtr); 236 if (r == TCL_OK) { 237 r = Tcl_GetLongFromObj(interp, lkpPtr, &lkp); 238 } 239 if (r == TCL_OK) { 240 t = lkp ^ (t >> 8); 241 } 242 } 243 } 244 245 if (r == TCL_OK) { 246 Tcl_SetObjResult(interp, Tcl_NewLongObj(t ^ 0xFFFFFFFF)); 247 } 248 return r; 249 } 250 } 251} 252 253# LoadAccelerator -- 254# 255# This package can make use of a number of compiled extensions to 256# accelerate the digest computation. This procedure manages the 257# use of these extensions within the package. During normal usage 258# this should not be called, but the test package manipulates the 259# list of enabled accelerators. 260# 261proc ::crc::LoadAccelerator {name} { 262 variable accel 263 set r 0 264 switch -exact -- $name { 265 critcl { 266 if {![catch {package require tcllibc}] 267 || ![catch {package require crcc}]} { 268 set r [expr {[info command ::crc::Crc32_c] != {}}] 269 } 270 } 271 trf { 272 if {![catch {package require Trf}]} { 273 set r [expr {![catch {::crc-zlib aa} msg]}] 274 } 275 } 276 default { 277 return -code error "invalid accelerator package:\ 278 must be one of [join [array names accel] {, }]" 279 } 280 } 281 set accel($name) $r 282} 283 284# crc::Pop -- 285# 286# Pop the nth element off a list. Used in options processing. 287# 288proc ::crc::Pop {varname {nth 0}} { 289 upvar $varname args 290 set r [lindex $args $nth] 291 set args [lreplace $args $nth $nth] 292 return $r 293} 294 295# crc::crc32 -- 296# 297# Provide a Tcl implementation of a crc32 checksum similar to the 298# cksum and sum unix commands. 299# 300# Options: 301# -filename name - return a checksum for the specified file. 302# -format string - return the checksum using this format string. 303# -seed value - seed the algorithm using value (default is 0xffffffff) 304# 305proc ::crc::crc32 {args} { 306 array set opts [list -filename {} -format %u -seed 0xffffffff \ 307 -channel {} -chunksize 4096 -timeout 30000] 308 while {[string match -* [set option [lindex $args 0]]]} { 309 switch -glob -- $option { 310 -file* { set opts(-filename) [Pop args 1] } 311 -for* { set opts(-format) [Pop args 1] } 312 -chan* { set opts(-channel) [Pop args 1] } 313 -chunk* { set opts(-chunksize) [Pop args 1] } 314 -time* { set opts(-timeout) [Pop args 1] } 315 -seed { set opts(-seed) [Pop args 1] } 316 -impl* { set junk [Pop args 1] } 317 default { 318 if {[llength $args] == 1} { break } 319 if {[string compare $option "--"] == 0} { Pop args; break } 320 set err [join [lsort [array names opts -*]] ", "] 321 return -code error "bad option \"$option\": must be $err" 322 } 323 } 324 Pop args 325 } 326 327 # If a file was given - open it 328 if {$opts(-filename) != {}} { 329 set opts(-channel) [open $opts(-filename) r] 330 fconfigure $opts(-channel) -translation binary 331 } 332 333 if {$opts(-channel) == {}} { 334 335 if {[llength $args] != 1} { 336 return -code error "wrong # args: should be \ 337 \"crc32 ?-format string? ?-seed value? \ 338 -channel chan | -file name | data\"" 339 } 340 set tok [Crc32Init $opts(-seed)] 341 Crc32Update $tok [lindex $args 0] 342 set r [Crc32Final $tok] 343 344 } else { 345 346 set r $opts(-seed) 347 set tok [Crc32Init $opts(-seed)] 348 while {![eof $opts(-channel)]} { 349 Crc32Update $tok [read $opts(-channel) $opts(-chunksize)] 350 } 351 set r [Crc32Final $tok] 352 353 if {$opts(-filename) != {}} { 354 close $opts(-channel) 355 } 356 } 357 358 return [format $opts(-format) $r] 359} 360 361# ------------------------------------------------------------------------- 362 363# Try and load a compiled extension to help (note - trf is fastest) 364namespace eval ::crc { 365 foreach e {trf critcl} { if {[LoadAccelerator $e]} { break } } 366} 367 368package provide crc32 $::crc::crc32_version 369 370# ------------------------------------------------------------------------- 371# 372# Local variables: 373# mode: tcl 374# indent-tabs-mode: nil 375# End: 376