{Copyright:      Hagen Reddmann  mailto:HaReddmann@AOL.COM
 Author:         Hagen Reddmann
 Remarks:        freeware, but this Copyright must be included
 known Problems: none
 Version:        3.0, Delphi Encryption Compendium
                 Delphi 2-4, BCB 3-4
 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.
}
{$IFNDEF CLR}

{$I Dac.inc}

unit CRDECUtil;
{$ENDIF}

interface
{$A+,Q-,R-,Y-}
uses
{$IFDEF CLR}
  System.Runtime.InteropServices,
{$ELSE}
  CLRClasses,
{$ENDIF}
  SysUtils, CRTypes, CRFunctions;

type
// basic Class for all Protection Classes, TCipher, THash
// 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;

  TProtection = class(TInterfacedObject)
  private
    FProtection: TProtection;
    FActions: TPActions;
    function GetProtection: TProtection;
    procedure SetProtection(Value: TProtection);
  protected
    procedure CodeInit(Action: TPAction); virtual;
    procedure CodeDone(Action: TPAction); virtual;
    procedure CodeBuf(const Buffer: TValueArr; const BufferSize: Integer; Action: TPAction); virtual;
  public
    constructor Create(AProtection: TProtection);
    destructor Destroy; override;
    function CodeBuffer(const Buffer: TValueArr; BufferSize: Integer; Action: TPAction): Integer; virtual;
    property Protection: TProtection read GetProtection write SetProtection;
    property Actions: TPActions read FActions write FActions default [paEncode..paWipe];
  end;

// Result := Value shl Shift or Value shr (32 - Shift)
function ROL(Value: LongWord; Shift: Integer): LongWord;
// XOR's buffers Data and XORBlock ByteSize bytes to Data
procedure XORBuffers({$IFDEF CLR}const{$ENDIF} Data: TIntArray; Offset: Integer; const XORBlock: TIntArray; ByteSize: Integer);
// XOR Buffer Size Bytes with Seed Randoms,
// the initial State from Buffer have effect on the Output
function RndXORBuffer(Seed: Integer; const Buf: TValueArr; Size: Integer): Integer;
function RndXORBufferL(Seed: Integer; const Buf: TIntArray; Size: Integer): Integer;
function SwapInteger(Value: LongWord): LongWord; {$IFNDEF CLR}register;{$ENDIF}
procedure SwapIntegerBuffer(const Source: TIntArray; const Dest: TIntArray; Count: Integer); {$IFNDEF CLR}register;{$ENDIF}
// Compare Memory, D2 have no CompareMem, Result can be -1, 0, 1
function MemCompare(const P1, P2: TIntArray; Size: Integer): Integer; {$IFNDEF CLR}register;{$ENDIF}

procedure ArrayClear(var Arr: TBytes; const Index: Integer; const Length: Integer);
procedure ArrayReverse(var Arr: TBytes; const Offset: Integer; const Length: Integer);

procedure CopyBuffer(Source, Dest: IntPtr; Count: Integer);

implementation

uses
{$IFNDEF CLR}
{$IFNDEF FPC}
{$IFDEF MSWINDOWS}
  Windows,
{$ENDIF}
{$ENDIF}
{$ENDIF}
  DAConsts;

{ TProtection }

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

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

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

procedure TProtection.SetProtection(Value: TProtection);

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

begin
  if Value <> FProtection then
    if CheckProtection(Value) then
      FProtection := Value
    else raise Exception.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(const Buffer: TValueArr; const BufferSize: Integer; Action: TPAction);
begin
  if Protection <> nil then Protection.CodeBuf(Buffer, BufferSize, Action);
end;

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

function ROL(Value: LongWord; Shift: Integer): LongWord; {$IFDEF UseASM}assembler;{$ENDIF}
{$IFNDEF UseASM}
begin
  Result := (Value shl Shift) or (Value shr (32 - Shift));

{$ELSE}
asm
       MOV   ECX,EDX
       ROL   EAX,CL
{$ENDIF}
end;

function SwapInteger(Value: LongWord): LongWord; {$IFDEF UseASM}assembler; register;{$ENDIF}
{$IFNDEF UseASM}
begin
  Result := ((Value and $ff) shl 24) or ((Value and $ff00) shl 8) or ((Value and $ff0000) shr 8) or ((Value and $ff000000) shr 24);

{$ELSE}
asm
       BSWAP  EAX
{$ENDIF}
end;

procedure SwapIntegerBuffer(const Source: TIntArray; const Dest: TIntArray; Count: Integer); {$IFDEF UseASM}assembler; register;{$ENDIF}
{$IFNDEF UseASM}
var
  i: Integer;
begin
  for i := 0 to Count - 1 do
    Dest[i] := SwapInteger(Source[i]);

{$ELSE}
asm
       TEST   ECX,ECX
       JLE    @Exit
       PUSH   EBX
       SUB    EAX,4
       SUB    EDX,4
@@1:   MOV    EBX,[EAX + ECX * 4]
       BSWAP  EBX
       MOV    [EDX + ECX * 4],EBX
       DEC    ECX
       JNZ    @@1
       POP    EBX
@Exit:
{$ENDIF}
end;

