ctdwork.pas

Citadel v.1.6 Full Sources

unit ctdWork;

interface

{$INCLUDE ctdDefs.inc}

uses Windows, Classes, SysUtils,
  {$ifndef CtdNoPack}
  Controls,
  {$endif CtdNoPack}
  {$ifndef CtdCmd}
  Forms,
  ToolsAPI,
  {$endif CtdCmd}
  ctdAux;

type
  TCtdWork = class
  private
    MainLog,
    SecLog: TStringList;
  protected
    procedure ProcessDFMs(const ExeFileName: String;
      const DoPack, DoCompress, DoCrypt, DoRunTimeLog: Boolean;
      const Password: AnsiString; Steps: Integer;
      var TotDFMOrgSize, TotDFMDstSize: Double; var DFMCount: Integer);
    function ProcessDFM(const Name: String; const DoPackDFM, DoCompressDFM,
      DoEncryptDFM, DoRunTimeLog: Boolean; const PasswordDFM: AnsiString; UpdateHandle:
      THandle; var OrgSize, DstSize: Double): Boolean;
    procedure ProgressStep(const StepSize: Integer = 1); virtual;
    procedure SetProgressSteps(const Steps: Integer); virtual;
    procedure ShowMsg(const Msg: String;
      LogMode: TCtdLogModes = [lmMain]); virtual;
    function  Name: String; virtual; abstract;
    function  GetIDEVersion: String; virtual;
  public
    {$ifndef CtdCmd}
    Project: IOTAProject40;
    {$endif CtdCmd}
    LastMsg: String;
    DoLog: Boolean;

    constructor Create; virtual;
    destructor  Destroy; override;
    procedure CheckAbort(DoAbort: Boolean);
    procedure PreProcess(var ExeFileName, ResName: String); virtual;
    procedure ProcessExe(const DoLogValue, DoRunTimeLog: Boolean;
      Steps: Integer);
  end;

  TCtdBeginUpdRes = function(pFileName: PWideChar;
    bDeleteExistingResources: Boolean): THandle; stdcall;
  TCtdEndUpdRes   = function(hUpdate: THandle;
    fDiscard: Boolean): Boolean; stdcall;
  TCtdUpdRes      = function(hUpdate: THandle; lpType, lpName: PWideChar;
    wLanguage: Word; lpData: Pointer; cbData: DWord): Boolean; stdcall;
  TCtdGetRes      = function(hUpdate: THandle; lpType, lpName: PWideChar;
    wLanguage: Word; var lpData: Pointer; var cbData: DWord): Boolean; stdcall;

  {$ifndef CtdCmd}
  function GetActiveProject: IOTAProject40;
  {$endif CtdCmd}
  {$ifndef CtdNoPack}
  function GetComponentFromModule(const TheProject: IOTAProject40;
    const ClassName: String): TComponentClass;
  {$endif CtdNoPack}

var
  CtdBeginUpdRes: TCtdBeginUpdRes;
  CtdEndUpdRes  : TCtdEndUpdRes;
  CtdUpdRes     : TCtdUpdRes;
  CtdGetRes     : TCtdGetRes;

  ModuleClassesList: TList;

implementation

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

type
  TCtdMemStream = class(TMemoryStream);

{$ifndef CtdCmd}
function GetActiveProject: IOTAProject40;

  function FindModuleInterface(AInterface: TGUID): IUnknown;
  var
    i: Integer;
  begin
    Result := nil;
    with BorlandIDEServices as IOTAModuleServices do
      for i := 0 to ModuleCount - 1 do
        if Modules[i].QueryInterface(AInterface, Result) = S_OK then
          Break;
  end;

var
  ProjectGroup: IOTAProjectGroup;
begin
  ProjectGroup := FindModuleInterface(IOTAProjectGroup) as IOTAProjectGroup;
  if Assigned(ProjectGroup)
  then Result := ProjectGroup.ActiveProject
  else Result := FindModuleInterface(IOTAProject) as IOTAProject;
