//******************************************************************************
//MD5算法：实现
//******************************************************************************
//作者：Cai
//日期：2011-10-25
//修改：2011-11-15 添加 支持大头字节序编译开关，可供Lazarus使用
//******************************************************************************
//MD5算法源码
unit MD5Class;

interface
uses
  SysUtils,
  Classes;

type

INT4 = Integer;
UINT4 = Cardinal;
UINT2 = WORD;

PUINT4 = ^UINT4;
TBytes_4 = array[0..4-1] of Byte;
TBytes_16 = array[0..16-1]of Byte;
TBytes_32 = array[0..32-1]of Byte;
TBytes_64 = array[0..64-1]of Byte;

PBytes_64 = ^TBytes_64;

TUINT4s_2 = array[0..2-1]of UINT4;
TUINT4s_4 = array[0..4-1]of UINT4;
TUINT4s_16 = array[0..16-1]of UINT4;
TUINT4s = array of UINT4;

TMD5_CTX = record
State : TUINT4s_4; // /* state (ABCD) */
Count : TUINT4s_2; ///* number of bits, modulo 2^64 (lsb first) */
Buffer: TBytes_64; // /* input buffer */
end;
TMD5Context = TMD5_CTX;

TMD5Digest = TBytes_16;
PMD5Digest = ^TMD5Digest;

TMD5Class = Class
protected
//MD5核心算法
procedure MD5Transform(var States: TUINT4s_4; pBlock: PBytes_64);
procedure Encode(pOutBuf: PByte; iInBuf: PUINT4; iInBufNumOfBytes: UINT4);
procedure Decode(iOutBuf: PUINT4; pInBuf: PByte; iInBufNumOfBytes: UINT4);
//其他
procedure MD5_MemCpy(pDest, pSrc: Pointer; iLen: UINT4);
procedure MD5_MemSet(P: POINTER; iValue, iLen: UINT4);
public
constructor Create(); virtual;
destructor Destroy; override;
class function DigestToString(MD5Digest: TMD5Digest):String;
class function StringToDigest(sMD5Str: string): TMD5Digest;
//=========MD5算法：实现==============
procedure MD5Init(var Context: TMD5Context);
procedure MD5Update(var Context: TMD5Context; pInBuffer: PByte; iInBufLen: UINT4);
procedure MD5Final(var Digest: TMD5Digest; var Context: TMD5Context);
end;

implementation
//implementation of the CMd5A class.

function ArrUINT4s(pArrUINT4s: PUINT4; iIndex: UINT4): UINT4;overload;
begin
Inc(pArrUINT4s, iIndex);
Result := pArrUINT4s^;
end;

procedure ArrUINT4s(pArrUINT4s: PUINT4; iIndex: UINT4; iValue: UINT4);overload;
begin
Inc(pArrUINT4s, iIndex);
pArrUINT4s^ := iValue;
end;

//////////////////////////////////////////////////////////////////////
//////////////////////////////////////////////////////////////////////
// Construction/Destruction
//////////////////////////////////////////////////////////////////////

const
//Constants for MD5Transform routine
S11 = 7; S12 = 12; S13 = 17; S14 = 22;
S21 = 5; S22 = 9; S23 = 14; S24 = 20;
S31 = 4; S32 = 11; S33 = 16; S34 = 23;
S41 = 6; S42 = 10; S43 = 15; S44 = 21;

PADDING: array[0..64-1] of Byte = (
$80, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0);
// F, G, H and I are basic MD5 functions.
(***************************************
以一下是每次操作中用到的四个非线性函数（每轮一个）。
　　F(X,Y,Z) =(X&Y)|((~X)&Z)
　　G(X,Y,Z) =(X&Z)|(Y&(~Z))
　　H(X,Y,Z) =X^Y^Z
　　I(X,Y,Z)=Y^(X|(~Z))
****************************************)
function F(x, y, z: UINT4):UINT4;
begin
Result := (x and y) or ((not x) and z);
end;

function G(x, y, z: UINT4): UINT4;
begin
Result := (x and z) or (y and (not z));
end;

function H(x, y, z: UINT4): UINT4;
begin
Result := x xor y xor z;
end;

function I(x, y, z: UINT4): UINT4;
begin
Result := y xor (x or (not z));
end;

//rotates x left n bits.
function ROL_32(xParam, nBits:UINT4):UINT4;
begin
Result := (((xParam) shl (nBits)) or ((xParam) shr (32-(nBits))))
end;

