# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package md5crypt 1.0.0
# Meta as::origin  http://sf.net/projects/tcllib
# Meta category    MD5-based password encryption
# Meta description MD5-based password encryption
# Meta license     BSD
# Meta platform    tcl
# Meta recommend   md5cryptc
# Meta recommend   tcllibc
# Meta require     {Tcl 8.2}
# Meta require     {md5 2}
# Meta subject     security md5crypt message-digest hashing md5
# Meta summary     md5crypt
# @@ Meta End




# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.2
package require md5 2

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide md5crypt 1.0.0

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# 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 eval 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
}

proc ::md5crypt::to64_tcl {v 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
}

proc ::md5crypt::md5crypt_tcl {magic pw 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: