unit MYLDBDecUtil;

interface

uses SysUtils, Classes;

{$I MYLDBVer.Inc}
{$I VER.INC}

const
// String Formats
  fmtDEFAULT     =    -1;     // use DefaultStringFormat
  fmtNONE        =     0;     // allways an Empty String, nothing Action
  fmtCOPY        =     1;     // One to One binary (input = output)
  fmtHEX         =    16;     // Hexadecimal
  fmtHEXL        =  1016;     // Hexadecimal lowercase
  fmtMIME64      = $1064;     // MIME Base 64
  fmtUU          = $5555;     // UU Coding  $5555 = 'UU'
  fmtXX          = $5858;     // XX Coding  $5858 = 'XX'

// 2 - 64 reserved for Formats to the Base 2 - 64
// over 1000 all other Formats

type
{$IFNDEF VER_D4H}
  LongWord       = LongInt;
  PLongWord      = ^LongWord;
{$ENDIF}
  PByte          = ^Byte;
  PInteger       = ^LongWord;
  PWord          = ^Word;
  PIntArray      = ^TIntArray;
  TIntArray      = array[0..1023] of LongWord;

  EProtection    = class(Exception);
  EStringFormat  = class(Exception);

// basic Class for all Protection Classes, TCipher, THash, TRandom
// TProtect can build a chain with varios Encryption Algos.
// i.E. CodeBuffer() can en/decode the Buffer with more as one Cipher when
// property Protection is set to a other Cipher :-)
  TPAction  = (paEncode, paDecode, paScramble, paCalc, paWipe);
  TPActions = set of TPAction;

{$IFDEF VER_D3H}
  TProtection = class(TInterfacedObject)
  private
{$ELSE}
  TProtection = class(TObject)
  private
    FRefCount: Integer;
{$ENDIF}
    FProtection: TProtection;
    FActions: TPActions;
    function GetProtection: TProtection;
    procedure SetProtection(Value: TProtection);
  protected
    procedure CodeInit(Action: TPAction); virtual;
    procedure CodeDone(Action: TPAction); virtual;
    procedure CodeBuf(var Buffer; const BufferSize: Integer; Action: TPAction); virtual;
  public
    constructor Create(AProtection: TProtection);
    destructor Destroy; override;

    class function Identity: Word;

    function Release: Integer;
    function AddRef: Integer;

    procedure CodeStream(Source, Dest: TStream; DataSize: Integer; Action: TPAction); virtual;
    procedure CodeFile(const Source, Dest: String; Action: TPAction); virtual;
    function  CodeString(const Source: String; Action: TPAction; Format: Integer): String; virtual;
    function  CodeBuffer(var Buffer; BufferSize: Integer; Action: TPAction): Integer; virtual;
// Protection Object, to cascade more Protection
    property Protection: TProtection read GetProtection write SetProtection;
    property Actions: TPActions read FActions write FActions default [paEncode..paWipe];
{$IFNDEF VER_D3H}
    property RefCount: Integer read FRefCount;
{$ENDIF}
  end;

// String converting

  TStringFormatClass = class of TStringFormat;

  TStringFormat = class(TObject) // for binary one to one convert = fmtCOPY
  public
    class function ToStr(Value: PChar; Len: Integer): String; virtual;
    class function StrTo(Value: PChar; Len: Integer): String; virtual;
    class function Name: String; virtual;
    class function Format: Integer; virtual;
    class function IsValid(Value: PChar; Len: Integer; ToStr: Boolean): Boolean; virtual;
  end;

  TStringFormat_HEX = class(TStringFormat) // Hexadecimal = fmtHEX
  public
    class function ToStr(Value: PChar; Len: Integer): String; override;
    class function StrTo(Value: PChar; Len: Integer): String; override;
    class function Name: String; override;
    class function Format: Integer; override;
    class function IsValid(Value: PChar; Len: Integer; ToStr: Boolean): Boolean; override;
    class function CharTable: PChar; virtual;
  end;

  TStringFormat_HEXL = class(TStringFormat_HEX) // Hexadecimal lowercase = fmtHEXL
  public
    class function Name: String; override;
    class function Format: Integer; override;
    class function CharTable: PChar; override;
  end;

  TStringFormat_MIME64 = class(TStringFormat_HEX)  // MIME Base 64 = fmtMIME64
  public
    class function ToStr(Value: PChar; Len: Integer): String; override;
    class function StrTo(Value: PChar; Len: Integer): String; override;
    class function Name: String; override;
    class function Format: Integer; override;
    class function CharTable: PChar; override;
  end;

  TStringFormat_UU = class(TStringFormat) // UU Encode = fmtUU
  public
    class function ToStr(Value: PChar; Len: Integer): String; override;
    class function StrTo(Value: PChar; Len: Integer): String; override;
    class function Name: String; override;
    class function Format: Integer; override;
    class function IsValid(Value: PChar; Len: Integer; ToStr: Boolean): Boolean; override;
    class function CharTable: PChar; virtual;
  end;

  TStringFormat_XX = class(TStringFormat_UU) // XX Encode = fmtXX
  public
    class function Name: String; override;
    class function Format: Integer; override;
    class function CharTable: PChar; override;
  end;

