sha1.tcl

Go to the documentation of this file.

/*  sha1.tcl - */
/* */
/*  Copyright (C) 2001 Don Libes <libes@nist.gov>*/
/*  Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>*/
/* */
/*  SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm"*/
/*  HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"*/
/* */
/*  This is an implementation of SHA1 based upon the example code given in*/
/*  FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas*/
/*  and methods from the earlier tcllib sha1 version by Don Libes.*/
/* */
/*  This implementation permits incremental updating of the hash and */
/*  provides support for external compiled implementations either using*/
/*  critcl (sha1c) or Trf.*/
/* */
/*  ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm*/
/* */
/*  -------------------------------------------------------------------------*/
/*  See the file "license.terms" for information on usage and redistribution*/
/*  of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/*  -------------------------------------------------------------------------*/
/* */
/*  $Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $*/

/*  @mdgen EXCLUDE: sha1c.tcl*/

package require Tcl 8.2;                /*  tcl minimum version*/

namespace ::sha1 {
    variable  version 2.0.3
    variable  rcsid {$Id: sha1.tcl,v 1.21 2007/05/03 21:41:10 andreas_kupries Exp $}

    variable  accel
    array  accel =  {tcl 0 critcl 0 cryptkit 0 trf 0}
    variable  
    variable  active
    array  active =  {tcl 0 critcl 0 cryptkit 0 trf 0}

    namespace export sha1 hmac SHA1Init SHA1Update SHA1Final

    variable uid
    if {![info exists uid]} {
         uid =  0
    }
}

/*  -------------------------------------------------------------------------*/
/*  Management of sha1 implementations.*/

/*  LoadAccelerator --*/
/* */
/*  This package can make use of a number of compiled extensions to*/
/*  accelerate the digest computation. This procedure manages the*/
/*  use of these extensions within the package. During normal usage*/
/*  this should not be called, but the test package manipulates the*/
/*  list of enabled accelerators.*/
/* */
ret  ::sha1::LoadAccelerator (type name) {
    variable accel
    set r 0
    switch -exact -- $name {
        tcl {
            # Already present (this file)
            set r 1
        }
        critcl {
            if {![catch {package require tcllibc}]
                || ![catch {package require sha1c}]} {
                set r [expr {[info command ::sha1::sha1c] != {}}]
            }
        }
        cryptkit {
            if {![catch {package require cryptkit}]} {
                set r [expr {![catch {cryptkit::cryptInit}]}]
            }
        }
        trf {
            if {![catch {package require Trf}]} {
                set r [expr {![catch {::sha1 aa} msg]}]
            }
        }
        default {
            return -code error "invalid accelerator $key:\
                must be one of [join [KnownImplementations] {, }]"
        }
    }
    set accel($name) $r
    return $r
}

/*  ::sha1::Implementations --*/
/* */
/*  Determines which implementations are*/
/*  present, i.e. loaded.*/
/* */
/*  Arguments:*/
/*  None.*/
/* */
/*  Results:*/
/*  A list of implementation keys.*/

ret  ::sha1::Implementations () {
    variable accel
    set res {}
    foreach n [array names accel] {
    if {!$accel($n)} continue
    lappend res $n
    }
    return $res
}

/*  ::sha1::KnownImplementations --*/
/* */
/*  Determines which implementations are known*/
/*  as possible implementations.*/
/* */
/*  Arguments:*/
/*  None.*/
/* */
/*  Results:*/
/*  A list of implementation keys. In the order*/
/*  of preference, most prefered first.*/

ret  ::sha1::KnownImplementations () {
    return {critcl cryptkit trf tcl}
}

ret  ::sha1::Names () {
    return {
    critcl   {tcllibc based}
        cryptkit {cryptkit based}
        trf      {Trf based}
    tcl      {pure Tcl}
    }
}

/*  ::sha1::SwitchTo --*/
/* */
/*  Activates a loaded named implementation.*/
/* */
/*  Arguments:*/
/*  key Name of the implementation to activate.*/
/* */
/*  Results:*/
/*  None.*/

ret  ::sha1::SwitchTo (type key) {
    variable accel
    variable active
    variable loaded

    if {[string equal $key $loaded]} {
    # No change, nothing to do.
    return
    } elseif {![string equal $key ""]} {
    # Validate the target implementation of the switch.

    if {![info exists accel($key)]} {
        return -code error "Unable to activate unknown implementation \"$key\""
    } elseif {![info exists accel($key)] || !$accel($key)} {
        return -code error "Unable to activate missing implementation \"$key\""
    }
    }

    if {![string equal $loaded ""]} {
        set active($loaded) 0
    }
    if {![string equal $key ""]} {
        set active($key) 1
    }

    # Remember the active implementation, for deactivation by future
    # switches.

    set loaded $key
    return
}

