des.tcl

Go to the documentation of this file.

/*  des.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>*/
/* */
/*  Tcllib wrapper for the DES package. This wrapper provides the same */
/*  programming API that tcllib uses for AES and Blowfish. We require a*/
/*  DES implementation and use either TclDES or TclDESjr to get DES */
/*  and/or 3DES*/
/* */
/*  -------------------------------------------------------------------------*/
/*  See the file "license.terms" for information on usage and redistribution*/
/*  of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/*  -------------------------------------------------------------------------*/

package require Tcl 8.2

if {[catch {package require tclDES 1.0.0}]} {
    package require tclDESjr 1.0.0
}

namespace DES {
    variable version 1.1.0
    variable rcsid {$Id: des.tcl,v 1.14 2007/08/20 19:58:54 andreas_kupries Exp $}
    variable uid ; if {![info exists uid]} {  uid =  0 }
}

ret  ::DES::Init (type mode , type key , type iv , optional weak =0) {
    variable uid
    set Key [namespace current]::[incr uid]
    upvar #0 $Key state
    if {[string length $key] % 8 != 0} {
        return -code error "invalid key length of\
             [expr {[string length $key] * 8}] bits:\
             DES requires 64 bit keys (56 bits plus parity bits)"
    }
    array set state [list M $mode I $iv K [des::keyset create $key $weak]]
    return $Key
}

ret  ::DES::Encrypt (type Key , type data) {
    upvar #0 $Key state
    set iv $state(I)
    set r [des::encrypt $state(K) $data $state(M) iv]
    set state(I) $iv
    return $r
}

ret  ::DES::Decrypt (type Key , type data) {
    upvar #0 $Key state
    set iv $state(I)
    set r [des::decrypt $state(K) $data $state(M) iv]
    set state(I) $iv
    return $r
}

ret  ::DES::Reset (type Key , type iv) {
    upvar #0 $Key state
    set state(I) $iv
    return
}

ret  ::DES::Final (type Key) {
    upvar #0 $Key state
    des::keyset destroy $state(K)
    # FRINK: nocheck
    unset $Key
}
/*  -------------------------------------------------------------------------*/

/*  Backwards compatability - here we re-implement the DES 0.8 procs using the*/
/*  current implementation.*/
/* */
/*  -- DO NOT USE THESE FUNCTIONS IN NEW CODE--*/
/* */
ret  ::DES::GetKey (type mode , type keydata , type keyvarname) {
    set weak 1
    switch -exact -- $mode {
        -encrypt    { set dir encrypt ; set vnc 0 }
        -encryptVNC { set dir encrypt ; set vnc 1 }
        -decrypt    { set dir decrypt ; set vnc 0 }
        -decryptVNC { set dir decrypt ; set vnc 1 }
        default {
            return -code error "invalid mode \"$mode\":\
                must be one of -encrypt, -decrypt, -encryptVNC or -decryptVNC"
        }
    }
    if {$vnc} { set keydata [ReverseBytes $keydata] }
    upvar $keyvarname Key
    set Key [Init ecb $keydata [string repeat \0 8] $weak]
    upvar $Key state
    array set state [list dir $dir]
    return
}

ret  ::DES::DesBlock (type data , type keyvarname) {
    upvar $keyvarname Key
    upvar #0 $Key state
    if {[string equal $state(dir) "encrypt"]} {
        set r [Encrypt $Key $data]
    } else {
        set r [Decrypt $Key $data]
    }
    return $r
}

ret  ::DES::ReverseBytes (type data) {
    binary scan $data b* bin
    return [binary format B* $bin]
}

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

ret  ::DES::SetOneOf (type lst , type item) {
    set ndx [lsearch -glob $lst "${item}*"]
    if {$ndx == -1} {
        set err [join $lst ", "]
        return -code error "invalid mode \"$item\": must be one of $err"
    }
    return [lindex $lst $ndx]
}

ret  ::DES::CheckSize (type what , type size , type thing) {
    if {[string length $thing] != $size} {
        return -code error "invalid value for $what: must be $size bytes long"
    }
    return $thing
}

