Check-in [ee9eb7ed98]
Overview
Comment:Merged in updates from trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | internal_sha1
Files: files | file ages | folders
SHA1:ee9eb7ed98663bc2e73768874fd038e464701645
User & Date: rkeene on 2014-11-06 00:37:20
Other Links: manifest | tags
Context
2014-11-06
02:29
Updated to use C-based implementation of SHA1 Closed-Leaf check-in: 853a9068a7 user: rkeene tags: internal_sha1
00:37
Merged in updates from trunk check-in: ee9eb7ed98 user: rkeene tags: internal_sha1
2014-11-05
21:41
Fixed cleanup issue which was causing excessive lookups check-in: cc5a68a6de user: rkeene tags: trunk
2014-11-03
23:16
Started work on an internal sha1 implementation check-in: 5ebe069cbf user: rkeene tags: internal_sha1
Changes

Modified Makefile from [fe29eeac49] to [bee1193267].

    26     26   
    27     27   appfsd: appfsd.o
    28     28   	$(CC) $(CPPFLAGS) $(CFLAGS) $(LDFLAGS) -o appfsd appfsd.o $(LIBS)
    29     29   
    30     30   appfsd.o: appfsd.c appfsd.tcl.h
    31     31   	$(CC) $(CPPFLAGS) $(CFLAGS) -o appfsd.o -c appfsd.c
    32     32   
    33         -appfsd.tcl.h: appfsd.tcl
    34         -	sed 's@[\\"]@\\&@g;s@^@   "@;s@$$@\\n"@' appfsd.tcl > appfsd.tcl.h.new
           33  +appfsd.tcl.h: appfsd.tcl sha1.tcl
           34  +	sed '/@@SHA1\.TCL@@/ r sha1.tcl' appfsd.tcl | sed '/@@SHA1\.TCL@@/ d' | sed 's@[\\"]@\\&@g;s@^@   "@;s@$$@\\n"@' > appfsd.tcl.h.new
    35     35   	mv appfsd.tcl.h.new appfsd.tcl.h
    36     36   
    37     37   install: appfsd
    38     38   	if [ ! -d '$(DESTDIR)$(sbindir)' ]; then mkdir -p '$(DESTDIR)$(sbindir)'; chmod 755 '$(DESTDIR)$(sbindir)'; fi
    39     39   	cp appfsd '$(DESTDIR)$(sbindir)/'
    40     40   
    41     41   clean:
    42     42   	rm -f appfsd appfsd.o
    43     43   	rm -f appfsd.tcl.h
    44     44   
    45     45   distclean: clean
    46     46   
    47     47   .PHONY: all test clean distclean install

