jcldebugideimpl.pas

East make Tray Icon in delphi

//--------------------------------------------------------------------------------------------------

constructor TJclDebugExtension.Create;
begin
  inherited Create;
  Services := BorlandIDEServices as IOTAServices;
  Assert(Assigned(Services), 'IOTAServices not available');
  {$IFNDEF OldStyleExpert}
  FNotifierIndex := Services.AddNotifier(TIdeNotifier.Create(Self));
  {$ENDIF OldStyleExpert}
  RegisterCommand;
  {$IFNDEF OldStyleExpert}
  LoadExpertValues;
  {$ENDIF OldStyleExpert}
end;

//--------------------------------------------------------------------------------------------------

destructor TJclDebugExtension.Destroy;
begin
  {$IFNDEF OldStyleExpert}
  if FNotifierIndex <> -1 then
    Services.RemoveNotifier(FNotifierIndex);
  SaveExpertValues;
  {$ENDIF OldStyleExpert}
  UnregisterCommand;
  inherited;
end;

//--------------------------------------------------------------------------------------------------

procedure TJclDebugExtension.DisplayResults;
var
  I: Integer;
begin
  if FBuildError or (Length(FResultInfo) = 0) then
    Exit;
  with TJclDebugResultForm.Create(Application) do
  try
    for I := 0 to Length(FResultInfo) - 1 do
      with ResultListView.Items.Add, FResultInfo[I] do
      begin
        Caption := ProjectName;
        if Success then
        begin
          SubItems.Add(IntToStr(MapFileSize));
          SubItems.Add(IntToStr(JclDebugDataSize));
          SubItems.Add(Format('%3.1f', [JclDebugDataSize * 100 / MapFileSize]));
          SubItems.Add(ExecutableFileName);
          SubItems.Add(LinkerBugUnit);
          if LineNumberErrors > 0 then
            SubItems.Add(IntToStr(LineNumberErrors))
          else
            SubItems.Add('');
          ImageIndex := 0;
        end
        else
        begin
          SubItems.Add('');
          SubItems.Add('');
          SubItems.Add('');
          SubItems.Add(ExecutableFileName);
          SubItems.Add(LinkerBugUnit);
          SubItems.Add('');
          ImageIndex := 1;
        end;
      end;
    ShowModal;
  finally
    Free;
  end;
end;

//--------------------------------------------------------------------------------------------------

procedure TJclDebugExtension.EndStoreResults;
begin
  FStoreResults := False;
  FResultInfo := nil;
end;

//--------------------------------------------------------------------------------------------------

{$IFNDEF OldStyleExpert}

procedure TJclDebugExtension.ExpertActive(Active: Boolean);
begin
  FInsertDataAction.Checked := Active;
  HookBuildActions(Active);
end;

//--------------------------------------------------------------------------------------------------

procedure TJclDebugExtension.HookBuildActions(Enable: Boolean);
begin
  if Enable then
  begin
    if Assigned(FSaveBuildProject) then
      FSaveBuildProject.OnExecute := BuildProject;
    if Assigned(FSaveBuildAllProjects) then
      FSaveBuildAllProjects.OnExecute := BuildAllProjects;
  end
  else
  begin
    if Assigned(FSaveBuildProject) then
      FSaveBuildProject.OnExecute := FSaveBuildProjectExecute;
    if Assigned(FSaveBuildAllProjects) then
      FSaveBuildAllProjects.OnExecute := FSaveBuildAllProjectsExecute;
  end;
end;

//--------------------------------------------------------------------------------------------------

procedure TJclDebugExtension.InsertDataExecute(Sender: TObject);
begin
  ExpertActive(not FInsertDataAction.Checked);
  SaveExpertValues;
end;

//--------------------------------------------------------------------------------------------------

procedure TJclDebugExtension.LoadExpertValues;
begin
  ExpertActive(JediIniFile.ReadBool(ClassName, JclDebugEnabledName, False));
end;

//--------------------------------------------------------------------------------------------------

procedure TJclDebugExtension.SaveExpertValues;
begin
  JediIniFile.WriteBool(ClassName, JclDebugEnabledName, FInsertDataAction.Checked);
end;

{$ENDIF OldStyleExpert}

//--------------------------------------------------------------------------------------------------

{$IFDEF OldStyleExpert}

function TJclDebugExtension.InsertDataToProject(const ActiveProject: IOTAProject): Boolean;
var
  BuildOk, Succ: Boolean;
  ProjOptions: IOTAProjectOptions;
  SaveMapFile: Variant;
  ProjectFileName, MapFileName, ExecutableFileName: string;
  OutputDirectory, LinkerBugUnit: string;
  MapFileSize, JclDebugDataSize, LineNumberErrors, C: Integer;
  ExecutableNotFound: Boolean;
  {$IFDEF DELPHI5_UP}
  OptionsModifiedState: Boolean;
  {$ENDIF DELPHI5_UP}