procedure XORBuffers({$IFDEF CLR}const{$ENDIF} Data: TIntArray; Offset: Integer; const XORBlock: TIntArray; ByteSize: Integer); {$IFDEF UseASM}assembler;{$ENDIF}
{$IFNDEF UseASM}
var
  LenInt, LenBytes: Integer;
  Last: Longword;
  i: Integer;
begin
  if Data = nil then
    Exit;

  LenInt := ByteSize shr 2;
  LenBytes := ByteSize and $3;
  for i := 0 to LenInt - 1 do
    Data[Offset + i] := Data[Offset + i] xor XORBlock[i];

  if LenBytes > 0 then begin
    Last := Data[Offset + LenInt] xor XORBlock[LenInt];

    for i := LenBytes downto 1 do begin
      Buffer.SetByte(Data, (Offset shl 2) + ByteSize - i, Byte(Last));
      Last := Last shr 8;
    end;
  end;

{$ELSE}
asm
       PUSH  ESI
       PUSH  EBX
       MOV   EBX,ByteSize

       AND   EBX,EBX
       JZ    @@4
       SHL   EDX,2
       ADD   EAX,EDX
       MOV   ESI,EAX
@@1:   TEST  EBX,3
       JNZ   @@3
@@2:   SUB   EBX,4
       JL    @@4
       MOV   EAX,[ESI + EBX]
       XOR   EAX,[ECX + EBX]
       MOV   [ESI + EBX],EAX
       JMP   @@2
@@3:   DEC   EBX
       MOV   AL,[ESI + EBX]
       XOR   AL,[ECX + EBX]
       MOV   [ESI + EBX],AL
       JMP   @@1
@@4:   POP   EBX
       POP   ESI
{$ENDIF}
end;

function RndXORBuffer(Seed: Integer; const Buf: TValueArr; Size: Integer): Integer; {$IFDEF UseASM}assembler;{$ENDIF}
{$IFNDEF UseASM}
var
  i: Integer;
begin
  Result := Seed;
  if Buf = nil then
    Exit;

  for i := 0 to Size - 1 do begin
    Result := (Result xor byte(Buf[i])) * 134775813;
    Inc(Result);
    TBytes(Buf)[i] := byte(Result shr 24);
  end;

{$ELSE}
asm
      AND     EDX,EDX
      JZ      @@2
      AND     ECX,ECX
      JLE     @@2
      PUSH    EBX
@@1:  XOR     AL,[EDX]
      IMUL    EAX,EAX,134775813
      INC     EAX
      MOV     EBX,EAX
      SHR     EBX,24
      MOV     [EDX],BL
      INC     EDX
      DEC     ECX
      JNZ     @@1
      POP     EBX
@@2:
{$ENDIF}
end;

function RndXORBufferL(Seed: Integer; const Buf: TIntArray; Size: Integer): Integer; {$IFDEF UseASM}assembler;{$ENDIF}
{$IFDEF CLR}
var
  i: Integer;
begin
  Result := Seed;
  if Buf = nil then
    Exit;

  for i := 0 to Size - 1 do begin
    Result := (Result xor Buffer.GetByte(Buf, i)) * 134775813;
    Inc(Result);
    Buffer.SetByte(Buf, i, Result shr 24);
  end;
{$ELSE}
begin
  Result := RndXORBuffer(Seed, Pointer(Buf), Size);
{$ENDIF}
end;

function MemCompare(const P1, P2: TIntArray; Size: Integer): Integer; {$IFDEF UseASM}assembler; register;{$ENDIF}
{$IFNDEF UseASM}
var
  i: Integer;
begin
  for i := 0 to Size div SizeOf(Integer) - 1 do
    if P1[i] <> P2[i] then begin
      Result := Integer(P2[i] - P1[i]);
      Exit;
    end;

  Result := 0;
{$ELSE}
asm
       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
{$ENDIF}
end;

procedure ArrayClear(var Arr: TBytes; const Index: Integer; const Length: Integer);
begin
  if Length > 0 then
  {$IFNDEF CLR}
    FillChar(Arr[Index], Length, 0);
  {$ELSE}
    &Array.Clear(Arr, Index, Length);
  {$ENDIF}
end;

procedure ArrayReverse(var Arr: TBytes; const Offset: Integer; const Length: Integer);
{$IFNDEF CLR}
var
  i, j: Integer;
  t: Byte;
{$ENDIF}
begin
{$IFNDEF CLR}
  j := Length + Offset - 1;
  for i := Offset to Length shr 1 + Offset - 1 do begin
    t := Arr[i];
    Arr[i] := Arr[j];
    Arr[j] := t;
    Dec(j);
  end;

{$ELSE}
  &Array.Reverse(Arr, Offset, Length);
{$ENDIF}
end;

{$IFDEF CLR}
[DllImport('kernel32.dll')]
procedure CopyMemory(Dest, Source: IntPtr; Count: cardinal); external;
{$ENDIF}

procedure CopyBuffer(Source, Dest: IntPtr; Count: Integer);
begin
{$IFDEF CLR}
  CopyMemory(Dest, Source, Count);
{$ELSE}
  Move(Source^, Dest^, Count);
{$ENDIF}
end;

end.


