ctdwzrd.pas

Citadel v.1.6 Full Sources

unit ctdWzrd;

interface

{$INCLUDE ctdDefs.inc}

uses
  {$ifdef D6UP}
  DesignIntf,
  {$else}
  Dsgnintf,
  {$endif D6UP}
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ctdEng, Buttons, ToolsAPI, ComCtrls, ExtCtrls, ctdWork, ctdAux;

type
  TFormCtdWizard = class(TForm)
    Panel1: TPanel;
    ButtonApply: TBitBtn;
    ButtonClose: TBitBtn;
    PanelOptions: TPanel;
    CheckBoxReloc: TCheckBox;
    CheckBoxPack: TCheckBox;
    CheckBoxCompress: TCheckBox;
    CheckBoxCrypt: TCheckBox;
    PanelMessage: TPanel;
    PanelHelp: TPanel;
    LabelHelp: TLabel;
    EditPassword: TEdit;
    LabelPassword: TLabel;
    ProgressBar: TProgressBar;
    LabelUrl: TLabel;
    CheckBoxLog: TCheckBox;
    procedure ButtonApplyClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure CheckBoxRelocMouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure CheckBoxPackEnter(Sender: TObject);
    procedure CheckBoxCryptClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure LabelUrlClick(Sender: TObject);
    procedure PanelOptionsMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormDestroy(Sender: TObject);
  private
    Engine: TCtdEngine;
    CurControl: TControl;
    EditorDesigner: {$ifdef D6UP}IDesigner{$else}IFormDesigner{$endif D6UP};
    CitadelModule: IOTAModule40;
    DoRuntimeLog: Boolean;
    Processing,
    Abort,
    BuildProject,
    Modified: Boolean;

    procedure UpdateComp;
    procedure UpdateUnit;
    procedure ShowScreenMessage(Text: String; LogMode: TCtdLogModes = [lmMain];
      Append: Boolean = False);
    procedure ShowHelp(Control: TControl);
    procedure ProcessProject;
  public
    procedure Initialize(Engine: TCtdEngine;
      DesignerValue: {$ifdef D6UP}IDesigner{$else}IFormDesigner{$endif D6UP});
  end;

  procedure WriteToLog(const Text: String;
    LogMode: TCtdLogModes = [lmLogOnly, lmSecondary]);

var
  FormCtdWizard: TFormCtdWizard;

implementation

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

{$R *.DFM}

type
  TCtdEngineHack  = class(TCtdEngine);

  TCtdWzrdWork = class(TCtdWork)
  protected
    procedure SetProgressSteps(const Steps: Integer); override;
  public
    procedure PreProcess(var ExeFileName, ResName: String); override;
    procedure ProgressStep(const StepSize: Integer = 1); override;
    procedure ShowMsg(const Msg: String;
      LogMode: TCtdLogModes = [lmMain]); override;
    function  Name: String; override;
    function  GetIDEVersion: String; override;
  end;

var
  CtdWzrdWork: TCtdWzrdWork;
  LogEnabled: Boolean;

{$ifndef CtdNoPack}
function DsgnGetFieldClassByIndex(AClass: TClass;
  var Index: Smallint): TPersistentClass;
var
  Fields: TStringList;
begin
  Result := nil;
  Fields := TStringList.Create;
  try
    GetClassFields(AClass, Fields);
    if Index = High(Smallint)
    then Index := Fields.Count
    else Result := TPersistentClass(Fields.Objects[Index]);
  finally
    Fields.Free;
  end;
end;
{$endif CtdNoPack}

function GetPaletteComponents: TStringList;

  procedure ExtractComponents(Text: String; List: TStringList);
  var
    i,
    NameIndex: Integer;
    Name: array[0..127] of Char;
  begin
    Text := TrimSpaces(Text, Length(Text));
    NameIndex := 0;
    for i := 1 to Length(Text) do
    begin
      if Text[i] = '.'
      then NameIndex := 0
      else if Text[i] <> ';'
      then
      begin
        Name[NameIndex] := Text[i];
        Inc(NameIndex);
      end
      else
      begin
        Name[NameIndex] := #0;
        NameIndex := 0;
        List.Add(Name);
      end
    end;
  end;