(****************************************
FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4.
Rotation is separate from addition to prevent recomputation.
****************************************)
procedure FF(var a: UINT4; b, c, d, x, s, ac: UINT4);
begin
Inc(a, F(b, c, d) + x + ac);
a := ROL_32(a, s);
Inc(a, b);
end;

procedure GG(var a: UINT4; b, c, d, x, s, ac: UINT4);
begin
Inc(a, G(b, c, d) + x + ac);
a := ROL_32(a, s);
Inc(a, b);
end;

procedure HH(var a: UINT4; b, c, d, x, s, ac: UINT4);
begin
Inc(a, H(b, c, d) + x + ac);
a := ROL_32(a, s);
Inc(a, b);
end;

procedure II(var a: UINT4; b, c, d, x, s, ac: UINT4);
begin
Inc(a, I(b, c, d) + x + ac);
a := ROL_32(a, s);
Inc(a, b);
end;


const
SUPPORT_BIG_ENDIAN = FALSE; //编译开关 TRUE为 支持大头字节序 CPU 编译

{$IF SUPPORT_BIG_ENDIAN}
//是否小端字节序列
const
IsLittleEndian: Boolean = ByteBOOL($00000001);
(* Code: IsLittleEndian
function IsLittleEndian():Boolean;
var
dwValue: UINT4;
Bytes_4: TBytes_4;
begin
dwValue := $00000001;
Bytes_4 := TBytes_4(dwValue);
Result := (Bytes_4[0]=$01);
end; *)
(*
//ntohl, 大头字序转换
function BigEndianToHostEndian(const nValue: UINT4):UINT4;
begin
if IsLittleEndian then
begin
TBytes_4(Result)[0] := TBytes_4(nValue)[3];
TBytes_4(Result)[1] := TBytes_4(nValue)[2];
TBytes_4(Result)[2] := TBytes_4(nValue)[1];
TBytes_4(Result)[3] := TBytes_4(nValue)[0];
end
else
begin
Result := nValue;
end;
end; *)

//小头字节序转换
function LittleEndianToHostEndian(const nValue: UINT4):UINT4;
//这里使用函数的方式实现起来简单，但会降低MD5Transform的效率，
//实际应用中若对效率要求较高，可使用数组在进程初始化时就根据字节序填充即可
begin
if IsLittleEndian then
begin
Result := nValue;
end
else
begin
TBytes_4(Result)[0] := TBytes_4(nValue)[3];
TBytes_4(Result)[1] := TBytes_4(nValue)[2];
TBytes_4(Result)[2] := TBytes_4(nValue)[1];
TBytes_4(Result)[3] := TBytes_4(nValue)[0];
end;
end;
{$ELSE}
type
LittleEndianToHostEndian = UINT4;//不支持字节序时直接定义为类型强制转换即可
{$IFEND}

{ TMD5Class }

constructor TMD5Class.Create;
begin

end;

destructor TMD5Class.Destroy;
begin

inherited;
end;

