paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-06 12:40:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

IDE: started background scan of fpc source directory

Browse Source 
git-svn-id: trunk@27575 -
This commit is contained in:
mattias 2010-10-04 14:00:13 +00:00
parent d4fd6075e6
commit aac4168119
11 changed files with 565 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -3560,6 +3560,7 @@ ide/findreplacedialog.pp svneol=native#text/pascal
ide/findunitdlg.lfm svneol=native#text/plain
ide/findunitdlg.pas svneol=native#text/plain
ide/formeditor.pp svneol=native#text/pascal
ide/fpcsrcscan.pas svneol=native#text/pascal
ide/fpdoceditwindow.lfm svneol=native#text/plain
ide/fpdoceditwindow.pas svneol=native#text/plain
ide/fpdochints.pas svneol=native#text/plain
@ -3751,6 +3752,8 @@ ide/procedurelist.lfm svneol=native#text/plain
ide/procedurelist.pas svneol=native#text/plain
ide/progressdlg.lfm svneol=native#text/plain
ide/progressdlg.pas svneol=native#text/plain
ide/progresswnd.lfm svneol=native#text/plain
ide/progresswnd.pas svneol=native#text/pascal
ide/project.pp svneol=native#text/pascal
ide/projectdefs.pas svneol=native#text/pascal
ide/projecticon.pas svneol=native#text/pascal

10
components/codetools/definetemplates.pas
View File

@ -834,7 +834,7 @@ type
MustHavePPU: boolean = true;
SkipPPUCheckIfNoneExists: boolean = true): string;
property ChangeStamp: integer read FChangeStamp;
function GetInvalidChangeStamp: integer;
class function GetInvalidChangeStamp: integer;
procedure IncreaseChangeStamp;
function GetUnitSetID: string;
end;
@ -8758,13 +8758,9 @@ begin
end;
end;
function TFPCUnitSetCache.GetInvalidChangeStamp: integer;
class function TFPCUnitSetCache.GetInvalidChangeStamp: integer;
begin
Result:=ChangeStamp;
if Result>Low(Result) then
dec(Result)
else
Result:=High(Result);
Result:=CTInvalidChangeStamp;
end;
procedure TFPCUnitSetCache.IncreaseChangeStamp;

3
ide/basebuildmanager.pas
View File

@ -41,9 +41,12 @@ type
{ TBaseBuildManager }
TBaseBuildManager = class(TComponent)
private
FHasGUI: boolean;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property HasGUI: boolean read FHasGUI write FHasGUI;
function GetBuildMacroOverride(const MacroName: string): string; virtual; abstract;
function GetBuildMacroOverrides: TStrings; virtual; abstract;

52
ide/buildmanager.pas
View File

