decutil.pas

cipher 5.1。一个几乎包含了所有常见的加密算法的控件

{Copyright:      Hagen Reddmann  HaReddmann at T-Online dot de
 Author:         Hagen Reddmann
 Remarks:        freeware, but this Copyright must be included
 known Problems: none
 Version:        5.1, Delphi Encryption Compendium
                 Delphi 2-4, BCB 3-4, designed and testet under D3-5
 Description:    Utilitys for the DEC Packages

 * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ''AS IS'' AND ANY EXPRESS
 * OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
 * EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
}

unit DECUtil;
{$I VER.INC}

interface

uses Windows, SysUtils, Classes, CRC;

type
  Binary         = String;  // LongString with Binary Contens
{$IFNDEF VER_D4H}
  LongWord       = type Integer;
{$ENDIF}
  PLongWord      = ^LongWord;
  PByte          = ^Byte;
  PInteger       = ^Integer;
  PWord          = ^Word;
  PLongArray     = ^TLongArray;
  TLongArray     = array[0..1023] of LongWord;

// basicaly DEC Exceptionclass ALL-exception in DEC-Classes/methods should be use this or descends
  EDECException  = class(Exception);

// basicaly Class for all DEC classes that needed a RefCounter and
// Registration Support
  TDECClass = class of TDECObject;

  TDECObject = class(TPersistent)
  public
    constructor Create; virtual;
    class function Identity: LongWord;
    class procedure Register;
    procedure FreeInstance; override;
  end;

  IDECProgress = interface
    ['{64366E77-82FE-4B86-951E-79389729A493}']
    procedure Process(const Min,Max,Pos: Int64); stdcall;
  end;

// DEC Classes Registration
type
  TDECEnumClassesCallback = function(UserData: Pointer; ClassType: TClass): Boolean; register;

// Register DEC Classes to make it streamable
procedure RegisterDECClasses(const Classes: array of TClass);
// Unregister DEC Classes
procedure UnregisterDECClasses(const Classes: array of TClass);
// fillout a StringList with registered DEC Classes
procedure DECClasses(List: TStrings; Include: TClass = nil; Exclude: TClass = nil);
// find a registered DEC Class by Identity
function DECClassByIdentity(Identity: LongWord; ClassType: TClass): TDECClass;
// find DEC Class by Name, can be as Example: TCipher_Blowfish, Blowfish or registered Name override
function  DECClassByName(const Name: String; ClassType: TClass): TDECClass;
// returns correted short Classname of any registered DEC Class
function  DECClassName(ClassType: TClass): String;
// enumerate by callback over registered DEC classes
function  DECEnumClasses(Callback: TDECEnumClassesCallback; UserData: Pointer; Include: TClass = nil; Exclude: TClass = nil): TDECClass;

procedure ProtectBuffer(var Buffer; Size: Integer);
procedure ProtectBinary(var Value: Binary);
procedure ProtectStream(Stream: TStream; Size: Integer = 0);
// test iff Buffer contains BufferSize values
function  IsFilledWith(var Buffer; Size: Integer; Value: Char): Boolean;
procedure FoldBuf(var Dest; DestSize: Integer; const Source; SourceSize: Integer);
procedure FoldStr(var Dest; DestSize: Integer; const Source: String);
// Random Buffer/Binary, ATENTION! standard Random Function are'nt crytographicaly secure,
// please include DECRandom to install secure PRNG
function  RandomBinary(Size: Integer): Binary;
procedure RandomBuffer(var Buffer; Size: Integer);
function  RandomLong: LongWord;
procedure RandomSeed(const Buffer; Size: Integer); overload;
procedure RandomSeed; overload;
function  RandomSystemTime: Cardinal;
// reverse Byte order from Buffer
procedure SwapBytes(var Buffer; BufferSize: Integer);
function  SwapLong(Value: LongWord): LongWord;
procedure SwapLongBuffer(const Source; var Dest; Count: Integer);
function  SwapInt64(const Value: Int64): Int64;
procedure SwapInt64Buffer(const Source; var Dest; Count: Integer);
function  SwapBits(Value, Bits: LongWord): LongWord;
procedure XORBuffers(const Source1, Source2; Size: Integer; var Dest);
// saver Test iff AObject valid
function IsObject(AObject: Pointer; AClass: TClass): Boolean;