Modified appfsd.c from [e3ba0e89d2] to [72840611b5].

    79     79   	const char *fmt;
    80     80   };
    81     81   
    82     82   static Tcl_Interp *appfs_create_TclInterp(const char *cachedir) {
    83     83   	Tcl_Interp *interp;
    84     84   	int tcl_ret;
    85     85   
           86  +	APPFS_DEBUG("Creating new Tcl interpreter for TID = 0x%llx", (unsigned long long) pthread_self());
           87  +
    86     88   	interp = Tcl_CreateInterp();
    87     89   	if (interp == NULL) {
    88     90   		fprintf(stderr, "Unable to create Tcl Interpreter.  Aborting.\n");
    89     91   
    90     92   		return(NULL);
    91     93   	}
    92     94   
    93     95   	tcl_ret = Tcl_Init(interp);
    94     96   	if (tcl_ret != TCL_OK) {
    95     97   		fprintf(stderr, "Unable to initialize Tcl.  Aborting.\n");
           98  +
           99  +		Tcl_DeleteInterp(interp);
    96    100   
    97    101   		return(NULL);
    98    102   	}
    99    103   
   100    104   	tcl_ret = Tcl_Eval(interp, ""
   101    105   #include "appfsd.tcl.h"
   102    106   	"");
   103    107   	if (tcl_ret != TCL_OK) {
   104    108   		fprintf(stderr, "Unable to initialize Tcl AppFS script.  Aborting.\n");
   105    109   		fprintf(stderr, "Tcl Error is: %s\n", Tcl_GetStringResult(interp));
   106    110   
          111  +		Tcl_DeleteInterp(interp);
          112  +
   107    113   		return(NULL);
   108    114   	}
   109    115   
   110    116   	if (Tcl_SetVar(interp, "::appfs::cachedir", cachedir, TCL_GLOBAL_ONLY) == NULL) {
   111    117   		fprintf(stderr, "Unable to set cache directory.  This should never fail.\n");
          118  +
          119  +		Tcl_DeleteInterp(interp);
   112    120   
   113    121   		return(NULL);
   114    122   	}
   115    123   
   116    124   	tcl_ret = Tcl_Eval(interp, "::appfs::init");
   117    125   	if (tcl_ret != TCL_OK) {
   118    126   		fprintf(stderr, "Unable to initialize Tcl AppFS script (::appfs::init).  Aborting.\n");
   119    127   		fprintf(stderr, "Tcl Error is: %s\n", Tcl_GetStringResult(interp));
   120    128   
          129  +		Tcl_DeleteInterp(interp);
          130  +
   121    131   		return(NULL);
   122    132   	}
   123    133   
          134  +	Tcl_HideCommand(interp, "glob", "glob");
          135  +	Tcl_HideCommand(interp, "exec", "exec");
          136  +	Tcl_HideCommand(interp, "pid", "pid");
          137  +	Tcl_HideCommand(interp, "auto_load_index", "auto_load_index");
          138  +	Tcl_HideCommand(interp, "unknown", "unknown");
          139  +
   124    140   	return(interp);
   125    141   }
   126    142   
   127    143   static int appfs_Tcl_Eval(Tcl_Interp *interp, int objc, const char *cmd, ...) {
   128    144   	Tcl_Obj **objv;
   129    145   	const char *arg;
   130    146   	va_list argp;

Modified appfsd.tcl from [a0bff81028] to [86cb2b92c8].

     1      1   #! /usr/bin/env tclsh
     2      2   
     3      3   package require http 2.7
     4      4   package require sqlite3
     5         -package require sha1
            5  +
            6  +if {[catch {
            7  +	package require sha1
            8  +}]} {
            9  +	@@SHA1.TCL@@
           10  +	package require sha1
           11  +}
     6     12   
     7     13   namespace eval ::appfs {
     8     14   	variable cachedir "/tmp/appfs-cache"
     9     15   	variable ttl 3600
    10     16   	variable nttl 60
    11     17   
    12     18   	proc _hash_sep {hash {seps 4}} {
................................................................................
    24     30   			set filekey [_hash_sep $filekey]
    25     31   		}
    26     32   
    27     33   		set file [file join $::appfs::cachedir $filekey]
    28     34   
    29     35   		file mkdir [file dirname $file]
    30     36   
    31         -		if {![file exists $file]} {
    32         -			set tmpfile "${file}.new"
    33         -
    34         -			set fd [open $tmpfile "w"]
    35         -			fconfigure $fd -translation binary
    36         -
    37         -			catch {
    38         -				set token [::http::geturl $url -channel $fd -binary true]
    39         -			}
    40         -
    41         -			if {[info exists token]} {
    42         -				set ncode [::http::ncode $token]
    43         -				::http::reset $token
    44         -			} else {
    45         -				set ncode "900"
    46         -			}
    47         -
    48         -			close $fd
    49         -
    50         -			if {$keyIsHash} {
    51         -				set hash [string tolower [sha1::sha1 -hex -file $tmpfile]]
    52         -			} else {
    53         -				set hash $key
    54         -			}
    55         -
    56         -			if {$ncode == "200" && $hash == $key} {
    57         -				file rename -force -- $tmpfile $file
    58         -			} else {
    59         -				file delete -force -- $tmpfile
    60         -			}
           37  +		if {[file exists $file]} {
           38  +			return $file
           39  +		}
           40  +
           41  +		set tmpfile "${file}.[expr {rand()}]"
           42  +
           43  +		set fd [open $tmpfile "w"]
           44  +		fconfigure $fd -translation binary
           45  +
           46  +		catch {
           47  +			set token [::http::geturl $url -channel $fd -binary true]
           48  +		}
           49  +
           50  +		if {[info exists token]} {
           51  +			set ncode [::http::ncode $token]
           52  +			::http::reset $token
           53  +		} else {
           54  +			set ncode "900"
           55  +		}
           56  +
           57  +		close $fd
           58  +
           59  +		if {$keyIsHash} {
           60  +			set hash [string tolower [sha1::sha1 -hex -file $tmpfile]]
           61  +		} else {
           62  +			set hash $key
           63  +		}
           64  +
           65  +		if {$ncode == "200" && $hash == $key} {
           66  +			file rename -force -- $tmpfile $file
           67  +		} else {
           68  +			file delete -force -- $tmpfile
    61     69   		}
    62     70   
    63     71   		return $file
    64     72   	}
    65     73   
    66     74   
    67     75   	proc _isHash {value} {
................................................................................
    88     96   		switch -- $os {
    89     97   			"linux" - "freebsd" - "openbsd" - "netbsd" {
    90     98   				return $os
    91     99   			}
    92    100   			"sunos" {
    93    101   				return "solaris"
    94    102   			}
          103  +			"noarch" - "none" - "any" - "all" {
          104  +				return "noarch"
          105  +			}
    95    106   		}
    96    107   
    97    108   		return -code error "Unable to normalize OS: $os"
    98    109   	}
    99    110   
   100    111   	proc _normalizeCPU {cpu} {
   101    112   		set cpu [string tolower [string trim $cpu]]
................................................................................
   102    113   
   103    114   		switch -glob -- $cpu {
   104    115   			"i?86" {
   105    116   				return "ix86"
   106    117   			}
   107    118   			"x86_64" {
   108    119   				return $cpu
          120  +			}
          121  +			"noarch" - "none" - "any" - "all" {
          122  +				return "noarch"
   109    123   			}
   110    124   		}
   111    125   
   112    126   		return -code error "Unable to normalize CPU: $cpu"
   113    127   	}
   114    128   
   115    129   	proc init {} {
................................................................................
   137    151   	}
   138    152   
   139    153   	proc download {hostname hash {method sha1}} {
   140    154   		set url "http://$hostname/appfs/$method/$hash"
   141    155   		set file [_cachefile $url $hash]
   142    156   
   143    157   		if {![file exists $file]} {
   144         -			return -code error "Unable to fetch"
          158  +			return -code error "Unable to fetch (file does not exist: $file)"
   145    159   		}
   146    160   
   147    161   		return $file
   148    162   	}
   149    163   
   150    164   	proc getindex {hostname} {
   151    165   		set now [clock seconds]
................................................................................
   171    185   
   172    186   		catch {
   173    187   			set token [::http::geturl $url]
   174    188   			if {[::http::ncode $token] == "200"} {
   175    189   				set indexhash_data [::http::data $token]
   176    190   			}
   177    191   			::http::reset $token
   178         -			$token cleanup
          192  +			::http::cleanup $token
   179    193   		}
   180    194   
   181    195   		if {![info exists indexhash_data]} {
   182    196   			# Cache this result for 60 seconds
   183    197   			_db eval {INSERT OR REPLACE INTO sites (hostname, lastUpdate, ttl) VALUES ($hostname, $now, $::appfs::nttl);}
   184    198   
   185    199   			return -code error "Unable to fetch $url"
................................................................................
   207    221   			if {$line == ""} {
   208    222   				continue
   209    223   			}
   210    224   
   211    225   			set work [split $line ","]
   212    226   
   213    227   			unset -nocomplain pkgInfo
   214         -			set pkgInfo(package)  [lindex $work 0]
   215         -			set pkgInfo(version)  [lindex $work 1]
   216         -			set pkgInfo(os)       [_normalizeOS [lindex $work 2]]
   217         -			set pkgInfo(cpuArch)  [_normalizeCPU [lindex $work 3]]
   218         -			set pkgInfo(hash)     [string tolower [lindex $work 4]]
   219         -			set pkgInfo(hash_type) "sha1"
   220         -			set pkgInfo(isLatest) [expr {!![lindex $work 5]}]
          228  +			if {[catch {
          229  +				set pkgInfo(package)  [lindex $work 0]
          230  +				set pkgInfo(version)  [lindex $work 1]
          231  +				set pkgInfo(os)       [_normalizeOS [lindex $work 2]]
          232  +				set pkgInfo(cpuArch)  [_normalizeCPU [lindex $work 3]]
          233  +				set pkgInfo(hash)     [string tolower [lindex $work 4]]
          234  +				set pkgInfo(hash_type) "sha1"
          235  +				set pkgInfo(isLatest) [expr {!![lindex $work 5]}]
          236  +			}]} {
          237  +				continue
          238  +			}
   221    239   
   222    240   			if {![_isHash $pkgInfo(hash)]} {
   223    241   				continue
   224    242   			}
   225    243   
   226    244   			lappend curr_packages $pkgInfo(hash)
   227    245   

Added sha1.tcl version [a8b3b2afbe].

            1  +# sha1.tcl - 
            2  +
            3  +# @@ Meta Begin
            4  +# Package sha1 2.0.3
            5  +# Meta platform           tcl
            6  +# Meta rsk::build::date   2011-03-30
            7  +# Meta description        Part of the Tclib sha1 module
            8  +# Meta require            {Tcl 8.2}
            9  +# @@ Meta End
           10  +
           11  +#
           12  +# Copyright (C) 2001 Don Libes <libes@nist.gov>
           13  +# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
           14  +#
           15  +# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm"
           16  +# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
           17  +#
           18  +# This is an implementation of SHA1 based upon the example code given in
           19  +# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas
           20  +# and methods from the earlier tcllib sha1 version by Don Libes.
           21  +#
           22  +# This implementation permits incremental updating of the hash and 
           23  +# provides support for external compiled implementations either using
           24  +# critcl (sha1c) or Trf.
           25  +#
           26  +# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm
           27  +#
           28  +# -------------------------------------------------------------------------
           29  +# See the file "license.terms" for information on usage and redistribution
           30  +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
           31  +# -------------------------------------------------------------------------
           32  +#
           33  +# $Id: sha1.tcl,v 1.22 2009/05/07 00:35:10 patthoyts Exp $
           34  +
           35  +# @mdgen EXCLUDE: sha1c.tcl
           36  +
           37  +package require Tcl 8.2;                # tcl minimum version
           38  +
           39  +namespace eval ::sha1 {
           40  +    variable  version 2.0.3
           41  +    namespace export sha1 hmac SHA1Init SHA1Update SHA1Final
           42  +    variable uid
           43  +    if {![info exists uid]} {
           44  +        set uid 0
           45  +    }
           46  +}
           47  +
           48  +proc ::sha1::SHA1Init {} {
           49  +    variable uid
           50  +    set token [namespace current]::[incr uid]
           51  +    upvar #0 $token state
           52  +
           53  +    # FIPS 180-1: 7 - Initialize the hash state
           54  +    array set state \
           55  +        [list \
           56  +             A [expr {int(0x67452301)}] \
           57  +             B [expr {int(0xEFCDAB89)}] \
           58  +             C [expr {int(0x98BADCFE)}] \
           59  +             D [expr {int(0x10325476)}] \
           60  +             E [expr {int(0xC3D2E1F0)}] \
           61  +             n 0 i "" ]
           62  +    return $token
           63  +}
           64  +
           65  +# SHA1Update --
           66  +#
           67  +#   This is called to add more data into the hash. You may call this
           68  +#   as many times as you require. Note that passing in "ABC" is equivalent
           69  +#   to passing these letters in as separate calls -- hence this proc 
           70  +#   permits hashing of chunked data
           71  +#
           72  +#   If we have a C-based implementation available, then we will use
           73  +#   it here in preference to the pure-Tcl implementation.
           74  +#
           75  +proc ::sha1::SHA1Update {token data} {
           76  +    upvar #0 $token state
           77  +
           78  +    # Update the state values
           79  +    incr state(n) [string length $data]
           80  +    append state(i) $data
           81  +
           82  +    # Calculate the hash for any complete blocks
           83  +    set len [string length $state(i)]
           84  +    for {set n 0} {($n + 64) <= $len} {} {
           85  +        SHA1Transform $token [string range $state(i) $n [incr n 64]]
           86  +    }
           87  +
           88  +    # Adjust the state for the blocks completed.
           89  +    set state(i) [string range $state(i) $n end]
           90  +    return
           91  +}
           92  +
           93  +# SHA1Final --
           94  +#
           95  +#    This procedure is used to close the current hash and returns the
           96  +#    hash data. Once this procedure has been called the hash context
           97  +#    is freed and cannot be used again.
           98  +#
           99  +#    Note that the output is 160 bits represented as binary data.
          100  +#
          101  +proc ::sha1::SHA1Final {token} {
          102  +    upvar #0 $token state
          103  +
          104  +    # Padding
          105  +    #
          106  +    set len [string length $state(i)]
          107  +    set pad [expr {56 - ($len % 64)}]
          108  +    if {$len % 64 > 56} {
          109  +        incr pad 64
          110  +    }
          111  +    if {$pad == 0} {
          112  +        incr pad 64
          113  +    }
          114  +    append state(i) [binary format a$pad \x80]
          115  +
          116  +    # Append length in bits as big-endian wide int.
          117  +    set dlen [expr {8 * $state(n)}]
          118  +    append state(i) [binary format II 0 $dlen]
          119  +
          120  +    # Calculate the hash for the remaining block.
          121  +    set len [string length $state(i)]
          122  +    for {set n 0} {($n + 64) <= $len} {} {
          123  +        SHA1Transform $token [string range $state(i) $n [incr n 64]]
          124  +    }
          125  +
          126  +    # Output
          127  +    set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)]
          128  +    unset state
          129  +    return $r
          130  +}
          131  +
          132  +# -------------------------------------------------------------------------
          133  +# HMAC Hashed Message Authentication (RFC 2104)
          134  +#
          135  +# hmac = H(K xor opad, H(K xor ipad, text))
          136  +#
          137  +
          138  +# HMACInit --
          139  +#
          140  +#    This is equivalent to the SHA1Init procedure except that a key is
          141  +#    added into the algorithm
          142  +#
          143  +proc ::sha1::HMACInit {K} {
          144  +
          145  +    # Key K is adjusted to be 64 bytes long. If K is larger, then use
          146  +    # the SHA1 digest of K and pad this instead.
          147  +    set len [string length $K]
          148  +    if {$len > 64} {
          149  +        set tok [SHA1Init]
          150  +        SHA1Update $tok $K
          151  +        set K [SHA1Final $tok]
          152  +        set len [string length $K]
          153  +    }
          154  +    set pad [expr {64 - $len}]
          155  +    append K [string repeat \0 $pad]
          156  +
          157  +    # Cacluate the padding buffers.
          158  +    set Ki {}
          159  +    set Ko {}
          160  +    binary scan $K i16 Ks
          161  +    foreach k $Ks {
          162  +        append Ki [binary format i [expr {$k ^ 0x36363636}]]
          163  +        append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
          164  +    }
          165  +
          166  +    set tok [SHA1Init]
          167  +    SHA1Update $tok $Ki;                 # initialize with the inner pad
          168  +    
          169  +    # preserve the Ko value for the final stage.
          170  +    # FRINK: nocheck
          171  +    set [subst $tok](Ko) $Ko
          172  +
          173  +    return $tok
          174  +}
          175  +
          176  +# HMACUpdate --
          177  +#
          178  +#    Identical to calling SHA1Update
          179  +#
          180  +proc ::sha1::HMACUpdate {token data} {
          181  +    SHA1Update $token $data
          182  +    return
          183  +}
          184  +
          185  +# HMACFinal --
          186  +#
          187  +#    This is equivalent to the SHA1Final procedure. The hash context is
          188  +#    closed and the binary representation of the hash result is returned.
          189  +#
          190  +proc ::sha1::HMACFinal {token} {
          191  +    upvar #0 $token state
          192  +
          193  +    set tok [SHA1Init];                 # init the outer hashing function
          194  +    SHA1Update $tok $state(Ko);         # prepare with the outer pad.
          195  +    SHA1Update $tok [SHA1Final $token]; # hash the inner result
          196  +    return [SHA1Final $tok]
          197  +}
          198  +
          199  +# -------------------------------------------------------------------------
          200  +# Description:
          201  +#  This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but
          202  +#  includes an extra round and a set of constant modifiers throughout.
          203  +#
          204  +set ::sha1::SHA1Transform_body {
          205  +    upvar #0 $token state
          206  +
          207  +    # FIPS 180-1: 7a: Process Message in 16-Word Blocks
          208  +    binary scan $msg I* blocks
          209  +    set blockLen [llength $blocks]
          210  +    for {set i 0} {$i < $blockLen} {incr i 16} {
          211  +        set W [lrange $blocks $i [expr {$i+15}]]
          212  +        
          213  +        # FIPS 180-1: 7b: Expand the input into 80 words
          214  +        # For t = 16 to 79 
          215  +        #   let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1
          216  +        set t3  12
          217  +        set t8   7
          218  +        set t14  1
          219  +        set t16 -1
          220  +        for {set t 16} {$t < 80} {incr t} {
          221  +            set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \
          222  +                             [lindex $W [incr t14]] ^ [lindex $W [incr t16]]}]
          223  +            lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}]
          224  +        }
          225  +        
          226  +        # FIPS 180-1: 7c: Copy hash state.
          227  +        set A $state(A)
          228  +        set B $state(B)
          229  +        set C $state(C)
          230  +        set D $state(D)
          231  +        set E $state(E)
          232  +
          233  +        # FIPS 180-1: 7d: Do permutation rounds
          234  +        # For t = 0 to 79 do
          235  +        #   TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt;
          236  +        #   E = D; D = C; C = S30(B); B = A; A = TEMP;
          237  +
          238  +        # Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19)
          239  +        for {set t 0} {$t < 20} {incr t} {
          240  +            set TEMP [F1 $A $B $C $D $E [lindex $W $t]]
          241  +            set E $D
          242  +            set D $C
          243  +            set C [rotl32 $B 30]
          244  +            set B $A
          245  +            set A $TEMP
          246  +        }
          247  +
          248  +        # Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39)
          249  +        for {} {$t < 40} {incr t} {
          250  +            set TEMP [F2 $A $B $C $D $E [lindex $W $t]]
          251  +            set E $D
          252  +            set D $C
          253  +            set C [rotl32 $B 30]
          254  +            set B $A
          255  +            set A $TEMP
          256  +        }
          257  +
          258  +        # Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59)
          259  +        for {} {$t < 60} {incr t} {
          260  +            set TEMP [F3 $A $B $C $D $E [lindex $W $t]]
          261  +            set E $D
          262  +            set D $C
          263  +            set C [rotl32 $B 30]
          264  +            set B $A
          265  +            set A $TEMP
          266  +         }
          267  +
          268  +        # Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79)
          269  +        for {} {$t < 80} {incr t} {
          270  +            set TEMP [F4 $A $B $C $D $E [lindex $W $t]]
          271  +            set E $D
          272  +            set D $C
          273  +            set C [rotl32 $B 30]
          274  +            set B $A
          275  +            set A $TEMP
          276  +        }
          277  +
          278  +        # Then perform the following additions. (That is, increment each
          279  +        # of the four registers by the value it had before this block
          280  +        # was started.)
          281  +        incr state(A) $A
          282  +        incr state(B) $B
          283  +        incr state(C) $C
          284  +        incr state(D) $D
          285  +        incr state(E) $E
          286  +    }
          287  +
          288  +    return
          289  +}
          290  +
          291  +proc ::sha1::F1 {A B C D E W} {
          292  +    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
          293  +               + ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff}
          294  +}
          295  +
          296  +proc ::sha1::F2 {A B C D E W} {
          297  +    expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \
          298  +               + ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff}
          299  +}
          300  +
          301  +proc ::sha1::F3 {A B C D E W} {
          302  +    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
          303  +               + (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff}
          304  +}
          305  +
          306  +proc ::sha1::F4 {A B C D E W} {
          307  +    expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \
          308  +               + ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff}
          309  +}
          310  +
          311  +proc ::sha1::rotl32 {v n} {
          312  +    return [expr {((($v << $n) \
          313  +                        | (($v >> (32 - $n)) \
          314  +                               & (0x7FFFFFFF >> (31 - $n))))) \
          315  +                      & 0xFFFFFFFF}]
          316  +}
          317  +
          318  +
          319  +# -------------------------------------------------------------------------
          320  +# 
          321  +# In order to get this code to go as fast as possible while leaving
          322  +# the main code readable we can substitute the above function bodies
          323  +# into the transform procedure. This inlines the code for us an avoids
          324  +# a procedure call overhead within the loops.
          325  +#
          326  +# We can do some minor tweaking to improve speed on Tcl < 8.5 where we
          327  +# know our arithmetic is limited to 64 bits. On > 8.5 we may have 
          328  +# unconstrained integer arithmetic and must avoid letting it run away.
          329  +#
          330  +
          331  +regsub -all -line \
          332  +    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
          333  +    $::sha1::SHA1Transform_body \
          334  +    {[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \
          335  +    ::sha1::SHA1Transform_body_tmp
          336  +
          337  +regsub -all -line \
          338  +    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
          339  +    $::sha1::SHA1Transform_body_tmp \
          340  +    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \
          341  +    ::sha1::SHA1Transform_body_tmp
          342  +
          343  +regsub -all -line \
          344  +    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
          345  +    $::sha1::SHA1Transform_body_tmp \
          346  +    {[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \
          347  +    ::sha1::SHA1Transform_body_tmp
          348  +
          349  +regsub -all -line \
          350  +    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
          351  +    $::sha1::SHA1Transform_body_tmp \
          352  +    {[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \
          353  +    ::sha1::SHA1Transform_body_tmp
          354  +
          355  +regsub -all -line \
          356  +    {rotl32\(\$A,5\)} \
          357  +    $::sha1::SHA1Transform_body_tmp \
          358  +    {((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \
          359  +    ::sha1::SHA1Transform_body_tmp
          360  +
          361  +regsub -all -line \
          362  +    {\[rotl32 \$B 30\]} \
          363  +    $::sha1::SHA1Transform_body_tmp \
          364  +    {[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \
          365  +    ::sha1::SHA1Transform_body_tmp
          366  +#
          367  +# Version 2 avoids a few truncations to 32 bits in non-essential places.
          368  +#
          369  +regsub -all -line \
          370  +    {\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \
          371  +    $::sha1::SHA1Transform_body \
          372  +    {[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \
          373  +    ::sha1::SHA1Transform_body_tmp2
          374  +
          375  +regsub -all -line \
          376  +    {\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \
          377  +    $::sha1::SHA1Transform_body_tmp2 \
          378  +    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \
          379  +    ::sha1::SHA1Transform_body_tmp2
          380  +
          381  +regsub -all -line \
          382  +    {\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \
          383  +    $::sha1::SHA1Transform_body_tmp2 \
          384  +    {[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \
          385  +    ::sha1::SHA1Transform_body_tmp2
          386  +
          387  +regsub -all -line \
          388  +    {\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \
          389  +    $::sha1::SHA1Transform_body_tmp2 \
          390  +    {[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \
          391  +    ::sha1::SHA1Transform_body_tmp2
          392  +
          393  +regsub -all -line \
          394  +    {rotl32\(\$A,5\)} \
          395  +    $::sha1::SHA1Transform_body_tmp2 \
          396  +    {(($A << 5) | (($A >> 27) \& 0x1f))} \
          397  +    ::sha1::SHA1Transform_body_tmp2
          398  +
          399  +regsub -all -line \
          400  +    {\[rotl32 \$B 30\]} \
          401  +    $::sha1::SHA1Transform_body_tmp2 \
          402  +    {[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \
          403  +    ::sha1::SHA1Transform_body_tmp2
          404  +
          405  +if {[package vsatisfies [package provide Tcl] 8.5]} {
          406  +    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp
          407  +} else {
          408  +    proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2
          409  +}
          410  +
          411  +unset ::sha1::SHA1Transform_body
          412  +unset ::sha1::SHA1Transform_body_tmp
          413  +unset ::sha1::SHA1Transform_body_tmp2
          414  +
          415  +# -------------------------------------------------------------------------
          416  +
          417  +proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
          418  +proc ::sha1::bytes {v} { 
          419  +    #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
          420  +    format %c%c%c%c \
          421  +        [expr {((0xFF000000 & $v) >> 24) & 0xFF}] \
          422  +        [expr {(0xFF0000 & $v) >> 16}] \
          423  +        [expr {(0xFF00 & $v) >> 8}] \
          424  +        [expr {0xFF & $v}]
          425  +}
          426  +
          427  +# -------------------------------------------------------------------------
          428  +
          429  +proc ::sha1::Hex {data} {
          430  +    binary scan $data H* result
          431  +    return $result
          432  +}
          433  +
          434  +# -------------------------------------------------------------------------
          435  +
          436  +# Description:
          437  +#  Pop the nth element off a list. Used in options processing.
          438  +#
          439  +proc ::sha1::Pop {varname {nth 0}} {
          440  +    upvar $varname args
          441  +    set r [lindex $args $nth]
          442  +    set args [lreplace $args $nth $nth]
          443  +    return $r
          444  +}
          445  +
          446  +# -------------------------------------------------------------------------
          447  +
          448  +# fileevent handler for chunked file hashing.
          449  +#
          450  +proc ::sha1::Chunk {token channel {chunksize 4096}} {
          451  +    upvar #0 $token state
          452  +    
          453  +    if {[eof $channel]} {
          454  +        fileevent $channel readable {}
          455  +        set state(reading) 0
          456  +    }
          457  +        
          458  +    SHA1Update $token [read $channel $chunksize]
          459  +}
          460  +
          461  +# -------------------------------------------------------------------------
          462  +
          463  +proc ::sha1::sha1 {args} {
          464  +    array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
          465  +    if {[llength $args] == 1} {
          466  +        set opts(-hex) 1
          467  +    } else {
          468  +        while {[string match -* [set option [lindex $args 0]]]} {
          469  +            switch -glob -- $option {
          470  +                -hex       { set opts(-hex) 1 }
          471  +                -bin       { set opts(-hex) 0 }
          472  +                -file*     { set opts(-filename) [Pop args 1] }
          473  +                -channel   { set opts(-channel) [Pop args 1] }
          474  +                -chunksize { set opts(-chunksize) [Pop args 1] }
          475  +                default {
          476  +                    if {[llength $args] == 1} { break }
          477  +                    if {[string compare $option "--"] == 0} { Pop args; break }
          478  +                    set err [join [lsort [concat -bin [array names opts]]] ", "]
          479  +                    return -code error "bad option $option:\
          480  +                    must be one of $err"
          481  +                }
          482  +            }
          483  +            Pop args
          484  +        }
          485  +    }
          486  +
          487  +    if {$opts(-filename) != {}} {
          488  +        set opts(-channel) [open $opts(-filename) r]
          489  +        fconfigure $opts(-channel) -translation binary
          490  +    }
          491  +
          492  +    if {$opts(-channel) == {}} {
          493  +
          494  +        if {[llength $args] != 1} {
          495  +            return -code error "wrong # args:\
          496  +                should be \"sha1 ?-hex? -filename file | string\""
          497  +        }
          498  +        set tok [SHA1Init]
          499  +        SHA1Update $tok [lindex $args 0]
          500  +        set r [SHA1Final $tok]
          501  +
          502  +    } else {
          503  +
          504  +        set tok [SHA1Init]
          505  +        # FRINK: nocheck
          506  +        set [subst $tok](reading) 1
          507  +        fileevent $opts(-channel) readable \
          508  +            [list [namespace origin Chunk] \
          509  +                 $tok $opts(-channel) $opts(-chunksize)]
          510  +        # FRINK: nocheck
          511  +        vwait [subst $tok](reading)
          512  +        set r [SHA1Final $tok]
          513  +
          514  +        # If we opened the channel - we should close it too.
          515  +        if {$opts(-filename) != {}} {
          516  +            close $opts(-channel)
          517  +        }
          518  +    }
          519  +    
          520  +    if {$opts(-hex)} {
          521  +        set r [Hex $r]
          522  +    }
          523  +    return $r
          524  +}
          525  +
          526  +# -------------------------------------------------------------------------
          527  +
          528  +proc ::sha1::hmac {args} {
          529  +    array set opts {-hex 1 -filename {} -channel {} -chunksize 4096}
          530  +    if {[llength $args] != 2} {
          531  +        while {[string match -* [set option [lindex $args 0]]]} {
          532  +            switch -glob -- $option {
          533  +                -key       { set opts(-key) [Pop args 1] }
          534  +                -hex       { set opts(-hex) 1 }
          535  +                -bin       { set opts(-hex) 0 }
          536  +                -file*     { set opts(-filename) [Pop args 1] }
          537  +                -channel   { set opts(-channel) [Pop args 1] }
          538  +                -chunksize { set opts(-chunksize) [Pop args 1] }
          539  +                default {
          540  +                    if {[llength $args] == 1} { break }
          541  +                    if {[string compare $option "--"] == 0} { Pop args; break }
          542  +                    set err [join [lsort [array names opts]] ", "]
          543  +                    return -code error "bad option $option:\
          544  +                    must be one of $err"
          545  +                }
          546  +            }
          547  +            Pop args
          548  +        }
          549  +    }
          550  +
          551  +    if {[llength $args] == 2} {
          552  +        set opts(-key) [Pop args]
          553  +    }
          554  +
          555  +    if {![info exists opts(-key)]} {
          556  +        return -code error "wrong # args:\
          557  +            should be \"hmac ?-hex? -key key -filename file | string\""
          558  +    }
          559  +
          560  +    if {$opts(-filename) != {}} {
          561  +        set opts(-channel) [open $opts(-filename) r]
          562  +        fconfigure $opts(-channel) -translation binary
          563  +    }
          564  +
          565  +    if {$opts(-channel) == {}} {
          566  +
          567  +        if {[llength $args] != 1} {
          568  +            return -code error "wrong # args:\
          569  +                should be \"hmac ?-hex? -key key -filename file | string\""
          570  +        }
          571  +        set tok [HMACInit $opts(-key)]
          572  +        HMACUpdate $tok [lindex $args 0]
          573  +        set r [HMACFinal $tok]
          574  +
          575  +    } else {
          576  +
          577  +        set tok [HMACInit $opts(-key)]
          578  +        # FRINK: nocheck
          579  +        set [subst $tok](reading) 1
          580  +        fileevent $opts(-channel) readable \
          581  +            [list [namespace origin Chunk] \
          582  +                 $tok $opts(-channel) $opts(-chunksize)]
          583  +        # FRINK: nocheck
          584  +        vwait [subst $tok](reading)
          585  +        set r [HMACFinal $tok]
          586  +
          587  +        # If we opened the channel - we should close it too.
          588  +        if {$opts(-filename) != {}} {
          589  +            close $opts(-channel)
          590  +        }
          591  +    }
          592  +    
          593  +    if {$opts(-hex)} {
          594  +        set r [Hex $r]
          595  +    }
          596  +    return $r
          597  +}
          598  +
          599  +# -------------------------------------------------------------------------
          600  +
          601  +package provide sha1 $::sha1::version
          602  +
          603  +# -------------------------------------------------------------------------
          604  +# Local Variables:
          605  +#   mode: tcl
          606  +#   indent-tabs-mode: nil
          607  +# End: