Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -28,12 +28,12 @@ $(CC) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) -o appfsd appfsd.o $(LIBS) appfsd.o: appfsd.c appfsd.tcl.h $(CC) $(CPPFLAGS) $(CFLAGS) -o appfsd.o -c appfsd.c -appfsd.tcl.h: appfsd.tcl - sed 's@[\\"]@\\&@g;s@^@ "@;s@$$@\\n"@' appfsd.tcl > appfsd.tcl.h.new +appfsd.tcl.h: appfsd.tcl sha1.tcl + sed '/@@SHA1\.TCL@@/ r sha1.tcl' appfsd.tcl | sed '/@@SHA1\.TCL@@/ d' | sed 's@[\\"]@\\&@g;s@^@ "@;s@$$@\\n"@' > appfsd.tcl.h.new mv appfsd.tcl.h.new appfsd.tcl.h install: appfsd if [ ! -d '$(DESTDIR)$(sbindir)' ]; then mkdir -p '$(DESTDIR)$(sbindir)'; chmod 755 '$(DESTDIR)$(sbindir)'; fi cp appfsd '$(DESTDIR)$(sbindir)/' Index: appfsd.c ================================================================== --- appfsd.c +++ appfsd.c @@ -81,10 +81,12 @@ static Tcl_Interp *appfs_create_TclInterp(const char *cachedir) { Tcl_Interp *interp; int tcl_ret; + APPFS_DEBUG("Creating new Tcl interpreter for TID = 0x%llx", (unsigned long long) pthread_self()); + interp = Tcl_CreateInterp(); if (interp == NULL) { fprintf(stderr, "Unable to create Tcl Interpreter. Aborting.\n"); return(NULL); @@ -91,10 +93,12 @@ } tcl_ret = Tcl_Init(interp); if (tcl_ret != TCL_OK) { fprintf(stderr, "Unable to initialize Tcl. Aborting.\n"); + + Tcl_DeleteInterp(interp); return(NULL); } tcl_ret = Tcl_Eval(interp, "" @@ -102,27 +106,39 @@ ""); if (tcl_ret != TCL_OK) { fprintf(stderr, "Unable to initialize Tcl AppFS script. Aborting.\n"); fprintf(stderr, "Tcl Error is: %s\n", Tcl_GetStringResult(interp)); + Tcl_DeleteInterp(interp); + return(NULL); } if (Tcl_SetVar(interp, "::appfs::cachedir", cachedir, TCL_GLOBAL_ONLY) == NULL) { fprintf(stderr, "Unable to set cache directory. This should never fail.\n"); + + Tcl_DeleteInterp(interp); return(NULL); } tcl_ret = Tcl_Eval(interp, "::appfs::init"); if (tcl_ret != TCL_OK) { fprintf(stderr, "Unable to initialize Tcl AppFS script (::appfs::init). Aborting.\n"); fprintf(stderr, "Tcl Error is: %s\n", Tcl_GetStringResult(interp)); + Tcl_DeleteInterp(interp); + return(NULL); } + Tcl_HideCommand(interp, "glob", "glob"); + Tcl_HideCommand(interp, "exec", "exec"); + Tcl_HideCommand(interp, "pid", "pid"); + Tcl_HideCommand(interp, "auto_load_index", "auto_load_index"); + Tcl_HideCommand(interp, "unknown", "unknown"); + return(interp); } static int appfs_Tcl_Eval(Tcl_Interp *interp, int objc, const char *cmd, ...) { Tcl_Obj **objv; Index: appfsd.tcl ================================================================== --- appfsd.tcl +++ appfsd.tcl @@ -1,10 +1,16 @@ #! /usr/bin/env tclsh package require http 2.7 package require sqlite3 -package require sha1 + +if {[catch { + package require sha1 +}]} { + @@SHA1.TCL@@ + package require sha1 +} namespace eval ::appfs { variable cachedir "/tmp/appfs-cache" variable ttl 3600 variable nttl 60 @@ -26,40 +32,42 @@ set file [file join $::appfs::cachedir $filekey] file mkdir [file dirname $file] - if {![file exists $file]} { - set tmpfile "${file}.new" - - set fd [open $tmpfile "w"] - fconfigure $fd -translation binary - - catch { - set token [::http::geturl $url -channel $fd -binary true] - } - - if {[info exists token]} { - set ncode [::http::ncode $token] - ::http::reset $token - } else { - set ncode "900" - } - - close $fd - - if {$keyIsHash} { - set hash [string tolower [sha1::sha1 -hex -file $tmpfile]] - } else { - set hash $key - } - - if {$ncode == "200" && $hash == $key} { - file rename -force -- $tmpfile $file - } else { - file delete -force -- $tmpfile - } + if {[file exists $file]} { + return $file + } + + set tmpfile "${file}.[expr {rand()}]" + + set fd [open $tmpfile "w"] + fconfigure $fd -translation binary + + catch { + set token [::http::geturl $url -channel $fd -binary true] + } + + if {[info exists token]} { + set ncode [::http::ncode $token] + ::http::reset $token + } else { + set ncode "900" + } + + close $fd + + if {$keyIsHash} { + set hash [string tolower [sha1::sha1 -hex -file $tmpfile]] + } else { + set hash $key + } + + if {$ncode == "200" && $hash == $key} { + file rename -force -- $tmpfile $file + } else { + file delete -force -- $tmpfile } return $file } @@ -90,10 +98,13 @@ return $os } "sunos" { return "solaris" } + "noarch" - "none" - "any" - "all" { + return "noarch" + } } return -code error "Unable to normalize OS: $os" } @@ -104,10 +115,13 @@ "i?86" { return "ix86" } "x86_64" { return $cpu + } + "noarch" - "none" - "any" - "all" { + return "noarch" } } return -code error "Unable to normalize CPU: $cpu" } @@ -139,11 +153,11 @@ proc download {hostname hash {method sha1}} { set url "http://$hostname/appfs/$method/$hash" set file [_cachefile $url $hash] if {![file exists $file]} { - return -code error "Unable to fetch" + return -code error "Unable to fetch (file does not exist: $file)" } return $file } @@ -173,11 +187,11 @@ set token [::http::geturl $url] if {[::http::ncode $token] == "200"} { set indexhash_data [::http::data $token] } ::http::reset $token - $token cleanup + ::http::cleanup $token } if {![info exists indexhash_data]} { # Cache this result for 60 seconds _db eval {INSERT OR REPLACE INTO sites (hostname, lastUpdate, ttl) VALUES ($hostname, $now, $::appfs::nttl);} @@ -209,17 +223,21 @@ } set work [split $line ","] unset -nocomplain pkgInfo - set pkgInfo(package) [lindex $work 0] - set pkgInfo(version) [lindex $work 1] - set pkgInfo(os) [_normalizeOS [lindex $work 2]] - set pkgInfo(cpuArch) [_normalizeCPU [lindex $work 3]] - set pkgInfo(hash) [string tolower [lindex $work 4]] - set pkgInfo(hash_type) "sha1" - set pkgInfo(isLatest) [expr {!![lindex $work 5]}] + if {[catch { + set pkgInfo(package) [lindex $work 0] + set pkgInfo(version) [lindex $work 1] + set pkgInfo(os) [_normalizeOS [lindex $work 2]] + set pkgInfo(cpuArch) [_normalizeCPU [lindex $work 3]] + set pkgInfo(hash) [string tolower [lindex $work 4]] + set pkgInfo(hash_type) "sha1" + set pkgInfo(isLatest) [expr {!![lindex $work 5]}] + }]} { + continue + } if {![_isHash $pkgInfo(hash)]} { continue } ADDED sha1.tcl Index: sha1.tcl ================================================================== --- /dev/null +++ sha1.tcl @@ -0,0 +1,607 @@ +# sha1.tcl - + +# @@ Meta Begin +# Package sha1 2.0.3 +# Meta platform tcl +# Meta rsk::build::date 2011-03-30 +# Meta description Part of the Tclib sha1 module +# Meta require {Tcl 8.2} +# @@ Meta End + +# +# Copyright (C) 2001 Don Libes +# Copyright (C) 2003 Pat Thoyts +# +# 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.22 2009/05/07 00:35:10 patthoyts Exp $ + +# @mdgen EXCLUDE: sha1c.tcl + +package require Tcl 8.2; # tcl minimum version + +namespace eval ::sha1 { + variable version 2.0.3 + namespace export sha1 hmac SHA1Init SHA1Update SHA1Final + variable uid + if {![info exists uid]} { + set uid 0 + } +} + +proc ::sha1::SHA1Init {} { + 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 "" ] + 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. +# +proc ::sha1::SHA1Update {token data} { + upvar #0 $token state + + # 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. +# +proc ::sha1::SHA1Final {token} { + upvar #0 $token state + + # 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 +# +proc ::sha1::HMACInit {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 +# +proc ::sha1::HMACUpdate {token 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. +# +proc ::sha1::HMACFinal {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. +# +set ::sha1::SHA1Transform_body { + upvar #0 $token state + + # FIPS 180-1: 7a: Process Message in 16-Word Blocks + binary scan $msg I* blocks + set blockLen [llength $blocks] + for {set i 0} {$i < $blockLen} {incr i 16} { + set 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 + set t3 12 + set t8 7 + set t14 1 + set t16 -1 + for {set t 16} {$t < 80} {incr t} { + set 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. + set A $state(A) + set B $state(B) + set C $state(C) + set D $state(D) + set 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 {set t 0} {$t < 20} {incr t} { + set TEMP [F1 $A $B $C $D $E [lindex $W $t]] + set E $D + set D $C + set C [rotl32 $B 30] + set B $A + set A $TEMP + } + + # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39) + for {} {$t < 40} {incr t} { + set TEMP [F2 $A $B $C $D $E [lindex $W $t]] + set E $D + set D $C + set C [rotl32 $B 30] + set B $A + set A $TEMP + } + + # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59) + for {} {$t < 60} {incr t} { + set TEMP [F3 $A $B $C $D $E [lindex $W $t]] + set E $D + set D $C + set C [rotl32 $B 30] + set B $A + set A $TEMP + } + + # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79) + for {} {$t < 80} {incr t} { + set TEMP [F4 $A $B $C $D $E [lindex $W $t]] + set E $D + set D $C + set C [rotl32 $B 30] + set B $A + set 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 +} + +proc ::sha1::F1 {A B C D E W} { + expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ + + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff} +} + +proc ::sha1::F2 {A B C D E W} { + expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ + + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff} +} + +proc ::sha1::F3 {A B C D E W} { + expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ + + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff} +} + +proc ::sha1::F4 {A B C D E W} { + expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ + + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff} +} + +proc ::sha1::rotl32 {v 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]} { + proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp +} else { + proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2 +} + +unset ::sha1::SHA1Transform_body +unset ::sha1::SHA1Transform_body_tmp +unset ::sha1::SHA1Transform_body_tmp2 + +# ------------------------------------------------------------------------- + +proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} +proc ::sha1::bytes {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}] +} + +# ------------------------------------------------------------------------- + +proc ::sha1::Hex {data} { + binary scan $data H* result + return $result +} + +# ------------------------------------------------------------------------- + +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::sha1::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- + +# fileevent handler for chunked file hashing. +# +proc ::sha1::Chunk {token channel {chunksize 4096}} { + upvar #0 $token state + + if {[eof $channel]} { + fileevent $channel readable {} + set state(reading) 0 + } + + SHA1Update $token [read $channel $chunksize] +} + +# ------------------------------------------------------------------------- + +proc ::sha1::sha1 {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 +} + +# ------------------------------------------------------------------------- + +proc ::sha1::hmac {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 +} + +# ------------------------------------------------------------------------- + +package provide sha1 $::sha1::version + +# ------------------------------------------------------------------------- +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: