LDAS logo
TclDOC logo

The key.tcl Script

Modification Date: 03/23/2010

Table of Procedures

red ball changeKey
red ball key::increment
red ball key::intgen
red ball key::md5
red ball key::sha
red ball key::time

key.tcl Provides key generation functions.

package provide key 1.0
if { ! [ info exists genericAPI ] } {
   set msg    "key.tcl is a module of\n"
   append msg "the genericAPI.tcl and provides\n"
   append msg "no independent functionality."
   return -code error $msg
   }
namespace eval key { }

§   §   §

Name: key::sha

Description:
Returns the NIST Secure Hash Algorithm (SHA1) message digest of the string passed as an argument. This is a 40 character long hexadecimal string representing a "unique" hash key for the string which can be recomputed at any time.
Usage:
      set key [ key::sha $string ]
Comments:
The SHA algorithm is applied in the form of a shared object package fo efficiency when hashing long strings.
Currently deprecated as an external object module.
May be reimplemented as a pure Tcl call.
;## package require Tclsha1
proc key::sha { { str "" } } {
     if { ! [ string length $str ] } {
     return {}
     }
     set key [ uplevel #0 sha1 -string \"$str\" ]
     return $key
}

§   §   §

Name: key::md5

Description:
Don Libes pure Tcl implementation of the MD5 hashing algorithm.

Parameters: Usage:
      example: key::md5 foo --> acbd18db4cc2f85cedef654fccc4a4d8
Comments:
VERY SLOW. Use only on small strings. Plainly, the central rotator code needs to be redone as an algorithm.
proc key::md5 { text } {
 namespace eval md5 {
    variable i
    variable t
    variable T
    set i 0
    foreach t {
	0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
	0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
	0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
	0x6b901122 0xfd987193 0xa679438e 0x49b40821
	0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
	0xd62f105d 0x2441453  0xd8a1e681 0xe7d3fbc8
	0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
	0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
	0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
	0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
	0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
	0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
	0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
	0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
	0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
	0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
    } {
	incr i
	set T($i) [expr $t]
    }
 }
 proc md5::md5 {msg} {
    variable T
    set msgLen [string length $msg]
    set padLen [expr {56 - $msgLen%64}]
    if {$msgLen % 64 > 56} {
	incr padLen 64
    }
    if {$padLen == 0} { incr padLen 64 }
    append msg [binary format "a$padLen" \200]
    append msg [binary format "i1i1" [expr {8*$msgLen}] 0]
    set msgList [split $msg ""]
    set A [expr 0x67452301]
    set B [expr 0xefcdab89]
    set C [expr 0x98badcfe]
    set D [expr 0x10325476]
    set i 0
    foreach {c1 c2 c3 c4} $msgList {
	binary scan $c1$c2$c3$c4 "i" M($i)
	incr i
    }
    set blockLen [array size M]
    for {set i 0} {$i < $blockLen/16} {incr i} {
	for {set j 0} {$j<16} {incr j} {
	    set X($j) $M([expr {$i*16+$j}])
	}
	set AA $A
	set BB $B
	set CC $C
	set DD $D
	set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X(0)  + $T(1) }]  7]}]
	set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X(1)  + $T(2) }] 12]}]
	set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X(2)  + $T(3) }] 17]}]
	set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X(3)  + $T(4) }] 22]}]
	set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X(4)  + $T(5) }]  7]}]
	set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X(5)  + $T(6) }] 12]}]
	set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X(6)  + $T(7) }] 17]}]
	set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X(7)  + $T(8) }] 22]}]
	set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X(8)  + $T(9) }]  7]}]
	set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X(9)  + $T(10)}] 12]}]
	set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X(10) + $T(11)}] 17]}]
	set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X(11) + $T(12)}] 22]}]
	set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X(12) + $T(13)}]  7]}]
	set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X(13) + $T(14)}] 12]}]
	set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X(14) + $T(15)}] 17]}]
	set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X(15) + $T(16)}] 22]}]
	set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X(1)  + $T(17)}]  5]}]
	set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X(6)  + $T(18)}]  9]}]
	set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X(11) + $T(19)}] 14]}]
	set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X(0)  + $T(20)}] 20]}]
	set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X(5)  + $T(21)}]  5]}]
	set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X(10) + $T(22)}]  9]}]
	set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X(15) + $T(23)}] 14]}]
	set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X(4)  + $T(24)}] 20]}]
	set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X(9)  + $T(25)}]  5]}]
	set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X(14) + $T(26)}]  9]}]
	set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X(3)  + $T(27)}] 14]}]
	set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X(8)  + $T(28)}] 20]}]
	set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X(13) + $T(29)}]  5]}]
	set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X(2)  + $T(30)}]  9]}]
	set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X(7)  + $T(31)}] 14]}]
	set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X(12) + $T(32)}] 20]}]
	set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X(5)  + $T(33)}]  4]}]
	set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X(8)  + $T(34)}] 11]}]
	set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X(11) + $T(35)}] 16]}]
	set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X(14) + $T(36)}] 23]}]
	set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X(1)  + $T(37)}]  4]}]
	set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X(4)  + $T(38)}] 11]}]
	set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X(7)  + $T(39)}] 16]}]
	set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X(10) + $T(40)}] 23]}]
	set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X(13) + $T(41)}]  4]}]
	set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X(0)  + $T(42)}] 11]}]
	set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X(3)  + $T(43)}] 16]}]
	set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X(6)  + $T(44)}] 23]}]
	set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X(9)  + $T(45)}]  4]}]
	set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X(12) + $T(46)}] 11]}]
	set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X(15) + $T(47)}] 16]}]
	set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X(2)  + $T(48)}] 23]}]
	set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X(0)  + $T(49)}]  6]}]
	set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X(7)  + $T(50)}] 10]}]
	set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X(14) + $T(51)}] 15]}]
	set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X(5)  + $T(52)}] 21]}]
	set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X(12) + $T(53)}]  6]}]
	set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X(3)  + $T(54)}] 10]}]
	set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X(10) + $T(55)}] 15]}]
	set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X(1)  + $T(56)}] 21]}]
	set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X(8)  + $T(57)}]  6]}]
	set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X(15) + $T(58)}] 10]}]
	set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X(6)  + $T(59)}] 15]}]
	set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X(13) + $T(60)}] 21]}]
	set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X(4)  + $T(61)}]  6]}]
	set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X(11) + $T(62)}] 10]}]
	set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X(2)  + $T(63)}] 15]}]
	set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X(9)  + $T(64)}] 21]}]
	incr A $AA
	incr B $BB
	incr C $CC
	incr D $DD
    }
    return [bytes $A][bytes $B][bytes $C][bytes $D]
 }
 proc md5::<<< {x i} { expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))} }
 proc md5::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}}
 proc md5::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}}
 proc md5::H {x y z} {expr {$x ^ $y ^ $z}}
 proc md5::I {x y z} {expr {$y ^ ($x | (~$z))}}
 proc md5::byte0 {i} {expr {0xff & $i}}
 proc md5::byte1 {i} {expr {(0xff00 & $i) >> 8}}
 proc md5::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
 proc md5::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}
 proc md5::bytes {i} {format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i]}
 return [ md5::md5 $text ]
}

