ctdwzrd.pas

Citadel v.1.6 Full Sources

        Writer.CopyTo(CtdRegPos);
        Writer.DeleteTo(EndPos);
        Writer.Insert(PAnsiChar(RegText));
        Writer.CopyTo(Size-1);
      finally
        Writer := nil;
      end;
    end;
  finally
    FreeMem(Text);
  end;

  if not WasModified then
    CitadelModule.Save(False, True);

  Modified := False;
end;

procedure TFormCtdWizard.ProcessProject;
var
  DoRemoveReloc: Boolean;
begin
  Screen.Cursor := crHourGlass;
  try
    CtdWzrdWork := TCtdWzrdWork.Create;
    try
      try
        try
          LogEnabled    := CheckBoxLog.Checked;
          DoRemoveReloc := CheckBoxReloc.Checked;
          if DoRemoveReloc
          then ProgressBar.Max := 1
          else ProgressBar.Max := 0;
          ProgressBar.Position := 0;
          LabelUrl   .Visible := False;
          ProgressBar.Visible := True;
          Application.ProcessMessages;
          CtdWzrdWork.CheckAbort(Abort);

          {$ifndef CtdNoPack}
          {$ifndef CtdNoLog}
          if LogEnabled
          then ctdUnPak.WriteToLog := WriteToLog
          else ctdUnPak.WriteToLog := CtdDummyWriteToLog;
          {$endif CtdNoLog}
          {$endif CtdNoPack}

          try
            CtdWzrdWork.ProcessExe(LogEnabled, DoRunTimeLog, ProgressBar.Max);
            MessageBeep(MB_OK);
            Application.MessageBox(PChar(CtdWzrdWork.LastMsg), 'Citadel', MB_OK);
            Assert(ProgressBar.Max = ProgressBar.Position);
          finally
            ProgressBar.Visible := False;
            LabelUrl   .Visible := True;
          end;
        finally
          {$ifndef CtdNoPack}
          {$ifndef CtdNoLog}
          ctdUnPak.WriteToLog := CtdDummyWriteToLog;
          {$endif CtdNoLog}
          {$endif CtdNoPack}
        end;
      except
        on E: Exception do
        begin
          MessageBeep(MB_ICONHAND);
          if not Abort then
            Application.HandleException(Self);
        end;
      end;
    finally
      FreeAndNil(CtdWzrdWork);
    end;
  finally
    Screen.Cursor := crDefault;
    SetFocus;
  end;
end;

procedure TFormCtdWizard.ShowHelp(Control: TControl);
begin
  if Processing
  then
  begin
    LabelHelp.Caption := 'Press Escape key to abort the process.';
    CurControl := nil;
  end
  else
  begin
    if Control.Hint = '' then
      Control := ActiveControl;
    if Control = nil
    then
    begin
      LabelHelp.Caption := '';
      CurControl := nil;
    end
    else
    begin
      if Control <> CurControl then
      begin
        LabelHelp.Caption := Control.Hint;
        CurControl := Control;
      end;
    end;
  end;
end;

procedure TFormCtdWizard.ShowScreenMessage(Text: String; LogMode: TCtdLogModes;
  Append: Boolean);
begin
  if not(lmLogOnly in LogMode) then
  begin
    if Append
    then
    begin
      PanelMessage.Caption := PanelMessage.Caption + ' - ' + Text;
      PanelMessage.Hint    := PanelMessage.Hint + #13#10 + Text;
    end
    else
    begin
      PanelMessage.Caption := Text;
      PanelMessage.Hint    := Text;
    end;
  end;

  Application.ProcessMessages;
end;

procedure TFormCtdWizard.CheckBoxRelocMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  ShowHelp(Sender as TControl);
end;

procedure TFormCtdWizard.CheckBoxPackEnter(Sender: TObject);
begin
  ShowHelp(Sender as TControl);
end;

procedure TFormCtdWizard.CheckBoxCryptClick(Sender: TObject);
begin
  LabelPassword.Enabled := CheckBoxCrypt.Checked;
  {$ifndef CtdDoTrial}
  EditPassword .Enabled := CheckBoxCrypt.Checked;
  if EditPassword.Enabled
  then EditPassword.Color := clWindow
  else EditPassword.Color := clLtGray;
  {$endif CtdDoTrial}