/*  -------------------------------------------------------------------------*/

/*  SHA1Init --*/
/* */
/*    Create and initialize an SHA1 state variable. This will be*/
/*    cleaned up when we call SHA1Final*/
/* */

ret  ::sha1::SHA1Init () {
    variable active
    variable uid
    set token [namespace current]::[incr uid]
    upvar #0 $token state

    # FIPS 180-1: 7 - Initialize the hash state
    array set state \
        [list \
             A [expr {int(0x67452301)}] \
             B [expr {int(0xEFCDAB89)}] \
             C [expr {int(0x98BADCFE)}] \
             D [expr {int(0x10325476)}] \
             E [expr {int(0xC3D2E1F0)}] \
             n 0 i "" ]
    if {$active(cryptkit)} {
        cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA
    } elseif {$active(trf)} {
        set s {}
        switch -exact -- $::tcl_platform(platform) {
            windows { set s [open NUL w] }
            unix    { set s [open /dev/null w] }
        }
        if {$s != {}} {
            fconfigure $s -translation binary -buffering none
            ::sha1 -attach $s -mode write \
                -read-type variable \
                -read-destination [subst $token](trfread) \
                -write-type variable \
                -write-destination [subst $token](trfwrite)
            array set state [list trfread 0 trfwrite 0 trf $s]
        }
    }
    return $token
}

/*  SHA1Update --*/
/* */
/*    This is called to add more data into the hash. You may call this*/
/*    as many times as you require. Note that passing in "ABC" is equivalent*/
/*    to passing these letters in as separate calls -- hence this proc */
/*    permits hashing of chunked data*/
/* */
/*    If we have a C-based implementation available, then we will use*/
/*    it here in preference to the pure-Tcl implementation.*/
/* */
ret  ::sha1::SHA1Update (type token , type data) {
    variable active
    upvar #0 $token state

    if {$active(critcl)} {
        if {[info exists state(sha1c)]} {
            set state(sha1c) [sha1c $data $state(sha1c)]
        } else {
            set state(sha1c) [sha1c $data]
        }
        return
    } elseif {[info exists state(ckctx)]} {
        if {[string length $data] > 0} {
            cryptkit::cryptEncrypt $state(ckctx) $data
        }
        return
    } elseif {[info exists state(trf)]} {
        puts -nonewline $state(trf) $data
        return
    }

    # Update the state values
    incr state(n) [string length $data]
    append state(i) $data

    # Calculate the hash for any complete blocks
    set len [string length $state(i)]
    for {set n 0} {($n + 64) <= $len} {} {
        SHA1Transform $token [string range $state(i) $n [incr n 64]]
    }

    # Adjust the state for the blocks completed.
    set state(i) [string range $state(i) $n end]
    return
}

/*  SHA1Final --*/
/* */
/*     This procedure is used to close the current hash and returns the*/
/*     hash data. Once this procedure has been called the hash context*/
/*     is freed and cannot be used again.*/
/* */
/*     Note that the output is 160 bits represented as binary data.*/
/* */
ret  ::sha1::SHA1Final (type token) {
    upvar #0 $token state

    # Check for either of the C-compiled versions.
    if {[info exists state(sha1c)]} {
        set r $state(sha1c)
        unset state
        return $r
    } elseif {[info exists state(ckctx)]} {
        cryptkit::cryptEncrypt $state(ckctx) ""
        cryptkit::cryptGetAttributeString $state(ckctx) \
            CRYPT_CTXINFO_HASHVALUE r 20
        cryptkit::cryptDestroyContext $state(ckctx)
        # If nothing was hashed, we get no r variable set!
        if {[info exists r]} {
            unset state
            return $r
        }
    } elseif {[info exists state(trf)]} {
        close $state(trf)
        set r $state(trfwrite)
        unset state
        return $r
    }

    # Padding
    #
    set len [string length $state(i)]
    set pad [expr {56 - ($len % 64)}]
    if {$len % 64 > 56} {
        incr pad 64
    }
    if {$pad == 0} {
        incr pad 64
    }
    append state(i) [binary format a$pad \x80]

    # Append length in bits as big-endian wide int.
    set dlen [expr {8 * $state(n)}]
    append state(i) [binary format II 0 $dlen]

    # Calculate the hash for the remaining block.
    set len [string length $state(i)]
    for {set n 0} {($n + 64) <= $len} {} {
        SHA1Transform $token [string range $state(i) $n [incr n 64]]
    }

    # Output
    set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)]
    unset state
    return $r
}