var
  IdentityBase : LongWord = $25844852; // used as base in classmethod Identity

  DoRandomBuffer: procedure(var Buffer; Size: Integer); register = nil;
  DoRandomSeed: procedure(const Buffer; Size: Integer); register = nil;

implementation

resourcestring
  sClassNotRegistered = 'Class %s not registered';
  sWrongIdentity      = 'Another class "%s" with same identity as "%s" are allready registered.';
  
var
  FClasses: TList = nil;

function GetShortClassName(const Value: String): String;
var
  I: Integer;
begin
  Result := Value;
  I := Pos('_', Result);
  if I > 0 then Delete(Result, 1, I);
end;

procedure RegisterDECClasses(const Classes: array of TClass);
var
  I: Integer;
begin
  for I := Low(Classes) to High(Classes) do
    if (Classes[I] <> nil) and Classes[I].InheritsFrom(TDECObject) then
      TDECClass(Classes[I]).Register;
end;

procedure UnregisterDECClasses(const Classes: array of TClass);
var
  I,J: Integer;
begin
  if IsObject(FClasses, TList) then
    for I := Low(Classes) to High(Classes) do
    begin
      J := FClasses.IndexOf(Classes[I]);
      if J >= 0 then FClasses.Delete(J);
    end;
end;

procedure DECClasses(List: TStrings; Include: TClass = nil; Exclude: TClass = nil);

  function DoAdd(List: TStrings; ClassType: TClass): Boolean;
  begin
    Result := False;
    List.AddObject(ClassType.ClassName, Pointer(ClassType));
  end;

begin
  if IsObject(List, TStrings) then
  try
    List.BeginUpdate;
    List.Clear;
    DECEnumClasses(@DoAdd, List, Include, Exclude);
  finally
    List.EndUpdate;
  end;
end;

function DECClassByIdentity(Identity: LongWord; ClassType: TClass): TDECClass;

  function DoFind(Identity: LongWord; ClassType: TDECClass): Boolean;
  begin
    Result := ClassType.Identity = Identity;
  end;

begin
  Result := DECEnumClasses(@DoFind, Pointer(Identity), ClassType);
  if Result = nil then
    raise EDECException.CreateFmt(sClassNotRegistered, [IntToHEX(Identity, 8)]);
end;

function DECClassByName(const Name: String; ClassType: TClass): TDECClass;

  function DoFindShort(const Name: String; ClassType: TClass): Boolean;
  begin
    Result := AnsiCompareText(DECClassName(ClassType), Name) = 0;
  end;

  function DoFindLong(const Name: String; ClassType: TClass): Boolean;
  begin
    Result := AnsiCompareText(ClassType.ClassName, Name) = 0;
  end;

begin
  Result := nil;
  if Name <> '' then
    if GetShortClassName(Name) = Name then
      Result := DECEnumClasses(@DoFindShort, Pointer(Name), ClassType)
    else
      Result := DECEnumClasses(@DoFindLong, Pointer(Name), ClassType);
  if Result = nil then
    raise EDECException.CreateFmt(sClassNotRegistered, [Name]);
end;

function DECClassName(ClassType: TClass): String;
begin
  if ClassType = nil then Result := ''
    else Result := GetShortClassName(ClassType.ClassName);
end;

function DECEnumClasses(Callback: TDECEnumClassesCallback; UserData: Pointer;
            Include: TClass = nil; Exclude: TClass = nil): TDECClass;
var
  I: Integer;
begin
  Result := nil;
  if Assigned(Callback) and IsObject(FClasses, TList) then
    for I := 0 to FClasses.Count -1 do
      if ((Include = nil) or     TClass(FClasses[I]).InheritsFrom(Include)) and
         ((Exclude = nil) or not TClass(FClasses[I]).InheritsFrom(Exclude)) and
          Callback(UserData, FClasses[I]) then
      begin
        Result := FClasses[I];
        Break;
      end;
end;

constructor TDECObject.Create;
begin
  inherited Create;
end;

class function TDECObject.Identity: LongWord;
var
  Signature: String;
