ctdeng.pas

Citadel v.1.6 Full Sources

unit ctdEng;

interface

{$INCLUDE ctdDefs.inc}

uses Windows, Classes, SysUtils, Forms, ctdAux;

type
  {$ifndef CTD_NOHLP}
  TCtdRegProc = procedure();
  {$endif CTD_NOHLP}

  TCtdEngine = class(TComponent)
  private
    function  GetVersion: String;
    procedure SetVersion(const Value: String);
    procedure ReadCtdConfig(Stream: TStream);
    procedure WriteCtdConfig(Stream: TStream);
  protected
    Config: TCtdConfig;

    procedure DefineProperties(Filer: TFiler); override;
  public
    {$ifndef CTD_NOHLP}
    constructor Create(AOwner: TComponent); override;
    {$endif CTD_NOHLP}
  published
    property Version: String read GetVersion write SetVersion stored False;
  end;

  procedure CtdReg; overload;
  {$ifndef CTD_NOHLP}
  procedure CtdReg(const RegProcs: array of TCtdRegProc); overload;
  procedure CtdReg(const RegProcs: array of TCtdRegProc;
    const Password: array of AnsiChar); overload;
  {$ifndef CtdNoPack}
  procedure CtdRgPak;
  {$ifndef CtdNoRTLog}
  procedure CtdRgLog;
  {$endif CtdNoRTLog}
  {$endif CtdNoPack}
  procedure CtdRgCompress;
  {$ifndef CtdNoCrypt}
  procedure CtdRgCrypt;
  {$endif CtdNoCrypt}
  {$endif CTD_NOHLP}

implementation

uses
  {$ifndef CtdNoCrypt}
  ctdCrypt,
  {$endif CtdNoCrypt}
  {$ifndef CtdNoPack}
  ctdUnpak,
  {$endif CtdNoPack}
  ctdCompr;

const
  FilerSignature: array[0..3] of AnsiChar = 'TPF0';


var
  {$ifndef CtdNoPack}
  UnpakProc  : procedure(RootClass: TComponentClass; Input, Output: TStream);
  {$ifndef CtdNoRTLog}
  LogFile: TextFile;
  {$endif CtdNoRTLog}
  {$endif CtdNoPack}
  ExpandProc : procedure(InStr, OutStr: TStream);
  {$ifndef CtdNoCrypt}
  DecryptProc: procedure(Password: AnsiString; BufferOrg, BufferDst: Pointer;
    BufLen: Integer);
  {$endif CtdNoCrypt}
  CtdPassword: AnsiString;

{$ifndef CtdNoPack}
{$ifndef CtdNoRTLog}
procedure CtdLog(const Text: String;
  LogMode: TCtdLogModes = [lmLogOnly, lmSecondary]);
begin
  WriteLn(LogFile, Text);
end;
{$endif CtdNoRTLog}
{$endif CtdNoPack}

{$ifdef CtdDoTrial}
{$include trial\taux5.inc}
{$endif CtdDoTrial}

type
  TCtdMemStream = class(TMemoryStream);

procedure CtdDecodeDFM(const ComponentClass: TComponentClass;
  var InStream: TResourceStream; var OutStream: TMemoryStream;
  const Password: AnsiString);
var
  IsPacked,
  IsCompressed,
  IsEncrypted: Boolean;
  CurStream: TCustomMemoryStream;
  {$ifndef CtdNoCrypt}
  DecPassword: AnsiString;
  {$endif CtdNoCrypt}
  {$ifndef CtdNoPack}
  {$ifndef CtdNoRTLog}
  FileName: String;
  {$endif CtdNoRTLog}
  {$endif CtdNoPack}
