Algoritmo Md5

unit mymd5unt;

interface
function MyMD5(const InputString: UTF8String): UTF8String;
function MD5Crypt(const Password: UnicodeString): UnicodeString; overload;
function MD5Crypt(const Password: UnicodeString; Salt: UTF8String): UnicodeString; overload;

implementation

uses
  SysUtils, ComObj, ActiveX, IdGlobal, IdHash, IdHashMessageDigest, IdCoderMIME;

const
  L = UnicodeString('');
  // to make strings Unicode
  // in C++: L"abcd"
  // in Delphi: L+'abcd'
  // otherwise 'nonunicode literal' + UnicodeFunction(Arg1, Arg2) becomes
  // converted to screwed ANSI

function RandomString: UnicodeString;
var
  GUID: TGUID;
begin
  OleCheck(CreateGUID(GUID));
  Result := Copy(GUIDToString(GUID), 2, 36);
end;

const
  MD5CryptAlphabet : UnicodeString =
    UnicodeString('./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz');

function MyMD5(const InputString: UTF8String): UTF8String;
var
  Input, Output: TIdBytes;
  X_Hash_Alg: TIdHash;
begin
  SetLength(Input, Length(InputString));
  Move(InputString[1], Input[0], Length(InputString));
  X_Hash_Alg := nil;
  try
    X_Hash_Alg := TIdHashMessageDigest5.Create;
    Output := X_Hash_Alg.HashBytes(Input);
    SetString(Result, PAnsiChar(@Output[0]), Length(Output));
  finally
    FreeAndNil(X_Hash_Alg);
  end;
end;

function MD5Crypt(const Password: UnicodeString): UnicodeString; overload;
var
  Salt: UTF8String;
  PasswordUTF8: UTF8String;
  Len: Integer;
  I: Integer;
  FinalString: UTF8String;
  Final: TIdBytes;
  CTXString: UTF8String;
  CTX1String: UTF8String;
  procedure To64(Value, Len: Integer);
  var
    J: Integer;
  begin
    for J := 1 to Len do
    begin
      Result := Result + MD5CryptAlphabet[Value and $3f + 1];
      Value := Value shr 6;
    end;
  end;