begin
  Assert(Assigned(ActiveProject));
  ProjectFileName := ActiveProject.FileName;
  ProjOptions := ActiveProject.ProjectOptions;
  // read output directory
  OutputDirectory := GetOutputDirectory(ActiveProject);
  MapFileName := GetMapFileName(ActiveProject);
  {$IFDEF DELPHI5_UP}
  OptionsModifiedState := ProjOptions.ModifiedState;
  {$ENDIF DELPHI5_UP}
  SaveMapFile := ProjOptions.Values[MapFileOptionName];
  ProjOptions.Values[MapFileOptionName] := MapFileOptionDetailed;
  BuildOk := ActiveProject.ProjectBuilder.BuildProject(cmOTABuild, False);
  ProjOptions.Values[MapFileOptionName] := SaveMapFile;
  {$IFDEF DELPHI5_UP}
  ProjOptions.ModifiedState := OptionsModifiedState;
  {$ENDIF DELPHI5_UP}
  ExecutableNotFound := False;
  LinkerBugUnit := '';
  LineNumberErrors := 0;
  if BuildOk then
  begin
    Succ := FileExists(MapFileName);
    if Succ then
    begin
      if FindExecutableName(MapFileName, OutputDirectory, ExecutableFileName) then
      begin
        Succ := InsertDebugDataIntoExecutableFile(ExecutableFileName, MapFileName,
          LinkerBugUnit, MapFileSize, JclDebugDataSize, LineNumberErrors);
      end
      else
      begin
        ExecutableNotFound := True;
        Succ := False;
      end;
    end;
  end
  else
    Succ := False;
  if SaveMapFile <> MapFileOptionDetailed then
  begin
    DeleteFile(MapFileName);
    DeleteFile(ChangeFileExt(ProjectFileName, DrcFileExtension));
  end;
  Result := BuildOk and not ExecutableNotFound;
  C := Length(FResultInfo);
  SetLength(FResultInfo, C + 1);
  FResultInfo[C].ProjectName := ExtractFileName(ProjectFileName);
  FResultInfo[C].ExecutableFileName := ExecutableFileName;
  FResultInfo[C].MapFileSize := MapFileSize;
  FResultInfo[C].JclDebugDataSize := JclDebugDataSize;
  FResultInfo[C].LinkerBugUnit := LinkerBugUnit;
  FResultInfo[C].LineNumberErrors := LineNumberErrors;
  FResultInfo[C].Success := Succ;
  if ExecutableNotFound then
    MessageDlg(Format(RsExecutableNotFound, [ProjectFileName]), mtError, [mbOk], 0);
end;

{$ENDIF OldStyleExpert}

//--------------------------------------------------------------------------------------------------

procedure TJclDebugExtension.RegisterCommand;
var
  IDEMainMenu: TMainMenu;
  IDEProjectItem: TMenuItem;
  IDEActionList: TActionList;
  I: Integer;
  ImageBmp: TBitmap;
