| /trunk/Units/BitOps.pas |
|---|
| 0,0 → 1,691 |
| unit BitOps; |
| (************************************************************* |
| BitOps.pas |
| Bit- Byte- and Nibbleoperations |
| 64 Bit Edition; Rev 21 March 2010 |
| (C) 2010 ViaThinkSoft [www.viathinksoft.com] |
| Developed by Daniel Marschall [www.daniel-marschall.de] |
| *************************************************************) |
| interface |
| uses |
| SysUtils; |
| // * TYPES * |
| type |
| Nibble = 0..127; |
| THexNibble = $0..$F; |
| T4BitPos = 0..3; |
| T8BitPos = 0..7; |
| T16BitPos = 0..15; |
| T32BitPos = 0..31; |
| T64BitPos = 0..63; |
| // Maximum amount of bytes in the biggest data type (int64) |
| TBytePos = 0..7; |
| // Maximum amount of nibbles in the biggest data type (int64) |
| THexNibblePos = 0..15; |
| TBit = Boolean; |
| THexNibbleBitArray = array[Low(T4BitPos)..High(T4BitPos)] of TBit; |
| TByteBitArray = array[Low(T8BitPos)..High(T8BitPos)] of TBit; |
| TBitString = type string; |
| TByteBitString = type TBitString; |
| THexNibbleBitString = type TBitString; |
| // ****************** |
| // * BYTE FUNCTIONS * |
| // ****************** |
| // Build a byte. |
| // Either you combine two nibbles... |
| function BuildByte(AUpperNibble, ALowerNibble: THexNibble): Byte; overload; |
| // ...or you define an array of 8 bits. |
| function BuildByte(ABitArray: TByteBitArray): Byte; overload; |
| // ...or you define a bitstring (e.g. '00011100') |
| function BuildByte(ABits: TByteBitString): Byte; overload; |
| // ...or you define the bits as parameters |
| function BuildByte(ABit1, ABit2, ABit3, ABit4, ABit5, ABit6, ABit7, |
| ABit8: TBit): Byte; overload; |
| // Converts a byte into a array of 8 bits |
| function GetByteBitArray(AByte: Byte): TByteBitArray; |
| // Getting and setting the lower nibble of a byte. |
| function GetLowerNibble(AByte: Byte): THexNibble; |
| function SetLowerNibble(AByte: Byte; ANewNibble: THexNibble): Byte; |
| // Getting and setting the upper nibble of a byte. |
| function GetUpperNibble(AByte: Byte): THexNibble; |
| function SetUpperNibble(AByte: Byte; ANewNibble: THexNibble): Byte; |
| // Interchanges upper and lower Nibble in a byte |
| function InterchangeNibbles(AByte: Byte): Byte; |
| // Creates an 8-bit-array from a 8-bit-string |
| // Throws EBitStringTooLong and EBitStringInvalidCharacter |
| function ByteBitArrayFromBitString(const ABits: TByteBitString): |
| TByteBitArray; |
| // Getting and setting of a bit in a byte |
| function GetByteBit(AByte: Byte; ABitPos: T8BitPos): TBit; |
| function SetByteBit(AByte: Byte; ABitPos: T8BitPos; ANewBit: TBit): Byte; |
| // Logical operations for the 8 bit arrays. |
| function ByteBitArrayShr(ABitArray: TByteBitArray; |
| AVal: Longword): TByteBitArray; |
| function ByteBitArrayShl(ABitArray: TByteBitArray; |
| AVal: Longword): TByteBitArray; |
| function ByteBitArrayAnd(ABitArray, ABitArray2: TByteBitArray): TByteBitArray; |
| function ByteBitArrayOr(ABitArray, ABitArray2: TByteBitArray): TByteBitArray; |
| function ByteBitArrayXor(ABitArray, ABitArray2: TByteBitArray): TByteBitArray; |
| function ByteBitArrayNot(ABitArray: TByteBitArray): TByteBitArray; |
| // Inverse the bits of a byte |
| function InverseByteBits(x: Byte): Byte; |
| // Reverses the bit sequence of a byte |
| function ReverseByteBitSequence(AByte: Byte): Byte; |
| // ******************** |
| // * NIBBLE FUNCTIONS * |
| // ******************** |
| // Build a Nibble. |
| // You can define an array of 4 bits. |
| function BuildNibble(ABitArray: THexNibbleBitArray): Nibble; overload; |
| // ...or you define a bitstring (e.g. '0001') |
| function BuildNibble(ABits: THexNibbleBitString): Nibble; overload; |
| // ...or you define the bits as parameters |
| function BuildNibble(ABit1, ABit2, ABit3, ABit4: TBit): Nibble; overload; |
| // Converts a nibble into a array of 4 bits |
| function GetNibbleBitArray(ANibble: Nibble): THexNibbleBitArray; |
| // Creates an 4-bit-array from a 4-bit-string |
| // Throws EBitStringTooLong and EBitStringInvalidCharacter |
| function NibbleBitArrayFromBitString(const ABits: THexNibbleBitString): |
| THexNibbleBitArray; |
| // Getting and setting of a bit in a nibble |
| function GetNibbleBit(ANibble: Nibble; ABitPos: T4BitPos): TBit; |
| function SetNibbleBit(ANibble: Nibble; ABitPos: T4BitPos; |
| ANewBit: TBit): Nibble; |
| // Logical operations for the 4 bit arrays. |
| function NibbleBitArrayShr(ABitArray: THexNibbleBitArray; AVal: Longword): |
| THexNibbleBitArray; |
| function NibbleBitArrayShl(ABitArray: THexNibbleBitArray; AVal: Longword): |
| THexNibbleBitArray; |
| function NibbleBitArrayAnd(ABitArray, ABitArray2: THexNibbleBitArray): |
| THexNibbleBitArray; |
| function NibbleBitArrayOr(ABitArray, ABitArray2: THexNibbleBitArray): |
| THexNibbleBitArray; |
| function NibbleBitArrayXor(ABitArray, ABitArray2: THexNibbleBitArray): |
| THexNibbleBitArray; |
| function NibbleBitArrayNot(ABitArray: THexNibbleBitArray): THexNibbleBitArray; |
| // Inverse the bits of a nibble |
| function InverseNibbleBits(x: Nibble): Nibble; |
| // Reverses the bit sequence of a nibble |
| function ReverseNibbleBitSequence(ANibble: Nibble): Nibble; |
| // * EXCEPTIONS * |
| type |
| EInvalidBitString = class(Exception); |
| EBitStringTooLong = class(EInvalidBitString); |
| EBitStringInvalidCharacter = class(EInvalidBitString); |
| // * CONSTANTS * |
| // Lookup tables to avoid calculation each time |
| const |
| AllSetBitsBytes: array[TBytePos] of int64 = |
| ($00000000000000FF, |
| $000000000000FFFF, |
| $0000000000FFFFFF, |
| $00000000FFFFFFFF, |
| $000000FFFFFFFFFF, |
| $0000FFFFFFFFFFFF, |
| $00FFFFFFFFFFFFFF, |
| $FFFFFFFFFFFFFFFF); |
| AllSetBitsNibbles: array[THexNibblePos] of int64 = |
| ($000000000000000F, |
| $00000000000000FF, |
| $0000000000000FFF, |
| $000000000000FFFF, |
| $00000000000FFFFF, |
| $0000000000FFFFFF, |
| $000000000FFFFFFF, |
| $00000000FFFFFFFF, |
| $0000000FFFFFFFFF, |
| $000000FFFFFFFFFF, |
| $00000FFFFFFFFFFF, |
| $0000FFFFFFFFFFFF, |
| $000FFFFFFFFFFFFF, |
| $00FFFFFFFFFFFFFF, |
| $0FFFFFFFFFFFFFFF, |
| $FFFFFFFFFFFFFFFF); |
| AllSetBitsNibble: array[THexNibblePos] of int64 = |
| ($000000000000000F, |
| $00000000000000F0, |
| $0000000000000F00, |
| $000000000000F000, |
| $00000000000F0000, |
| $0000000000F00000, |
| $000000000F000000, |
| $00000000F0000000, |
| $0000000F00000000, |
| $000000F000000000, |
| $00000F0000000000, |
| $0000F00000000000, |
| $000F000000000000, |
| $00F0000000000000, |
| $0F00000000000000, |
| $F000000000000000); |
| // Deprecated function: |
| // function GetSingleBit(ABit: T64BitPos): Int64; |
| // |
| // Gives you a 64 bit datatype which is representing the binary coding |
| // |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000001, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000010, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000100, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00001000, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00010000, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 00100000, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 01000000, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 10000000, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000001 00000000, |
| // ... |
| // 10000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000. |
| // |
| // Limitation because of the data type: 64 Bit |
| // |
| // For the GetByteBit() and SetByteBit functions we only need this array to |
| // be max at $80 (128). |
| // Manual calculation (not 64 bit useable) would be |
| // result := Math.Floor(Math.Power(2, ABit)); |
| SingleBitArray: array[T64BitPos] of int64 = |
| ($0000000000000001, $0000000000000002, $0000000000000004, $0000000000000008, |
| $0000000000000010, $0000000000000020, $0000000000000040, $0000000000000080, |
| $0000000000000100, $0000000000000200, $0000000000000400, $0000000000000800, |
| $0000000000001000, $0000000000002000, $0000000000004000, $0000000000008000, |
| $0000000000010000, $0000000000020000, $0000000000040000, $0000000000080000, |
| $0000000000100000, $0000000000200000, $0000000000400000, $0000000000800000, |
| $0000000001000000, $0000000002000000, $0000000004000000, $0000000008000000, |
| $0000000010000000, $0000000020000000, $0000000040000000, $0000000080000000, |
| $0000000100000000, $0000000200000000, $0000000400000000, $0000000800000000, |
| $0000001000000000, $0000002000000000, $0000004000000000, $0000008000000000, |
| $0000010000000000, $0000020000000000, $0000040000000000, $0000080000000000, |
| $0000100000000000, $0000200000000000, $0000400000000000, $0000800000000000, |
| $0001000000000000, $0002000000000000, $0004000000000000, $0008000000000000, |
| $0010000000000000, $0020000000000000, $0040000000000000, $0080000000000000, |
| $0100000000000000, $0200000000000000, $0400000000000000, $0800000000000000, |
| $1000000000000000, $2000000000000000, $4000000000000000, $8000000000000000); |
| // Deprecated function: |
| // function GetSingleBitDynamicInversed(ABit: T64BitPos): Int64; |
| // |
| // Gives you a 64 bit datatype which is representing the dynamic inversed |
| // binary encoding. (Dynamic inversed means, that only the used bytes get |
| // inverted, so this is NOT the same as "NOT GetSingleBit(ABit)"!) |
| // |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 11111110, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 11111101, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 11111011, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 11110111, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 11101111, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 11011111, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 10111111, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 00000000 01111111, |
| // 00000000 00000000 00000000 00000000 00000000 00000000 11111110 11111111, |
| // ... |
| // 01111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111. |
| // |
| // Limitation because of the data type: 64 Bit |
| // |
| // Manual calculation (not 64 bit useable) would be |
| // result := MathFloor( |
| // Math.Power(256, Math.Floor(ABit / 8)+1)-1 {***} - |
| // Math.Power(2, ABit)); |
| // |
| // *** is the maximal value of the byte amount we were requesting. |
| // Example: |
| // If ABit in [ 0.. 7] => 1 Byte used => (256^1-1) = $FF |
| // If ABit in [ 8..15] => 2 Bytes used => (256^2-1) = $FF FF |
| // If ABit in [16..23] => 3 Bytes used => (256^3-1) = $FF FF FF |
| // If ABit in [24..31] => 4 Bytes used => (256^3-1) = $FF FF FF FF |
| // ... |
| SingleBitArrayDynamicInversed: array[T64BitPos] of int64 = |
| ($00000000000000FE, $00000000000000FD, $00000000000000FB, $00000000000000F7, |
| $00000000000000EF, $00000000000000DF, $00000000000000BF, $000000000000007F, |
| $000000000000FEFF, $000000000000FDFF, $000000000000FBFF, $000000000000F7FF, |
| $000000000000EFFF, $000000000000DFFF, $000000000000BFFF, $0000000000007FFF, |
| $0000000000FEFFFF, $0000000000FDFFFF, $0000000000FBFFFF, $0000000000F7FFFF, |
| $0000000000EFFFFF, $0000000000DFFFFF, $0000000000BFFFFF, $00000000007FFFFF, |
| $00000000FEFFFFFF, $00000000FDFFFFFF, $00000000FBFFFFFF, $00000000F7FFFFFF, |
| $00000000EFFFFFFF, $00000000DFFFFFFF, $00000000BFFFFFFF, $000000007FFFFFFF, |
| $000000FEFFFFFFFF, $000000FDFFFFFFFF, $000000FBFFFFFFFF, $000000F7FFFFFFFF, |
| $000000EFFFFFFFFF, $000000DFFFFFFFFF, $000000BFFFFFFFFF, $0000007FFFFFFFFF, |
| $0000FEFFFFFFFFFF, $0000FDFFFFFFFFFF, $0000FBFFFFFFFFFF, $0000F7FFFFFFFFFF, |
| $0000EFFFFFFFFFFF, $0000DFFFFFFFFFFF, $0000BFFFFFFFFFFF, $00007FFFFFFFFFFF, |
| $00FEFFFFFFFFFFFF, $00FDFFFFFFFFFFFF, $00FBFFFFFFFFFFFF, $00F7FFFFFFFFFFFF, |
| $00EFFFFFFFFFFFFF, $00DFFFFFFFFFFFFF, $00BFFFFFFFFFFFFF, $007FFFFFFFFFFFFF, |
| $FEFFFFFFFFFFFFFF, $FDFFFFFFFFFFFFFF, $FBFFFFFFFFFFFFFF, $F7FFFFFFFFFFFFFF, |
| $EFFFFFFFFFFFFFFF, $DFFFFFFFFFFFFFFF, $BFFFFFFFFFFFFFFF, $7FFFFFFFFFFFFFFF); |
| // Gives you a 64 bit datatype which is representing the inversed |
| // binary encoding. |
| // |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111110, |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111101, |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11111011, |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11110111, |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11101111, |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111111 11011111, |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111111 10111111, |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111111 01111111, |
| // 11111111 11111111 11111111 11111111 11111111 11111111 11111110 11111111, |
| // ... |
| // 01111111 11111111 11111111 11111111 11111111 11111111 11111111 11111111. |
| // |
| // Limitation because of the data type: 64 Bit |
| // |
| // Manual calculation (not 64 bit useable) would be |
| // result := NOT GetSingleBit(ABit) |
| // |
| SingleBitArrayInversed: array[T64BitPos] of int64 = |
| ($FFFFFFFFFFFFFFFE, $FFFFFFFFFFFFFFFD, $FFFFFFFFFFFFFFFB, $FFFFFFFFFFFFFFF7, |
| $FFFFFFFFFFFFFFEF, $FFFFFFFFFFFFFFDF, $FFFFFFFFFFFFFFBF, $FFFFFFFFFFFFFF7F, |
| $FFFFFFFFFFFFFEFF, $FFFFFFFFFFFFFDFF, $FFFFFFFFFFFFFBFF, $FFFFFFFFFFFFF7FF, |
| $FFFFFFFFFFFFEFFF, $FFFFFFFFFFFFDFFF, $FFFFFFFFFFFFBFFF, $FFFFFFFFFFFF7FFF, |
| $FFFFFFFFFFFEFFFF, $FFFFFFFFFFFDFFFF, $FFFFFFFFFFFBFFFF, $FFFFFFFFFFF7FFFF, |
| $FFFFFFFFFFEFFFFF, $FFFFFFFFFFDFFFFF, $FFFFFFFFFFBFFFFF, $FFFFFFFFFF7FFFFF, |
| $FFFFFFFFFEFFFFFF, $FFFFFFFFFDFFFFFF, $FFFFFFFFFBFFFFFF, $FFFFFFFFF7FFFFFF, |
| $FFFFFFFFEFFFFFFF, $FFFFFFFFDFFFFFFF, $FFFFFFFFBFFFFFFF, $FFFFFFFF7FFFFFFF, |
| $FFFFFFFEFFFFFFFF, $FFFFFFFDFFFFFFFF, $FFFFFFFBFFFFFFFF, $FFFFFFF7FFFFFFFF, |
| $FFFFFFEFFFFFFFFF, $FFFFFFDFFFFFFFFF, $FFFFFFBFFFFFFFFF, $FFFFFF7FFFFFFFFF, |
| $FFFFFEFFFFFFFFFF, $FFFFFDFFFFFFFFFF, $FFFFFBFFFFFFFFFF, $FFFFF7FFFFFFFFFF, |
| $FFFFEFFFFFFFFFFF, $FFFFDFFFFFFFFFFF, $FFFFBFFFFFFFFFFF, $FFFF7FFFFFFFFFFF, |
| $FFFEFFFFFFFFFFFF, $FFFDFFFFFFFFFFFF, $FFFBFFFFFFFFFFFF, $FFF7FFFFFFFFFFFF, |
| $FFEFFFFFFFFFFFFF, $FFDFFFFFFFFFFFFF, $FFBFFFFFFFFFFFFF, $FF7FFFFFFFFFFFFF, |
| $FEFFFFFFFFFFFFFF, $FDFFFFFFFFFFFFFF, $FBFFFFFFFFFFFFFF, $F7FFFFFFFFFFFFFF, |
| $EFFFFFFFFFFFFFFF, $DFFFFFFFFFFFFFFF, $BFFFFFFFFFFFFFFF, $7FFFFFFFFFFFFFFF); |
| implementation |
| resourcestring |
| LngEBitStringInvalidCharacter = 'The bitstring "%s" contains a invalid ' + |
| 'character. Unexpected character "%s" at position "%d".'; |
| LngEBitStringTooLong = 'The bitstring "%s" is too long. Expected: %d byte.'; |
| function GetByteBitArray(AByte: Byte): TByteBitArray; |
| var |
| i: T8BitPos; |
| begin |
| for i := Low(T8BitPos) to High(T8BitPos) do |
| begin |
| // result[i] := GetByteBit(AByte, i); |
| result[i] := AByte and SingleBitArray[i] = SingleBitArray[i]; |
| end; |
| end; |
| function GetNibbleBitArray(ANibble: Nibble): THexNibbleBitArray; |
| var |
| i: T4BitPos; |
| begin |
| for i := Low(T4BitPos) to High(T4BitPos) do |
| begin |
| // result[i] := GetNibbleBit(ANibble, i); |
| result[i] := ANibble and SingleBitArray[i] = SingleBitArray[i]; |
| end; |
| end; |
| function BuildByte(AUpperNibble, ALowerNibble: THexNibble): Byte; |
| begin |
| // result := $10 * AUpperNibble + ALowerNibble; |
| result := (AUpperNibble shl 4) + ALowerNibble; |
| end; |
| function BuildByte(ABitArray: TByteBitArray): Byte; |
| var |
| i: T8BitPos; |
| begin |
| result := 0; |
| for i := Low(T8BitPos) to High(T8BitPos) do |
| begin |
| // SetByteBit(result, i, ABitArray[i]); |
| if not ABitArray[i] then |
| result := result and SingleBitArrayDynamicInversed[i] |
| else |
| result := result or SingleBitArray[i]; |
| end; |
| end; |
| function BuildByte(ABits: TByteBitString): Byte; |
| begin |
| result := BuildByte(ByteBitArrayFromBitString(ABits)); |
| end; |
| function BuildByte(ABit1, ABit2, ABit3, ABit4, ABit5, ABit6, ABit7, |
| ABit8: TBit): Byte; overload; |
| var |
| ba: TByteBitArray; |
| begin |
| ba[0] := ABit1; |
| ba[1] := ABit2; |
| ba[2] := ABit3; |
| ba[3] := ABit4; |
| ba[4] := ABit5; |
| ba[5] := ABit6; |
| ba[6] := ABit7; |
| ba[7] := ABit8; |
| result := BuildByte(ba); |
| end; |
| function ByteBitArrayFromBitString(const ABits: TByteBitString): TByteBitArray; |
| var |
| i: integer; |
| begin |
| if Length(ABits) <> 8 then |
| begin |
| raise EBitStringTooLong.CreateFmt(LngEBitStringTooLong, [ABits, 8]); |
| exit; |
| end; |
| for i := 1 to Length(ABits) do |
| begin |
| case ABits[i] of |
| '0': result[i-1] := false; |
| '1': result[i-1] := true; |
| else |
| raise EBitStringInvalidCharacter.CreateFmt(LngEBitStringInvalidCharacter, |
| [ABits, ABits[i], i]); |
| end; |
| end; |
| end; |
| function NibbleBitArrayFromBitString(const ABits: THexNibbleBitString): |
| THexNibbleBitArray; |
| var |
| i: integer; |
| begin |
| if Length(ABits) <> 4 then |
| begin |
| raise EBitStringTooLong.CreateFmt(LngEBitStringTooLong, [ABits, 4]); |
| exit; |
| end; |
| for i := 1 to Length(ABits) do |
| begin |
| case ABits[i] of |
| '0': result[i-1] := false; |
| '1': result[i-1] := true; |
| else |
| raise EBitStringInvalidCharacter.CreateFmt(LngEBitStringInvalidCharacter, |
| [ABits, ABits[i], i]); |
| end; |
| end; |
| end; |
| function BuildNibble(ABit1, ABit2, ABit3, ABit4: TBit): Nibble; |
| var |
| ba: THexNibbleBitArray; |
| begin |
| ba[0] := ABit1; |
| ba[1] := ABit2; |
| ba[2] := ABit3; |
| ba[3] := ABit4; |
| result := BuildNibble(ba); |
| end; |
| function BuildNibble(ABitArray: THexNibbleBitArray): Nibble; |
| var |
| i: T4BitPos; |
| begin |
| result := 0; |
| for i := Low(T4BitPos) to High(T4BitPos) do |
| begin |
| // SetNibbleBit(result, i, ABitArray[i]); |
| if not ABitArray[i] then |
| result := result and SingleBitArrayDynamicInversed[i] |
| else |
| result := result or SingleBitArray[i]; |
| end; |
| end; |
| function BuildNibble(ABits: THexNibbleBitString): Nibble; |
| begin |
| result := BuildNibble(NibbleBitArrayFromBitString(ABits)); |
| end; |
| function GetLowerNibble(AByte: Byte): THexNibble; |
| begin |
| result := AByte and AllSetBitsNibble[0]; |
| end; |
| function SetLowerNibble(AByte: Byte; ANewNibble: THexNibble): Byte; |
| begin |
| // result := BuildByte(GetUpperNibble(AByte), ANewNibble); |
| // result := $10 * (AByte and AllSetBitsNibble[1] shr 4) + ANewNibble; |
| // result := (AByte and AllSetBitsNibble[1] shr 4) shl 4 + ANewNibble; |
| // Optimized: "shr 4 shl 4" removed |
| result := (AByte and AllSetBitsNibble[1]) + ANewNibble; |
| end; |
| function GetUpperNibble(AByte: Byte): THexNibble; |
| begin |
| result := AByte and AllSetBitsNibble[1] shr 4; |
| end; |
| function SetUpperNibble(AByte: Byte; ANewNibble: THexNibble): Byte; |
| begin |
| // result := BuildByte(ANewNibble, GetLowerNibble(AByte)); |
| // result := ($10 * ANewNibble) + (AByte and AllSetBitsNibble[0]); |
| result := (ANewNibble shl 4) + (AByte and AllSetBitsNibble[0]); |
| end; |
| function GetByteBit(AByte: Byte; ABitPos: T8BitPos): TBit; |
| begin |
| // result := AByte and SingleBitArray[ABitPos] shr ABitPos = 1; |
| // result := AByte and Math.Power(2, ABitPos) shr ABitPos = 1; |
| // result := AByte and SingleBitArray[ABitPos] shr ABitPos = 1; |
| result := AByte and SingleBitArray[ABitPos] = SingleBitArray[ABitPos]; |
| end; |
| function SetByteBit(AByte: Byte; ABitPos: T8BitPos; ANewBit: TBit): Byte; |
| begin |
| if not ANewBit then |
| begin |
| // Set a bit to 0. |
| // Example: abcdefgh AND 11111011 = abcde0gh |
| // result := AByte and (AllSetBitsBytes[0] - SingleBitArray[ABitPos]); |
| // result := AByte and (AllSetBitsBytes[0] - Math.Power(2, ABitPos)); |
| result := AByte and SingleBitArrayDynamicInversed[ABitPos] |
| end |
| else |
| begin |
| // Set a bit to 1. |
| // Example: abcdefgh OR 00000100 = abcde1gh |
| // result := AByte or Math.Power(2, ABitPos); |
| result := AByte or SingleBitArray[ABitPos]; |
| end; |
| end; |
| function GetNibbleBit(ANibble: Nibble; ABitPos: T4BitPos): TBit; |
| begin |
| result := GetByteBit(ANibble, ABitPos); |
| end; |
| function SetNibbleBit(ANibble: Nibble; ABitPos: T4BitPos; |
| ANewBit: TBit): Nibble; |
| begin |
| result := SetByteBit(ANibble, ABitPos, ANewBit); |
| end; |
| function ByteBitArrayShr(ABitArray: TByteBitArray; |
| AVal: Longword): TByteBitArray; |
| var |
| b: Byte; |
| begin |
| b := BuildByte(ABitArray); |
| result := GetByteBitArray(b shr AVal); |
| end; |
| function ByteBitArrayShl(ABitArray: TByteBitArray; |
| AVal: Longword): TByteBitArray; |
| var |
| b: Byte; |
| begin |
| b := BuildByte(ABitArray); |
| result := GetByteBitArray(b shl AVal); |
| end; |
| function ByteBitArrayAnd(ABitArray, ABitArray2: TByteBitArray): TByteBitArray; |
| var |
| b, b2: Byte; |
| begin |
| b := BuildByte(ABitArray); |
| b2 := BuildByte(ABitArray2); |
| result := GetByteBitArray(b and b2); |
| end; |
| function ByteBitArrayOr(ABitArray, ABitArray2: TByteBitArray): TByteBitArray; |
| var |
| b, b2: Byte; |
| begin |
| b := BuildByte(ABitArray); |
| b2 := BuildByte(ABitArray2); |
| result := GetByteBitArray(b or b2); |
| end; |
| function ByteBitArrayXor(ABitArray, ABitArray2: TByteBitArray): TByteBitArray; |
| var |
| b, b2: Byte; |
| begin |
| b := BuildByte(ABitArray); |
| b2 := BuildByte(ABitArray2); |
| result := GetByteBitArray(b xor b2); |
| end; |
| function ByteBitArrayNot(ABitArray: TByteBitArray): TByteBitArray; |
| var |
| b: Byte; |
| begin |
| b := BuildByte(ABitArray); |
| result := GetByteBitArray(not b); |
| end; |
| function NibbleBitArrayShr(ABitArray: THexNibbleBitArray; AVal: Longword): |
| THexNibbleBitArray; |
| var |
| b: Nibble; |
| begin |
| b := BuildNibble(ABitArray); |
| result := GetNibbleBitArray(b shr AVal); |
| end; |
| function NibbleBitArrayShl(ABitArray: THexNibbleBitArray; AVal: Longword): |
| THexNibbleBitArray; |
| var |
| b: Nibble; |
| begin |
| b := BuildNibble(ABitArray); |
| result := GetNibbleBitArray(b shl AVal); |
| end; |
| function NibbleBitArrayAnd(ABitArray, ABitArray2: THexNibbleBitArray): |
| THexNibbleBitArray; |
| var |
| b, b2: Nibble; |
| begin |
| b := BuildNibble(ABitArray); |
| b2 := BuildNibble(ABitArray2); |
| result := GetNibbleBitArray(b and b2); |
| end; |
| function NibbleBitArrayOr(ABitArray, ABitArray2: THexNibbleBitArray): |
| THexNibbleBitArray; |
| var |
| b, b2: Nibble; |
| begin |
| b := BuildNibble(ABitArray); |
| b2 := BuildNibble(ABitArray2); |
| result := GetNibbleBitArray(b or b2); |
| end; |
| function NibbleBitArrayXor(ABitArray, ABitArray2: THexNibbleBitArray): |
| THexNibbleBitArray; |
| var |
| b, b2: Nibble; |
| begin |
| b := BuildNibble(ABitArray); |
| b2 := BuildNibble(ABitArray2); |
| result := GetNibbleBitArray(b xor b2); |
| end; |
| function NibbleBitArrayNot(ABitArray: THexNibbleBitArray): THexNibbleBitArray; |
| var |
| b: Nibble; |
| begin |
| b := BuildNibble(ABitArray); |
| result := GetNibbleBitArray(not b); |
| end; |
| function InverseByteBits(x: Byte): Byte; |
| begin |
| // 10110001 |
| // xor 11111111 |
| // = 01001110 |
| result := x xor AllSetBitsBytes[0]; |
| end; |
| function InverseNibbleBits(x: Nibble): Nibble; |
| begin |
| // 0001 |
| // xor 1111 |
| // = 1110 |
| result := x xor AllSetBitsNibbles[0]; |
| end; |
| function InterchangeNibbles(AByte: Byte): Byte; |
| begin |
| // result := BuildByte(GetLowerNibble(AByte), GetUpperNibble(AByte)); |
| result := (AByte and AllSetBitsNibble[0] shl 4) + |
| (AByte and AllSetBitsNibble[1] shr 4) |
| end; |
| function ReverseByteBitSequence(AByte: Byte): Byte; |
| var |
| ba: TByteBitArray; |
| begin |
| ba := GetByteBitArray(AByte); |
| result := BuildByte(ba[7], ba[6], ba[5], ba[4], ba[3], ba[2], ba[1], ba[0]); |
| end; |
| function ReverseNibbleBitSequence(ANibble: Nibble): Nibble; |
| var |
| ba: THexNibbleBitArray; |
| begin |
| ba := GetNibbleBitArray(ANibble); |
| result := BuildNibble(ba[3], ba[2], ba[1], ba[0]); |
| end; |
| end. |
| /trunk/Units/HighPerfFileComparator.pas |
|---|
| 0,0 → 1,605 |
| unit HighPerfFileComparator; |
| (* |
| HighPerfFileComparator.pas |
| (C) 2010 ViaThinkSoft, Daniel Marschall |
| Last modified: January, 21th 2010 |
| THighPerfFileComparator.compare(filenameA, filenameB: string): boolean; |
| Compares two files primary with size comparison and |
| secundary with MD5 hash comparison. All results will be cached. |
| Note: If you want to use the cache for every file, please do not |
| destroy the instance of THighPerfFileComparator after done your job. |
| Use in a field of your form class and free it when the application |
| closes. |
| Example of usage: |
| var |
| comparator: THighPerfFileComparator; |
| procedure TForm1.FormCreate(Sender: TObject); |
| begin |
| comparator := THighPerfFileComparator.Create; |
| end; |
| procedure TForm1.Button1Click(Sender: TObject); |
| begin |
| // This deletes all cached file hashs, so that the result will be |
| // new calculated. Alternatively you can create a new |
| // THighPerfFileComparator at the beginning of every new job. |
| comparator.clearCache; |
| if comparator.Compare('C:\a.txt', 'C:\b.txt') then |
| ShowMessage('Files are equal') |
| else |
| ShowMessage('Files are not equal'); |
| end; |
| procedure TForm1.FormDestroy(Sender: TObject); |
| begin |
| comparator.Free; |
| end; |
| Class hierarchie: |
| Exception |
| EFileNotFound |
| ENoRegisteredComparators |
| TObject |
| (TContainer) |
| (TStringContainer) |
| (TInteger64Container) |
| TCacheManager |
| TFilenameCacheManager |
| TInteger64CacheManager |
| TStringCacheManager |
| TInterfacedObject |
| TComparator |
| TFileComparator |
| THashMD5Comparator |
| TCachedHashMD5Comparator [ICachedComparator] |
| TSizeComparator |
| TCachedSizeComparator [ICachedComparator] |
| TMultipleFileComparators |
| TCachedSizeHashMD5FileComparator [ICachedComparator] |
| = THighPerfFileComparator |
| *) |
| interface |
| uses |
| SysUtils, Classes, Contnrs; |
| type |
| ICachedComparator = interface(IInterface) |
| // private |
| procedure SetCacheEnabled(Value: boolean); |
| function GetCacheEnabled: boolean; |
| // public |
| property CacheEnabled: boolean read getCacheEnabled write setCacheEnabled; |
| procedure ClearCache; |
| end; |
| EFileNotFound = class(Exception); |
| ENoRegisteredComparators = class(Exception); |
| TCacheManager = class(TObject) |
| private |
| FCache: TStringList; |
| public |
| procedure SetCache(identifier: string; cacheObject: TObject); |
| function GetCache(identifier: string): TObject; |
| function IsCached(identifier: string): boolean; |
| procedure Clear; |
| constructor Create; |
| destructor Destroy; override; |
| end; |
| // TFilenameCacheManager extends every filename to a unique identifier |
| TFilenameCacheManager = class(TCacheManager) |
| protected |
| function FullQualifiedFilename(filename: string): string; |
| public |
| procedure SetCache(filename: string; cacheObject: TObject); |
| function GetCache(filename: string): TObject; |
| function IsCached(filename: string): boolean; |
| end; |
| // Wäre eigentlich ein guter Ansatz für Mehrfachvererbung... |
| TInteger64CacheManager = class(TFilenameCacheManager) |
| public |
| procedure SetCache(filename: string; content: int64); |
| function GetCache(filename: string): int64; |
| end; |
| TStringCacheManager = class(TFilenameCacheManager) |
| public |
| procedure SetCache(filename: string; content: string); |
| function GetCache(filename: string): string; |
| end; |
| TComparator = class(TInterfacedObject) // abstract |
| public |
| function Compare(a, b: string): boolean; virtual; abstract; |
| end; |
| TFileComparator = class(TComparator) // abstract |
| protected |
| // Please call this method for both filenames at every Compare() |
| // call of your derivates. |
| procedure CheckFileExistence(filename: string); |
| public |
| // This is an abstract method since it only checks filenames and returns |
| // always false. |
| // function Compare(filenameA, filenameB: string): boolean; override; |
| end; |
| TSizeComparator = class(TFileComparator) |
| protected |
| function GetFileSize(filename: string): Int64; virtual; |
| public |
| function Compare(filenameA, filenameB: string): boolean; override; |
| end; |
| TCachedSizeComparator = class(TSizeComparator, ICachedComparator) |
| private |
| FCacheManager: TInteger64CacheManager; |
| FCacheEnabled: boolean; |
| procedure SetCacheEnabled(Value: boolean); |
| function GetCacheEnabled: boolean; |
| protected |
| function GetFileSize(filename: string): Int64; override; |
| public |
| property CacheEnabled: boolean read getCacheEnabled write setCacheEnabled; |
| procedure ClearCache; |
| constructor Create; |
| destructor Destroy; override; |
| end; |
| THashMD5Comparator = class(TFileComparator) |
| protected |
| function GetFileHashMD5(filename: string): String; virtual; |
| public |
| function Compare(filenameA, filenameB: string): boolean; override; |
| end; |
| TCachedHashMD5Comparator = class(THashMD5Comparator, ICachedComparator) |
| private |
| FCacheManager: TStringCacheManager; |
| FCacheEnabled: boolean; |
| procedure SetCacheEnabled(Value: boolean); |
| function GetCacheEnabled: boolean; |
| protected |
| function GetFileHashMD5(filename: string): String; override; |
| public |
| property CacheEnabled: boolean read getCacheEnabled write setCacheEnabled; |
| procedure ClearCache; |
| constructor Create; |
| destructor Destroy; override; |
| end; |
| TMultipleFileComparators = class(TFileComparator) // abstract |
| // This is an abstract class since no comparators are registered and so |
| // compare() will throw an ENoRegisteredComparators exception. |
| protected |
| // WARNING: DOES *NOT* OWNS ITS OBJECTS. PLEASE FREE THEM ON DESTROY. |
| FRegisteredComparators: TObjectList; // of TFileComparator |
| procedure RegisterComparator(comparator: TFileComparator); |
| public |
| function Compare(filenameA, filenameB: string): boolean; override; |
| constructor Create; |
| destructor Destroy; override; |
| end; |
| TCachedSizeHashMD5FileComparator = class(TMultipleFileComparators, |
| ICachedComparator) |
| private |
| FHashComparator: TCachedHashMD5Comparator; |
| FSizeComparator: TCachedSizeComparator; |
| procedure SetCacheEnabled(Value: boolean); |
| function GetCacheEnabled: boolean; |
| public |
| property CacheEnabled: boolean read getCacheEnabled write setCacheEnabled; |
| procedure ClearCache; |
| constructor Create; |
| destructor Destroy; override; |
| end; |
| THighPerfFileComparator = TCachedSizeHashMD5FileComparator; |
| implementation |
| // Please download MD5.pas from |
| // http://www.koders.com/delphi/fid1C4B47A76F8C7172FDCFE7B3A74863D6FB7FC2BA.aspx |
| uses |
| MD5; |
| resourcestring |
| LNG_E_NO_REGISTERED_COMPARATORS = 'No comparators registered. Please use ' + |
| 'a derivate of the class TMultipleFileComparators which does register ' + |
| 'comparators.'; |
| LNG_E_FILE_NOT_FOUND = 'The file "%s" was not found.'; |
| type |
| TContainer = class(TObject); |
| TStringContainer = class(TContainer) |
| public |
| Content: string; |
| constructor Create(AContent: string); |
| end; |
| TInteger64Container = class(TContainer) |
| public |
| Content: int64; |
| constructor Create(AContent: int64); |
| end; |
| { Functions } |
| function _MD5File(filename: string): string; |
| begin |
| result := MD5Print(MD5File(filename)); |
| end; |
| { TStringContainer } |
| constructor TStringContainer.Create(AContent: string); |
| begin |
| inherited Create; |
| content := AContent; |
| end; |
| { TInteger64Container } |
| constructor TInteger64Container.Create(AContent: int64); |
| begin |
| inherited Create; |
| content := AContent; |
| end; |
| { TCacheManager } |
| procedure TCacheManager.SetCache(identifier: string; cacheObject: TObject); |
| begin |
| FCache.AddObject(identifier, cacheObject); |
| end; |
| function TCacheManager.GetCache(identifier: string): TObject; |
| begin |
| if isCached(identifier) then |
| result := FCache.Objects[FCache.IndexOf(identifier)] as TContainer |
| else |
| result := nil; |
| end; |
| function TCacheManager.IsCached(identifier: string): boolean; |
| begin |
| result := FCache.IndexOf(identifier) <> -1; |
| end; |
| procedure TCacheManager.Clear; |
| begin |
| FCache.Clear; |
| end; |
| constructor TCacheManager.Create; |
| begin |
| inherited Create; |
| FCache := TStringList.Create; |
| end; |
| destructor TCacheManager.Destroy; |
| begin |
| FCache.Free; |
| inherited Destroy; |
| end; |
| { TFilenameCacheManager } |
| function TFilenameCacheManager.FullQualifiedFilename(filename: string): string; |
| begin |
| result := ExpandUNCFileName(filename); |
| end; |
| procedure TFilenameCacheManager.SetCache(filename: string; |
| cacheObject: TObject); |
| begin |
| inherited setCache(FullQualifiedFilename(filename), cacheObject); |
| end; |
| function TFilenameCacheManager.GetCache(filename: string): TObject; |
| begin |
| result := inherited getCache(FullQualifiedFilename(filename)); |
| end; |
| function TFilenameCacheManager.IsCached(filename: string): boolean; |
| begin |
| result := inherited isCached(FullQualifiedFilename(filename)); |
| end; |
| { TInteger64CacheManager } |
| procedure TInteger64CacheManager.SetCache(filename: string; content: int64); |
| begin |
| inherited setCache(filename, TInteger64Container.Create(content)); |
| end; |
| function TInteger64CacheManager.GetCache(filename: string): int64; |
| begin |
| result := (inherited getCache(filename) as TInteger64Container).content; |
| end; |
| { TStringCacheManager } |
| procedure TStringCacheManager.SetCache(filename: string; content: string); |
| begin |
| inherited setCache(filename, TStringContainer.Create(content)); |
| end; |
| function TStringCacheManager.GetCache(filename: string): string; |
| begin |
| result := (inherited getCache(filename) as TStringContainer).content; |
| end; |
| { TFileComparator } |
| procedure TFileComparator.CheckFileExistence(filename: string); |
| begin |
| if not fileExists(filename) then |
| raise EFileNotFound.CreateFmt(LNG_E_FILE_NOT_FOUND, [filename]); |
| end; |
| (* function TFileComparator.Compare(filenameA, filenameB: string): boolean; |
| begin |
| if not fileExists(filenameA) then |
| raise EFileNotFound.CreateFmt(LNG_E_FILE_NOT_FOUND, [filenameA]); |
| if not fileExists(filenameB) then |
| raise EFileNotFound.CreateFmt(LNG_E_FILE_NOT_FOUND, [filenameB]); |
| // Leider keine Überprüfung, ob Methode überschrieben wurde |
| // (da sonst result immer false ist!) |
| if Self.ClassType = TFileComparator then |
| raise EDirectCall.CreateFmt(LNG_E_DIRECT_CALL, [Self.ClassName]); |
| result := false; |
| end; *) |
| { TSizeComparator } |
| function TSizeComparator.GetFileSize(filename: string): Int64; |
| var |
| f: TFileStream; |
| begin |
| f := TFileStream.Create(filename, fmOpenRead); |
| try |
| result := f.Size |
| finally |
| f.Free; |
| end; |
| end; |
| function TSizeComparator.Compare(filenameA, filenameB: string): boolean; |
| begin |
| //inherited compare(filenameA, filenameB); |
| CheckFileExistence(filenameA); |
| CheckFileExistence(filenameB); |
| result := getFileSize(filenameA) = getFileSize(filenameB); |
| end; |
| { TCachedSizeComparator } |
| procedure TCachedSizeComparator.SetCacheEnabled(Value: boolean); |
| begin |
| if FCacheEnabled <> Value then |
| FCacheEnabled := Value; |
| end; |
| function TCachedSizeComparator.GetCacheEnabled: boolean; |
| begin |
| result := FCacheEnabled; |
| end; |
| function TCachedSizeComparator.GetFileSize(filename: string): Int64; |
| begin |
| if FCacheEnabled then |
| begin |
| if FCacheManager.isCached(filename) then |
| begin |
| result := FCacheManager.getCache(filename); |
| end |
| else |
| begin |
| result := inherited getFileSize(filename); |
| FCacheManager.setCache(filename, result); |
| end; |
| end |
| else |
| result := inherited getFileSize(filename); |
| end; |
| procedure TCachedSizeComparator.ClearCache; |
| begin |
| FCacheManager.clear; |
| end; |
| constructor TCachedSizeComparator.Create; |
| begin |
| inherited Create; |
| FCacheManager := TInteger64CacheManager.Create; |
| FCacheEnabled := true; |
| end; |
| destructor TCachedSizeComparator.Destroy; |
| begin |
| FCacheManager.Free; |
| inherited Destroy; |
| end; |
| { THashMD5Comparator } |
| function THashMD5Comparator.GetFileHashMD5(filename: string): String; |
| begin |
| result := _MD5File(filename); |
| end; |
| function THashMD5Comparator.Compare(filenameA, filenameB: string): boolean; |
| begin |
| //inherited Compare(filenameA, filenameB); |
| CheckFileExistence(filenameA); |
| CheckFileExistence(filenameB); |
| result := GetFileHashMD5(filenameA) = GetFileHashMD5(filenameB); |
| end; |
| { TCachedHashMD5Comparator } |
| procedure TCachedHashMD5Comparator.SetCacheEnabled(Value: boolean); |
| begin |
| if FCacheEnabled <> Value then |
| FCacheEnabled := Value; |
| end; |
| function TCachedHashMD5Comparator.GetCacheEnabled: boolean; |
| begin |
| result := FCacheEnabled; |
| end; |
| function TCachedHashMD5Comparator.GetFileHashMD5(filename: string): String; |
| begin |
| if FCacheEnabled then |
| begin |
| if FCacheManager.IsCached(filename) then |
| begin |
| result := FCacheManager.GetCache(filename); |
| end |
| else |
| begin |
| result := inherited GetFileHashMD5(filename); |
| FCacheManager.SetCache(filename, result); |
| end; |
| end |
| else |
| result := inherited GetFileHashMD5(filename); |
| end; |
| procedure TCachedHashMD5Comparator.ClearCache; |
| begin |
| FCacheManager.Clear; |
| end; |
| constructor TCachedHashMD5Comparator.Create; |
| begin |
| inherited Create; |
| FCacheManager := TStringCacheManager.Create; |
| FCacheEnabled := true; |
| end; |
| destructor TCachedHashMD5Comparator.Destroy; |
| begin |
| FCacheManager.Free; |
| inherited Destroy; |
| end; |
| { TMultipleFileComparators } |
| procedure TMultipleFileComparators.RegisterComparator(comparator: TFileComparator); |
| begin |
| FRegisteredComparators.Add(comparator) |
| end; |
| function TMultipleFileComparators.Compare(filenameA, |
| filenameB: string): boolean; |
| var |
| i: integer; |
| begin |
| //inherited Compare(filenameA, filenameB); |
| CheckFileExistence(filenameA); |
| CheckFileExistence(filenameB); |
| if FRegisteredComparators.Count = 0 then |
| raise ENoRegisteredComparators.Create(LNG_E_NO_REGISTERED_COMPARATORS); |
| for i := 0 to FRegisteredComparators.Count - 1 do |
| begin |
| if not (FRegisteredComparators.Items[i] as TFileComparator). |
| Compare(filenameA, filenameB) then |
| begin |
| result := false; |
| exit; |
| end; |
| end; |
| result := true; |
| end; |
| constructor TMultipleFileComparators.Create; |
| begin |
| inherited Create; |
| FRegisteredComparators := TObjectList.Create(false); |
| end; |
| destructor TMultipleFileComparators.Destroy; |
| begin |
| FRegisteredComparators.Free; |
| inherited Destroy; |
| end; |
| { TCachedSizeHashMD5FileComparator } |
| procedure TCachedSizeHashMD5FileComparator.SetCacheEnabled(Value: boolean); |
| begin |
| FSizeComparator.SetCacheEnabled(Value); |
| FHashComparator.SetCacheEnabled(Value); |
| end; |
| function TCachedSizeHashMD5FileComparator.getCacheEnabled: boolean; |
| begin |
| result := FSizeComparator.GetCacheEnabled and FHashComparator.GetCacheEnabled; |
| end; |
| procedure TCachedSizeHashMD5FileComparator.ClearCache; |
| begin |
| FSizeComparator.ClearCache; |
| FHashComparator.ClearCache; |
| end; |
| constructor TCachedSizeHashMD5FileComparator.Create; |
| begin |
| inherited Create; |
| FSizeComparator := TCachedSizeComparator.Create; |
| RegisterComparator(FSizeComparator); |
| FHashComparator := TCachedHashMD5Comparator.Create; |
| RegisterComparator(FHashComparator); |
| end; |
| destructor TCachedSizeHashMD5FileComparator.Destroy; |
| begin |
| FHashComparator.Free; |
| FSizeComparator.Free; |
| inherited Destroy; |
| end; |
| end. |
| /trunk/Units/md5.pas |
|---|
| 0,0 → 1,392 |
| // tabs = 2 |
| // ----------------------------------------------------------------------------------------------- |
| // |
| // MD5 Message-Digest for Delphi 4 |
| // |
| // Delphi 4 Unit implementing the |
| // RSA Data Security, Inc. MD5 Message-Digest Algorithm |
| // |
| // Implementation of Ronald L. Rivest's RFC 1321 |
| // |
| // Copyright 1997-1999 Medienagentur Fichtner & Meyer |
| // Written by Matthias Fichtner |
| // |
| // ----------------------------------------------------------------------------------------------- |
| // See RFC 1321 for RSA Data Security's copyright and license notice! |
| // ----------------------------------------------------------------------------------------------- |
| // |
| // 14-Jun-97 mf Implemented MD5 according to RFC 1321 RFC 1321 |
| // 16-Jun-97 mf Initial release of the compiled unit (no source code) RFC 1321 |
| // 28-Feb-99 mf Added MD5Match function for comparing two digests RFC 1321 |
| // 13-Sep-99 mf Reworked the entire unit RFC 1321 |
| // 17-Sep-99 mf Reworked the "Test Driver" project RFC 1321 |
| // 19-Sep-99 mf Release of sources for MD5 unit and "Test Driver" project RFC 1321 |
| // |
| // ----------------------------------------------------------------------------------------------- |
| // The latest release of md5.pas will always be available from |
| // the distribution site at: http://www.fichtner.net/delphi/md5/ |
| // ----------------------------------------------------------------------------------------------- |
| // Please send questions, bug reports and suggestions |
| // regarding this code to: mfichtner@fichtner-meyer.com |
| // ----------------------------------------------------------------------------------------------- |
| // This code is provided "as is" without express or |
| // implied warranty of any kind. Use it at your own risk. |
| // ----------------------------------------------------------------------------------------------- |
| unit md5; |
| // ----------------------------------------------------------------------------------------------- |
| INTERFACE |
| // ----------------------------------------------------------------------------------------------- |
| uses |
| Windows; |
| type |
| MD5Count = array[0..1] of DWORD; |
| MD5State = array[0..3] of DWORD; |
| MD5Block = array[0..15] of DWORD; |
| MD5CBits = array[0..7] of byte; |
| MD5Digest = array[0..15] of byte; |
| MD5Buffer = array[0..63] of byte; |
| MD5Context = record |
| State: MD5State; |
| Count: MD5Count; |
| Buffer: MD5Buffer; |
| end; |
| procedure MD5Init(var Context: MD5Context); |
| procedure MD5Update(var Context: MD5Context; Input: pChar; Length: longword); |
| procedure MD5Final(var Context: MD5Context; var Digest: MD5Digest); |
| function MD5String(M: string): MD5Digest; |
| function MD5File(N: string): MD5Digest; |
| function MD5Print(D: MD5Digest): string; |
| function MD5Match(D1, D2: MD5Digest): boolean; |
| // ----------------------------------------------------------------------------------------------- |
| IMPLEMENTATION |
| // ----------------------------------------------------------------------------------------------- |
| var |
| PADDING: MD5Buffer = ( |
| $80, $00, $00, $00, $00, $00, $00, $00, |
| $00, $00, $00, $00, $00, $00, $00, $00, |
| $00, $00, $00, $00, $00, $00, $00, $00, |
| $00, $00, $00, $00, $00, $00, $00, $00, |
| $00, $00, $00, $00, $00, $00, $00, $00, |
| $00, $00, $00, $00, $00, $00, $00, $00, |
| $00, $00, $00, $00, $00, $00, $00, $00, |
| $00, $00, $00, $00, $00, $00, $00, $00 |
| ); |
| function F(x, y, z: DWORD): DWORD; |
| begin |
| Result := (x and y) or ((not x) and z); |
| end; |
| function G(x, y, z: DWORD): DWORD; |
| begin |
| Result := (x and z) or (y and (not z)); |
| end; |
| function H(x, y, z: DWORD): DWORD; |
| begin |
| Result := x xor y xor z; |
| end; |
| function I(x, y, z: DWORD): DWORD; |
| begin |
| Result := y xor (x or (not z)); |
| end; |
| procedure rot(var x: DWORD; n: BYTE); |
| begin |
| x := (x shl n) or (x shr (32 - n)); |
| end; |
| procedure FF(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD); |
| begin |
| inc(a, F(b, c, d) + x + ac); |
| rot(a, s); |
| inc(a, b); |
| end; |
| procedure GG(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD); |
| begin |
| inc(a, G(b, c, d) + x + ac); |
| rot(a, s); |
| inc(a, b); |
| end; |
| procedure HH(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD); |
| begin |
| inc(a, H(b, c, d) + x + ac); |
| rot(a, s); |
| inc(a, b); |
| end; |
| procedure II(var a: DWORD; b, c, d, x: DWORD; s: BYTE; ac: DWORD); |
| begin |
| inc(a, I(b, c, d) + x + ac); |
| rot(a, s); |
| inc(a, b); |
| end; |
| // ----------------------------------------------------------------------------------------------- |
| // Encode Count bytes at Source into (Count / 4) DWORDs at Target |
| procedure Encode(Source, Target: pointer; Count: longword); |
| var |
| S: PByte; |
| T: PDWORD; |
| I: longword; |
| begin |
| S := Source; |
| T := Target; |
| for I := 1 to Count div 4 do begin |
| T^ := S^; |
| inc(S); |
| T^ := T^ or (S^ shl 8); |
| inc(S); |
| T^ := T^ or (S^ shl 16); |
| inc(S); |
| T^ := T^ or (S^ shl 24); |
| inc(S); |
| inc(T); |
| end; |
| end; |
| // Decode Count DWORDs at Source into (Count * 4) Bytes at Target |
| procedure Decode(Source, Target: pointer; Count: longword); |
| var |
| S: PDWORD; |
| T: PByte; |
| I: longword; |
| begin |
| S := Source; |
| T := Target; |
| for I := 1 to Count do begin |
| T^ := S^ and $ff; |
| inc(T); |
| T^ := (S^ shr 8) and $ff; |
| inc(T); |
| T^ := (S^ shr 16) and $ff; |
| inc(T); |
| T^ := (S^ shr 24) and $ff; |
| inc(T); |
| inc(S); |
| end; |
| end; |
| // Transform State according to first 64 bytes at Buffer |
| procedure Transform(Buffer: pointer; var State: MD5State); |
| var |
| a, b, c, d: DWORD; |
| Block: MD5Block; |
| begin |
| Encode(Buffer, @Block, 64); |
| a := State[0]; |
| b := State[1]; |
| c := State[2]; |
| d := State[3]; |
| FF (a, b, c, d, Block[ 0], 7, $d76aa478); |
| FF (d, a, b, c, Block[ 1], 12, $e8c7b756); |
| FF (c, d, a, b, Block[ 2], 17, $242070db); |
| FF (b, c, d, a, Block[ 3], 22, $c1bdceee); |
| FF (a, b, c, d, Block[ 4], 7, $f57c0faf); |
| FF (d, a, b, c, Block[ 5], 12, $4787c62a); |
| FF (c, d, a, b, Block[ 6], 17, $a8304613); |
| FF (b, c, d, a, Block[ 7], 22, $fd469501); |
| FF (a, b, c, d, Block[ 8], 7, $698098d8); |
| FF (d, a, b, c, Block[ 9], 12, $8b44f7af); |
| FF (c, d, a, b, Block[10], 17, $ffff5bb1); |
| FF (b, c, d, a, Block[11], 22, $895cd7be); |
| FF (a, b, c, d, Block[12], 7, $6b901122); |
| FF (d, a, b, c, Block[13], 12, $fd987193); |
| FF (c, d, a, b, Block[14], 17, $a679438e); |
| FF (b, c, d, a, Block[15], 22, $49b40821); |
| GG (a, b, c, d, Block[ 1], 5, $f61e2562); |
| GG (d, a, b, c, Block[ 6], 9, $c040b340); |
| GG (c, d, a, b, Block[11], 14, $265e5a51); |
| GG (b, c, d, a, Block[ 0], 20, $e9b6c7aa); |
| GG (a, b, c, d, Block[ 5], 5, $d62f105d); |
| GG (d, a, b, c, Block[10], 9, $2441453); |
| GG (c, d, a, b, Block[15], 14, $d8a1e681); |
| GG (b, c, d, a, Block[ 4], 20, $e7d3fbc8); |
| GG (a, b, c, d, Block[ 9], 5, $21e1cde6); |
| GG (d, a, b, c, Block[14], 9, $c33707d6); |
| GG (c, d, a, b, Block[ 3], 14, $f4d50d87); |
| GG (b, c, d, a, Block[ 8], 20, $455a14ed); |
| GG (a, b, c, d, Block[13], 5, $a9e3e905); |
| GG (d, a, b, c, Block[ 2], 9, $fcefa3f8); |
| GG (c, d, a, b, Block[ 7], 14, $676f02d9); |
| GG (b, c, d, a, Block[12], 20, $8d2a4c8a); |
| HH (a, b, c, d, Block[ 5], 4, $fffa3942); |
| HH (d, a, b, c, Block[ 8], 11, $8771f681); |
| HH (c, d, a, b, Block[11], 16, $6d9d6122); |
| HH (b, c, d, a, Block[14], 23, $fde5380c); |
| HH (a, b, c, d, Block[ 1], 4, $a4beea44); |
| HH (d, a, b, c, Block[ 4], 11, $4bdecfa9); |
| HH (c, d, a, b, Block[ 7], 16, $f6bb4b60); |
| HH (b, c, d, a, Block[10], 23, $bebfbc70); |
| HH (a, b, c, d, Block[13], 4, $289b7ec6); |
| HH (d, a, b, c, Block[ 0], 11, $eaa127fa); |
| HH (c, d, a, b, Block[ 3], 16, $d4ef3085); |
| HH (b, c, d, a, Block[ 6], 23, $4881d05); |
| HH (a, b, c, d, Block[ 9], 4, $d9d4d039); |
| HH (d, a, b, c, Block[12], 11, $e6db99e5); |
| HH (c, d, a, b, Block[15], 16, $1fa27cf8); |
| HH (b, c, d, a, Block[ 2], 23, $c4ac5665); |
| II (a, b, c, d, Block[ 0], 6, $f4292244); |
| II (d, a, b, c, Block[ 7], 10, $432aff97); |
| II (c, d, a, b, Block[14], 15, $ab9423a7); |
| II (b, c, d, a, Block[ 5], 21, $fc93a039); |
| II (a, b, c, d, Block[12], 6, $655b59c3); |
| II (d, a, b, c, Block[ 3], 10, $8f0ccc92); |
| II (c, d, a, b, Block[10], 15, $ffeff47d); |
| II (b, c, d, a, Block[ 1], 21, $85845dd1); |
| II (a, b, c, d, Block[ 8], 6, $6fa87e4f); |
| II (d, a, b, c, Block[15], 10, $fe2ce6e0); |
| II (c, d, a, b, Block[ 6], 15, $a3014314); |
| II (b, c, d, a, Block[13], 21, $4e0811a1); |
| II (a, b, c, d, Block[ 4], 6, $f7537e82); |
| II (d, a, b, c, Block[11], 10, $bd3af235); |
| II (c, d, a, b, Block[ 2], 15, $2ad7d2bb); |
| II (b, c, d, a, Block[ 9], 21, $eb86d391); |
| inc(State[0], a); |
| inc(State[1], b); |
| inc(State[2], c); |
| inc(State[3], d); |
| end; |
| // ----------------------------------------------------------------------------------------------- |
| // Initialize given Context |
| procedure MD5Init(var Context: MD5Context); |
| begin |
| with Context do begin |
| State[0] := $67452301; |
| State[1] := $efcdab89; |
| State[2] := $98badcfe; |
| State[3] := $10325476; |
| Count[0] := 0; |
| Count[1] := 0; |
| ZeroMemory(@Buffer, SizeOf(MD5Buffer)); |
| end; |
| end; |
| // Update given Context to include Length bytes of Input |
| procedure MD5Update(var Context: MD5Context; Input: pChar; Length: longword); |
| var |
| Index: longword; |
| PartLen: longword; |
| I: longword; |
| begin |
| with Context do begin |
| Index := (Count[0] shr 3) and $3f; |
| inc(Count[0], Length shl 3); |
| if Count[0] < (Length shl 3) then inc(Count[1]); |
| inc(Count[1], Length shr 29); |
| end; |
| PartLen := 64 - Index; |
| if Length >= PartLen then begin |
| CopyMemory(@Context.Buffer[Index], Input, PartLen); |
| Transform(@Context.Buffer, Context.State); |
| I := PartLen; |
| while I + 63 < Length do begin |
| Transform(@Input[I], Context.State); |
| inc(I, 64); |
| end; |
| Index := 0; |
| end else I := 0; |
| CopyMemory(@Context.Buffer[Index], @Input[I], Length - I); |
| end; |
| // Finalize given Context, create Digest and zeroize Context |
| procedure MD5Final(var Context: MD5Context; var Digest: MD5Digest); |
| var |
| Bits: MD5CBits; |
| Index: longword; |
| PadLen: longword; |
| begin |
| Decode(@Context.Count, @Bits, 2); |
| Index := (Context.Count[0] shr 3) and $3f; |
| if Index < 56 then PadLen := 56 - Index else PadLen := 120 - Index; |
| MD5Update(Context, @PADDING, PadLen); |
| MD5Update(Context, @Bits, 8); |
| Decode(@Context.State, @Digest, 4); |
| ZeroMemory(@Context, SizeOf(MD5Context)); |
| end; |
| // ----------------------------------------------------------------------------------------------- |
| // Create digest of given Message |
| function MD5String(M: string): MD5Digest; |
| var |
| Context: MD5Context; |
| begin |
| MD5Init(Context); |
| MD5Update(Context, pChar(M), length(M)); |
| MD5Final(Context, Result); |
| end; |
| // Create digest of file with given Name |
| function MD5File(N: string): MD5Digest; |
| var |
| FileHandle: THandle; |
| MapHandle: THandle; |
| ViewPointer: pointer; |
| Context: MD5Context; |
| begin |
| MD5Init(Context); |
| FileHandle := CreateFile(pChar(N), GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE, |
| nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_SEQUENTIAL_SCAN, 0); |
| if FileHandle <> INVALID_HANDLE_VALUE then try |
| MapHandle := CreateFileMapping(FileHandle, nil, PAGE_READONLY, 0, 0, nil); |
| if MapHandle <> 0 then try |
| ViewPointer := MapViewOfFile(MapHandle, FILE_MAP_READ, 0, 0, 0); |
| if ViewPointer <> nil then try |
| MD5Update(Context, ViewPointer, GetFileSize(FileHandle, nil)); |
| finally |
| UnmapViewOfFile(ViewPointer); |
| end; |
| finally |
| CloseHandle(MapHandle); |
| end; |
| finally |
| CloseHandle(FileHandle); |
| end; |
| MD5Final(Context, Result); |
| end; |
| // Create hex representation of given Digest |
| function MD5Print(D: MD5Digest): string; |
| var |
| I: byte; |
| const |
| Digits: array[0..15] of char = |
| ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'); |
| begin |
| Result := ''; |
| for I := 0 to 15 do Result := Result + Digits[(D[I] shr 4) and $0f] + Digits[D[I] and $0f]; |
| end; |
| // ----------------------------------------------------------------------------------------------- |
| // Compare two Digests |
| function MD5Match(D1, D2: MD5Digest): boolean; |
| var |
| I: byte; |
| begin |
| I := 0; |
| Result := TRUE; |
| while Result and (I < 16) do begin |
| Result := D1[I] = D2[I]; |
| inc(I); |
| end; |
| end; |
| end. |