begin
  Salt := Copy(UTF8Encode(RandomString), 1, 8);
  //Salt := 'GzQ4OT9U';
  PasswordUTF8 := UTF8Encode(Password);

  CTXString := PasswordUTF8 + UTF8String('$1$') + Salt;

  FinalString := MyMD5(PasswordUTF8 + Salt + PasswordUTF8);

  // Add as many characters of Final to CTX
  Len := Length(PasswordUTF8);
  while Len > 0 do
  begin
    if Len >= Length(FinalString) then
    begin
      CTXString := CTXString + FinalString;
      Dec(Len, Length(FinalString));
    end
    else
    begin
      CTXString := CTXString + Copy(FinalString, 1, Len);
      Len := 0;
    end;
  end;

  // Then something really weird...
  I := Length(PasswordUTF8);
  while I > 0 do
  begin
    if I and 1 = 1 then
    begin
      CTXString := CTXString + UTF8String(#0);
    end
    else
    begin
      CTXString := CTXString + PasswordUTF8[1];
    end;
    I := I shr 1;
  end;

  FinalString := MyMD5(CTXString);

  // Do additional mutations
  for I := 0 to 999 do
  begin
    CTX1String := '';
    if I and 1 > 0 then
    begin
      CTX1String := CTX1String + PasswordUTF8;
    end
    else
    begin
      CTX1String := CTX1String + FinalString;
    end;

    if I mod 3 > 0 then
    begin
      CTX1String := CTX1String + Salt;
    end;

    if I mod 7 > 0 then
    begin
      CTX1String := CTX1String + PasswordUTF8;
    end;

    if I and 1 > 0 then
    begin
      CTX1String := CTX1String + FinalString;
    end
    else
    begin
      CTX1String := CTX1String + PasswordUTF8;
    end;

    FinalString := MyMD5(CTX1String);
  end;

  Result := L+'$1$' + UTF8ToUnicodeString(Salt) + '$';

  SetLength(Final, Length(FinalString));
  Move(FinalString[1], Final[0], Length(FinalString));
  To64(((Integer(Final[ 0]) and $FF) shl 16) or ((Integer(Final[ 6]) and $FF) shl 8) or (Integer(Final[12]) and $FF), 4);
  To64(((Integer(Final[ 1]) and $FF) shl 16) or ((Integer(Final[ 7]) and $FF) shl 8) or (Integer(Final[13]) and $FF), 4);
  To64(((Integer(Final[ 2]) and $FF) shl 16) or ((Integer(Final[ 8]) and $FF) shl 8) or (Integer(Final[14]) and $FF), 4);
  To64(((Integer(Final[ 3]) and $FF) shl 16) or ((Integer(Final[ 9]) and $FF) shl 8) or (Integer(Final[15]) and $FF), 4);
  To64(((Integer(Final[ 4]) and $FF) shl 16) or ((Integer(Final[10]) and $FF) shl 8) or (Integer(Final[ 5]) and $FF), 4);
  To64(                                           Integer(Final[11]) and $FF                                        , 2);
end;

function MD5Crypt(const Password: UnicodeString; Salt: UTF8String): UnicodeString; overload;
var
  PasswordUTF8: UTF8String;
  Len: Integer;
  I: Integer;
  FinalString: UTF8String;
  Final: TIdBytes;
  CTXString: UTF8String;
  CTX1String: UTF8String;
  procedure To64(Value, Len: Integer);
  var
    J: Integer;
  begin
    for J := 1 to Len do
    begin
      Result := Result + MD5CryptAlphabet[Value and $3f + 1];
      Value := Value shr 6;
    end;
  end;
begin
  PasswordUTF8 := UTF8Encode(Password);

  CTXString := PasswordUTF8 + UTF8String('$1$') + Salt;

  FinalString := MyMD5(PasswordUTF8 + Salt + PasswordUTF8);

  // Add as many characters of Final to CTX
  Len := Length(PasswordUTF8);
  while Len > 0 do
  begin
    if Len >= Length(FinalString) then
    begin
      CTXString := CTXString + FinalString;
      Dec(Len, Length(FinalString));
    end
    else
    begin
      CTXString := CTXString + Copy(FinalString, 1, Len);
      Len := 0;
    end;
  end;

  // Then something really weird...
  I := Length(PasswordUTF8);
  while I > 0 do
  begin
    if I and 1 = 1 then
    begin
      CTXString := CTXString + UTF8String(#0);
    end
    else
    begin
      CTXString := CTXString + PasswordUTF8[1];
    end;
    I := I shr 1;
  end;

  FinalString := MyMD5(CTXString);

  // Do additional mutations
  for I := 0 to 999 do
  begin
    CTX1String := '';
    if I and 1 > 0 then
    begin
      CTX1String := CTX1String + PasswordUTF8;
    end
    else
    begin
      CTX1String := CTX1String + FinalString;
    end;

    if I mod 3 > 0 then
    begin
      CTX1String := CTX1String + Salt;
    end;

    if I mod 7 > 0 then
    begin
      CTX1String := CTX1String + PasswordUTF8;
    end;

    if I and 1 > 0 then
    begin
      CTX1String := CTX1String + FinalString;
    end
    else
    begin
      CTX1String := CTX1String + PasswordUTF8;
    end;

    FinalString := MyMD5(CTX1String);
  end;

  Result := L+'$1$' + UTF8ToUnicodeString(Salt) + '$';

  SetLength(Final, Length(FinalString));
  Move(FinalString[1], Final[0], Length(FinalString));
  To64(((Integer(Final[ 0]) and $FF) shl 16) or ((Integer(Final[ 6]) and $FF) shl 8) or (Integer(Final[12]) and $FF), 4);
  To64(((Integer(Final[ 1]) and $FF) shl 16) or ((Integer(Final[ 7]) and $FF) shl 8) or (Integer(Final[13]) and $FF), 4);
  To64(((Integer(Final[ 2]) and $FF) shl 16) or ((Integer(Final[ 8]) and $FF) shl 8) or (Integer(Final[14]) and $FF), 4);
  To64(((Integer(Final[ 3]) and $FF) shl 16) or ((Integer(Final[ 9]) and $FF) shl 8) or (Integer(Final[15]) and $FF), 4);
  To64(((Integer(Final[ 4]) and $FF) shl 16) or ((Integer(Final[10]) and $FF) shl 8) or (Integer(Final[ 5]) and $FF), 4);
  To64(                                           Integer(Final[11]) and $FF                                        , 2);
end;


end.