begin
  Assert(ComponentClass <> nil);
  Assert(InStream <> nil);
  Assert(OutStream = nil);

  if not CtdReadSignature(InStream.Memory, IsPacked, IsCompressed, IsEncrypted) then
    raise Exception.Create('Incorrect signature in ' + ComponentClass.ClassName + '''s dfm');

  CurStream := nil;
  try
    {$ifndef CtdNoCrypt}
    if IsEncrypted
    then
    begin
      SetLength(DecPassword, Length(Password));
      DecryptProc('citadel', PByte(Password), PByte(DecPassword), Length(DecPassword));

      CurStream := TMemoryStream.Create;
      CurStream.Size := InStream.Size;
      CurStream.Write(FilerSignature, 4);
      DecryptProc(DecPassword, Pointer(Longint(InStream.Memory) + 4),
        Pointer(Longint(CurStream.Memory) + 4), InStream.Size - 4);
      InStream.Free;
    end
    else
    {$endif CtdNoCrypt}
    begin
      CurStream := InStream;
    end;
    InStream := nil;

    if IsCompressed then
    begin
      OutStream := TMemoryStream.Create;
      OutStream.Write(FilerSignature, 4);
      CurStream.Position := 4;
      ExpandProc(CurStream, OutStream);
      CurStream.Free;
      CurStream := OutStream;
      OutStream := nil;
    end;

    {$ifndef CtdNoPack}
    if IsPacked
    then
    begin
      OutStream := TMemoryStream.Create;
      OutStream.Write(FilerSignature, 4);
      CurStream.Position := 4;

      {$ifndef CtdNoRTLog}
      if @WriteToLog <> @CtdDummyWriteToLog then
      begin
        FileName :=
          ExtractFilePath(Application.ExeName) + 'ctdlog.txt';
        AssignFile(LogFile, FileName);
        if FileExists(FileName)
        then Append (LogFile)
        else Rewrite(LogFile);
        WriteLn(LogFile,
          '** Runtime log started at ' + FormatDateTime('dd/mm/yy hh:nn:ss', Now) +
          ' - ' + 'Citadel ' + CtdVersion +
          {$ifdef D5}' for Delphi 5' + {$endif D5}
          {$ifdef D6}' for Delphi 6' + {$endif D6}
          {$ifdef D7}' for Delphi 7' + {$endif D7}
          ' **');
      end;
      try
        try
          {$endif CtdNoRTLog}
          UnpakProc(TComponentClass(ComponentClass), CurStream, OutStream);

          {$ifndef CtdNoRTLog}
          if @WriteToLog <> @CtdDummyWriteToLog then
            WriteLn(LogFile, 'Log finished at ' + FormatDateTime('hh:nn:ss', Time));
        except
          on E: Exception do
          begin
            if @WriteToLog <> @CtdDummyWriteToLog then
              WriteLn(LogFile, E.Message);
            raise;
          end;
        end;
      finally
        if @WriteToLog <> @CtdDummyWriteToLog then
          CloseFile(LogFile);
      end;
      {$endif CtdNoRTLog}

      CurStream.Free;
    end
    else
    {$endif CtdNoPack}
    begin
      OutStream := CurStream as TMemoryStream;
    end;
    CurStream := nil;
  finally
    InStream .Free;
    CurStream.Free;
    InStream := nil;
  end;
end;

{$ifdef CtdDoTrial}
{$include trial\taux3.inc}
{$endif CtdDoTrial}

function NewInternalReadComponentRes(const ResName: string; HInst: THandle;
  var Instance: TComponent): Boolean;
var
  HRsrc: THandle;
  ResourceStream: TResourceStream;
  DecodeStream: TMemoryStream;
  Signature: array[0..3] of AnsiChar;
  ClassType: TClass;
  {$ifdef CtdSaveDfm}
  SaveStream: TMemoryStream;
  {$endif CtdSaveDfm}
begin
  if HInst = 0 then HInst := HInstance;
  {$ifdef D12UP}
  HRsrc := FindResourceW(HInst, PWideChar(ResName), PWideChar(RT_RCDATA));
  {$else}
  HRsrc := FindResource(HInst, PChar(ResName), RT_RCDATA);
  {$endif D12UP}
  Result := HRsrc <> 0;
  if not Result then Exit;
  ResourceStream := TResourceStream.Create(HInst, ResName, RT_RCDATA);
  try
    ResourceStream.Read(Signature, 4);
    if DWord(Signature) = DWord(FilerSignature)
    then
    begin
      ResourceStream.Position := 0;
      Instance := ResourceStream.ReadComponent(Instance);
    end
    else
    begin
      try
        DecodeStream := nil;
        ClassType := Instance.ClassType;
        while(CompareText(ClassType.ClassName, ResName) <> 0) and
             (ClassType <> TComponent) do
          ClassType := ClassType.ClassParent;
        {$ifdef CtdSaveDfm}
        ShowMessage('Dfm ''' + ResName + ''' is going to be decoded');
        {$endif CtdSaveDfm}
        CtdDecodeDFM(TComponentClass(ClassType), ResourceStream, DecodeStream,
          CtdPassword);
        {$ifdef CtdSaveDfm}
        SaveStream := TMemoryStream.Create;
        try
          DecodeStream.Position := 0;
          ShowMessage('Binary to text processing');
          ObjectBinaryToText(DecodeStream, SaveStream);
          SaveStream.SaveToFile(ExtractFilePath(Application.ExeName) + ResName + '.ctd');
          ShowMessage('''' + ResName + '.ctd'' file created');
        finally
          SaveStream.Free;
        end;
        {$endif CtdSaveDfm}
        DecodeStream.Position := 0;
        try
          Instance := DecodeStream.ReadComponent(Instance);
        except
          on E: Exception do
            raise Exception.Create(ResName + ': ' + E.Message);
        end;
      finally
        DecodeStream.Free;
      end;
    end;
  finally
    ResourceStream.Free;
  end;
  Result := True;
end;

{$ifdef CtdDoTrial}
{$include trial\taux4.inc}
{$endif CtdDoTrial}

procedure HookInternalReadComponentRes;
var
  ICR: PByteArray;
  IRCR: Pointer;
  i,
  j,
  SaveProtect: Integer;
  IsRunTimePackage: Boolean;
begin
  IsRunTimePackage :=
    FindClassHInstance(TPersistent) <>
    FindHInstance(@HookInternalReadComponentRes);

  if not IsRunTimePackage then
  begin
    ICR  := PByteArray(@InitComponentRes);
    IRCR := nil;
    for i := 0 to 200 do
    begin
      if(ICR[i+5] = $E8) and (ICR[i+10] = $E8) then
      begin
        j := i + 11;
        repeat
          if ICR[j] = $E8 then
          begin
            IRCR := Pointer(PInteger(@PByteArray(ICR)[j+1])^ + Longint(ICR) + j + 5);
            break;
          end;
          Inc(j);
        until False;
        break;
      end;
    end;

    if IRCR = nil then
      raise Exception.Create('Citadel hooking error');

    if not VirtualProtect(IRCR, 5, PAGE_READWRITE, @SaveProtect) then
      {$ifndef D6Up}
      RaiseLastWin32Error;
      {$else}
      RaiseLastOSError;
      {$endif D6Up}

    PByte(IRCR)^ := $E9;
    {$OVERFLOWCHECKS OFF}
    PInteger(@PByteArray(IRCR)[1])^ :=
      DWord(@NewInternalReadComponentRes) - DWord(IRCR) - 5;
    {$OVERFLOWCHECKS ON}

    if not VirtualProtect(IRCR, 5, SaveProtect, @SaveProtect) then
      {$ifndef D6Up}
      RaiseLastWin32Error;
      {$else}
      RaiseLastOSError;
      {$endif D6Up}

    if IRCR = nil then
      InitComponentRes('', nil); 
  end;
end;

{ TCtdEngine }

constructor TCtdEngine.Create(AOwner: TComponent);
begin
  inherited;

  Config.RmvReloc := True;
  Config.Encrypt  := True;
  Config.Compress := True;
  Config.Pack     := True;
  {$ifdef Trial}
  Config.Password := 'trial';
  {$endif Trial}
end;

procedure TCtdEngine.ReadCtdConfig(Stream: TStream);
begin
  CtdReadConfig(Stream, Config, True);
end;

procedure TCtdEngine.WriteCtdConfig(Stream: TStream);
begin
  CtdWriteConfig(Stream, Config);
end;

procedure TCtdEngine.DefineProperties(Filer: TFiler);
begin
  inherited;

  Filer.DefineBinaryProperty('CtdConfig', ReadCtdConfig, WriteCtdConfig, True);
end;

function TCtdEngine.GetVersion: String;
begin
  Result := CtdVersion;
end;

procedure TCtdEngine.SetVersion(const Value: String);
begin
end;

procedure CtdReg;
begin
end;

procedure CtdReg(const RegProcs: array of TCtdRegProc);
begin
  CtdReg(RegProcs, []);
end;

procedure CtdReg(const RegProcs: array of TCtdRegProc;
  const Password: array of AnsiChar);
var
  i: Integer;
begin
  {$ifdef CtdDoTrial}
  {$include trial\taux.inc}
  {$endif CtdDoTrial}

  {$ifndef CtdNoPack}
  UnpakProc   := nil;
  {$endif CtdNoPack}
  ExpandProc  := nil;
  {$ifndef CtdNoCrypt}
  DecryptProc := nil;
  {$endif CtdNoCrypt}
  {$ifdef CtdDoTrial}
  {$include trial\taux2.inc}
  {$endif CtdDoTrial}
  for i := 0 to High(RegProcs) do
    RegProcs[i];
  if SizeOf(RegProcs) > 0 then
    HookInternalReadComponentRes;
  {$ifdef CtdDoTrial}
  {$include trial\taux2.inc}
  {$endif CtdDoTrial}                         
  SetLength(CtdPassword, SizeOf(Password));
  for i := 0 to High(Password) do
    CtdPassword[i+1] := AnsiChar(Password[i]);

  {$ifdef CtdDoTrial}
  {$include trial\taux7.inc}
  {$endif CtdDoTrial}
end;

{$ifndef CtdNoPack}
procedure CtdRgPak;
begin
  UnpakProc := CtdObjectPackedToBinary;
end;

{$ifndef CtdNoRTLog}
procedure CtdRgLog;
begin
  ctdUnpak.WriteToLog := CtdLog;
  ctdUnpak.RuntimeLog := True;
end;
{$endif CtdNoRTLog}
{$endif CtdNoPack}

procedure CtdRgCompress;
begin
  ExpandProc := CtdExpand;
end;

{$ifndef CtdNoCrypt}
procedure CtdRgCrypt;
begin
  DecryptProc := CtdDecrypt2;
end;
{$endif CtdNoCrypt}

end.