//MD5 initialization. Begins an MD5 operation, writing a new context.
procedure TMD5Class.MD5Init(var Context: TMD5Context);
begin
FillChar(Context, SizeOf(TMD5Context), 0);
(*MD5中有四个32位被称作链接变量（Chaining Variable）的整数参数，他们分别为：
A=0x01234567，
B=0x89abcdef，
C=0xfedcba98，
D=0x76543210
// word A: 01 23 45 67
// word B: 89 ab cd ef
// word C: fe dc ba 98
// word D: 76 54 32 10 *)
//Load magic initialization constants.
//检查CPU字节序列模式
//if IsLittleEndian then
begin // Little endian 小头字节序列
Context.State[0] := LittleEndianToHostEndian($67452301);
Context.State[1] := LittleEndianToHostEndian($EFCDAB89);
Context.State[2] := LittleEndianToHostEndian($98BADCFE);
Context.State[3] := LittleEndianToHostEndian($10325476);
end
(*else
begin // Big endian 大头字节序列
Context.State[0] := $01234567;
Context.State[1] := $89ABCDEF;
Context.State[2] := $FEDCBA98;
Context.State[3] := $76543210;
end;*)
end;

(* MD5 block update operation. Continues an MD5 message-digest
operation, processing another message block, and updating the
context. MD5数据更新操作*)
procedure TMD5Class.MD5Update(var Context: TMD5Context; pInBuffer: PByte; iInBufLen: UINT4);
var
iIndex,
iPartLen,
I: UINT4;
begin
// Compute number of bytes mod 64
iIndex := UINT4((Context.Count[0] shr 3) and $3F); //(Context.Count[0] / 8) mod 64

// Update number of bits
Inc(Context.Count[0], UINT4(iInBufLen shl 3)); //iInBufLen * 8
if Context.Count[0]< UINT4(iInBufLen shl 3) then Inc(Context.Count[1]); //进位
Context.Count[1] := Context.Count[1] + iInBufLen shr (32 - 3); // iInBufLen + iInBufLen / 2^29
iPartLen := 64 - iIndex;

//Transform as many times as possible.
if (iInBufLen >= iPartLen) then
begin
MD5_Memcpy(@Context.Buffer[iIndex], pInBuffer, iPartLen);
MD5Transform(Context.State, @Context.Buffer);
I := iPartLen;
while (I+64<=iInBufLen) do
begin
MD5Transform(Context.State, PBytes_64(@PChar(pInBuffer)[I]));
Inc(I, 64);
end;
iIndex := 0;
end
else
I := 0;
// Buffer remaining input
Inc(pInBuffer, I);
MD5_Memcpy(@Context.Buffer[iIndex], pInBuffer, iInBufLen-I);
end;

(*
MD5 finalization. Ends an MD5 message-digest operation, writing the
the message digest and zeroizing the context.*)
procedure TMD5Class.MD5Final(var Digest: TBytes_16; var Context: TMD5Context);
var
Bits: array[0..8-1]of Byte;
iIndex, iPadLen: UINT4;
begin
//Save number of bits
Encode(@Bits, @Context.Count, 8);

//Pad out to 56 mod 64.
iIndex := UINT4((Context.Count[0] shr 3) and $3F);
if iIndex < 56 then
iPadLen := (56 - iIndex)
else
iPadLen := (120 - iIndex);
MD5Update(Context, @PADDING, iPadLen);
//Append length (before padding)
MD5Update(Context, @Bits, 8);
//Store state in digest
Encode(@Digest, @Context.State, 16);

//Zeroize sensitive information.
MD5_MemSet(@Context, 0, SizeOf(TMD5Context));
end;

// MD5 basic transformation. Transforms state based on block.
procedure TMD5Class.MD5Transform(var States: TUINT4s_4; pBlock: PBytes_64);
var
//I,
A, B, C, D: UINT4;
x: TUINT4s_16;
begin
//I := 0;
a := States[0];
b := States[1];
c := States[2];
d := States[3];
Decode(@x, PByte(pBlock), 64);
//Round 1
FF (a, b, c, d, x[ 0], S11, LittleEndianToHostEndian($d76aa478)); // 1 */
FF (d, a, b, c, x[ 1], S12, LittleEndianToHostEndian($e8c7b756)); // 2 */
FF (c, d, a, b, x[ 2], S13, LittleEndianToHostEndian($242070db)); // 3 */
FF (b, c, d, a, x[ 3], S14, LittleEndianToHostEndian($c1bdceee)); // 4 */
FF (a, b, c, d, x[ 4], S11, LittleEndianToHostEndian($f57c0faf)); // 5 */
FF (d, a, b, c, x[ 5], S12, LittleEndianToHostEndian($4787c62a)); // 6 */
FF (c, d, a, b, x[ 6], S13, LittleEndianToHostEndian($a8304613)); // 7 */
FF (b, c, d, a, x[ 7], S14, LittleEndianToHostEndian($fd469501)); // 8 */
FF (a, b, c, d, x[ 8], S11, LittleEndianToHostEndian($698098d8)); // 9 */
FF (d, a, b, c, x[ 9], S12, LittleEndianToHostEndian($8b44f7af)); // 10 */
FF (c, d, a, b, x[10], S13, LittleEndianToHostEndian($ffff5bb1)); // 11 */
FF (b, c, d, a, x[11], S14, LittleEndianToHostEndian($895cd7be)); // 12 */
FF (a, b, c, d, x[12], S11, LittleEndianToHostEndian($6b901122)); // 13 */
FF (d, a, b, c, x[13], S12, LittleEndianToHostEndian($fd987193)); // 14 */
FF (c, d, a, b, x[14], S13, LittleEndianToHostEndian($a679438e)); // 15 */
FF (b, c, d, a, x[15], S14, LittleEndianToHostEndian($49b40821)); // 16 */
// Round 2 */
GG (a, b, c, d, x[ 1], S21, LittleEndianToHostEndian($f61e2562)); // 17 */
GG (d, a, b, c, x[ 6], S22, LittleEndianToHostEndian($c040b340)); // 18 */
GG (c, d, a, b, x[11], S23, LittleEndianToHostEndian($265e5a51)); // 19 */
GG (b, c, d, a, x[ 0], S24, LittleEndianToHostEndian($e9b6c7aa)); // 20 */
GG (a, b, c, d, x[ 5], S21, LittleEndianToHostEndian($d62f105d)); // 21 */
GG (d, a, b, c, x[10], S22, LittleEndianToHostEndian($02441453)); // 22 */
GG (c, d, a, b, x[15], S23, LittleEndianToHostEndian($d8a1e681)); // 23 */
GG (b, c, d, a, x[ 4], S24, LittleEndianToHostEndian($e7d3fbc8)); // 24 */
GG (a, b, c, d, x[ 9], S21, LittleEndianToHostEndian($21e1cde6)); // 25 */
GG (d, a, b, c, x[14], S22, LittleEndianToHostEndian($c33707d6)); // 26 */
GG (c, d, a, b, x[ 3], S23, LittleEndianToHostEndian($f4d50d87)); // 27 */
GG (b, c, d, a, x[ 8], S24, LittleEndianToHostEndian($455a14ed)); // 28 */
GG (a, b, c, d, x[13], S21, LittleEndianToHostEndian($a9e3e905)); // 29 */
GG (d, a, b, c, x[ 2], S22, LittleEndianToHostEndian($fcefa3f8)); // 30 */
GG (c, d, a, b, x[ 7], S23, LittleEndianToHostEndian($676f02d9)); // 31 */
GG (b, c, d, a, x[12], S24, LittleEndianToHostEndian($8d2a4c8a)); // 32 */
// Round 3 */
HH (a, b, c, d, x[ 5], S31, LittleEndianToHostEndian($fffa3942)); // 33 */
HH (d, a, b, c, x[ 8], S32, LittleEndianToHostEndian($8771f681)); // 34 */
HH (c, d, a, b, x[11], S33, LittleEndianToHostEndian($6d9d6122)); // 35 */
HH (b, c, d, a, x[14], S34, LittleEndianToHostEndian($fde5380c)); // 36 */
HH (a, b, c, d, x[ 1], S31, LittleEndianToHostEndian($a4beea44)); // 37 */
HH (d, a, b, c, x[ 4], S32, LittleEndianToHostEndian($4bdecfa9)); // 38 */
HH (c, d, a, b, x[ 7], S33, LittleEndianToHostEndian($f6bb4b60)); // 39 */
HH (b, c, d, a, x[10], S34, LittleEndianToHostEndian($bebfbc70)); // 40 */
HH (a, b, c, d, x[13], S31, LittleEndianToHostEndian($289b7ec6)); // 41 */
HH (d, a, b, c, x[ 0], S32, LittleEndianToHostEndian($eaa127fa)); // 42 */
HH (c, d, a, b, x[ 3], S33, LittleEndianToHostEndian($d4ef3085)); // 43 */
HH (b, c, d, a, x[ 6], S34, LittleEndianToHostEndian($04881d05)); // 44 */
HH (a, b, c, d, x[ 9], S31, LittleEndianToHostEndian($d9d4d039)); // 45 */
HH (d, a, b, c, x[12], S32, LittleEndianToHostEndian($e6db99e5)); // 46 */
HH (c, d, a, b, x[15], S33, LittleEndianToHostEndian($1fa27cf8)); // 47 */
HH (b, c, d, a, x[ 2], S34, LittleEndianToHostEndian($c4ac5665)); // 48 */
// Round 4 */
II (a, b, c, d, x[ 0], S41, LittleEndianToHostEndian($f4292244)); // 49 */
II (d, a, b, c, x[ 7], S42, LittleEndianToHostEndian($432aff97)); // 50 */
II (c, d, a, b, x[14], S43, LittleEndianToHostEndian($ab9423a7)); // 51 */
II (b, c, d, a, x[ 5], S44, LittleEndianToHostEndian($fc93a039)); // 52 */
II (a, b, c, d, x[12], S41, LittleEndianToHostEndian($655b59c3)); // 53 */
II (d, a, b, c, x[ 3], S42, LittleEndianToHostEndian($8f0ccc92)); // 54 */
II (c, d, a, b, x[10], S43, LittleEndianToHostEndian($ffeff47d)); // 55 */
II (b, c, d, a, x[ 1], S44, LittleEndianToHostEndian($85845dd1)); // 56 */
II (a, b, c, d, x[ 8], S41, LittleEndianToHostEndian($6fa87e4f)); // 57 */
II (d, a, b, c, x[15], S42, LittleEndianToHostEndian($fe2ce6e0)); // 58 */
II (c, d, a, b, x[ 6], S43, LittleEndianToHostEndian($a3014314)); // 59 */
II (b, c, d, a, x[13], S44, LittleEndianToHostEndian($4e0811a1)); // 60 */
II (a, b, c, d, x[ 4], S41, LittleEndianToHostEndian($f7537e82)); // 61 */
II (d, a, b, c, x[11], S42, LittleEndianToHostEndian($bd3af235)); // 62 */
II (c, d, a, b, x[ 2], S43, LittleEndianToHostEndian($2ad7d2bb)); // 63 */
II (b, c, d, a, x[ 9], S44, LittleEndianToHostEndian($eb86d391)); // 64 */

Inc(States[0], a);
Inc(States[1], b);
Inc(States[2], c);
Inc(States[3], d);

//Zeroize sensitive information.*/
MD5_MemSet(@x, 0, SizeOf(x));
end;

(* Encodes input (UINT4) into output (unsigned char). Assumes len is
a multiple of 4. *)
procedure TMD5Class.Encode(pOutBuf: PByte; iInBuf: PUINT4; iInBufNumOfBytes: UINT4);
var
I, J: UINT4;
begin
I:=0; J:=0;
while J<=(iInBufNumOfBytes-1) do
begin
Byte(PChar(pOutBuf)[j]) := Byte((ArrUINT4s(iInBuf, i) ) and $ff);
Byte(PChar(pOutBuf)[j+1]) := Byte((ArrUINT4s(iInBuf, i) shr 8) and $ff);
Byte(PChar(pOutBuf)[j+2]) := Byte((ArrUINT4s(iInBuf, i) shr 16) and $ff);
Byte(PChar(pOutBuf)[j+3]) := Byte((ArrUINT4s(iInBuf, i) shr 24) and $ff);
Inc(I);
Inc(J, 4);
end;
end;

(* Decodes input (unsigned char) into output (UINT4). Assumes len is
a multiple of 4.*)
procedure TMD5Class.Decode(iOutBuf: PUINT4; pInBuf: PByte; iInBufNumOfBytes: UINT4);
var
I, J: UINT4;
begin
I:=0; J:=0;
while J<=(iInBufNumOfBytes-1) do
begin
try
ArrUINT4s(iOutBuf, I, (UINT4(PChar(pInBuf)[J]) ) or
(UINT4(PChar(pInBuf)[J+1]) shl 8) or
(UINT4(PChar(pInBuf)[J+2]) shl 16) or
(UINT4(PChar(pInBuf)[J+3]) shl 24));
except
Break;
end;
Inc(I);
Inc(J, 4);
end;
end;

// Note: Replace "for loop" with standard memcpy if possible. */
procedure TMD5Class.MD5_MemCpy (pDest, pSrc: Pointer; iLen: UINT4);
var
I: UINT4;
begin
if iLen>0 then
for I := 0 to iLen-1 do
PChar(pDest)[I] := PChar(pSrc)[I];
end;

// Note: Replace "for loop" with standard memset if possible. */
procedure TMD5Class.MD5_MemSet(P: POINTER; iValue, iLen: UINT4);
var
I: UINT4;
begin
for I := 0 to iLen-1 do
PChar(P)[I] := Char(iValue);
end;

class function TMD5Class.DigestToString(MD5Digest: TMD5Digest):string;
var
pBuf: PChar;
begin
pBuf := AllocMem(64);
try
BinToHex(@MD5Digest, pBuf, SizeOf(TMD5Digest));
Result := string(pBuf);
finally
FreeMem(pBuf);
end;
end;

class function TMD5Class.StringToDigest(sMD5Str: string): TMD5Digest;
var
pBuf: PChar;
begin
pBuf := AllocMem(64);
try
HexToBin(PChar(sMD5Str), pBuf, 64);
Result := PMD5Digest(pBuf)^;
finally
FreeMem(pBuf);
end;
end;

end.