begin
  IDEActionList := TActionList((BorlandIDEServices as INTAServices).ActionList);
  IDEMainMenu := (BorlandIDEServices as INTAServices).MainMenu;
  ImageBmp := TBitmap.Create;
  try
    {$IFDEF OldStyleExpert}
    ImageBmp.LoadFromResourceName(FindResourceHInstance(HInstance), 'JCLDEBUG');
    FBuildAction := TAction.Create(nil);
    FBuildAction.Caption := Format(RsActionCaption, [RsProjectNone]);
    FBuildAction.ImageIndex := (BorlandIDEServices as INTAServices).AddMasked(ImageBmp, clPurple);
    FBuildAction.Visible := True;
    FBuildAction.OnExecute := BuildActionExecute;
    FBuildAction.OnUpdate := BuildActionUpdate;
    FBuildAction.ActionList := IDEActionList;
    FBuildMenuItem := TMenuItem.Create(nil);
    FBuildMenuItem.Action := FBuildAction;
    FBuildAllAction := TAction.Create(nil);
    FBuildAllAction.Caption := RsBuildAllCaption;
    FBuildAllAction.ImageIndex := (BorlandIDEServices as INTAServices).AddMasked(ImageBmp, clPurple);
    FBuildAllAction.Visible := True;
    FBuildAllAction.OnExecute := BuildAllActionExecute;
    FBuildAllAction.OnUpdate := BuildAllActionUpdate;
    FBuildAllAction.ActionList := IDEActionList;
    FBuildAllMenuItem := TMenuItem.Create(nil);
    FBuildAllMenuItem.Action := FBuildAllAction;
    {$ELSE OldStyleExpert}
    FInsertDataAction := TAction.Create(nil);
    FInsertDataAction.Caption := RsInsertDataCaption;
    FInsertDataAction.Visible := True;
    FInsertDataAction.OnExecute := InsertDataExecute;
    FInsertDataAction.ActionList := IDEActionList;
    FInsertDataItem := TMenuItem.Create(nil);
    FInsertDataItem.Action := FInsertDataAction;
    {$ENDIF OldStyleExpert}
  finally
    ImageBmp.Free;
  end;

  IDEProjectItem := nil;
  with IDEMainMenu do
    for I := 0 to Items.Count - 1 do
      if Items[I].Name = 'ProjectMenu' then
      begin
        IDEProjectItem := Items[I];
        Break;
      end;
  Assert(IDEProjectItem <> nil);

  {$IFDEF OldStyleExpert}
  with IDEProjectItem do
    for I := 0 to Count - 1 do
      if Items[I].Name = 'ProjectBuildItem' then
      begin
        IDEProjectItem.Insert(I + 1, FBuildMenuItem);
        System.Break;
      end;
  Assert(FBuildMenuItem.Parent <> nil);
  with IDEProjectItem do
    for I := 0 to Count - 1 do
      if Items[I].Name = 'ProjectBuildAllItem' then
      begin
        IDEProjectItem.Insert(I + 1, FBuildAllMenuItem);
        System.Break;
      end;
  Assert(FBuildMenuItem.Parent <> nil);
  {$IFNDEF DELPHI5_UP}
  FSaveAllAction := nil;
  with IDEActionList do
    for I := 0 to ActionCount - 1 do
      if Actions[I].Name = 'FileSaveAllCommand' then
      begin
        FSaveAllAction := TAction(Actions[I]);
        Break;
      end;
  Assert(FSaveAllAction <> nil);
  {$ENDIF DELPHI5_UP}
  {$ELSE OldStyleExpert}
  with IDEProjectItem do
    for I := 0 to Count - 1 do
      if Items[I].Name = 'ProjectOptionsItem' then
      begin
        IDEProjectItem.Insert(I + 1, FInsertDataItem);
        System.Break;
      end;
  Assert(FInsertDataItem.Parent <> nil);
  FSaveBuildProject := nil;
  with IDEActionList do
    for I := 0 to ActionCount - 1 do
      if Actions[I].Name = 'ProjectBuildCommand' then
      begin
        FSaveBuildProject := TAction(Actions[I]);
        FSaveBuildProjectExecute := Actions[I].OnExecute;
        Break;
      end;
  Assert(Assigned(FSaveBuildProject), 'Build action not found');
  FSaveBuildAllProjects := nil;
  with IDEActionList do
    for I := 0 to ActionCount - 1 do
      if Actions[I].Name = 'ProjectBuildAllCommand' then
      begin
        FSaveBuildAllProjects := TAction(Actions[I]);
        FSaveBuildAllProjectsExecute := Actions[I].OnExecute;
        Break;
      end;
  Assert(Assigned(FSaveBuildAllProjects), 'Build All action not found');
  {$ENDIF OldStyleExpert}
end;

//--------------------------------------------------------------------------------------------------

procedure TJclDebugExtension.UnregisterCommand;
begin
  {$IFNDEF OldStyleExpert}
  HookBuildActions(False);
  {$ENDIF OldStyleExpert}
  FreeAndNil(FBuildMenuItem);
  FreeAndNil(FBuildAction);
  FreeAndNil(FBuildAllMenuItem);
  FreeAndNil(FBuildAllAction);
  FreeAndNil(FInsertDataItem);
  FreeAndNil(FInsertDataAction);
end;

//==================================================================================================
// TIdeNotifier
//==================================================================================================

{$IFNDEF OldStyleExpert}

procedure TIdeNotifier.AfterCompile(Succeeded: Boolean);
begin
end;

//--------------------------------------------------------------------------------------------------

procedure TIdeNotifier.AfterCompile(Succeeded, IsCodeInsight: Boolean);
begin
  if not IsCodeInsight then
    FDebugExtension.AfterCompile(Succeeded);
end;

//--------------------------------------------------------------------------------------------------

procedure TIdeNotifier.BeforeCompile(const Project: IOTAProject; IsCodeInsight: Boolean; var Cancel: Boolean);
begin
  if not IsCodeInsight then
    FDebugExtension.BeforeCompile(Project, Cancel);
end;

//--------------------------------------------------------------------------------------------------

procedure TIdeNotifier.BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
begin
end;

//--------------------------------------------------------------------------------------------------

constructor TIdeNotifier.Create(ADebugExtension: TJclDebugExtension);
begin
  inherited Create;
  FDebugExtension := ADebugExtension;
end;

//--------------------------------------------------------------------------------------------------

procedure TIdeNotifier.FileNotification(NotifyCode: TOTAFileNotification; const FileName: string; var Cancel: Boolean);
begin
end;

{$ENDIF OldStyleExpert}

//--------------------------------------------------------------------------------------------------

end.