§   §   §

Name: key::time

Description:
Produces a unique key by manipulating the output of the Tcl clock function.
Usage:
      set unique_key [ key::time ]
Comments:
The value returned cannot be used for calculating elapsed time, it is not a valid timestamp. It is only a key. Keys generated with this function should sort in time order, however.
proc key::time { } {
	 if	{ [ catch {
     	set key   [ expr { int(pow(2,31))+[clock clicks] } ]
     } err ] } {
     	set key [ expr { pow(2,31)+[clock clicks] } ]
     }
     set begin [ expr { [ string length $key ] -8 } ]
     set end   [ expr { [ string length $key ] -3 } ]
     set key   [ string range $key $begin $end ]
     regsub -all -- {-} $key {} key
     ;## leapSecs calls getCurlUrl, which calls key::time
     if { [ info exists ::leapdates ] } {
        set key [ gpsTime ]$key
     } else {
        set key [ clock seconds ]$key
     }
     return $key
}

§   §   §

Name: key::increment

Description:
Increments a sequential key value. If the key is not known it will create it. At shutdown, keys will be saved in the $::KEYFILE file, and at startup they will be read from that file.
The key file consists of name/value pairs of keys.
Usage:
      set key [ key::incr keyname ]
Comments:
Sending a key name of "shutdown" will cause the $::KEYFILE file to be written only if there are keys which need to be updated in the file -- unmodified key values will never be reset by this function.
The actual name of the key file is set in the LDASmanager.rsc file with the KEYFILE variable.
proc key::increment { { key "" } } {
     set errs [ list ]
     if { ! [ string length $key ] } {
        return {}
     }
     if { [ string match shutdown $key ] } {
        if { [ array exists ::keys ] && \
             [ info exists ::keys($::RUNCODE) ] } {
           set    fid [ open $::KEYFILE w ]
           puts  $fid [ array get ::keys ]
           close $fid
           set msg    "incrKey:\n"
           append msg "\"key\" array written to:\n"
           append msg "$::KEYFILE"
           addLogEntry $msg
        }
        return {}
     }
     if { ! [ info exists ::keys($key) ] } {
        set ::keys($key) 0
        ;## if the system was properly shut down, a keyfile
        ;## exists.
        if { [ file exists $::KEYFILE ] } {
           set fid  [ open $::KEYFILE ]
           array set ::keys [ read $fid ]
           close $fid
           set msg    "incrKey:\n"
           append msg "$::KEYFILE read into \"key\" array.\n"
           addLogEntry $msg
           if { ! [ set ::keys($key) ] } {
              addLogEntry "key $key not found in keyfile!"
           }
        } else {
           addLogEntry "$::KEYFILE not found!"
           set ::keys($key) 0
        }
        ;## if the key is set to 0, try to con it from the
        ;## logs archive.
        if { ! [ set ::keys($key) ] } {
           ;## it is possible to recover the ::RUNCODE
           ;## key from the file $::LDASLOG/archiveIndex
           ;## where it should be found in the last line.
           if { [ string match $key $::RUNCODE ] } {
              set filename [ file join $::LDASARC archiveIndex ]
              set N 0
              if { [ file readable $filename ] } {
                 set fid [ open $filename r ]
                 ;## regexp for matching last job number in an
                 ;## archiveLog file
                 set arc_rx [ subst {${key}(\\d+)(\\s+\\d+)?$} ]
                 while { [ gets $fid line ] > -1 } {
                    set n 0
                    set line [ string trim $line ]
                    if { ! [ regexp $arc_rx $line -> n ] } {
                       set msg    "something is wrong with $filename, "
                       append msg "I can't parse the job i.d. from this "
                       append msg "line: '$line'"
                       lappend errs $msg
                    }
                    if { $n > $N } { set N $n }
                 }
                 close $fid
              }
              if { ! $N } {
                 addLogEntry "new system key: $key"
              } else {
                 addLogEntry "found key $key at $N in logs"
              }
              set ::keys($key) $N
           }
        }
     } ;## end of handler for uninitialised keys
     if { [ llength $errs ] } {
        set subj "Error generating ::RUNCODE key"
        addLogEntry "Subject: ${subj}; Body: $errs" mail
     }
     incr ::keys($key)
     set    fid [ open $::KEYFILE w ]
     puts  $fid [ array get ::keys ]
     close $fid
     return $key$::keys($key)
}