/*  -------------------------------------------------------------------------*/
/*  HMAC Hashed Message Authentication (RFC 2104)*/
/* */
/*  hmac = H(K xor opad, H(K xor ipad, text))*/
/* */

/*  HMACInit --*/
/* */
/*     This is equivalent to the SHA1Init procedure except that a key is*/
/*     added into the algorithm*/
/* */
ret  ::sha1::HMACInit (type K) {

    # Key K is adjusted to be 64 bytes long. If K is larger, then use
    # the SHA1 digest of K and pad this instead.
    set len [string length $K]
    if {$len > 64} {
        set tok [SHA1Init]
        SHA1Update $tok $K
        set K [SHA1Final $tok]
        set len [string length $K]
    }
    set pad [expr {64 - $len}]
    append K [string repeat \0 $pad]

    # Cacluate the padding buffers.
    set Ki {}
    set Ko {}
    binary scan $K i16 Ks
    foreach k $Ks {
        append Ki [binary format i [expr {$k ^ 0x36363636}]]
        append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
    }

    set tok [SHA1Init]
    SHA1Update $tok $Ki;                 # initialize with the inner pad
    
    # preserve the Ko value for the final stage.
    # FRINK: nocheck
    set [subst $tok](Ko) $Ko

    return $tok
}

/*  HMACUpdate --*/
/* */
/*     Identical to calling SHA1Update*/
/* */
ret  ::sha1::HMACUpdate (type token , type data) {
    SHA1Update $token $data
    return
}

/*  HMACFinal --*/
/* */
/*     This is equivalent to the SHA1Final procedure. The hash context is*/
/*     closed and the binary representation of the hash result is returned.*/
/* */
ret  ::sha1::HMACFinal (type token) {
    upvar #0 $token state

    set tok [SHA1Init];                 # init the outer hashing function
    SHA1Update $tok $state(Ko);         # prepare with the outer pad.
    SHA1Update $tok [SHA1Final $token]; # hash the inner result
    return [SHA1Final $tok]
}

/*  -------------------------------------------------------------------------*/
/*  Description:*/
/*   This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but*/
/*   includes an extra round and a set of constant modifiers throughout.*/
/* */
 ::sha1 = ::SHA1Transform_body {
    upvar /* 0 $token state*/

    /*  FIPS 180-1: 7a: Process Message in 16-Word Blocks*/
    binary scan $msg I* blocks
     blockLen =  [llength $blocks]
    for { i =  0} {$i < $blockLen} {incr i 16} {
         W =  [lrange $blocks $i [expr {$i+15}]]
        
        /*  FIPS 180-1: 7b: Expand the input into 80 words*/
        /*  For t = 16 to 79 */
        /*    let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1*/
         t3 =   12
         t8 =    7
         t14 =   1
         t16 =  -1
        for { t =  16} {$t < 80} {incr t} {
             x =  [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \
                             [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}]
            lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}]
        }
        
        /*  FIPS 180-1: 7c: Copy hash state.*/
         A =  $state(A)
         B =  $state(B)
         C =  $state(C)
         D =  $state(D)
         E =  $state(E)

        /*  FIPS 180-1: 7d: Do permutation rounds*/
        /*  For t = 0 to 79 do*/
        /*    TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt;*/
        /*    E = D; D = C; C = S30(B); B = A; A = TEMP;*/

        /*  Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19)*/
        for { t =  0} {$t < 20} {incr t} {
             TEMP =  [F1 $A $B $C $D $E [lindex $W $t]]
             E =  $D
             D =  $C
             C =  [rotl32 $B 30]
             B =  $A
             A =  $TEMP
        }

        /*  Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39)*/
        for {} {$t < 40} {incr t} {
             TEMP =  [F2 $A $B $C $D $E [lindex $W $t]]
             E =  $D
             D =  $C
             C =  [rotl32 $B 30]
             B =  $A
             A =  $TEMP
        }

        /*  Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59)*/
        for {} {$t < 60} {incr t} {
             TEMP =  [F3 $A $B $C $D $E [lindex $W $t]]
             E =  $D
             D =  $C
             C =  [rotl32 $B 30]
             B =  $A
             A =  $TEMP
         }

        /*  Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79)*/
        for {} {$t < 80} {incr t} {
             TEMP =  [F4 $A $B $C $D $E [lindex $W $t]]
             E =  $D
             D =  $C
             C =  [rotl32 $B 30]
             B =  $A
             A =  $TEMP
        }

        /*  Then perform the following additions. (That is, increment each*/
        /*  of the four registers by the value it had before this block*/
        /*  was started.)*/
        incr state(A) $A
        incr state(B) $B
        incr state(C) $C
        incr state(D) $D
        incr state(E) $E
    }

    return
}