begin
  Signature := StringOfChar(#$5A, 256 - Length(Classname)) + AnsiUpperCase(ClassName);
  Result := CRC32(IdentityBase, Signature[1], Length(Signature));
end;

class procedure TDECObject.Register;
var
  I: Integer;
  Found: Boolean;
  ID: LongWord;
begin
  if IsObject(FClasses, TList) then
  begin
    Found := False;
    ID := Identity;
    for I := 0 to FClasses.Count-1 do
      if FClasses[I] = Self then Found := True else
        if ID = TDECClass(FClasses[I]).Identity then 
          raise EDECException.CreateFmt(sWrongIdentity, [TDECClass(FClasses[I]).ClassName, ClassName]);
    if not Found then FClasses.Add(Self);
  end;
end;

// override FreeInstance to fillout allocated Object with Zeros
// that is safer for any access to invalid Pointers of any released Object
// WE WANT SECURITY !!!
procedure TDECObject.FreeInstance;
asm
      PUSH    EBX
      PUSH    EDI
      MOV     EBX,EAX
      CALL    TObject.CleanupInstance
      MOV     EAX,[EBX]
      CALL    TObject.InstanceSize
      MOV     ECX,EAX
      MOV     EDI,EBX
      XOR     EAX,EAX
      REP     STOSB
      MOV     EAX,EBX
      CALL    System.@FreeMem
      POP     EDI
      POP     EBX
end;


function IsObject(AObject: Pointer; AClass: TClass): Boolean;
// Relacement of "is" Operator for safer access/check iff AObject is AClass

  function IsClass(AObject: Pointer; AClass: TClass): Boolean;
  asm  // safer replacement for Borland's "is" operator
  @@1:    TEST    EAX,EAX
          JE      @@3
          MOV     EAX,[EAX]
          TEST    EAX,EAX
          JE      @@3
          CMP     EAX,EDX
          JE      @@2
          MOV     EAX,[EAX].vmtParent
          JMP     @@1
  @@2:    MOV     EAX,1
  @@3:
  end;
  
begin
  Result := False;
  if AObject <> nil then
  try
    Result := IsClass(AObject, AClass);
  except
  end;
end;

function MemCompare(P1, P2: Pointer; Size: Integer): Integer;
asm //equal to StrLComp(P1, P2, Size), but allways Size Bytes are checked
       PUSH    ESI
       PUSH    EDI
       MOV     ESI,P1
       MOV     EDI,P2
       XOR     EAX,EAX
       REPE    CMPSB
       JE      @@1
       MOVZX   EAX,BYTE PTR [ESI-1]
       MOVZX   EDX,BYTE PTR [EDI-1]
       SUB     EAX,EDX
@@1:   POP     EDI
       POP     ESI
end;

procedure XORBuffers(const Source1, Source2; Size: Integer; var Dest);
asm // Dest^ =  Source1^ xor Source2^ , Size bytes
       AND   ECX,ECX
       JZ    @@5
       PUSH  ESI
       PUSH  EDI
       MOV   ESI,EAX
       MOV   EDI,Dest
@@1:   TEST  ECX,3
       JNZ   @@3
@@2:   SUB   ECX,4
       JL    @@4
       MOV   EAX,[ESI + ECX]
       XOR   EAX,[EDX + ECX]
       MOV   [EDI + ECX],EAX
       JMP   @@2
@@3:   DEC   ECX
       MOV   AL,[ESI + ECX]
       XOR   AL,[EDX + ECX]
       MOV   [EDI + ECX],AL
       JMP   @@1
@@4:   POP   EDI
       POP   ESI
@@5:                           
end;

// wipe
const
  WipeCount = 4;
  WipeBytes : array[0..WipeCount -1] of Byte = ($55, $AA, $FF, $00);

procedure ProtectBuffer(var Buffer; Size: Integer);
var
  Count: Integer;
begin
  if Size > 0 then
    for Count := 0 to WipeCount -1 do
      FillChar(Buffer, Size, WipeBytes[Count]);
end;

procedure ProtectString(var Value: String);
begin
  UniqueString(Value);
  ProtectBuffer(Pointer(Value)^, Length(Value));
  Value := '';
end;

procedure ProtectBinary(var Value: Binary);
begin
  UniqueString(String(Value));
  ProtectBuffer(Pointer(Value)^, Length(Value));
  Value := '';
end;

procedure ProtectStream(Stream: TStream; Size: Integer = 0);
const
  BufferSize = 512;
var