@ -45,11 +45,16 @@ uses
// IDE
LazarusIDEStrConsts, DialogProcs, IDEProcs, CodeToolsOptions, InputHistory,
EditDefineTree, ProjectResources, MiscOptions, LazConf, EnvironmentOpts,
TransferMacros, CompilerOptions, OutputFilter, Compiler,
TransferMacros, CompilerOptions, OutputFilter, Compiler, FPCSrcScan,
PackageDefs, PackageSystem, Project,
BaseBuildManager, ApplicationBundle;
type
TBMScanFPCSources = (
bmsfsSkip,
bmsfsWaitTillDone, // scan now and wait till finished
bmsfsBackground // start in background
);
{ TBuildManager }
@ -57,7 +62,6 @@ type
private
CurrentParsedCompilerOption: TParsedCompilerOptions;
FUnitSetCache: TFPCUnitSetCache;
FScanningCompilerDisabled: boolean;
function OnSubstituteCompilerOption(Options: TParsedCompilerOptions;
const UnparsedValue: string;
PlatformIndependent: boolean): string;
@ -146,9 +150,8 @@ type
function GetTargetUnitFilename(AnUnitInfo: TUnitInfo): string; override;
procedure UpdateEnglishErrorMsgFilename;
procedure RescanCompilerDefines(ResetBuildTarget, ClearCaches: boolean);
property ScanningCompilerDisabled: boolean read FScanningCompilerDisabled
write FScanningCompilerDisabled;
procedure RescanCompilerDefines(ResetBuildTarget, ClearCaches,
WaitTillDone: boolean);
procedure LoadFPCDefinesCaches;
procedure SaveFPCDefinesCaches;
property UnitSetCache: TFPCUnitSetCache read FUnitSetCache write SetUnitSetCache;
@ -172,7 +175,7 @@ type
// methods for building IDE (will be changed when project groups are there)
procedure SetBuildTarget(const TargetOS, TargetCPU, LCLWidgetType: string;
DoNotScanFPCSrc: boolean = false);
ScanFPCSrc: TBMScanFPCSources = bmsfsSkip);
procedure SetBuildTargetIDE;
end;
@ -226,6 +229,7 @@ begin
FFPCVerChangeStamp:=InvalidParseStamp;
MainBuildBoss:=Self;
inherited Create(AOwner);
FUnitSetChangeStamp:=TFPCUnitSetCache.GetInvalidChangeStamp;
OnBackupFileInteractive:=@BackupFile;
RunCompilerWithOptions:=@OnRunCompilerWithOptions;
@ -536,12 +540,14 @@ begin
end;
procedure TBuildManager.RescanCompilerDefines(ResetBuildTarget,
ClearCaches: boolean);
ClearCaches, WaitTillDone: boolean);
var
TargetOS, TargetCPU: string;
CompilerFilename: String;
FPCSrcDir: string;
ADefTempl: TDefineTemplate;
FPCSrcCache: TFPCSourceCache;
NeedUpdateFPCSrcCache: Boolean;
procedure AddTemplate(ADefTempl: TDefineTemplate; AddToPool: boolean;
const ErrorMsg: string);
@ -574,7 +580,6 @@ var
end;
begin
if ScanningCompilerDisabled then exit;
if ClearCaches then begin
{ $IFDEF VerboseFPCSrcScan}
debugln(['TBuildManager.RescanCompilerDefines clear caches']);
@ -583,7 +588,7 @@ begin
CodeToolBoss.FPCDefinesCache.SourceCaches.Clear;
end;
if ResetBuildTarget then
SetBuildTarget('','','',true);
SetBuildTarget('','','');
// start the compiler and ask for his settings
// provide an english message file
@ -608,7 +613,30 @@ begin
UnitSetCache:=CodeToolBoss.FPCDefinesCache.FindUnitSet(
CompilerFilename,TargetOS,TargetCPU,'',FPCSrcDir,true);
NeedUpdateFPCSrcCache:=false;
if (not WaitTillDone) or (not HasGUI) then
begin
// FPC sources are not needed
// => disable scan
FPCSrcCache:=UnitSetCache.GetSourceCache(false);
if (FPCSrcCache<>nil) and (not FPCSrcCache.Valid) then
begin
{$IFDEF EnableDelayedFPCSrcScan}
NeedUpdateFPCSrcCache:=HasGUI;
FPCSrcCache.Valid:=true;
{$ENDIF}
end;
end;
// scan compiler, fpc sources and create indices for quick lookup
UnitSetCache.Init;
if NeedUpdateFPCSrcCache then
begin
// start background scan of fpc source directory
debugln(['TBuildManager.RescanCompilerDefines TODO: implement background scan '+FPCSrcCache.Directory]);
end;
if FUnitSetChangeStamp=UnitSetCache.ChangeStamp then begin
{$IFDEF VerboseFPCSrcScan}
debugln(['TBuildManager.RescanCompilerDefines nothing changed']);
@ -1769,7 +1797,7 @@ begin
end;
procedure TBuildManager.SetBuildTarget(const TargetOS, TargetCPU,
LCLWidgetType: string; DoNotScanFPCSrc: boolean);
LCLWidgetType: string; ScanFPCSrc: TBMScanFPCSources);
var
OldTargetOS: String;
OldTargetCPU: String;
@ -1799,8 +1827,8 @@ begin
if LCLTargetChanged then
CodeToolBoss.SetGlobalValue(ExternalMacroStart+'LCLWidgetType',NewLCLWidgetType);
if FPCTargetChanged and (not DoNotScanFPCSrc) then
RescanCompilerDefines(false,false);
if FPCTargetChanged and (ScanFPCSrc<>bmsfsSkip) then
RescanCompilerDefines(false,false,ScanFPCSrc=bmsfsWaitTillDone);
if FPCTargetChanged or LCLTargetChanged then begin
IncreaseCompilerParseStamp;

