| 1 | # sha1.tcl - |
|---|
| 2 | # |
|---|
| 3 | # Copyright (C) 2001 Don Libes <libes@nist.gov> |
|---|
| 4 | # Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> |
|---|
| 5 | # |
|---|
| 6 | # SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm" |
|---|
| 7 | # HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" |
|---|
| 8 | # |
|---|
| 9 | # This is an implementation of SHA1 based upon the example code given in |
|---|
| 10 | # FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas |
|---|
| 11 | # and methods from the earlier tcllib sha1 version by Don Libes. |
|---|
| 12 | # |
|---|
| 13 | # This implementation permits incremental updating of the hash and |
|---|
| 14 | # provides support for external compiled implementations either using |
|---|
| 15 | # critcl (sha1c) or Trf. |
|---|
| 16 | # |
|---|
| 17 | # ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm |
|---|
| 18 | # |
|---|
| 19 | # ------------------------------------------------------------------------- |
|---|
| 20 | # See the file "license.terms" for information on usage and redistribution |
|---|
| 21 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|---|
| 22 | # ------------------------------------------------------------------------- |
|---|
| 23 | # |
|---|
| 24 | # $Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $ |
|---|
| 25 | |
|---|
| 26 | # @mdgen EXCLUDE: sha1c.tcl |
|---|
| 27 | |
|---|
| 28 | package require Tcl 8.2; # tcl minimum version |
|---|
| 29 | |
|---|
| 30 | namespace eval ::sha1 { |
|---|
| 31 | variable version 2.0.3 |
|---|
| 32 | variable rcsid {$Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $} |
|---|
| 33 | |
|---|
| 34 | variable accel |
|---|
| 35 | array set accel {tcl 0 critcl 0 cryptkit 0 trf 0} |
|---|
| 36 | variable loaded {} |
|---|
| 37 | variable active |
|---|
| 38 | array set active {tcl 0 critcl 0 cryptkit 0 trf 0} |
|---|
| 39 | |
|---|
| 40 | namespace export sha1 hmac SHA1Init SHA1Update SHA1Final |
|---|
| 41 | |
|---|
| 42 | variable uid |
|---|
| 43 | if {![info exists uid]} { |
|---|
| 44 | set uid 0 |
|---|
| 45 | } |
|---|
| 46 | } |
|---|
| 47 | |
|---|
| 48 | # ------------------------------------------------------------------------- |
|---|
| 49 | # Management of sha1 implementations. |
|---|
| 50 | |
|---|
| 51 | # LoadAccelerator -- |
|---|
| 52 | # |
|---|
| 53 | # This package can make use of a number of compiled extensions to |
|---|
| 54 | # accelerate the digest computation. This procedure manages the |
|---|
| 55 | # use of these extensions within the package. During normal usage |
|---|
| 56 | # this should not be called, but the test package manipulates the |
|---|
| 57 | # list of enabled accelerators. |
|---|
| 58 | # |
|---|
| 59 | proc ::sha1::LoadAccelerator {name} { |
|---|
| 60 | variable accel |
|---|
| 61 | set r 0 |
|---|
| 62 | switch -exact -- $name { |
|---|
| 63 | tcl { |
|---|
| 64 | # Already present (this file) |
|---|
| 65 | set r 1 |
|---|
| 66 | } |
|---|
| 67 | critcl { |
|---|
| 68 | if {![catch {package require tcllibc}] |
|---|
| 69 | || ![catch {package require sha1c}]} { |
|---|
| 70 | set r [expr {[info command ::sha1::sha1c] != {}}] |
|---|
| 71 | } |
|---|
| 72 | } |
|---|
| 73 | cryptkit { |
|---|
| 74 | if {![catch {package require cryptkit}]} { |
|---|
| 75 | set r [expr {![catch {cryptkit::cryptInit}]}] |
|---|
| 76 | } |
|---|
| 77 | } |
|---|
| 78 | trf { |
|---|
| 79 | if {![catch {package require Trf}]} { |
|---|
| 80 | set r [expr {![catch {::sha1 aa} msg]}] |
|---|
| 81 | } |
|---|
| 82 | } |
|---|
| 83 | default { |
|---|
| 84 | return -code error "invalid accelerator $key:\ |
|---|
| 85 | must be one of [join [KnownImplementations] {, }]" |
|---|
| 86 | } |
|---|
| 87 | } |
|---|
| 88 | set accel($name) $r |
|---|
| 89 | return $r |
|---|
| 90 | } |
|---|
| 91 | |
|---|
| 92 | # ::sha1::Implementations -- |
|---|
| 93 | # |
|---|
| 94 | # Determines which implementations are |
|---|
| 95 | # present, i.e. loaded. |
|---|
| 96 | # |
|---|
| 97 | # Arguments: |
|---|
| 98 | # None. |
|---|
| 99 | # |
|---|
| 100 | # Results: |
|---|
| 101 | # A list of implementation keys. |
|---|
| 102 | |
|---|
| 103 | proc ::sha1::Implementations {} { |
|---|
| 104 | variable accel |
|---|
| 105 | set res {} |
|---|
| 106 | foreach n [array names accel] { |
|---|
| 107 | if {!$accel($n)} continue |
|---|
| 108 | lappend res $n |
|---|
| 109 | } |
|---|
| 110 | return $res |
|---|
| 111 | } |
|---|
| 112 | |
|---|
| 113 | # ::sha1::KnownImplementations -- |
|---|
| 114 | # |
|---|
| 115 | # Determines which implementations are known |
|---|
| 116 | # as possible implementations. |
|---|
| 117 | # |
|---|
| 118 | # Arguments: |
|---|
| 119 | # None. |
|---|
| 120 | # |
|---|
| 121 | # Results: |
|---|
| 122 | # A list of implementation keys. In the order |
|---|
| 123 | # of preference, most prefered first. |
|---|
| 124 | |
|---|
| 125 | proc ::sha1::KnownImplementations {} { |
|---|
| 126 | return {critcl cryptkit trf tcl} |
|---|
| 127 | } |
|---|
| 128 | |
|---|
| 129 | proc ::sha1::Names {} { |
|---|
| 130 | return { |
|---|
| 131 | critcl {tcllibc based} |
|---|
| 132 | cryptkit {cryptkit based} |
|---|
| 133 | trf {Trf based} |
|---|
| 134 | tcl {pure Tcl} |
|---|
| 135 | } |
|---|
| 136 | } |
|---|
| 137 | |
|---|
| 138 | # ::sha1::SwitchTo -- |
|---|
| 139 | # |
|---|
| 140 | # Activates a loaded named implementation. |
|---|
| 141 | # |
|---|
| 142 | # Arguments: |
|---|
| 143 | # key Name of the implementation to activate. |
|---|
| 144 | # |
|---|
| 145 | # Results: |
|---|
| 146 | # None. |
|---|
| 147 | |
|---|
| 148 | proc ::sha1::SwitchTo {key} { |
|---|
| 149 | variable accel |
|---|
| 150 | variable active |
|---|
| 151 | variable loaded |
|---|
| 152 | |
|---|
| 153 | if {[string equal $key $loaded]} { |
|---|
| 154 | # No change, nothing to do. |
|---|
| 155 | return |
|---|
| 156 | } elseif {![string equal $key ""]} { |
|---|
| 157 | # Validate the target implementation of the switch. |
|---|
| 158 | |
|---|
| 159 | if {![info exists accel($key)]} { |
|---|
| 160 | return -code error "Unable to activate unknown implementation \"$key\"" |
|---|
| 161 | } elseif {![info exists accel($key)] || !$accel($key)} { |
|---|
| 162 | return -code error "Unable to activate missing implementation \"$key\"" |
|---|
| 163 | } |
|---|
| 164 | } |
|---|
| 165 | |
|---|
| 166 | if {![string equal $loaded ""]} { |
|---|
| 167 | set active($loaded) 0 |
|---|
| 168 | } |
|---|
| 169 | if {![string equal $key ""]} { |
|---|
| 170 | set active($key) 1 |
|---|
| 171 | } |
|---|
| 172 | |
|---|
| 173 | # Remember the active implementation, for deactivation by future |
|---|
| 174 | # switches. |
|---|
| 175 | |
|---|
| 176 | set loaded $key |
|---|
| 177 | return |
|---|
| 178 | } |
|---|
| 179 | |
|---|
| 180 | # ------------------------------------------------------------------------- |
|---|
| 181 | |
|---|
| 182 | # SHA1Init -- |
|---|
| 183 | # |
|---|
| 184 | # Create and initialize an SHA1 state variable. This will be |
|---|
| 185 | # cleaned up when we call SHA1Final |
|---|
| 186 | # |
|---|
| 187 | |
|---|
| 188 | proc ::sha1::SHA1Init {} { |
|---|
| 189 | variable active |
|---|
| 190 | variable uid |
|---|
| 191 | set token [namespace current]::[incr uid] |
|---|
| 192 | upvar #0 $token state |
|---|
| 193 | |
|---|
| 194 | # FIPS 180-1: 7 - Initialize the hash state |
|---|
| 195 | array set state \ |
|---|
| 196 | [list \ |
|---|
| 197 | A [expr {int(0x67452301)}] \ |
|---|
| 198 | B [expr {int(0xEFCDAB89)}] \ |
|---|
| 199 | C [expr {int(0x98BADCFE)}] \ |
|---|
| 200 | D [expr {int(0x10325476)}] \ |
|---|
| 201 | E [expr {int(0xC3D2E1F0)}] \ |
|---|
| 202 | n 0 i "" ] |
|---|
| 203 | if {$active(cryptkit)} { |
|---|
| 204 | cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA |
|---|
| 205 | } elseif {$active(trf)} { |
|---|
| 206 | set s {} |
|---|
| 207 | switch -exact -- $::tcl_platform(platform) { |
|---|
| 208 | windows { set s [open NUL w] } |
|---|
| 209 | unix { set s [open /dev/null w] } |
|---|
| 210 | } |
|---|
| 211 | if {$s != {}} { |
|---|
| 212 | fconfigure $s -translation binary -buffering none |
|---|
| 213 | ::sha1 -attach $s -mode write \ |
|---|
| 214 | -read-type variable \ |
|---|
| 215 | -read-destination [subst $token](trfread) \ |
|---|
| 216 | -write-type variable \ |
|---|
| 217 | -write-destination [subst $token](trfwrite) |
|---|
| 218 | array set state [list trfread 0 trfwrite 0 trf $s] |
|---|
| 219 | } |
|---|
| 220 | } |
|---|
| 221 | return $token |
|---|
| 222 | } |
|---|
| 223 | |
|---|
| 224 | # SHA1Update -- |
|---|
| 225 | # |
|---|
| 226 | # This is called to add more data into the hash. You may call this |
|---|
| 227 | # as many times as you require. Note that passing in "ABC" is equivalent |
|---|
| 228 | # to passing these letters in as separate calls -- hence this proc |
|---|
| 229 | # permits hashing of chunked data |
|---|
| 230 | # |
|---|
| 231 | # If we have a C-based implementation available, then we will use |
|---|
| 232 | # it here in preference to the pure-Tcl implementation. |
|---|
| 233 | # |
|---|
| 234 | proc ::sha1::SHA1Update {token data} { |
|---|
| 235 | variable active |
|---|
| 236 | upvar #0 $token state |
|---|
| 237 | |
|---|
| 238 | if {$active(critcl)} { |
|---|
| 239 | if {[info exists state(sha1c)]} { |
|---|
| 240 | set state(sha1c) [sha1c $data $state(sha1c)] |
|---|
| 241 | } else { |
|---|
| 242 | set state(sha1c) [sha1c $data] |
|---|
| 243 | } |
|---|
| 244 | return |
|---|
| 245 | } elseif {[info exists state(ckctx)]} { |
|---|
| 246 | if {[string length $data] > 0} { |
|---|
| 247 | cryptkit::cryptEncrypt $state(ckctx) $data |
|---|
| 248 | } |
|---|
| 249 | return |
|---|
| 250 | } elseif {[info exists state(trf)]} { |
|---|
| 251 | puts -nonewline $state(trf) $data |
|---|
| 252 | return |
|---|
| 253 | } |
|---|
| 254 | |
|---|
| 255 | # Update the state values |
|---|
| 256 | incr state(n) [string length $data] |
|---|
| 257 | append state(i) $data |
|---|
| 258 | |
|---|
| 259 | # Calculate the hash for any complete blocks |
|---|
| 260 | set len [string length $state(i)] |
|---|
| 261 | for {set n 0} {($n + 64) <= $len} {} { |
|---|
| 262 | SHA1Transform $token [string range $state(i) $n [incr n 64]] |
|---|
| 263 | } |
|---|
| 264 | |
|---|
| 265 | # Adjust the state for the blocks completed. |
|---|
| 266 | set state(i) [string range $state(i) $n end] |
|---|
| 267 | return |
|---|
| 268 | } |
|---|
| 269 | |
|---|
| 270 | # SHA1Final -- |
|---|
| 271 | # |
|---|
| 272 | # This procedure is used to close the current hash and returns the |
|---|
| 273 | # hash data. Once this procedure has been called the hash context |
|---|
| 274 | # is freed and cannot be used again. |
|---|
| 275 | # |
|---|
| 276 | # Note that the output is 160 bits represented as binary data. |
|---|
| 277 | # |
|---|
| 278 | proc ::sha1::SHA1Final {token} { |
|---|
| 279 | upvar #0 $token state |
|---|
| 280 | |
|---|
| 281 | # Check for either of the C-compiled versions. |
|---|
| 282 | if {[info exists state(sha1c)]} { |
|---|
| 283 | set r $state(sha1c) |
|---|
| 284 | unset state |
|---|
| 285 | return $r |
|---|
| 286 | } elseif {[info exists state(ckctx)]} { |
|---|
| 287 | cryptkit::cryptEncrypt $state(ckctx) "" |
|---|
| 288 | cryptkit::cryptGetAttributeString $state(ckctx) \ |
|---|
| 289 | CRYPT_CTXINFO_HASHVALUE r 20 |
|---|
| 290 | cryptkit::cryptDestroyContext $state(ckctx) |
|---|
| 291 | # If nothing was hashed, we get no r variable set! |
|---|
| 292 | if {[info exists r]} { |
|---|
| 293 | unset state |
|---|
| 294 | return $r |
|---|
| 295 | } |
|---|
| 296 | } elseif {[info exists state(trf)]} { |
|---|
| 297 | close $state(trf) |
|---|
| 298 | set r $state(trfwrite) |
|---|
| 299 | unset state |
|---|
| 300 | return $r |
|---|
| 301 | } |
|---|
| 302 | |
|---|
| 303 | # Padding |
|---|
| 304 | # |
|---|
| 305 | set len [string length $state(i)] |
|---|
| 306 | set pad [expr {56 - ($len % 64)}] |
|---|
| 307 | if {$len % 64 > 56} { |
|---|
| 308 | incr pad 64 |
|---|
| 309 | } |
|---|
| 310 | if {$pad == 0} { |
|---|
| 311 | incr pad 64 |
|---|
| 312 | } |
|---|
| 313 | append state(i) [binary format a$pad \x80] |
|---|
| 314 | |
|---|
| 315 | # Append length in bits as big-endian wide int. |
|---|
| 316 | set dlen [expr {8 * $state(n)}] |
|---|
| 317 | append state(i) [binary format II 0 $dlen] |
|---|
| 318 | |
|---|
| 319 | # Calculate the hash for the remaining block. |
|---|
| 320 | set len [string length $state(i)] |
|---|
| 321 | for {set n 0} {($n + 64) <= $len} {} { |
|---|
| 322 | SHA1Transform $token [string range $state(i) $n [incr n 64]] |
|---|
| 323 | } |
|---|
| 324 | |
|---|
| 325 | # Output |
|---|
| 326 | set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)] |
|---|
| 327 | unset state |
|---|
| 328 | return $r |
|---|
| 329 | } |
|---|
| 330 | |
|---|
| 331 | # ------------------------------------------------------------------------- |
|---|
| 332 | # HMAC Hashed Message Authentication (RFC 2104) |
|---|
| 333 | # |
|---|
| 334 | # hmac = H(K xor opad, H(K xor ipad, text)) |
|---|
| 335 | # |
|---|
| 336 | |
|---|
| 337 | # HMACInit -- |
|---|
| 338 | # |
|---|
| 339 | # This is equivalent to the SHA1Init procedure except that a key is |
|---|
| 340 | # added into the algorithm |
|---|
| 341 | # |
|---|
| 342 | proc ::sha1::HMACInit {K} { |
|---|
| 343 | |
|---|
| 344 | # Key K is adjusted to be 64 bytes long. If K is larger, then use |
|---|
| 345 | # the SHA1 digest of K and pad this instead. |
|---|
| 346 | set len [string length $K] |
|---|
| 347 | if {$len > 64} { |
|---|
| 348 | set tok [SHA1Init] |
|---|
| 349 | SHA1Update $tok $K |
|---|
| 350 | set K [SHA1Final $tok] |
|---|
| 351 | set len [string length $K] |
|---|
| 352 | } |
|---|
| 353 | set pad [expr {64 - $len}] |
|---|
| 354 | append K [string repeat \0 $pad] |
|---|
| 355 | |
|---|
| 356 | # Cacluate the padding buffers. |
|---|
| 357 | set Ki {} |
|---|
| 358 | set Ko {} |
|---|
| 359 | binary scan $K i16 Ks |
|---|
| 360 | foreach k $Ks { |
|---|
| 361 | append Ki [binary format i [expr {$k ^ 0x36363636}]] |
|---|
| 362 | append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]] |
|---|
| 363 | } |
|---|
| 364 | |
|---|
| 365 | set tok [SHA1Init] |
|---|
| 366 | SHA1Update $tok $Ki; # initialize with the inner pad |
|---|
| 367 | |
|---|
| 368 | # preserve the Ko value for the final stage. |
|---|
| 369 | # FRINK: nocheck |
|---|
| 370 | set [subst $tok](Ko) $Ko |
|---|
| 371 | |
|---|
| 372 | return $tok |
|---|
| 373 | } |
|---|
| 374 | |
|---|
| 375 | # HMACUpdate -- |
|---|
| 376 | # |
|---|
| 377 | # Identical to calling SHA1Update |
|---|
| 378 | # |
|---|
| 379 | proc ::sha1::HMACUpdate {token data} { |
|---|
| 380 | SHA1Update $token $data |
|---|
| 381 | return |
|---|
| 382 | } |
|---|
| 383 | |
|---|
| 384 | # HMACFinal -- |
|---|
| 385 | # |
|---|
| 386 | # This is equivalent to the SHA1Final procedure. The hash context is |
|---|
| 387 | # closed and the binary representation of the hash result is returned. |
|---|
| 388 | # |
|---|
| 389 | proc ::sha1::HMACFinal {token} { |
|---|
| 390 | upvar #0 $token state |
|---|
| 391 | |
|---|
| 392 | set tok [SHA1Init]; # init the outer hashing function |
|---|
| 393 | SHA1Update $tok $state(Ko); # prepare with the outer pad. |
|---|
| 394 | SHA1Update $tok [SHA1Final $token]; # hash the inner result |
|---|
| 395 | return [SHA1Final $tok] |
|---|
| 396 | } |
|---|
| 397 | |
|---|
| 398 | # ------------------------------------------------------------------------- |
|---|
| 399 | # Description: |
|---|
| 400 | # This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but |
|---|
| 401 | # includes an extra round and a set of constant modifiers throughout. |
|---|
| 402 | # |
|---|
| 403 | set ::sha1::SHA1Transform_body { |
|---|
| 404 | upvar #0 $token state |
|---|
| 405 | |
|---|
| 406 | # FIPS 180-1: 7a: Process Message in 16-Word Blocks |
|---|
| 407 | binary scan $msg I* blocks |
|---|
| 408 | set blockLen [llength $blocks] |
|---|
| 409 | for {set i 0} {$i < $blockLen} {incr i 16} { |
|---|
| 410 | set W [lrange $blocks $i [expr {$i+15}]] |
|---|
| 411 | |
|---|
| 412 | # FIPS 180-1: 7b: Expand the input into 80 words |
|---|
| 413 | # For t = 16 to 79 |
|---|
| 414 | # let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1 |
|---|
| 415 | set t3 12 |
|---|
| 416 | set t8 7 |
|---|
| 417 | set t14 1 |
|---|
| 418 | set t16 -1 |
|---|
| 419 | for {set t 16} {$t < 80} {incr t} { |
|---|
| 420 | set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \ |
|---|
| 421 | [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}] |
|---|
| 422 | lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}] |
|---|
| 423 | } |
|---|
| 424 | |
|---|
| 425 | # FIPS 180-1: 7c: Copy hash state. |
|---|
| 426 | set A $state(A) |
|---|
| 427 | set B $state(B) |
|---|
| 428 | set C $state(C) |
|---|
| 429 | set D $state(D) |
|---|
| 430 | set E $state(E) |
|---|
| 431 | |
|---|
| 432 | # FIPS 180-1: 7d: Do permutation rounds |
|---|
| 433 | # For t = 0 to 79 do |
|---|
| 434 | # TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt; |
|---|
| 435 | # E = D; D = C; C = S30(B); B = A; A = TEMP; |
|---|
| 436 | |
|---|
| 437 | # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19) |
|---|
| 438 | for {set t 0} {$t < 20} {incr t} { |
|---|
| 439 | set TEMP [F1 $A $B $C $D $E [lindex $W $t]] |
|---|
| 440 | set E $D |
|---|
| 441 | set D $C |
|---|
| 442 | set C [rotl32 $B 30] |
|---|
| 443 | set B $A |
|---|
| 444 | set A $TEMP |
|---|
| 445 | } |
|---|
| 446 | |
|---|
| 447 | # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39) |
|---|
| 448 | for {} {$t < 40} {incr t} { |
|---|
| 449 | set TEMP [F2 $A $B $C $D $E [lindex $W $t]] |
|---|
| 450 | set E $D |
|---|
| 451 | set D $C |
|---|
| 452 | set C [rotl32 $B 30] |
|---|
| 453 | set B $A |
|---|
| 454 | set A $TEMP |
|---|
| 455 | } |
|---|
| 456 | |
|---|
| 457 | # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59) |
|---|
| 458 | for {} {$t < 60} {incr t} { |
|---|
| 459 | set TEMP [F3 $A $B $C $D $E [lindex $W $t]] |
|---|
| 460 | set E $D |
|---|
| 461 | set D $C |
|---|
| 462 | set C [rotl32 $B 30] |
|---|
| 463 | set B $A |
|---|
| 464 | set A $TEMP |
|---|
| 465 | } |
|---|
| 466 | |
|---|
| 467 | # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79) |
|---|
| 468 | for {} {$t < 80} {incr t} { |
|---|
| 469 | set TEMP [F4 $A $B $C $D $E [lindex $W $t]] |
|---|
| 470 | set E $D |
|---|
| 471 | set D $C |
|---|
| 472 | set C [rotl32 $B 30] |
|---|
| 473 | set B $A |
|---|
| 474 | set A $TEMP |
|---|
| 475 | } |
|---|
| 476 | |
|---|
| 477 | # Then perform the following additions. (That is, increment each |
|---|
| 478 | # of the four registers by the value it had before this block |
|---|
| 479 | # was started.) |
|---|
| 480 | incr state(A) $A |
|---|
| 481 | incr state(B) $B |
|---|
| 482 | incr state(C) $C |
|---|
| 483 | incr state(D) $D |
|---|
| 484 | incr state(E) $E |
|---|
| 485 | } |
|---|
| 486 | |
|---|
| 487 | return |
|---|
| 488 | } |
|---|
| 489 | |
|---|
| 490 | proc ::sha1::F1 {A B C D E W} { |
|---|
| 491 | expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ |
|---|
| 492 | + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff} |
|---|
| 493 | } |
|---|
| 494 | |
|---|
| 495 | proc ::sha1::F2 {A B C D E W} { |
|---|
| 496 | expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ |
|---|
| 497 | + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff} |
|---|
| 498 | } |
|---|
| 499 | |
|---|
| 500 | proc ::sha1::F3 {A B C D E W} { |
|---|
| 501 | expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ |
|---|
| 502 | + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff} |
|---|
| 503 | } |
|---|
| 504 | |
|---|
| 505 | proc ::sha1::F4 {A B C D E W} { |
|---|
| 506 | expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ |
|---|
| 507 | + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff} |
|---|
| 508 | } |
|---|
| 509 | |
|---|
| 510 | proc ::sha1::rotl32 {v n} { |
|---|
| 511 | return [expr {((($v << $n) \ |
|---|
| 512 | | (($v >> (32 - $n)) \ |
|---|
| 513 | & (0x7FFFFFFF >> (31 - $n))))) \ |
|---|
| 514 | & 0xFFFFFFFF}] |
|---|
| 515 | } |
|---|
| 516 | |
|---|
| 517 | |
|---|
| 518 | # ------------------------------------------------------------------------- |
|---|
| 519 | # |
|---|
| 520 | # In order to get this code to go as fast as possible while leaving |
|---|
| 521 | # the main code readable we can substitute the above function bodies |
|---|
| 522 | # into the transform procedure. This inlines the code for us an avoids |
|---|
| 523 | # a procedure call overhead within the loops. |
|---|
| 524 | # |
|---|
| 525 | # We can do some minor tweaking to improve speed on Tcl < 8.5 where we |
|---|
| 526 | # know our arithmetic is limited to 64 bits. On > 8.5 we may have |
|---|
| 527 | # unconstrained integer arithmetic and must avoid letting it run away. |
|---|
| 528 | # |
|---|
| 529 | |
|---|
| 530 | regsub -all -line \ |
|---|
| 531 | {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
|---|
| 532 | $::sha1::SHA1Transform_body \ |
|---|
| 533 | {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \ |
|---|
| 534 | ::sha1::SHA1Transform_body_tmp |
|---|
| 535 | |
|---|
| 536 | regsub -all -line \ |
|---|
| 537 | {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
|---|
| 538 | $::sha1::SHA1Transform_body_tmp \ |
|---|
| 539 | {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \ |
|---|
| 540 | ::sha1::SHA1Transform_body_tmp |
|---|
| 541 | |
|---|
| 542 | regsub -all -line \ |
|---|
| 543 | {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
|---|
| 544 | $::sha1::SHA1Transform_body_tmp \ |
|---|
| 545 | {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \ |
|---|
| 546 | ::sha1::SHA1Transform_body_tmp |
|---|
| 547 | |
|---|
| 548 | regsub -all -line \ |
|---|
| 549 | {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
|---|
| 550 | $::sha1::SHA1Transform_body_tmp \ |
|---|
| 551 | {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \ |
|---|
| 552 | ::sha1::SHA1Transform_body_tmp |
|---|
| 553 | |
|---|
| 554 | regsub -all -line \ |
|---|
| 555 | {rotl32\(\$A,5\)} \ |
|---|
| 556 | $::sha1::SHA1Transform_body_tmp \ |
|---|
| 557 | {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \ |
|---|
| 558 | ::sha1::SHA1Transform_body_tmp |
|---|
| 559 | |
|---|
| 560 | regsub -all -line \ |
|---|
| 561 | {\[rotl32 \$B 30\]} \ |
|---|
| 562 | $::sha1::SHA1Transform_body_tmp \ |
|---|
| 563 | {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \ |
|---|
| 564 | ::sha1::SHA1Transform_body_tmp |
|---|
| 565 | # |
|---|
| 566 | # Version 2 avoids a few truncations to 32 bits in non-essential places. |
|---|
| 567 | # |
|---|
| 568 | regsub -all -line \ |
|---|
| 569 | {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
|---|
| 570 | $::sha1::SHA1Transform_body \ |
|---|
| 571 | {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \ |
|---|
| 572 | ::sha1::SHA1Transform_body_tmp2 |
|---|
| 573 | |
|---|
| 574 | regsub -all -line \ |
|---|
| 575 | {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
|---|
| 576 | $::sha1::SHA1Transform_body_tmp2 \ |
|---|
| 577 | {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \ |
|---|
| 578 | ::sha1::SHA1Transform_body_tmp2 |
|---|
| 579 | |
|---|
| 580 | regsub -all -line \ |
|---|
| 581 | {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
|---|
| 582 | $::sha1::SHA1Transform_body_tmp2 \ |
|---|
| 583 | {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \ |
|---|
| 584 | ::sha1::SHA1Transform_body_tmp2 |
|---|
| 585 | |
|---|
| 586 | regsub -all -line \ |
|---|
| 587 | {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
|---|
| 588 | $::sha1::SHA1Transform_body_tmp2 \ |
|---|
| 589 | {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \ |
|---|
| 590 | ::sha1::SHA1Transform_body_tmp2 |
|---|
| 591 | |
|---|
| 592 | regsub -all -line \ |
|---|
| 593 | {rotl32\(\$A,5\)} \ |
|---|
| 594 | $::sha1::SHA1Transform_body_tmp2 \ |
|---|
| 595 | {(($A << 5) | (($A >> 27) \& 0x1f))} \ |
|---|
| 596 | ::sha1::SHA1Transform_body_tmp2 |
|---|
| 597 | |
|---|
| 598 | regsub -all -line \ |
|---|
| 599 | {\[rotl32 \$B 30\]} \ |
|---|
| 600 | $::sha1::SHA1Transform_body_tmp2 \ |
|---|
| 601 | {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \ |
|---|
| 602 | ::sha1::SHA1Transform_body_tmp2 |
|---|
| 603 | |
|---|
| 604 | if {[package vsatisfies [package provide Tcl] 8.5]} { |
|---|
| 605 | proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp |
|---|
| 606 | } else { |
|---|
| 607 | proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2 |
|---|
| 608 | } |
|---|
| 609 | |
|---|
| 610 | unset ::sha1::SHA1Transform_body_tmp |
|---|
| 611 | unset ::sha1::SHA1Transform_body_tmp2 |
|---|
| 612 | |
|---|
| 613 | # ------------------------------------------------------------------------- |
|---|
| 614 | |
|---|
| 615 | proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} |
|---|
| 616 | proc ::sha1::bytes {v} { |
|---|
| 617 | #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] |
|---|
| 618 | format %c%c%c%c \ |
|---|
| 619 | [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \ |
|---|
| 620 | [expr {(0xFF0000 & $v) >> 16}] \ |
|---|
| 621 | [expr {(0xFF00 & $v) >> 8}] \ |
|---|
| 622 | [expr {0xFF & $v}] |
|---|
| 623 | } |
|---|
| 624 | |
|---|
| 625 | # ------------------------------------------------------------------------- |
|---|
| 626 | |
|---|
| 627 | proc ::sha1::Hex {data} { |
|---|
| 628 | binary scan $data H* result |
|---|
| 629 | return $result |
|---|
| 630 | } |
|---|
| 631 | |
|---|
| 632 | # ------------------------------------------------------------------------- |
|---|
| 633 | |
|---|
| 634 | # Description: |
|---|
| 635 | # Pop the nth element off a list. Used in options processing. |
|---|
| 636 | # |
|---|
| 637 | proc ::sha1::Pop {varname {nth 0}} { |
|---|
| 638 | upvar $varname args |
|---|
| 639 | set r [lindex $args $nth] |
|---|
| 640 | set args [lreplace $args $nth $nth] |
|---|
| 641 | return $r |
|---|
| 642 | } |
|---|
| 643 | |
|---|
| 644 | # ------------------------------------------------------------------------- |
|---|
| 645 | |
|---|
| 646 | # fileevent handler for chunked file hashing. |
|---|
| 647 | # |
|---|
| 648 | proc ::sha1::Chunk {token channel {chunksize 4096}} { |
|---|
| 649 | upvar #0 $token state |
|---|
| 650 | |
|---|
| 651 | if {[eof $channel]} { |
|---|
| 652 | fileevent $channel readable {} |
|---|
| 653 | set state(reading) 0 |
|---|
| 654 | } |
|---|
| 655 | |
|---|
| 656 | SHA1Update $token [read $channel $chunksize] |
|---|
| 657 | } |
|---|
| 658 | |
|---|
| 659 | # ------------------------------------------------------------------------- |
|---|
| 660 | |
|---|
| 661 | proc ::sha1::sha1 {args} { |
|---|
| 662 | array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} |
|---|
| 663 | if {[llength $args] == 1} { |
|---|
| 664 | set opts(-hex) 1 |
|---|
| 665 | } else { |
|---|
| 666 | while {[string match -* [set option [lindex $args 0]]]} { |
|---|
| 667 | switch -glob -- $option { |
|---|
| 668 | -hex { set opts(-hex) 1 } |
|---|
| 669 | -bin { set opts(-hex) 0 } |
|---|
| 670 | -file* { set opts(-filename) [Pop args 1] } |
|---|
| 671 | -channel { set opts(-channel) [Pop args 1] } |
|---|
| 672 | -chunksize { set opts(-chunksize) [Pop args 1] } |
|---|
| 673 | default { |
|---|
| 674 | if {[llength $args] == 1} { break } |
|---|
| 675 | if {[string compare $option "--"] == 0} { Pop args; break } |
|---|
| 676 | set err [join [lsort [concat -bin [array names opts]]] ", "] |
|---|
| 677 | return -code error "bad option $option:\ |
|---|
| 678 | must be one of $err" |
|---|
| 679 | } |
|---|
| 680 | } |
|---|
| 681 | Pop args |
|---|
| 682 | } |
|---|
| 683 | } |
|---|
| 684 | |
|---|
| 685 | if {$opts(-filename) != {}} { |
|---|
| 686 | set opts(-channel) [open $opts(-filename) r] |
|---|
| 687 | fconfigure $opts(-channel) -translation binary |
|---|
| 688 | } |
|---|
| 689 | |
|---|
| 690 | if {$opts(-channel) == {}} { |
|---|
| 691 | |
|---|
| 692 | if {[llength $args] != 1} { |
|---|
| 693 | return -code error "wrong # args:\ |
|---|
| 694 | should be \"sha1 ?-hex? -filename file | string\"" |
|---|
| 695 | } |
|---|
| 696 | set tok [SHA1Init] |
|---|
| 697 | SHA1Update $tok [lindex $args 0] |
|---|
| 698 | set r [SHA1Final $tok] |
|---|
| 699 | |
|---|
| 700 | } else { |
|---|
| 701 | |
|---|
| 702 | set tok [SHA1Init] |
|---|
| 703 | # FRINK: nocheck |
|---|
| 704 | set [subst $tok](reading) 1 |
|---|
| 705 | fileevent $opts(-channel) readable \ |
|---|
| 706 | [list [namespace origin Chunk] \ |
|---|
| 707 | $tok $opts(-channel) $opts(-chunksize)] |
|---|
| 708 | # FRINK: nocheck |
|---|
| 709 | vwait [subst $tok](reading) |
|---|
| 710 | set r [SHA1Final $tok] |
|---|
| 711 | |
|---|
| 712 | # If we opened the channel - we should close it too. |
|---|
| 713 | if {$opts(-filename) != {}} { |
|---|
| 714 | close $opts(-channel) |
|---|
| 715 | } |
|---|
| 716 | } |
|---|
| 717 | |
|---|
| 718 | if {$opts(-hex)} { |
|---|
| 719 | set r [Hex $r] |
|---|
| 720 | } |
|---|
| 721 | return $r |
|---|
| 722 | } |
|---|
| 723 | |
|---|
| 724 | # ------------------------------------------------------------------------- |
|---|
| 725 | |
|---|
| 726 | proc ::sha1::hmac {args} { |
|---|
| 727 | array set opts {-hex 1 -filename {} -channel {} -chunksize 4096} |
|---|
| 728 | if {[llength $args] != 2} { |
|---|
| 729 | while {[string match -* [set option [lindex $args 0]]]} { |
|---|
| 730 | switch -glob -- $option { |
|---|
| 731 | -key { set opts(-key) [Pop args 1] } |
|---|
| 732 | -hex { set opts(-hex) 1 } |
|---|
| 733 | -bin { set opts(-hex) 0 } |
|---|
| 734 | -file* { set opts(-filename) [Pop args 1] } |
|---|
| 735 | -channel { set opts(-channel) [Pop args 1] } |
|---|
| 736 | -chunksize { set opts(-chunksize) [Pop args 1] } |
|---|
| 737 | default { |
|---|
| 738 | if {[llength $args] == 1} { break } |
|---|
| 739 | if {[string compare $option "--"] == 0} { Pop args; break } |
|---|
| 740 | set err [join [lsort [array names opts]] ", "] |
|---|
| 741 | return -code error "bad option $option:\ |
|---|
| 742 | must be one of $err" |
|---|
| 743 | } |
|---|
| 744 | } |
|---|
| 745 | Pop args |
|---|
| 746 | } |
|---|
| 747 | } |
|---|
| 748 | |
|---|
| 749 | if {[llength $args] == 2} { |
|---|
| 750 | set opts(-key) [Pop args] |
|---|
| 751 | } |
|---|
| 752 | |
|---|
| 753 | if {![info exists opts(-key)]} { |
|---|
| 754 | return -code error "wrong # args:\ |
|---|
| 755 | should be \"hmac ?-hex? -key key -filename file | string\"" |
|---|
| 756 | } |
|---|
| 757 | |
|---|
| 758 | if {$opts(-filename) != {}} { |
|---|
| 759 | set opts(-channel) [open $opts(-filename) r] |
|---|
| 760 | fconfigure $opts(-channel) -translation binary |
|---|
| 761 | } |
|---|
| 762 | |
|---|
| 763 | if {$opts(-channel) == {}} { |
|---|
| 764 | |
|---|
| 765 | if {[llength $args] != 1} { |
|---|
| 766 | return -code error "wrong # args:\ |
|---|
| 767 | should be \"hmac ?-hex? -key key -filename file | string\"" |
|---|
| 768 | } |
|---|
| 769 | set tok [HMACInit $opts(-key)] |
|---|
| 770 | HMACUpdate $tok [lindex $args 0] |
|---|
| 771 | set r [HMACFinal $tok] |
|---|
| 772 | |
|---|
| 773 | } else { |
|---|
| 774 | |
|---|
| 775 | set tok [HMACInit $opts(-key)] |
|---|
| 776 | # FRINK: nocheck |
|---|
| 777 | set [subst $tok](reading) 1 |
|---|
| 778 | fileevent $opts(-channel) readable \ |
|---|
| 779 | [list [namespace origin Chunk] \ |
|---|
| 780 | $tok $opts(-channel) $opts(-chunksize)] |
|---|
| 781 | # FRINK: nocheck |
|---|
| 782 | vwait [subst $tok](reading) |
|---|
| 783 | set r [HMACFinal $tok] |
|---|
| 784 | |
|---|
| 785 | # If we opened the channel - we should close it too. |
|---|
| 786 | if {$opts(-filename) != {}} { |
|---|
| 787 | close $opts(-channel) |
|---|
| 788 | } |
|---|
| 789 | } |
|---|
| 790 | |
|---|
| 791 | if {$opts(-hex)} { |
|---|
| 792 | set r [Hex $r] |
|---|
| 793 | } |
|---|
| 794 | return $r |
|---|
| 795 | } |
|---|
| 796 | |
|---|
| 797 | # ------------------------------------------------------------------------- |
|---|
| 798 | |
|---|
| 799 | # Try and load a compiled extension to help. |
|---|
| 800 | namespace eval ::sha1 { |
|---|
| 801 | variable e {} |
|---|
| 802 | foreach e [KnownImplementations] { |
|---|
| 803 | if {[LoadAccelerator $e]} { |
|---|
| 804 | SwitchTo $e |
|---|
| 805 | break |
|---|
| 806 | } |
|---|
| 807 | } |
|---|
| 808 | unset e |
|---|
| 809 | } |
|---|
| 810 | |
|---|
| 811 | package provide sha1 $::sha1::version |
|---|
| 812 | |
|---|
| 813 | # ------------------------------------------------------------------------- |
|---|
| 814 | # Local Variables: |
|---|
| 815 | # mode: tcl |
|---|
| 816 | # indent-tabs-mode: nil |
|---|
| 817 | # End: |
|---|