end;
{$endif CtdCmd}
{$ifndef CtdNoPack}
function GetComponentFromModule(const TheProject: IOTAProject40;
  const ClassName: String): TComponentClass;
var
  i,
  j: Integer;
  FormName: String;
  Editor: IOTAFormEditor;
  NTAComponent: INTAComponent;
  Project: IOTAProject40;
  Module: IOTAModule;
  aux: TClass;
  {$ifdef D6UP}
  OldGroup: TPersistentClass;
  {$endif D6UP}
begin
  Result := nil;
  if TheProject = nil
  then Project := GetActiveProject
  else Project := TheProject;
  FormName := Copy(ClassName, 2, Length(ClassName)-1);

  for i := 0 to Project.GetModuleCount-1 do
  begin
    if(CompareText(Project.GetModule(i).FormName, FormName) = 0) and
      (Project.GetModule(i).FileName <> '')                      then
    begin
      Module := (BorlandIDEServices as IOTAModuleServices).FindModule(
        Project.GetModule(i).FileName);
      if Module = nil then
        Module := Project.GetModule(i).OpenModule;
      break;
    end;
  end;

  if Module <> nil then
  begin
    begin
      for j := 0 to Module.GetModuleFileCount-1 do
      begin
        if Module.GetModuleFileEditor(j).
             QueryInterface(IOTAFormEditor, Editor) = S_OK then
        begin
          Assert(Editor <> nil);
          try
            Editor.GetRootComponent;
          except
            on Exception do
              raise Exception.Create(
                'Please close the project and reopen it.' + #13#10 +
                'After doing that you must execute again this process.');
          end;
          if Editor.GetRootComponent.
               QueryInterface(INTAComponent, NTAComponent) = S_OK then
          begin
            if NTAComponent.GetComponent <> nil then
            begin
              {$ifdef D6UP}
              OldGroup := ActivateClassGroup(TControl);
              try
              {$endif D6UP}
                Result := TComponentClass(NTAComponent.GetComponent.ClassType);
                aux := Result;
                repeat
                  ModuleClassesList.Add(aux);
                  aux := aux.ClassParent;
                until GetClass(aux.ClassName) <> nil;
                RegisterClass(TPersistentClass(Result));
              {$ifdef D6UP}
              finally
                ActivateClassGroup(OldGroup);
              end;
              {$endif D6UP}
            end;
            break;
          end;
        end;
      end;
    end;
  end;
end;
{$endif CtdNoPack}

procedure TCtdWork.CheckAbort(DoAbort: Boolean);
begin
  if DoAbort then
    raise Exception.Create('Process aborted by the user');
end;

constructor TCtdWork.Create;
begin
  MainLog := TStringList.Create;
  SecLog  := TStringList.Create;
end;

destructor TCtdWork.Destroy;
begin
  MainLog.Free;
  SecLog .Free;

  inherited;
end;

function TCtdWork.GetIDEVersion: String;
begin
end;

procedure TCtdWork.PreProcess(var ExeFileName, ResName: String);
begin
end;

function TCtdWork.ProcessDFM(const Name: String; const DoPackDFM, DoCompressDFM,
  DoEncryptDFM, DoRunTimeLog: Boolean; const PasswordDFM: AnsiString; UpdateHandle:
  THandle; var OrgSize, DstSize: Double): Boolean;

  function FirstDiffByte(P1, P2: PAnsiChar; Size: Integer): String;
  var
    i: Integer;
  begin
    i := 0;
    while(i < Size) and (P1[i] = P2[i]) do
      Inc(i);
    Result := IntToStr(i);
  end;

const
  DoSave      = False;
  DoFullStats = False;