end;

procedure TFormCtdWizard.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  ModuleClassesList.Free;
  UpdateComp;
  if Modified then
  begin
    try
      UpdateUnit;
    except
      on E: Exception do
      begin
        Application.ShowException(E);
        Modified := False;
      end;
    end;
  end;
end;

procedure TFormCtdWizard.LabelUrlClick(Sender: TObject);
var
  Url,
  Ident: String;
  MajorVersion,
  MinorVersion: Char;
begin
  MajorVersion := CtdVersion[ 9];
  MinorVersion := CtdVersion[11];
  {$ifdef CtdDoTrial}
  Url := 'http://www.billeniumsoft.com/ctd/order.htm?';
  Ident := 't1';
  {$else}
  Url := 'http://www.billeniumsoft.com?ctd';
  Ident := 'r1';
  {$endif CtdDoTrial}
  ShellExecute(Application.MainForm.Handle, nil,
    PChar(Url + MajorVersion + MinorVersion + Ident), nil, nil, SW_SHOWNORMAL);
end;

procedure TFormCtdWizard.PanelOptionsMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
var
  Wnd: HWnd;
  Control: TWinControl;
begin
  Wnd := ChildWindowFromPoint(PanelOptions.Handle, Point(X, Y));
  if Wnd <> PanelOptions.Handle then
  begin
    Control := FindControl(Wnd);
    if Control <> nil then
      ShowHelp(Control);
  end;
end;

procedure TFormCtdWizard.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  {$ifndef CtdNoLog}
  if(not Processing) and (ssCtrl in Shift) and (Key = VK_F1) then
  begin
    DoRuntimeLog := not DoRuntimeLog;

    if DoRuntimeLog
    then
    begin
      ShowMessage(
        'You have configured Citadel to also write the log each' + #13#10 + 
        'time you open a form at runtime.' + #13#10 + #13#10 +
        'Please use this option only for debugging a problem in' + #13#10 +
        'Citadel and never distribute your executables created' + #13#10 +
        'this way.');
      CheckBoxLog.Caption := '&Log / Runtime log';
    end
    else CheckBoxLog.Caption := '&Log';
  end;
  {$endif CtdNoLog}

  if Key = VK_ESCAPE then
  begin
    if Processing
    then Abort := MessageDlg('Abort process?', mtConfirmation, [mbYes, mbNo], 0) = mrYes
    else Close;
  end;
end;

procedure TFormCtdWizard.FormDestroy(Sender: TObject);
begin
  {$ifndef CtdNoPack}
  FreeAndNil(ctdPak.Palette);
  {$endif CtdNoPack}
end;