ret  ::sha1::F1 (type A , type B , type C , type D , type E , type W) {
    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
               + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff}
}

ret  ::sha1::F2 (type A , type B , type C , type D , type E , type W) {
    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
               + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff}
}

ret  ::sha1::F3 (type A , type B , type C , type D , type E , type W) {
    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
               + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff}
}

ret  ::sha1::F4 (type A , type B , type C , type D , type E , type W) {
    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
               + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff}
}

ret  ::sha1::rotl32 (type v , type n) {
    return [expr {((($v << $n) \
                        | (($v >> (32 - $n)) \
                               & (0x7FFFFFFF >> (31 - $n))))) \
                      & 0xFFFFFFFF}]
}


/*  -------------------------------------------------------------------------*/
/*  */
/*  In order to get this code to go as fast as possible while leaving*/
/*  the main code readable we can substitute the above function bodies*/
/*  into the transform procedure. This inlines the code for us an avoids*/
/*  a procedure call overhead within the loops.*/
/* */
/*  We can do some minor tweaking to improve speed on Tcl < 8.5 where we*/
/*  know our arithmetic is limited to 64 bits. On > 8.5 we may have */
/*  unconstrained integer arithmetic and must avoid letting it run away.*/
/* */

regsub -all -line \
    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body \
    {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp \
    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp \
    {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp \
    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {rotl32\(\$A,5\)} \
    $::sha1::SHA1Transform_body_tmp \
    {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \
    ::sha1::SHA1Transform_body_tmp

regsub -all -line \
    {\[rotl32 \$B 30\]} \
    $::sha1::SHA1Transform_body_tmp \
    {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \
    ::sha1::SHA1Transform_body_tmp
/* */
/*  Version 2 avoids a few truncations to 32 bits in non-essential places.*/
/* */
regsub -all -line \
    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body \
    {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp2 \
    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp2 \
    {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
    $::sha1::SHA1Transform_body_tmp2 \
    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {rotl32\(\$A,5\)} \
    $::sha1::SHA1Transform_body_tmp2 \
    {(($A << 5) | (($A >> 27) \& 0x1f))} \
    ::sha1::SHA1Transform_body_tmp2

regsub -all -line \
    {\[rotl32 \$B 30\]} \
    $::sha1::SHA1Transform_body_tmp2 \
    {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \
    ::sha1::SHA1Transform_body_tmp2

if {[package vsatisfies [package provide Tcl] 8.5]} {
    ret  ::sha1::SHA1Transform (type token , type msg) $::sha1::SHA1Transform_body_tmp
} else {
    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2
}

un ::sha1 = ::SHA1Transform_body_tmp
un ::sha1 = ::SHA1Transform_body_tmp2

/*  -------------------------------------------------------------------------*/

ret  ::sha1::byte (type n , type v) {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
ret  ::sha1::bytes (type v) { 
    #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
    format %c%c%c%c \
        [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \
        [expr {(0xFF0000 & $v) >> 16}] \
        [expr {(0xFF00 & $v) >> 8}] \
        [expr {0xFF & $v}]
}

/*  -------------------------------------------------------------------------*/

ret  ::sha1::Hex (type data) {
    binary scan $data H* result
    return $result
}

/*  -------------------------------------------------------------------------*/

/*  Description:*/
/*   Pop the nth element off a list. Used in options processing.*/
/* */
ret  ::sha1::Pop (type varname , optional nth =0) {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

/*  -------------------------------------------------------------------------*/

/*  fileevent handler for chunked file hashing.*/
/* */
ret  ::sha1::Chunk (type token , type channel , optional chunksize =4096) {
    upvar #0 $token state
    
    if {[eof $channel]} {
        fileevent $channel readable {}
        set state(reading) 0
    }
        
    SHA1Update $token [read $channel $chunksize]
}

/*  -------------------------------------------------------------------------*/

ret  ::sha1::sha1 (type args) {
    array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
    if {[llength $args] == 1} {
        set opts(-hex) 1
    } else {
        while {[string match -* [set option [lindex $args 0]]]} {
            switch -glob -- $option {
                -hex       { set opts(-hex) 1 }
                -bin       { set opts(-hex) 0 }
                -file*     { set opts(-filename) [Pop args 1] }
                -channel   { set opts(-channel) [Pop args 1] }
                -chunksize { set opts(-chunksize) [Pop args 1] }
                default {
                    if {[llength $args] == 1} { break }
                    if {[string compare $option "--"] == 0} { Pop args; break }
                    set err [join [lsort [concat -bin [array names opts]]] ", "]
                    return -code error "bad option $option:\
                    must be one of $err"
                }
            }
            Pop args
        }
    }

    if {$opts(-filename) != {}} {
        set opts(-channel) [open $opts(-filename) r]
        fconfigure $opts(-channel) -translation binary
    }

    if {$opts(-channel) == {}} {

        if {[llength $args] != 1} {
            return -code error "wrong # args:\
                should be \"sha1 ?-hex? -filename file | string\""
        }
        set tok [SHA1Init]
        SHA1Update $tok [lindex $args 0]
        set r [SHA1Final $tok]

    } else {

        set tok [SHA1Init]
        # FRINK: nocheck
        set [subst $tok](reading) 1
        fileevent $opts(-channel) readable \
            [list [namespace origin Chunk] \
                 $tok $opts(-channel) $opts(-chunksize)]
        # FRINK: nocheck
        vwait [subst $tok](reading)
        set r [SHA1Final $tok]

        # If we opened the channel - we should close it too.
        if {$opts(-filename) != {}} {
            close $opts(-channel)
        }
    }
    
    if {$opts(-hex)} {
        set r [Hex $r]
    }
    return $r
}

/*  -------------------------------------------------------------------------*/

ret  ::sha1::hmac (type args) {
    array set opts {-hex 1 -filename {} -channel {} -chunksize 4096}
    if {[llength $args] != 2} {
        while {[string match -* [set option [lindex $args 0]]]} {
            switch -glob -- $option {
                -key       { set opts(-key) [Pop args 1] }
                -hex       { set opts(-hex) 1 }
                -bin       { set opts(-hex) 0 }
                -file*     { set opts(-filename) [Pop args 1] }
                -channel   { set opts(-channel) [Pop args 1] }
                -chunksize { set opts(-chunksize) [Pop args 1] }
                default {
                    if {[llength $args] == 1} { break }
                    if {[string compare $option "--"] == 0} { Pop args; break }
                    set err [join [lsort [array names opts]] ", "]
                    return -code error "bad option $option:\
                    must be one of $err"
                }
            }
            Pop args
        }
    }

    if {[llength $args] == 2} {
        set opts(-key) [Pop args]
    }

    if {![info exists opts(-key)]} {
        return -code error "wrong # args:\
            should be \"hmac ?-hex? -key key -filename file | string\""
    }

    if {$opts(-filename) != {}} {
        set opts(-channel) [open $opts(-filename) r]
        fconfigure $opts(-channel) -translation binary
    }

    if {$opts(-channel) == {}} {

        if {[llength $args] != 1} {
            return -code error "wrong # args:\
                should be \"hmac ?-hex? -key key -filename file | string\""
        }
        set tok [HMACInit $opts(-key)]
        HMACUpdate $tok [lindex $args 0]
        set r [HMACFinal $tok]

    } else {

        set tok [HMACInit $opts(-key)]
        # FRINK: nocheck
        set [subst $tok](reading) 1
        fileevent $opts(-channel) readable \
            [list [namespace origin Chunk] \
                 $tok $opts(-channel) $opts(-chunksize)]
        # FRINK: nocheck
        vwait [subst $tok](reading)
        set r [HMACFinal $tok]

        # If we opened the channel - we should close it too.
        if {$opts(-filename) != {}} {
            close $opts(-channel)
        }
    }
    
    if {$opts(-hex)} {
        set r [Hex $r]
    }
    return $r
}

/*  -------------------------------------------------------------------------*/

/*  Try and load a compiled extension to help.*/
namespace ::sha1 {
    variable e {}
    foreach e [KnownImplementations] {
    if {[LoadAccelerator $e]} {
        SwitchTo $e
        break
    }
    }
    un e = 
}

package provide sha1 $::sha1::version

/*  -------------------------------------------------------------------------*/
/*  Local Variables:*/
/*    mode: tcl*/
/*    indent-tabs-mode: nil*/
/*  End:*/