var
  ResSize: Integer;
  ResData: Pointer;
  aux,
  Signature: DWord;
  StreamRes,
  StreamPak,
  StreamCompress,
  StreamCrypt,
  StreamUpd: TMemoryStream;
  WasPacked,
  WasCompressed,
  WasEncrypted,
  DoneCompress: Boolean;
  Msg: String;
  WName: array[0..255] of WideChar;

  {$ifndef CtdNoPack}
  i,
  SaveModuleCount: Integer;
  CompClass: TComponentClass;
  {$endif CtdNoPack}
  {$ifndef CtdNoUnpackExact}
  NameOutput: String;
  StreamUnPak,
  StreamExpand: TMemoryStream;
  {$endif CtdNoUnpackExact}
begin
  Result    := False;
  ShowMsg('Processing resource: ' + Name);
  DoneCompress := False;

  StringToWideChar(Name, WName, SizeOf(WName) div 2);
  if not CtdGetRes(UpdateHandle, PWideChar(RT_RCDATA), WName, 0, ResData, aux)
  then raise Exception.Create('Resource ''' + Name + ''' not found')
  else
  begin
    ResSize := Longint(aux);
    OrgSize := 0;
    DstSize := 0;
    ProgressStep;
    if not CtdReadSignature(ResData, WasPacked, WasCompressed, WasEncrypted) then
    begin
      if DoPackDFM then
        ProgressStep(2);
      if DoCompressDFM then
        ProgressStep(2);
      if DoEncryptDFM then
        ProgressStep(2);
      ProgressStep;
      ShowMsg('Resource discarded (not a DFM)');
      exit;
    end;

    OrgSize := ResSize;

    // Keep out signature
    ResData := Pointer(Longint(ResData) + 4);
    Dec(ResSize, 4);

    if DoPackDFM
    then
    begin
      {$ifndef CtdNoPack}
      SaveModuleCount := (BorlandIDEServices as IOTAModuleServices).ModuleCount;
      CompClass := GetComponentFromModule(Project, Name);
      {$endif CtdNoPack}
    end
    else
    begin
      {$ifndef CtdNoPack}
      CompClass := nil;
      SaveModuleCount := 0;
      {$endif CtdNoPack}
    end;
    try
      StreamRes := TMemoryStream.Create;
      try
        TCtdMemStream(StreamRes).SetPointer(ResData, ResSize);
        if DoSave then
          StreamRes.SaveToFile('D:\Proyecto\Temp\Dfms\' + Name + '-Res.txt');
        StreamRes.Position := 0;
        StreamPak := TMemoryStream.Create;
        try
          if DoPackDFM
          then
          begin
            ShowMsg('Packing DFM: ' + Name + '...');
            {$ifndef CtdNoPack}
            if DoLog then
              ShowMsg('***** Packing details *****', [lmLogOnly, lmSecondary]);
            {$ifndef CtdNoPack}
            CtdObjectBinaryToPacked(CompClass, StreamRes, StreamPak,
              DoRunTimeLog);
            {$endif CtdNoPack}
            if DoLog then
              ShowMsg('***** Packing finished *****', [lmLogOnly, lmSecondary]);
            {$endif CtdNoPack}
            ProgressStep;
          end
          else TCtdMemStream(StreamPak).SetPointer(StreamRes.Memory, StreamRes.Size);

          // StreamRes no more needed
          TCtdMemStream(StreamRes).SetPointer(nil, 0);
          FreeAndNil(StreamRes);

          if DoSave then
            StreamPak.SaveToFile('D:\Proyecto\Temp\Dfms\' + Name + '-Pak.txt');
          StreamPak.Position := 0;

          StreamCompress := TMemoryStream.Create;
          try
            DoneCompress := DoCompressDFM;
            if DoCompressDFM
            then
            begin
              ShowMsg('Compressing DFM: ' + Name + '...');
              CtdCompress(StreamPak, StreamCompress);
              ProgressStep;
              if StreamCompress.Size >= StreamPak.Size
              then
              begin
                StreamCompress.Clear;