{$ifndef D9UP}
var
  Palettes: TStringList;
  Reg: TRegistry;
  Key: String;
  i: Integer;
{$endif D9UP}
begin
  Result := TStringList.Create;
  {$ifndef D9UP}
  Result.BeginUpdate;
  Reg := TRegistry.Create(KEY_READ);
  try
    Key :=
      {$ifdef D5}'5';{$endif D5}
      {$ifdef D6}'6';{$endif D6}
      {$ifdef D7}'7';{$endif D7}
    Key := '\Software\Borland\Delphi\' + Key + '.0\Palette';
    if Reg.OpenKey(Key, False) then
    begin
      Palettes := TStringList.Create;
      try
        Reg.GetValueNames(Palettes);
        for i := 0 to Palettes.Count-1 do
          ExtractComponents(Reg.ReadString(Palettes[i]), Result);
      finally
        Palettes.Free;
      end;
    end;
  finally
    Reg.Free;
  end;
  Result.EndUpdate;
  Result.Sort;
  {$endif D9UP}
end;

procedure TFormCtdWizard.FormCreate(Sender: TObject);
var
  Project: IOTAProject40;
begin
  {$ifndef CtdNoPack}
  DsgnGetFieldClassByIndexRoutine := @DsgnGetFieldClassByIndex;
  ctdPak.Palette := GetPaletteComponents;
  {$else}
  CheckBoxPack .Enabled := False;
  CheckBoxPack .Checked := False;
  {$endif CtdNoPack}
  {$ifdef CtdNoCrypt}
  EditPassword .Text    := 'not available';
  EditPassword .Enabled := False;
  CheckBoxCrypt.Enabled := False;
  CheckBoxCrypt.Checked := False;
  {$else}
  {$ifdef CtdDoTrial}
  EditPassword .Text    := 'trial';
  {$endif CtdDoTrial}
  {$endif CtdNoCrypt}
  {$ifdef CtdDoTrial}
  EditPassword .Enabled := False;
  {$endif CtdDoTrial}

  ModuleClassesList := TList.Create;
  CtdWzrdWork       := nil;

  PanelMessage.Hint := PanelMessage.Caption;

  Project := GetActiveProject;
  if Project.ProjectOptions.GetOptionValue('GenDll') then
  begin
    CheckBoxReloc.Enabled := False;
    CheckBoxReloc.Checked := False;
  end;

  {$ifdef CtdDoTrial}
  LabelUrl.Caption := 'Click here to buy now';
  LabelUrl.Hint    :=
    'Click to get the full version in just a few minutes by using our online ' +
    'secure ordering service.';
  {$endif CtdDoTrial}
end;

procedure TFormCtdWizard.Initialize(Engine: TCtdEngine;
  DesignerValue: {$ifdef D6UP}IDesigner{$else}IFormDesigner{$endif D6UP});
begin
  Self.Engine        := Engine;
  EditorDesigner     := DesignerValue;
  CitadelModule      := (BorlandIDEServices as IOTAModuleServices).CurrentModule;
  CurControl         := nil;
  Processing         := False;
  Abort              := False;
  Modified           := False;
  LabelPassword.Hint := EditPassword.Hint;

  if CheckBoxReloc.Enabled then
    CheckBoxReloc.Checked := TCtdEngineHack(Engine).Config.RmvReloc;
  if CheckBoxCompress.Enabled then
    CheckBoxCompress.Checked := TCtdEngineHack(Engine).Config.Compress;
  {$ifndef CtdNoPack}
  if CheckBoxPack.Enabled then
    CheckBoxPack.Checked := TCtdEngineHack(Engine).Config.Pack;
  {$endif CtdNoPack}
  {$ifndef CtdNoCrypt}
  if CheckBoxCrypt.Enabled then
    CheckBoxCrypt.Checked := TCtdEngineHack(Engine).Config.Encrypt;
  {$ifndef CtdDoTrial}
  EditPassword.Text := String(TCtdEngineHack(Engine).Config.Password);
  {$endif CtdDoTrial}
  {$endif CtdNoCrypt}

  DoRuntimeLog := False;
end;