{Progress (gauge) for Hash and Cipher}
  TProgressEvent = procedure(Sender: TObject; Current, Maximal: Integer) of Object;

//calculate CRCR16/CRC32 Checksum, CRC is default $FFFFFFFF,
//after calc you must inverse Result with NOT
function CRC16(CRC: Word; Data: Pointer; DataSize: LongWord): Word;
// the basicly used TestVector for all Hash/Cipher classes
// used for SelfTest, random Data, don't modify
function GetTestVector: PChar; register;

// String/Format routines
// convert any String to Format
function StrToFormat(Value: PChar; Len, Format: Integer): String;
// convert any Format to String
function FormatToStr(Value: PChar; Len, Format: Integer): String;
// convert any Format to Format
function ConvertFormat(Value: PChar; Len, FromFormat, ToFormat: Integer): String;
// Check is String convertable to Format
function IsValidString(Value: PChar; Len, Format: Integer): Boolean;
// Check is Format an valid Format
function IsValidFormat(Value: PChar; Len, Format: Integer): Boolean;
// register a new Format
procedure RegisterStringFormats(const StringFormats: array of TStringFormatClass);
// give all registered Formats in Strings
procedure GetStringFormats(Strings: TStrings);
// the Default, = fmtMIME64
function DefaultStringFormat: Integer;
// set the Default
procedure SetDefaultStringFormat(Format: Integer);
// give StringFormatClass from Format
function StringFormat(Format: Integer): TStringFormatClass;
// insert #13#10 Chars in Blocks from BlockSize
function InsertCR(const Value: String; BlockSize: Integer): String;
// delete all #13 and #10 Chars
function DeleteCR(const Value: String): String;
// format any String to a Block
function InsertBlocks(const Value, BlockStart, BlockEnd: String; BlockSize: Integer): String;
// remove any Block format
function RemoveBlocks(const Value, BlockStart, BlockEnd: String): String;
// give back a shorter Name, i.E. THash_MD4 -> "MD4" or TCipher_Blowfish -> "Blowfish"
function GetShortClassName(Value: TClass): String;

// Result := Value shl Shift or Value shr (32 - Shift)
function ROL(Value: LongWord; Shift: Integer): LongWord;
// Result := ROL(Value, Shift) + Add
function ROLADD(Value, Add: LongWord; Shift: Integer): LongWord;
// Result := ROL(Value, Shift) - Sub
function ROLSUB(Value, Sub: LongWord; Shift: Integer): LongWord;
// Result := Value shr Shift or Value shl (32 - Shift)
function ROR(Value: LongWord; Shift: Integer): LongWord;
// Result := ROR(Value, Shift) + Add
function RORADD(Value, Add: LongWord; Shift: Integer): LongWord;
// Result := ROR(Value, Shift) - Sub
function RORSUB(Value, Sub: LongWord; Shift: Integer): LongWord;
// Reverse the Bitorder from Value
function SwapBits(Value: LongWord): LongWord;
// Index of Least Significant Bit from Value
function LSBit(Value: Integer): Integer;
// Index of Most Significant Bit from Value
function MSBit(Value: Integer): Integer;
// Check iff only One Bit is set and give back the Index
function OneBit(Value: Integer): Integer;
// Compare Memory, D2 have no CompareMem, Result can be -1, 0, 1
function MemCompare(P1, P2: Pointer; Size: Integer): Integer;
// XOR's Buffers I1 and I2 Size Bytes to Dest
procedure XORBuffers(I1, I2: Pointer; Size: Integer; Dest: Pointer);
// Processor Type
function CPUType: Integer; {3 = 386, 4 = 486, 5 = Pentium, 6 > Pentium i.E. PII}
// call a installed Progress Event
procedure DoProgress(Sender: TObject; Current, Maximal: Integer);
// saver Test
function IsObject(AObject: Pointer; AClass: TClass): Boolean;
// Time Seed produced from GetSystemTime and QueryPerformanceCounter
function RndTimeSeed: Integer;
// XOR Buffer Size Bytes with Seed Randoms,
// the initial State from Buffer have effect on the Output
function RndXORBuffer(Seed: Integer; var Buffer; Size: Integer): Integer;
// encapsulate QueryPerformanceCounter/Frequency
function PerfCounter: Comp;
function PerfFreq: Comp;