155
ide/fpcsrcscan.pas Normal file
View File

@ -0,0 +1,155 @@
{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
Scanning FPC sources in background.
}
unit FPCSrcScan;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileProcs, DefineTemplates, ProgressWnd;
type
TFPCSrcScans = class;
{ TFPCSrcScan }
TFPCSrcScan = class(TThread)
protected
procedure Execute; override;
public
Directory: string;
Scans: TFPCSrcScans;
end;
{ TFPCSrcScans }
TFPCSrcScans = class(TComponent)
private
fItems: TFPList;
FCritSec: TRTLCriticalSection;
function GetItems(Index: integer): TFPCSrcScan;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Count: integer; // requires Enter/Leave
property Items[Index: integer]: TFPCSrcScan read GetItems; default; // requires Enter/Leave
procedure Clear; // waits until all
procedure EnterCriticalsection;
procedure LeaveCriticalsection;
procedure Scan(Directory: string);
end;
implementation
{ TFPCSrcScan }
procedure TFPCSrcScan.Execute;
begin
// ToDo: scan fpc source directory, check for terminated
// ToDo: when finished, let main thread update the codetools fpc source cache
// ToDo: delete item in progress window
end;
{ TFPCSrcScans }
function TFPCSrcScans.GetItems(Index: integer): TFPCSrcScan;
begin
Result:=TFPCSrcScan(fItems[Index]);
end;
constructor TFPCSrcScans.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fItems:=TFPList.Create;
InitCriticalSection(FCritSec);
end;
destructor TFPCSrcScans.Destroy;
begin
Clear;
FreeAndNil(fItems);
DoneCriticalsection(FCritSec);
inherited Destroy;
end;
function TFPCSrcScans.Count: integer;
begin
Result:=fItems.Count;
end;
procedure TFPCSrcScans.Clear;
var
i: Integer;
begin
// terminate all threads
EnterCriticalsection;
try
for i:=0 to Count-1 do
Items[i].Terminate;
finally
LeaveCriticalsection;
end;
repeat
EnterCriticalsection;
try
if Count=0 then break;
finally
LeaveCriticalsection;
end;
Sleep(10);
until false;
end;
procedure TFPCSrcScans.EnterCriticalsection;
begin
System.EnterCriticalsection(FCritSec);
end;
procedure TFPCSrcScans.LeaveCriticalsection;
begin
System.LeaveCriticalsection(FCritSec);
end;
procedure TFPCSrcScans.Scan(Directory: string);
var
i: Integer;
begin
// check if already scanning that directory
EnterCriticalsection;
try
for i:=0 to Count-1 do
if CompareFilenames(Directory,Items[i].Directory)=0 then exit;
finally
LeaveCriticalsection;
end;
// ToDo: create thread and create progress window
end;
end.

18
ide/lazarus.lpi
View File

@ -53,7 +53,7 @@
<PackageName Value="SynEdit"/>
</Item5>
</RequiredPackages>
<Units Count="69">
<Units Count="71">
<Unit0>
<Filename Value="lazarus.pp"/>
<IsPartOfProject Value="True"/>
@ -526,6 +526,18 @@
<IsPartOfProject Value="True"/>
<UnitName Value="DebugManager"/>
</Unit68>
<Unit69>
<Filename Value="progresswnd.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="IDEProgressWindow"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ProgressWnd"/>
</Unit69>
<Unit70>
<Filename Value="fpcsrcscan.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="FPCSrcScan"/>
</Unit70>
</Units>
</ProjectOptions>
<CompilerOptions>
@ -534,8 +546,8 @@
<Filename Value="../lazarus"/>
</Target>
<SearchPaths>
<IncludeFiles Value="include/"/>
<OtherUnitFiles Value="frames/;../converter/;../debugger/;../debugger/frames/;../packager/;../designer/"/>
<IncludeFiles Value="include"/>
<OtherUnitFiles Value="frames;../converter;../debugger;../debugger/frames;../packager;../designer"/>
<UnitOutputDirectory Value="$(LazarusDir)/units/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>