§   §   §

Name: changeKey

Description:
This proc is puts'd by the manager to a remote api to change the USER_KEY recorded in the local LDAS${API}.rsc file and register the change in the running API.
Usage:
       changeKey newkey
Comments:
Assumes that the key is made entirely of alphanumerics.
:TODO: currently broken!!
proc changeKey { { newkey "" } } {
     set filename [ file join $::LDAS LDAS${::API}.rsc ]
     set data [ dumpFile $filename ]
     ;## base64 class in regexp
     regsub {USER_KEY[ a-zA-Z0-9]+} $data "USER_KEY $newkey" data
     if { [ catch {
        set fid [ open $filename w ]
     } err ] } {
        return -code error "Could not open LDAS${::API}.rsc for writing!"
     }
     puts $fid $data
     close $fid
     if { ! [ info exists ::USER_KEY ] } {
        addLogEntry "USER_KEY not initialised in resource file." 2
     }
     set ::USER_KEY $newkey
     return {}
}

§   §   §

Name: key::intgen

Description:
Richard Suchenwirth's auto-incrementing instance counter.
Rewrites itself automagically with the new value, so no global variable is required.

Parameters: Usage:

Comments:

Nice example of manipulting proc parts.
proc key::intgen { { seed 0 } } {
     set self [lindex [info level 0] 0]
     proc $self "{ seed [ incr seed ] }" [ info body $self ]
     set seed
}

§   §   §

up arrow Back to Top up arrow