#!/usr/bin/perl
use strict;
use warnings;
use Digest::MD5 qw(md5);


sub mycrypt {
    my ($plain, $salt) = @_;

    $salt =~ m#^\$1\$([^\$]*)#
        or return crypt($plain, $salt);
    $salt = $1;

    # chr() und ord() etc. sollen utf8 ignorieren
    use bytes;

    # Zunaechst eine MD5-Summe aus $plain und $salt und noch einmal $plain
    # bauen:
    my $res = md5($plain . $salt . $plain);

    # Fuer jedes Zeichen aus $plain kommt ein Zeichen aus der berechneten
    # MD5-Summe:
    my $resmult = $res x (length($plain) / 16 + 1);
    chop $resmult while length($resmult) > length($plain);

    # Nun bauen wir eine neue MD5-Summe mit komischen Berechnungen aus den
    # bisherigen Ergebnissen.
    my $str1 = $plain . '$1$' . $salt . $resmult;
    for (my $i=length($plain); $i > 0; $i >>= 1) {
        # Der Kommentar in der glibc sagt, dass dies vermutlich nicht genau so
        # simpel beabsichtigt war, aber in der urspruenglichen Implementation
        # effektiv so herauskam.
        $str1 .= $i % 2 ? chr(0) : chr ord $plain;
    }
    $res = md5($str1);

    # Damit das alles auch recht lange dauert (und nicht so schnell zu knacken
    # ist), bauen wir in einer Schleife andauernd neue MD5-Summen aus der
    # jeweils vorherigen Summe sowie $plain und $salt
    for my $j (0..999) {
        my $str2 = '';

        $str2 .= $j % 2 ? $plain : $res;
        $str2 .= $salt  if $j % 3;
        $str2 .= $plain if $j % 7;
        $str2 .= $j % 2 ? $res : $plain;

        $res = md5($str2);
    }

    # Nun ist das Ergebnis schon berechnet, es muessen die Bytes nur noch in
    # seltsamer Reihenfolge mit Base64 kodiert werden.

    my $binbuf = '';
    my @order = (0, 6, 12,
                 1, 7, 13,
                 2, 8, 14,
                 3, 9, 15,
                 4, 10,
                 5, undef, 11);
    for my $idx (@order) {
        $binbuf .= defined ($idx) ? sprintf('%08b', ord substr($res, $idx, 1)) : '0000';
    }
    my $txtbuf = '';
    my @b64t = ('.', '/', 0..9, 'A'..'Z', 'a'..'z');
    while ($binbuf =~ m/(.{24}|.{12})/g) {
        $txtbuf .= $b64t[oct "0b$_"] for reverse $1 =~ /.{6}/g;
    }

    return join '$', '', 1, $salt, $txtbuf;
}


# Geht ueberall
print my $x = mycrypt('hallo welt', '$1$salt'), "\n";

# Geht nur unter Linux
print crypt('hallo welt', '$1$salt'), "\n";

# Und das Passwort ueberpruefen:
if (mycrypt('hallo welt', $x) eq $x) {
    print "Passwort richtig!\n";
}