4
ide/lazarus.pp
View File

@ -39,9 +39,9 @@ program Lazarus;
{off $DEFINE IDE_MEM_CHECK}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
{$IFDEF UNIX}
cthreads,
{$ENDIF}{$ENDIF}
{$ENDIF}
{$IFDEF IDE_MEM_CHECK}
MemCheck,
{$ENDIF}

2
ide/lazbuild.lpr
View File

@ -747,7 +747,7 @@ begin
CreatePrimaryConfigPath;
MainBuildBoss:=TBuildManager.Create(nil);
MainBuildBoss.ScanningCompilerDisabled:=true;
MainBuildBoss.HasGUI:=false;
LoadEnvironmentOptions;
LoadMiscellaneousOptions;
InteractiveSetup:=false;

13
ide/main.pp
View File

@ -1281,6 +1281,7 @@ begin
{$ENDIF}
MainBuildBoss:=TBuildManager.Create(nil);
MainBuildBoss.HasGUI:=true;
{$IFDEF IDE_MEM_CHECK}CheckHeapWrtMemCnt('TMainIDE.Create BUILD MANAGER');{$ENDIF}
// load options
@ -4384,7 +4385,7 @@ begin
if MacroValueChanged then CodeToolBoss.DefineTree.ClearCache;
debugln(['TMainIDE.DoEnvironmentOptionsAfterWrite FPCCompilerChanged=',FPCCompilerChanged,' FPCSrcDirChanged=',FPCSrcDirChanged,' LazarusSrcDirChanged=',LazarusSrcDirChanged]);
if FPCCompilerChanged or FPCSrcDirChanged then
MainBuildBoss.RescanCompilerDefines(true,false);
MainBuildBoss.RescanCompilerDefines(true,false,false);
// update environment
UpdateDesigners;
@ -4548,7 +4549,7 @@ begin
begin
TBaseCompilerOptions(Sender).Modified := True;
IncreaseCompilerParseStamp;
MainBuildBoss.RescanCompilerDefines(True, False);
MainBuildBoss.RescanCompilerDefines(True, False, false);
IncreaseCompilerParseStamp;
UpdateHighlighters; // because of FPC/Delphi mode
end;
@ -4577,7 +4578,7 @@ end;
procedure TMainIDE.mnuEnvRescanFPCSrcDirClicked(Sender: TObject);
begin
MainBuildBoss.RescanCompilerDefines(false,true);
MainBuildBoss.RescanCompilerDefines(false,true,true);
end;
procedure TMainIDE.SaveEnvironment;
@ -7586,7 +7587,7 @@ begin
EnvironmentOptions.LastSavedProjectFile:=Project1.ProjectInfoFile;
EnvironmentOptions.Save(false);
MainBuildBoss.RescanCompilerDefines(true,false);
MainBuildBoss.RescanCompilerDefines(true,false,false);
// load required packages
PkgBoss.OpenProjectDependencies(Project1,true);
@ -9666,7 +9667,7 @@ begin
PkgBoss.AddDefaultDependencies(Project1);
// rebuild codetools defines
MainBuildBoss.RescanCompilerDefines(true,false);
MainBuildBoss.RescanCompilerDefines(true,false,false);
// (i.e. remove old project specific things and create new)
IncreaseCompilerParseStamp;
@ -13432,7 +13433,7 @@ begin
// create defines for the lazarus sources
SetupLazarusDirectory(InteractiveSetup);
MainBuildBoss.RescanCompilerDefines(true,false);
MainBuildBoss.RescanCompilerDefines(true,false,false);
// load include file relationships
AFilename:=AppendPathDelim(GetPrimaryConfigPath)+CodeToolsIncludeLinkFile;

10
ide/progresswnd.lfm Normal file
View File

@ -0,0 +1,10 @@
object IDEProgressWindow: TIDEProgressWindow
Left = 275
Height = 109
Top = 250
Width = 437
AutoSize = True
Caption = 'IDEProgressWindow'
Position = poScreenCenter
LCLVersion = '0.9.29'
end