procedure TFormCtdWizard.UpdateComp;
begin
  if TCtdEngineHack(Engine).Config.RmvReloc <> CheckBoxReloc.Checked then
  begin
    TCtdEngineHack(Engine).Config.RmvReloc := CheckBoxReloc.Checked;
    EditorDesigner.Modified;
    Modified := True;
  end;
  if TCtdEngineHack(Engine).Config.Compress <> CheckBoxCompress.Checked then
  begin
    TCtdEngineHack(Engine).Config.Compress := CheckBoxCompress.Checked;
    EditorDesigner.Modified;
    Modified := True;
  end;
  if TCtdEngineHack(Engine).Config.Pack <> CheckBoxPack.Checked then
  begin
    TCtdEngineHack(Engine).Config.Pack := CheckBoxPack.Checked;
    EditorDesigner.Modified;
    Modified := True;
  end;
  if TCtdEngineHack(Engine).Config.Encrypt <> CheckBoxCrypt.Checked then
  begin
    TCtdEngineHack(Engine).Config.Encrypt  := CheckBoxCrypt.Checked;
    EditorDesigner.Modified;
    Modified := True;
  end;
  {$ifdef CtdDoTrial}
  if TCtdEngineHack(Engine).Config.Password <> 'trial' then
  begin
    TCtdEngineHack(Engine).Config.Password := 'trial';
    EditorDesigner.Modified;
    Modified := True;
  end;
  {$else}
  if String(TCtdEngineHack(Engine).Config.Password) <> EditPassword.Text then
  begin
    TCtdEngineHack(Engine).Config.Password := AnsiString(EditPassword.Text);
    EditorDesigner.Modified;
    Modified := True;
  end;
  {$endif CtdDoTrial}
end;

procedure TFormCtdWizard.ButtonApplyClick(Sender: TObject);
begin
  {$ifdef CtdDoTrial}
  if CheckBoxReloc.Checked          and
     not (CheckBoxCompress.Checked  or
          CheckBoxPack    .Checked  or
          CheckBoxCrypt   .Checked) then
  begin
    MessageBeep(MB_ICONHAND);
    Application.MessageBox(
      'This trial version does not allow to select only the relocations option.',
      'Citadel', MB_OK);
    exit;
  end;
  {$endif CtdDoTrial}

  ButtonApply.Enabled := False;
  ButtonClose.Enabled := False;
  Processing          := True;
  Abort               := False;
  try
    UpdateComp;
    ShowHelp(nil);
    BuildProject := (GetKeyState(VK_CONTROL) and $80) <> 0;
    ProcessProject;
  finally
    Processing          := False;
    Abort               := False;
    ButtonApply.Enabled := True;
    ButtonClose.Enabled := True;
    ButtonApply.SetFocus;
  end;
end;

type
  TCtdMemStream = class(TMemoryStream);

procedure TFormCtdWizard.UpdateUnit;

  function LocateString(const Text, Search: PAnsiChar;
    const Start: Integer): Integer;
  var
    i,
    SPos: Integer;
    Ch1,
    Ch2: AnsiChar;
  begin
    Result := -1;
    SPos   := StrLen(Search) - 1;
    for i := Start downto 0 do
    begin
      Ch1 := Text[i];
      if (Ch1 >= 'a') and (Ch1 <= 'z') then
        Dec(Ch1, 32);
      Ch2 := Search[SPos];
      if (Ch2 >= 'a') and (Ch2 <= 'z') then
        Dec(Ch2, 32);
      if Ch1 = Ch2
      then
      begin
        if SPos = 0
        then
        begin
          Result := i;
          break;
        end
        else Dec(SPos);
      end
      else SPos := StrLen(Search) - 1;
    end;
  end;

  function LocateEnd(Text: PAnsiChar; Start, Len: Integer): Integer;
  var
    i: Integer;
  begin
    Result := -1;
    for i := Start to Len-1 do
    begin
      if Text[i] = ';' then
      begin
        Result := i+1;
        break;
      end;
    end;
  end;

var
  Buffer: array [0..8191] of AnsiChar;
  CurPos: Integer;
  Text: PAnsiChar;
  i,
  CtdRegPos,
  EndPos,
  TextLen,
  Size: Integer;
  Editor: IOTASourceEditor;
  First,
  WasModified: Boolean;
  Reader: IOTAEditReader;
  Writer: IOTAEditWriter;
  FileName: String;
  RegText: AnsiString;
  {$ifndef CtdNoCrypt}
  Password: AnsiString;
  {$endif CtdNoCrypt}