procedure TCtdWzrdWork.PreProcess(var ExeFileName, ResName: String);

  function ParseDpr(Editor: IOTASourceEditor): String;
  const
    BlockSize = 8192;
  var
    Reader: IOTAEditReader;
    Stream: TMemoryStream;
    Pos,
    i: Integer;
    NrRead: Integer;
    Buf,
    P: PAnsiChar;
    aux: AnsiChar;
  begin
    Reader := Editor.CreateReader;
    GetMem(Buf, BlockSize+1);
    try
      Stream := TMemoryStream.Create;
      try
        Pos := 0;
        repeat
          NrRead := Reader.GetText(Pos, Buf, BlockSize);
          Inc(Pos, NrRead);
          Stream.WriteBuffer(Buf^, NrRead);
        until NrRead < BlockSize;
        aux := #0;
        Stream.Write(aux, 1);
        P := StrPos(StrLower(PAnsiChar(Stream.Memory)), '{$e ');
        if P <> nil then
        begin
          P := PAnsiChar(Longint(P) + 4);
          Buf[0] := '.';
          i := 0;
          while P[i] <> '}' do
          begin
            Buf[i+1] := P[i];
            Inc(i);
          end;
          Buf[i+1] := #0;
          Result := String(Buf);
        end;
      finally
        Stream.Free;
      end;
    finally
      FreeMem(Buf);
    end;
  end;

  function GetOutputExtension(Project: IOTAProject40): String;
  var
    i: Integer;
    Editor: IOTASourceEditor;
  begin
    Result := '';
    Editor := nil;
    for i := 0 to Project.GetModuleFileCount-1 do
    begin
      if CompareText(ExtractFileExt(Project.GetModuleFileEditor(i).FileName), '.dpr') =  0 then
      begin
        Project.GetModuleFileEditor(i).QueryInterface(IOTASourceEditor, Editor);
        break;
      end;
    end;

    if Editor <> nil then
      Result := ParseDpr(Editor);

    if Result = '' then
    begin
      if Project.ProjectOptions.GetOptionValue('GenDll')
      then Result := '.dll'
      else Result := '.exe';
    end;
  end;

  function GetOutputFileName(Project: IOTAProject40): String;
  var
    CurrentDir,
    OutputDir,
    ProjectFileName,
    Extension: String;
  begin
    ShowMsg('  Verifying output filename:');
    OutputDir  := Project.ProjectOptions.GetOptionValue('OutputDir');
    CurrentDir := GetCurrentDir;
    SetCurrentDir(ExtractFilePath(Project.FileName));
    try
      if OutputDir = '' then
        OutputDir := '.';
      OutputDir := ExpandUNCFileName(OutputDir);
      if OutputDir[Length(OutputDir)] <> '\' then
        OutputDir := OutputDir + '\';
      ShowMsg('    OutputDir: ' + OutputDir);
    finally
      SetCurrentDir(CurrentDir);
    end;
    ProjectFileName := ExtractFileName(Project.FileName);
    ShowMsg('    Project FileName: ' + ProjectFileName);
    Extension       := GetOutputExtension(Project);
    if(Extension[1] = '.') and (Extension[2] = '.') then
      Extension := Copy(Extension, 2, Length(Extension)-1);
    ShowMsg('    Extension: ' + Extension);

    Result := OutputDir + ChangeFileExt(ProjectFileName, Extension);
    ShowMsg('    FileName: ' + Result);
  end;

  function GetNameOnly(const S: String): String;
  var
    aux: String;
    p: Integer;
  begin
    aux := ExtractFileName(S);
    p := Pos('.', aux);
    if P > 1
    then Result := Copy(aux, 1, P-1)
    else Result := aux;
  end;

  procedure CheckModuleInProject(Project: IOTAProject40);
  var
    i: Integer;
    OwnedByProject: Boolean;
  begin
    OwnedByProject := False;
    for i := 0 to FormCtdWizard.CitadelModule.OwnerCount - 1 do
    begin
      if FormCtdWizard.CitadelModule.Owners[i] = Project then
      begin
        OwnedByProject := True;
        break;
      end;
    end;
    if not OwnedByProject then
      raise Exception.Create(
        Format('Unit ''%s'' does not belong to project ''%s''',
          [GetNameOnly(FormCtdWizard.CitadelModule.FileName),
          GetNameOnly(Project.FileName)]));
  end;

  procedure GetProjectSettings(var Project: IOTAProject40;
    var OutputFileName, ResName: String);
  var
    CompileMode: TOTACompileMode;
  begin
    ShowMsg('Checking project settings...');

    Project := GetActiveProject;
    ShowMsg('  Verifying packages');
    if Project.ProjectOptions.GetOptionValue('UsePackages') then
      raise Exception.Create('Runtime packages not supported');

    ShowMsg('  Verifying module in project');
    CheckModuleInProject(Project);
    OutputFileName := GetOutputFileName(Project);
    ShowMsg('  Updating unit');
    FormCtdWizard.UpdateUnit;

    ShowMsg('  Compiling project...');
    if FormCtdWizard.BuildProject
    then CompileMode := cmOTABuild
    else CompileMode := cmOTAMake;
    if not Project.ProjectBuilder.BuildProject(CompileMode, False) then
      raise Exception.Create('There are compilation errors');
    if not FileExists(OutputFileName) then
      raise Exception.Create(Format('File ''%s'' not found', [OutputFileName]));

    ResName :=
      UpperCase(FormCtdWizard.EditorDesigner.GetRoot.ClassName);
    ShowMsg('  Citadel resource: ' + ResName);
  end;

  procedure CheckTxtDfms;
  var
    i,
    j: Integer;
    Found: Boolean;
    Project: IOTAProject40;
    ModuleServices: IOTAModuleServices;
    Module: IOTAModule;
    FileName: String;
  begin
    ModuleServices := BorlandIDEServices as IOTAModuleServices;

    Project := GetActiveProject;
    for i := 0 to ModuleServices.ModuleCount-1 do
    begin
      Module := ModuleServices.Modules[i];
      if CompareText(ExtractFileExt(Module.GetFileName), '.dfm') =  0 then
      begin
        Found := False;
        FileName := ChangeFileExt(Module.GetFileName, '.pas');
        for j := 0 to Project.GetModuleCount - 1 do
        begin
          if CompareText(Project.GetModule(j).FileName, FileName) = 0 then
          begin
            Found := True;
            break;
          end;
        end;
        if Found then
          raise Exception.Create(
            'Please close ' + #13#10 + Module.GetFileName +
            #13#10 + 'After doing that you must execute again this process.');
      end;
    end;
  end;

begin
  GetProjectSettings(Project, ExeFileName, ResName);
  if FormCtdWizard.CheckBoxPack.Checked then
  begin
    ShowMsg('Checking opened dfms...');
    CheckTxtDfms;
  end;
end;

procedure TCtdWzrdWork.ProgressStep(const StepSize: Integer = 1);
begin
  Assert(
    FormCtdWizard.ProgressBar.Max >= FormCtdWizard.ProgressBar.Position + StepSize,
    Format(
      'Max=%d; Pos=%d; Step=%d',
      [FormCtdWizard.ProgressBar.Max, FormCtdWizard.ProgressBar.Position, StepSize]));
  FormCtdWizard.ProgressBar.StepBy(StepSize);
  Application.ProcessMessages;
  CheckAbort(FormCtdWizard.Abort);
end;

procedure TCtdWzrdWork.SetProgressSteps(const Steps: Integer);
begin
  FormCtdWizard.ProgressBar.Max := Steps;
end;

procedure WriteToLog(const Text: String; LogMode: TCtdLogModes);
begin
  Assert(CtdWzrdWork <> nil);
  CtdWzrdWork.ShowMsg(Text, LogMode);
end;

procedure TCtdWzrdWork.ShowMsg(const Msg: String; LogMode: TCtdLogModes);
begin
  inherited;

  FormCtdWizard.ShowScreenMessage(Msg, LogMode);
  CheckAbort(FormCtdWizard.Abort);
end;

function TCtdWzrdWork.Name: String;
begin
  Result := 'wizard';
end;

function TCtdWzrdWork.GetIDEVersion: String;
var
  strCSet: String;
  aux,
  VSize: DWord;
  VData: Pointer;
  aux2: Cardinal;
  Buf,
  pTransTab: Pointer;
  Info: PVSFixedFileInfo;
begin
  VSize := GetFileVersionInfoSize(PChar(Application.ExeName), aux);
  GetMem(VData, VSize);
  try
    aux2 := 0;
    GetFileVersionInfo(PChar(Application.ExeName), aux2, VSize, VData);
    VerQueryValue(VData, '\', Pointer(Info), aux);
    Result := 'Delphi ' +
      IntToStr(HiWord(Info.dwFileVersionMS)) + '.' +
      IntToStr(LoWord(Info.dwFileVersionMS)) + '.' +
      IntToStr(HiWord(Info.dwFileVersionLS)) + '.' +
      IntToStr(LoWord(Info.dwFileVersionLS));
    VerQueryValue(VData, '\\VarFileInfo\\Translation', pTransTab,
      VSize);
    strCSet:= '\\StringFileInfo\\' +
      IntToHex(LoWord(Longint(pTransTab^)), 4) +
      IntToHex(HiWord(Longint(pTransTab^)), 4) + '\\';
    if VerQueryValue(VData, PChar(strCSet + 'ProductName'), Buf, VSize) then
      Result := Result + ' ' + PChar(Buf);
    if VerQueryValue(VData, PChar(strCSet + 'ProductTitle'), Buf, VSize) then
      Result := Result + ' ' + PChar(Buf);
  finally
    FreeMem(VData);
  end;
end;

end.