326
ide/progresswnd.pas Normal file
View File

@ -0,0 +1,326 @@
{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code is distributed in the hope that it will be useful, but *
* WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
Author: Mattias Gaertner
Abstract:
A floating IDE window to show what long tasks are currently running in the
background.
}
unit ProgressWnd;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
StdCtrls, ExtCtrls;
type
TIDEProgressWindow = class;
{ TIDEProgressItem }
TIDEProgressItem = class(TComponent)
private
FCaption: string;
FCaptionLabel: TLabel;
FEndPos: integer;
FHint: string;
FPanel: TPanel;
FPosition: integer;
FProgressBar: TProgressBar;
FStartPos: integer;
FWindow: TIDEProgressWindow;
procedure SetCaption(const AValue: string);
procedure SetCaptionLabel(const AValue: TLabel);
procedure SetEndPos(const AValue: integer);
procedure SetHint(const AValue: string);
procedure SetPanel(const AValue: TPanel);
procedure SetPosition(const AValue: integer);
procedure SetProgressBar(const AValue: TProgressBar);
procedure SetStartPos(const AValue: integer);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation);
override;
public
property Caption: string read FCaption write SetCaption;
property Hint: string read FHint write SetHint;
property StartPos: integer read FStartPos write SetStartPos;
property EndPos: integer read FEndPos write SetEndPos; // if EndPos=StartPos then unknown
property Position: integer read FPosition write SetPosition;
property Panel: TPanel read FPanel write SetPanel;
property CaptionLabel: TLabel read FCaptionLabel write SetCaptionLabel;
property ProgressBar: TProgressBar read FProgressBar write SetProgressBar;
property Window: TIDEProgressWindow read FWindow;
end;
{ TIDEProgressWindow }
TIDEProgressWindow = class(TForm)
private
FItems: TFPList; // list of TIDEProgressItem
function GetItems(Index: integer): TIDEProgressItem;
protected
procedure Notification(AComponent: TComponent; Operation: TOperation);
override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
function Count: integer;
property Items[Index: integer]: TIDEProgressItem read GetItems; default;
procedure ClearItems;
function IndexByName(AName: string): integer;
function AddItem(AName, ACaption, AHint: string): TIDEProgressItem;
end;
var
IDEProgressWindow: TIDEProgressWindow;
implementation
{$R *.lfm}
{ TIDEProgressItem }
procedure TIDEProgressItem.SetCaption(const AValue: string);
begin
if FCaption=AValue then exit;
FCaption:=AValue;
if CaptionLabel<>Nil then
CaptionLabel.Caption:=Caption;
end;
procedure TIDEProgressItem.SetCaptionLabel(const AValue: TLabel);
begin
if FCaptionLabel=AValue then exit;
if CaptionLabel<>nil then
RemoveFreeNotification(CaptionLabel);
FCaptionLabel:=AValue;
if CaptionLabel<>nil then
begin
FreeNotification(CaptionLabel);
CaptionLabel.Caption:=Caption;
CaptionLabel.Hint:=Hint;
end;
end;
procedure TIDEProgressItem.SetEndPos(const AValue: integer);
begin
if FEndPos=AValue then exit;
FEndPos:=AValue;
if ProgressBar<>nil then
begin
if EndPos>StartPos then
begin
ProgressBar.Style:=pbstNormal;
ProgressBar.Min:=StartPos;
ProgressBar.Position:=Position;
ProgressBar.Max:=EndPos;
end else begin
ProgressBar.Style:=pbstMarquee;
end;
end;
end;
procedure TIDEProgressItem.SetHint(const AValue: string);
begin
if FHint=AValue then exit;
FHint:=AValue;
if ProgressBar<>Nil then
ProgressBar.Hint:=Hint;
if CaptionLabel<>Nil then
CaptionLabel.Hint:=Hint;
end;
procedure TIDEProgressItem.SetPanel(const AValue: TPanel);
begin
if FPanel=AValue then exit;
if Panel<>nil then
RemoveFreeNotification(Panel);
FPanel:=AValue;
if Panel<>nil then
FreeNotification(Panel);
end;
procedure TIDEProgressItem.SetPosition(const AValue: integer);
begin
if FPosition=AValue then exit;
FPosition:=AValue;
if ProgressBar<>nil then
ProgressBar.Position:=Position;
end;
procedure TIDEProgressItem.SetProgressBar(const AValue: TProgressBar);
begin
if FProgressBar=AValue then exit;
if ProgressBar<>nil then
RemoveFreeNotification(ProgressBar);
FProgressBar:=AValue;
if ProgressBar<>nil then begin
FreeNotification(ProgressBar);
if EndPos>StartPos then
begin
ProgressBar.Style:=pbstNormal;
ProgressBar.Min:=StartPos;
ProgressBar.Position:=Position;
ProgressBar.Max:=EndPos;
end else begin
ProgressBar.Style:=pbstMarquee;
end;
ProgressBar.Hint:=Hint;
end;
end;
procedure TIDEProgressItem.SetStartPos(const AValue: integer);
begin
if FStartPos=AValue then exit;
FStartPos:=AValue;
if ProgressBar<>Nil then
begin
if EndPos>StartPos then
begin
ProgressBar.Style:=pbstNormal;
ProgressBar.Min:=StartPos;
ProgressBar.Position:=Position;
ProgressBar.Max:=EndPos;
end else begin
ProgressBar.Style:=pbstMarquee;
end;
end;
end;
procedure TIDEProgressItem.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation=opRemove then
begin
if AComponent=Panel then
FPanel:=nil;
if AComponent=ProgressBar then
fProgressBar:=nil;
if AComponent=CaptionLabel then
fCaptionLabel:=nil;
end;
end;
{ TIDEProgressWindow }
function TIDEProgressWindow.GetItems(Index: integer): TIDEProgressItem;
begin
Result:=TIDEProgressItem(FItems[Index]);
end;
procedure TIDEProgressWindow.Notification(AComponent: TComponent;
Operation: TOperation);
var
i: Integer;
begin
inherited Notification(AComponent, Operation);
if Operation=opRemove then
begin
DisableAutoSizing;
try
for i:=Count-1 downto 0 do
if Items[i]=AComponent then
begin
FreeAndNil(Items[i].fPanel);
FItems.Delete(i);
end;
if Count=0 then
Hide;
finally
EnableAutoSizing;
end;
end;
end;
constructor TIDEProgressWindow.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
FItems:=TFPList.Create;
end;
destructor TIDEProgressWindow.Destroy;
begin
ClearItems;
FreeAndNil(FItems);
inherited Destroy;
end;
function TIDEProgressWindow.Count: integer;
begin
Result:=FItems.Count;
end;
procedure TIDEProgressWindow.ClearItems;
var
i: Integer;
begin
for i:=Count-1 downto 0 do Items[i].Free;
end;
function TIDEProgressWindow.IndexByName(AName: string): integer;
begin
Result:=Count-1;
while (Result>=0) and (SysUtils.CompareText(AName,Items[Result].Name)<>0) do
dec(Result);
end;
function TIDEProgressWindow.AddItem(AName, ACaption, AHint: string
): TIDEProgressItem;
begin
if FindComponent(AName)<>nil then
raise Exception.Create('TIDEProgressWindow.AddItem name already used: '+AName);
Result:=TIDEProgressItem.Create(Self);
Result.FWindow:=Self;
Result.Name:=AName;
Result.Caption:=ACaption;
Result.Hint:=AHint;
// add a panel
Result.Panel:=TPanel.Create(Result);
Result.Panel.Align:=alTop;
Result.Panel.AutoSize:=true;
// add a label into the panel
Result.CaptionLabel:=TLabel.Create(Result.Panel);
Result.CaptionLabel.Align:=alTop;
Result.CaptionLabel.AutoSize:=true;
// add a progressbar below the label
Result.ProgressBar:=TProgressBar.Create(Result.Panel);
Result.ProgressBar.Align:=alTop;
Result.ProgressBar.AutoSize:=true;
// show panel
DisableAutoSizing;
try
AutoSize:=false;
Result.Panel.Parent:=Self;
AutoSize:=true;
Show;
finally
EnableAutoSizing;
end;
end;
end.