begin
  Editor := nil;
  for i := 0 to CitadelModule.GetModuleFileCount-1 do
  begin
    if CompareText(ExtractFileExt(CitadelModule.GetModuleFileEditor(i).FileName), '.pas') =  0 then
    begin
      CitadelModule.GetModuleFileEditor(i).QueryInterface(IOTASourceEditor, Editor);
      FileName := CitadelModule.GetModuleFileEditor(i).FileName;
      if Assigned(CtdWzrdWork) then
        CtdWzrdWork.ShowMsg('    Unit: ''' + FileName + '''');
      break;
    end;
  end;

  if Editor = nil then
    raise Exception.Create('Source editor not found');

  WasModified := Editor.GetModified;

  GetMem(Text, MaxPasSize);
  try
    Reader := Editor.CreateReader;
    try
      CurPos := 0;
      repeat
        Size := Reader.GetText(CurPos, Buffer, SizeOf(Buffer));
        if CurPos + Size > MaxPasSize then
          raise Exception.Create('Unit ''' + CitadelModule.GetModuleFileEditor(i).FileName + ''' too big');
        MoveMemory(@Text[CurPos], @Buffer, Size);
        Inc(CurPos, Size);
      until Size < SizeOf(Buffer);
    finally
      Reader := nil;
    end;

    TextLen := StrLen(Text);
    CtdRegPos := LocateString(Text, 'CtdReg', TextLen);
    if CtdRegPos <> -1 then
    begin
      if LocateString(Text, 'initialization', CtdRegPos) = -1 then
        CtdRegPos := -1;
    end;
    if CtdRegPos <> -1
    then EndPos := LocateEnd(Text, CtdRegPos, TextLen)
    else EndPos := -1;
    if(CtdRegPos = -1) or (EndPos = -1) then
      raise Exception.Create(
        'You must add ''CtdReg;'' to the initialization section of' +
        #13#10 + FileName + #13#10 +
        'After doing that you must execute again this process.');

    RegText := 'CtdReg';
    First := True;

    {$ifndef CtdNoPack}
    if CheckBoxPack.Checked then
    begin
      RegText := RegText + '([CtdRgPak';
      First := False;

      {$ifndef CtdNoLog}
      if CheckBoxLog.Checked and DoRuntimeLog then
        RegText := RegText + ', CtdRgLog';
      {$endif CtdNoLog}
    end;

    {$endif CtdNoPack}

    if CheckBoxCompress.Checked then
    begin
      if First
      then RegText := RegText + '(['
      else RegText := RegText + ', ';
      RegText := RegText + 'CtdRgCompress';
      First := False;
    end;

    {$ifndef CtdNoCrypt}
    if CheckBoxCrypt.Checked then
    begin
      if First
      then RegText := RegText + '(['
      else RegText := RegText + ', ';
      RegText := RegText + 'CtdRgCrypt';
      First := False;
    end;
    {$endif CtdNoCrypt}

    if not First
      then RegText := RegText + ']';

    if CheckBoxCrypt.Checked and (EditPassword.Text <> '') then
    begin
      {$ifndef CtdNoCrypt}
      {$ifdef CtdDoTrial}
      EditPassword.Text := 'trial';
      {$endif CtdDoTrial}

      {$ifdef D12}
      if EditPassword.Text <> UnicodeString(AnsiString(EditPassword.Text)) then
        raise Exception.Create('Please only use ANSI characters for the password');
      {$endif D12}
      Password := AnsiString(EditPassword.Text);
      CtdEncrypt('citadel', PAnsiChar(Password), Length(Password));
      RegText := AnsiString(Format('%s, [#%d', [RegText, Ord(Password[1])]));
      for i := 2 to Length(Password) do
        RegText := AnsiString(Format('%s,#%d', [RegText, Ord(Password[i])]));
      RegText := RegText + '])';
      {$endif CtdNoCrypt}
    end
    else
    begin
      if not First then
        RegText := RegText + ')';
    end;
    RegText := RegText + ';';

    if StrLComp(PAnsiChar(RegText), @Text[CtdRegPos], EndPos - CtdRegPos) <> 0 then
    begin
      Writer := Editor.CreateWriter;
      try