ret  ::DES::Pad (type data , type blocksize , optional fill =\0) {
    set len [string length $data]
    if {$len == 0} {
        set data [string repeat $fill $blocksize]
    } elseif {($len % $blocksize) != 0} {
        set pad [expr {$blocksize - ($len % $blocksize)}]
        append data [string repeat $fill $pad]
    }
    return $data
}

ret  ::DES::Pop (type varname , optional nth =0) {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

ret  ::DES::Hex (type data) {
    binary scan $data H* r
    return $r 
}

ret  ::DES::des (type args) {
    array set opts {
        -dir encrypt -mode cbc -key {} -in {} -out {} -chunksize 4096 -hex 0 -weak 0 old 0
    }
    set blocksize 8
    set opts(-iv) [string repeat \0 $blocksize]
    set modes {ecb cbc cfb ofb}
    set dirs {encrypt decrypt}
    while {[string match -* [set option [lindex $args 0]]]} {
        switch -exact -- $option {
            -mode      { 
                set M [Pop args 1]
                if {[catch {set mode [SetOneOf $modes $M]} err]} {
                    if {[catch {SetOneOf {encode decode} $M}]} {
                        return -code error $err
                    } else {
                        # someone is using the old interface, therefore ecb
                        set mode ecb
                        set opts(-weak) 1
                        set opts(old) 1
                        set opts(-dir) [expr {[string match en* $M] ? "encrypt" : "decrypt"}]
                    }
                }
                set opts(-mode) $mode
            }
            -dir       { set opts(-dir) [SetOneOf $dirs [Pop args 1]] }
            -iv        { set opts(-iv) [Pop args 1] }
            -key       { set opts(-key) [Pop args 1] }
            -in        { set opts(-in) [Pop args 1] }
            -out       { set opts(-out) [Pop args 1] }
            -chunksize { set opts(-chunksize) [Pop args 1] }
            -hex       { set opts(-hex) 1 }
            -weak      { set opts(-weak) 1 }
            --         { Pop args ; break }
            default {
                set err [join [lsort [array names opts -*]] ", "]
                return -code error "bad option \"$option\":\
                    must be one of $err"
            }
        }
        Pop args
    }

    if {$opts(-key) == {}} {
        return -code error "no key provided: the -key option is required"
    }

    # pad the key if backwards compat required
    if {$opts(old)} {
        set pad [expr {8 - ([string length $opts(-key)] % 8)}]
        if {$pad != 8} {
            append opts(-key) [string repeat \0 $pad]
        }
    }

    set r {}
    if {$opts(-in) == {}} {

        if {[llength $args] != 1} {
            return -code error "wrong \# args:\
                should be \"des ?options...? -key keydata plaintext\""
        }

        set data [Pad [lindex $args 0] $blocksize]
        set Key [Init $opts(-mode) $opts(-key) $opts(-iv) $opts(-weak)]
        if {[string equal $opts(-dir) "encrypt"]} {
            set r [Encrypt $Key $data]
        } else {
            set r [Decrypt $Key $data]
        }

        if {$opts(-out) != {}} {
            puts -nonewline $opts(-out) $r
            set r {}
        }
        Final $Key

    } else {

        if {[llength $args] != 0} {
            return -code error "wrong \# args:\
                should be \"des ?options...? -key keydata -in channel\""
        }

        set Key [Init $opts(-mode) $opts(-key) $opts(-iv) $opts(-weak)]
        upvar $Key state
        set state(reading) 1
        if {[string equal $opts(-dir) "encrypt"]} {
            set state(cmd) Encrypt
        } else {
            set state(cmd) Decrypt
        }
        set state(output) ""
        fileevent $opts(-in) readable \
            [list [namespace origin Chunk] \
                 $Key $opts(-in) $opts(-out) $opts(-chunksize)]
        if {[info commands ::tkwait] != {}} {
            tkwait variable [subst $Key](reading)
        } else {
            vwait [subst $Key](reading)
        }
        if {$opts(-out) == {}} {
            set r $state(output)
        }
        Final $Key

    }

    if {$opts(-hex)} {
        set r [Hex $r]
    }
    return $r
}

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

package provide des $DES::version

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