md5crypt.tcl

Go to the documentation of this file.

/*  md5crypt.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>*/
/* */
/*  This file provides a pure tcl implementation of the BSD MD5 crypt algorithm.*/
/*  The implementation is based upon the OpenBSD code which is in turn based upon*/
/*  the original code by Poul-Henning Kamp. */
/* */
/*  -------------------------------------------------------------------------*/
/*  See the file "license.terms" for information on usage and redistribution*/
/*  of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/*  -------------------------------------------------------------------------*/

/*  @mdgen EXCLUDE: md5cryptc.tcl*/

package require Tcl 8.2;                /*  tcl minimum version*/
package require md5 2;                  /*  tcllib 1.5*/

/*  Try and load a compiled extension to help.*/
if {[catch {package require tcllibc}]} {
    catch {package require md5cryptc}
}

namespace md5crypt {
    variable version 1.0.0
    variable rcsid {$Id: md5crypt.tcl,v 1.4 2005/12/09 18:27:17 andreas_kupries Exp $}
    variable itoa64 \
        {./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz}

    namespace import -force ::md5::MD5Init ::md5::MD5Update ::md5::MD5Final
    namespace export md5crypt
}

ret  ::md5crypt::to64_tcl (type v , type n) {
    variable itoa64
    for {} {$n > 0} {incr n -1} {
        set i [expr {$v & 0x3f}]
        append s [string index $itoa64 $i]
        set v [expr {($v >> 6) & 0x3FFFFFFF}]
    }
    return $s
}

ret  ::md5crypt::md5crypt_tcl (type magic , type pw , type salt) {
    set sp 0

    set start 0
    if {[string match "${magic}*" $salt]} {
        set start [string length $magic]
    }
    set end [string first $ $salt $start]
    if {$end < 0} {set end [string length $salt]} else {incr end -1}
    if {$end - $start > 7} {set end [expr {$start + 7}]}
    set salt [string range $salt $start $end]

    set ctx [MD5Init]
    MD5Update $ctx $pw
    MD5Update $ctx $magic
    MD5Update $ctx $salt

    set ctx2 [MD5Init]
    MD5Update $ctx2 $pw
    MD5Update $ctx2 $salt
    MD5Update $ctx2 $pw
    set H2 [MD5Final $ctx2]

    for {set pl [string length $pw]} {$pl > 0} {incr pl -16} {
        set tl [expr {($pl > 16 ? 16 : $pl) - 1}]
        MD5Update $ctx [string range $H2 0 $tl]
    }
    
    for {set i [string length $pw]} {$i != 0} {set i [expr {$i >> 1}]} {
        if {$i & 1} {
            set c \0
        } else {
            set c [string index $pw 0]
        }
        MD5Update $ctx $c
    }
    
    set result "${magic}${salt}\$"
    
    set H [MD5Final $ctx]

    for {set i 0} {$i < 1000} {incr i} {
        set ctx [MD5Init]
        if {$i & 1} {
            MD5Update $ctx $pw
        } else {
            MD5Update $ctx $H
        }
        if {$i % 3} {
            MD5Update $ctx $salt
        }
        if {$i % 7} {
            MD5Update $ctx $pw
        }
        if {$i & 1} {
            MD5Update $ctx $H
        } else {
            MD5Update $ctx $pw
        }
        set H [MD5Final $ctx]
    }

    binary scan $H c* Vs
    foreach v $Vs {lappend V [expr {$v & 0xFF}]}
    set l [expr {([lindex $V 0] << 16) | ([lindex $V  6] << 8) | [lindex $V 12]}]
    append result [to64 $l 4]
    set l [expr {([lindex $V 1] << 16) | ([lindex $V  7] << 8) | [lindex $V 13]}]
    append result [to64 $l 4]
    set l [expr {([lindex $V 2] << 16) | ([lindex $V  8] << 8) | [lindex $V 14]}]
    append result [to64 $l 4]
    set l [expr {([lindex $V 3] << 16) | ([lindex $V  9] << 8) | [lindex $V 15]}]
    append result [to64 $l 4]
    set l [expr {([lindex $V 4] << 16) | ([lindex $V 10] << 8) | [lindex $V  5]}]
    append result [to64 $l 4]
    set l [expr {[lindex $V 11]}]
    append result [to64 $l 2]
    
    return $result
}

if {[info command ::md5crypt::to64_c] == {}} {
    interp alias {} ::md5crypt::to64 {} ::md5crypt::to64_tcl
} else {
    interp alias {} ::md5crypt::to64 {} ::md5crypt::to64_c
}

if {[info command ::md5crypt::md5crypt_c] == {}} {
    interp alias {} ::md5crypt::md5crypt {} ::md5crypt::md5crypt_tcl {$1$}
    interp alias {} ::md5crypt::aprcrypt {} ::md5crypt::md5crypt_tcl {$apr1$}
} else {
    interp alias {} ::md5crypt::md5crypt {} ::md5crypt::md5crypt_c {$1$}
    interp alias {} ::md5crypt::aprcrypt {} ::md5crypt::md5crypt_c {$apr1$}
}

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

package provide md5crypt $::md5crypt::version

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