const
  InitTestIsOk        : Boolean  = True;
  IdentityBase        : Word     = $1234;

{this is set to SwapInt for <= 386 and BSwapInt >= 486 CPU, don't modify}
  SwapInteger       : function(Value: LongWord): LongWord; register  = nil;
{Count of Integers Buffer}
  SwapIntegerBuffer : procedure(Source, Dest: Pointer; Count: Integer); register = nil;
{Progress callback function, set this to your Progresscallback}
  Progress: TProgressEvent = nil;

implementation

uses Windows, MYLDBDecConst2;

const
  FCPUType : Integer = 0;
  FStrFMTs : TList = nil;         // registered Stringformats
  FStrFMT  : Integer = fmtMIME64; // Default Stringformat

function PerfCounter: Comp;
begin
{$IFDEF VER_D4H}
  if not QueryPerformanceCounter(TULargeInteger(Result).QuadPart) then
{$ELSE}
  if not QueryPerformanceCounter(TLargeInteger(Result)) then
{$ENDIF}
    Result := GetTickCount;
end;

function PerfFreq: Comp;
begin
{$IFDEF VER_D4H}
  if not QueryPerformanceFrequency(TULargeInteger(Result).QuadPart) then
{$ELSE}
  if not QueryPerformanceFrequency(TLargeInteger(Result)) then
{$ENDIF}
    Result := 1000;
end;

function DefaultStringFormat: Integer;
begin
  Result := FStrFMT;
end;

procedure SetDefaultStringFormat(Format: Integer);
begin
  if (Format = fmtDEFAULT) or (StringFormat(Format) = nil) then FStrFMT := fmtMIME64
    else FStrFMT := Format;
end;

// TProtection Class
function TProtection.GetProtection: TProtection;
begin
  if (FProtection <> nil) and not IsObject(FProtection, TProtection) then FProtection := nil;
  Result := FProtection;
end;

procedure TProtection.SetProtection(Value: TProtection);

  function CheckProtection(P: TProtection): Boolean;
  begin
    Result := True;
    if IsObject(P, TProtection) then
      if P = Self then Result := False
        else Result := CheckProtection(P.FProtection)
  end;

begin
  if Value <> FProtection then
    if CheckProtection(Value) then
    begin
      FProtection.Release;
      FProtection := Value;
      FProtection.AddRef;
    end else raise EProtection.Create(sProtectionCircular)
end;

procedure TProtection.CodeInit(Action: TPAction);
begin
  if Protection <> nil then Protection.CodeInit(Action);
end;

procedure TProtection.CodeDone(Action: TPAction);
begin
  if Protection <> nil then Protection.CodeDone(Action);
end;

procedure TProtection.CodeBuf(var Buffer; const BufferSize: Integer; Action: TPAction);
begin
  if Protection <> nil then Protection.CodeBuf(Buffer, BufferSize, Action);
end;

function TProtection.Release: Integer;
begin
  if IsObject(Self, TProtection) then
  begin
{$IFDEF VER_D3H}
    Result := IUnknown(Self)._Release;
{$ELSE}
    Dec(FRefCount);
    Result := FRefCount;
    if FRefCount = 0 then Destroy;
{$ENDIF}
  end else Result := 0;
end;

function TProtection.AddRef: Integer;
begin
  if IsObject(Self, TProtection) then
  begin
{$IFDEF VER_D3H}
    Result := IUnknown(Self)._AddRef;
{$ELSE}
    Inc(FRefCount);
    Result := FRefCount;
{$ENDIF}
  end else Result := 0;
end;

procedure TProtection.CodeStream(Source, Dest: TStream; DataSize: Integer; Action: TPAction);
const
  maxBufSize = 1024 * 4;
var
  Buf: PChar;
  SPos: Integer;
  DPos: Integer;
  Len: Integer;
  Size: Integer;
begin
  if Source = nil then Exit;
  if Dest = nil then Dest := Source;
  if DataSize < 0 then
  begin
    DataSize := Source.Size;
    Source.Position := 0;
  end;
  CodeInit(Action);
  Buf := nil;
  Size := DataSize;
  DoProgress(Self, 0, Size);
  try
    Buf    := AllocMem(maxBufSize);
    DPos   := Dest.Position;
    SPos   := Source.Position;
    if Action = paCalc then
    begin
      while DataSize > 0 do
      begin
        Len := DataSize;
        if Len > maxBufSize then Len := maxBufSize;
        Len := Source.Read(Buf^, Len);
        if Len <= 0 then Break;
        CodeBuf(Buf^, Len, paCalc);
        Dec(DataSize, Len);
        DoProgress(Self, Size - DataSize, Size);
      end;
    end else
    begin
      while DataSize > 0 do
      begin
        Source.Position := SPos;
        Len := DataSize;
        if Len > maxBufSize then Len := maxBufSize;
        Len := Source.Read(Buf^, Len);
        SPos := Source.Position;
        if Len <= 0 then Break;
        CodeBuf(Buf^, Len, Action);
        Dest.Position := DPos;
        Dest.Write(Buf^, Len);
        DPos := Dest.Position;
        Dec(DataSize, Len);
        DoProgress(Self, Size - DataSize, Size);
      end;
    end;
  finally
    DoProgress(Self, 0, 0);
    ReallocMem(Buf, 0);
    CodeDone(Action);
  end;
end;

procedure TProtection.CodeFile(const Source, Dest: String; Action: TPAction);
var
  S,D: TFileStream;
begin
  S := nil;
  D := nil;
  try
    if (AnsiCompareText(Source, Dest) <> 0) and ((Trim(Dest) <> '') or (Action = paCalc)) then
    begin
      S := TFileStream.Create(Source, fmOpenRead or fmShareDenyNone);
      if Action = paCalc then D := S
        else D := TFileStream.Create(Dest, fmCreate);
    end else
    begin
      S := TFileStream.Create(Source, fmOpenReadWrite);
      D := S;
    end;
    CodeStream(S, D, S.Size, Action);
  finally
    S.Free;
    if S <> D then
    begin
{$IFDEF VER_D3H}
      D.Size := D.Position;
{$ENDIF}
      D.Free;
    end;
  end;
end;

function TProtection.CodeBuffer(var Buffer; BufferSize: Integer; Action: TPAction): Integer;
begin
  Result := BufferSize;
  CodeInit(Action);
  try
    CodeBuf(Buffer, BufferSize, Action);
  finally
    CodeDone(Action);
  end;
end;

function TProtection.CodeString(const Source: String; Action: TPAction; Format: Integer): String;
var
  M: TMemoryStream;
begin
  Result := '';
  if Length(Source) <= 0 then Exit;
  M := TMemoryStream.Create;
  try
    if Action <> paDecode then Result := Source
      else Result := FormatToStr(PChar(Source), Length(Source), Format);
    M.Write(PChar(Result)^, Length(Result));
    M.Position := 0;
    CodeStream(M, M, M.Size, Action);
    if Action = paDecode then
    begin
      SetLength(Result, M.Size);
      Move(M.Memory^, PChar(Result)^, M.Size);
    end else
      Result := StrToFormat(M.Memory, M.Size, Format);
  finally
    M.Free;
  end;
end;

constructor TProtection.Create(AProtection: TProtection);
begin
  inherited Create;
  Protection := AProtection;
  FActions := [paEncode..paWipe];
end;

destructor TProtection.Destroy;
begin
  Protection := nil;
  inherited Destroy;
end;

class function TProtection.Identity: Word;
var
  S: String;
begin
  S := ClassName;
  Result := not CRC16(IdentityBase, PChar(S), Length(S));
end;

class function TStringFormat.ToStr(Value: PChar; Len: Integer): String;
begin
  SetLength(Result, Len);
  Move(Value^, PChar(Result)^, Len);
end;

class function TStringFormat.StrTo(Value: PChar; Len: Integer): String;
begin
  SetLength(Result, Len);
  Move(Value^, PChar(Result)^, Len);
end;

class function TStringFormat.Name: String;
begin
  if Self = TStringFormat then Result := sFMT_COPY
    else Result := GetShortClassName(Self);
end;

class function TStringFormat.Format: Integer;
begin
  Result := fmtCOPY;
end;

class function TStringFormat.IsValid(Value: PChar; Len: Integer; ToStr: Boolean): Boolean;
begin
  Result := True;
end;

function TableFind(Value: Char; Table: PChar; Len: Integer): Integer; assembler;
asm // Utility for TStringFormat_XXXXX
      PUSH  EDI
      MOV   EDI,EDX
      REPNE SCASB
      MOV   EAX,0
      JNE   @@1
      MOV   EAX,EDI
      SUB   EAX,EDX
@@1:  DEC   EAX
      POP   EDI
end;