{ If you want to extend the package only access this unit. } unit ProjectGroupIntf; {$mode objfpc}{$H+} interface uses Classes, SysUtils, // LCL Forms, // LazUtils LazFileUtils, LazFileCache, LazMethodList, LazLoggerBase, // IdeIntf PackageIntf, ProjectIntf, IDEExternToolIntf; Type TPGTargetType = ( ttUnknown, ttProject, ttPackage, ttProjectGroup, // nested group ttPascalFile, // build/run file, parameters stored IDE directives ttExternalTool ); TPGTargetTypes = set of TPGTargetType; TPGTargetAction = ( taOpen, taSettings, taCompile, taCompileClean, taCompileFromHere, taCompileCleanFromHere, taRun, taInstall, taUninstall); TPGTargetActions = set of TPGTargetAction; TPGActionResult = (arNotAllowed,arOK,arFailed); TPGActionResults = set of TPGActionResult; TProjectGroup = class; TPGCompileTarget = class; { TPGBuildMode } TPGBuildMode = class private FCompile: boolean; FIdentifier: string; FTarget: TPGCompileTarget; procedure SetCompile(AValue: boolean); public constructor Create(aTarget: TPGCompileTarget; const anIdentifier: string; aCompile: boolean); property Target: TPGCompileTarget read FTarget; property Identifier: string read FIdentifier; property Compile: boolean read FCompile write SetCompile; end; { TPGDependency } TPGDependency = class private FPackageName: string; FTarget: TPGCompileTarget; public constructor Create(aTarget: TPGCompileTarget; const aPkgName: string); property Target: TPGCompileTarget read FTarget; property PackageName: string read FPackageName; end; { TPGCompileTarget - a node in the tree, see TPGTargetType } TPGCompileTarget = class private FActive: Boolean; FFilename: string; FTargetType: TPGTargetType; FMissing: boolean; protected FParent: TPGCompileTarget; FProjectGroup: TProjectGroup; function CallRunLazbuildHandlers(Tool: TAbstractExternalTool): boolean; virtual; function GetAllowedActions: TPGTargetActions; virtual; // By default, return all allowed actions for target type. function GetBuildModeCount: integer; virtual; abstract; function GetBuildModes(Index: integer): TPGBuildMode; virtual; abstract; function GetFileCount: integer; virtual; abstract; function GetFiles(Index: integer): string; virtual; abstract; function GetRequiredPackageCount: integer; virtual; abstract; function GetRequiredPackages(Index: integer): TPGDependency; virtual; abstract; function Perform(AAction: TPGTargetAction): TPGActionResult; function PerformAction(AAction: TPGTargetAction): TPGActionResult; virtual; abstract; procedure SetFilename(const AValue: string); virtual; procedure SetMissing(const AValue: boolean); virtual; procedure SetTargetType(AValue: TPGTargetType); virtual; procedure DoDeactivateChildren; procedure ActiveChanged(Sender: TPGCompileTarget); virtual; abstract; procedure DoActivate(DeactivateChildren: boolean); procedure DoDeActivate(DeactivateParents: boolean); public constructor Create(aParent: TPGCompileTarget); procedure Activate; procedure DeActivate; function GetOwnerProjectGroup: TProjectGroup; function GetRootProjectGroup: TProjectGroup; function GetNext(SkipChildren: boolean): TPGCompileTarget; function IndexOfBuildMode(aName: string): integer; function FindBuildMode(aName: string): TPGBuildMode; function PerformBuildModeAction(AAction: TPGTargetAction; aModeIdentifier: string): TPGActionResult; virtual; abstract; procedure Modified; virtual; abstract; property Parent: TPGCompileTarget read FParent; property Filename: string read FFilename write SetFilename; // Absolute, not relative. property Missing: boolean read FMissing write SetMissing; property TargetType: TPGTargetType read FTargetType write SetTargetType; property Active: Boolean Read FActive; function GetIndex: Integer; // Currently allowed actions. property AllowedActions: TPGTargetActions Read GetAllowedActions; // property ProjectGroup: TProjectGroup read FProjectGroup; // only set if TargetType=ttProjectGroup property BuildModes[Index: integer]: TPGBuildMode read GetBuildModes; property BuildModeCount: integer read GetBuildModeCount; property Files[Index: integer]: string read GetFiles; property FileCount: integer read GetFileCount; property RequiredPackages[Index: integer]: TPGDependency read GetRequiredPackages; property RequiredPackageCount: integer read GetRequiredPackageCount; end; TProjectGroupHandler = ( pghDestroy ); { TProjectGroup } TProjectGroup = class(TPersistent) private FHandlers: array[TProjectGroupHandler] of TMethodList; FChangeStamp: int64; FFileName: String; FLastSavedChangeStamp: int64; procedure SetModified(AValue: Boolean); protected FSelfTarget: TPGCompileTarget; FParent: TProjectGroup; function CallRunLazbuildHandlers(Target: TPGCompileTarget; Tool: TAbstractExternalTool): boolean; virtual; procedure SetFileName(AValue: String); virtual; function GetModified: Boolean; virtual; function GetTargetCount: Integer; virtual; abstract; function GetTarget(Index: Integer): TPGCompileTarget; virtual; abstract; procedure DoCallNotifyHandler(HandlerType: TProjectGroupHandler; Sender: TObject); overload; procedure AddHandler(HandlerType: TProjectGroupHandler; const AMethod: TMethod; AsLast: boolean = false); procedure RemoveHandler(HandlerType: TProjectGroupHandler; const AMethod: TMethod); function GetActiveTarget: TPGCompileTarget; virtual; abstract; procedure SetActiveTarget(AValue: TPGCompileTarget); virtual; abstract; public destructor Destroy; override; function GetRootGroup: TProjectGroup; property FileName: String Read FFileName Write SetFileName; // absolute property SelfTarget: TPGCompileTarget read FSelfTarget; // this group as target property Parent: TProjectGroup read FParent; // actions function Perform(Index: Integer; AAction: TPGTargetAction): TPGActionResult; function Perform(Const AFileName: String; AAction: TPGTargetAction): TPGActionResult; function Perform(Target: TPGCompileTarget; AAction: TPGTargetAction): TPGActionResult; virtual; function ActionAllowsFrom(Index: Integer; AAction: TPGTargetAction): Boolean; virtual; function PerformFrom(AIndex: Integer; AAction: TPGTargetAction): TPGActionResult; virtual; // targets function IndexOfTarget(Const Target: TPGCompileTarget): Integer; overload; virtual; abstract; function IndexOfTarget(Const AFilename: String): Integer; overload; virtual; function AddTarget(Const AFileName: String): TPGCompileTarget; virtual; abstract; function InsertTarget(Const Target: TPGCompileTarget; Index: Integer): Integer; virtual; abstract; procedure ExchangeTargets(ASource, ATarget: Integer); virtual; abstract; procedure RemoveTarget(Index: Integer); virtual; abstract; procedure RemoveTarget(Const AFileName: String); procedure RemoveTarget(Target: TPGCompileTarget); property Targets[Index: Integer]: TPGCompileTarget Read GetTarget; property TargetCount: Integer Read GetTargetCount; property ActiveTarget: TPGCompileTarget Read GetActiveTarget Write SetActiveTarget; function UpdateMissing: boolean; virtual; abstract; // true if something changed public // modified procedure IncreaseChangeStamp; property Modified: Boolean Read GetModified write SetModified; property ChangeStamp: int64 read FChangeStamp; public // handlers procedure RemoveAllHandlersOfObject(AnObject: TObject); procedure AddHandlerOnDestroy(const OnDestroy: TNotifyEvent; AsLast: boolean = false); procedure RemoveHandlerOnDestroy(const OnDestroy: TNotifyEvent); end; TProjectGroupLoadOption = ( pgloRemoveInvalid, // Remove non-existing targets from group automatically while loading pgloSkipInvalid, // Mark non-existing as Missing. pgloErrorInvalid, // Stop with error on non-existing. pgloLoadRecursively, // load all sub nodes pgloSkipDialog, // do not show Project Group editor. pgloBringToFront // when showing editor, bring it to front ); TProjectGroupLoadOptions = set of TProjectGroupLoadOption; TPGManagerHandler = ( pgmhRunLazbuild // called before running lazbuild ); TPGManagerHandlers = set of TPGManagerHandler; TPGMRunLazbuildEvent = function(Target: TPGCompileTarget; Tool: TAbstractExternalTool): boolean of object; // false = abort { TProjectGroupManager } TProjectGroupManager = Class(TPersistent) private FHandlers: array[TPGManagerHandler] of TMethodList; protected FEditor: TForm; function CallRunLazbuildHandlers(Target: TPGCompileTarget; Tool: TAbstractExternalTool): boolean; virtual; function GetCurrentProjectGroup: TProjectGroup; virtual; abstract; public constructor Create; destructor Destroy; override; function NewProjectGroup(AddActiveProject: boolean; BringToFront: boolean = true): boolean; virtual; abstract; function LoadProjectGroup(AFileName: string; AOptions: TProjectGroupLoadOptions): boolean; virtual; abstract; function SaveProjectGroup: boolean; virtual; abstract; function GetSrcPaths: string; virtual; abstract; function CanUndo: boolean; virtual; abstract; function CanRedo: boolean; virtual; abstract; procedure Undo; virtual; abstract; procedure Redo; virtual; abstract; property CurrentProjectGroup: TProjectGroup Read GetCurrentProjectGroup; // Always top-level. property Editor: TForm read FEditor write FEditor; public // handlers procedure RemoveAllHandlersOfObject(AnObject: TObject); procedure AddHandlerOnRunLazbuild(const OnRunLazbuild: TPGMRunLazbuildEvent; AsLast: boolean = false); procedure RemoveHandlerOnRunLazbuild(const OnRunLazbuild: TPGMRunLazbuildEvent); end; var ProjectGroupManager: TProjectGroupManager = nil; const PGTargetActions: array[TPGTargetType] of TPGTargetActions = ( [], // ttUnknown [taOpen,taSettings,taCompile,taCompileClean,taCompileFromHere,taCompileCleanFromHere,taRun], // ttProject [taOpen,taSettings,taCompile,taCompileClean,taCompileFromHere,taCompileCleanFromHere,taInstall,taUninstall], // ttPackage [taOpen,taCompile,taCompileClean,taCompileFromHere,taCompileCleanFromHere], // ttProjectGroup [taOpen,taSettings,taCompile,taCompileFromHere,taRun], // ttPascalFile [taOpen,taCompile,taCompileClean,taCompileFromHere,taCompileCleanFromHere,taRun] // ttExternalTool ); function TargetTypeFromExtension(AExt: String): TPGTargetType; function TargetSupportsAction(ATarget: TPGTargetType; AAction: TPGTargetAction): Boolean; function ActionAllowsMulti(AAction: TPGTargetAction): Boolean; implementation function TargetTypeFromExtension (AExt: String): TPGTargetType; begin while (AExt<>'') and (AExt[1]='.') do Delete(AExt,1,1); case LowerCase(AExt) of 'lpi', 'lpr': Result:=ttProject; 'lpk': Result:=ttPackage; 'lpg': Result:=ttProjectGroup; 'pas', 'pp', 'p' : Result:=ttPascalFile; else Result:=ttUnknown; end; end; function TargetSupportsAction(ATarget: TPGTargetType; AAction: TPGTargetAction ): Boolean; begin Result:=AAction in PGTargetActions[ATarget]; end; function ActionAllowsMulti(AAction: TPGTargetAction): Boolean; begin Result:=AAction in [taCompile,taCompileClean]; end; { TProjectGroupManager } function TProjectGroupManager.CallRunLazbuildHandlers(Target: TPGCompileTarget; Tool: TAbstractExternalTool): boolean; var Handler: TMethodList; i: Integer; begin Result:=true; Handler:=FHandlers[pgmhRunLazbuild]; i:=Handler.Count; while Handler.NextDownIndex(i) do begin if not TPGMRunLazbuildEvent(Handler[i])(Target,Tool) then exit(false); end; end; constructor TProjectGroupManager.Create; var HandlerType: TPGManagerHandler; begin for HandlerType in TPGManagerHandler do FHandlers[HandlerType]:=TMethodList.Create; end; destructor TProjectGroupManager.Destroy; var HandlerType: TPGManagerHandler; begin for HandlerType in TPGManagerHandler do FreeAndNil(FHandlers[HandlerType]); inherited Destroy; end; procedure TProjectGroupManager.RemoveAllHandlersOfObject(AnObject: TObject); var HandlerType: TPGManagerHandler; begin for HandlerType in TPGManagerHandler do FHandlers[HandlerType].RemoveAllMethodsOfObject(AnObject); end; procedure TProjectGroupManager.AddHandlerOnRunLazbuild( const OnRunLazbuild: TPGMRunLazbuildEvent; AsLast: boolean); begin FHandlers[pgmhRunLazbuild].Add(TMethod(OnRunLazbuild),AsLast); end; procedure TProjectGroupManager.RemoveHandlerOnRunLazbuild( const OnRunLazbuild: TPGMRunLazbuildEvent); begin FHandlers[pgmhRunLazbuild].Remove(TMethod(OnRunLazbuild)); end; { TPGBuildMode } procedure TPGBuildMode.SetCompile(AValue: boolean); begin if FCompile=AValue then Exit; FCompile:=AValue; Target.Modified; end; constructor TPGBuildMode.Create(aTarget: TPGCompileTarget; const anIdentifier: string; aCompile: boolean); begin FTarget:=aTarget; FIdentifier:=anIdentifier; FCompile:=aCompile; end; { TPGDependency } constructor TPGDependency.Create(aTarget: TPGCompileTarget; const aPkgName: string); begin FTarget:=aTarget; FPackageName:=aPkgName; end; { TProjectGroup } procedure TProjectGroup.SetModified(AValue: Boolean); begin if AValue then IncreaseChangeStamp else FLastSavedChangeStamp:=FChangeStamp; end; function TProjectGroup.CallRunLazbuildHandlers(Target: TPGCompileTarget; Tool: TAbstractExternalTool): boolean; begin if ProjectGroupManager<>nil then Result:=ProjectGroupManager.CallRunLazbuildHandlers(Target,Tool) else Result:=true; end; procedure TProjectGroup.SetFileName(AValue: String); begin if FFileName=AValue then Exit; FFileName:=AValue; IncreaseChangeStamp; if SelfTarget<>nil then SelfTarget.Filename:=Filename; end; function TProjectGroup.GetModified: Boolean; begin Result:=FLastSavedChangeStamp<>FChangeStamp; end; procedure TProjectGroup.DoCallNotifyHandler(HandlerType: TProjectGroupHandler; Sender: TObject); begin FHandlers[HandlerType].CallNotifyEvents(Sender); end; procedure TProjectGroup.AddHandler(HandlerType: TProjectGroupHandler; const AMethod: TMethod; AsLast: boolean); begin if FHandlers[HandlerType]=nil then FHandlers[HandlerType]:=TMethodList.Create; FHandlers[HandlerType].Add(AMethod,AsLast); end; procedure TProjectGroup.RemoveHandler(HandlerType: TProjectGroupHandler; const AMethod: TMethod); begin FHandlers[HandlerType].Remove(AMethod); end; destructor TProjectGroup.Destroy; var HandlerType: TProjectGroupHandler; begin DoCallNotifyHandler(pghDestroy,Self); for HandlerType:=Low(FHandlers) to High(FHandlers) do FreeAndNil(FHandlers[HandlerType]); inherited Destroy; end; function TProjectGroup.GetRootGroup: TProjectGroup; begin Result:=Self; while Result.Parent<>nil do Result:=Result.Parent; end; function TProjectGroup.Perform(Index: Integer; AAction: TPGTargetAction ): TPGActionResult; begin Result:=Perform(GetTarget(Index),AAction); end; function TProjectGroup.Perform(const AFileName: String; AAction: TPGTargetAction ): TPGActionResult; begin Result:=Perform(IndexOfTarget(AFileName),AAction); end; function TProjectGroup.Perform(Target: TPGCompileTarget; AAction: TPGTargetAction): TPGActionResult; begin Result:=Target.Perform(AAction); end; function TProjectGroup.ActionAllowsFrom(Index: Integer; AAction: TPGTargetAction ): Boolean; Var C: Integer; T: TPGCompileTarget; begin Result:=ActionAllowsMulti(AAction); C:=TargetCount; while Result and (Index=0) and (CompareFilenames(AFileName,GetTarget(Result).Filename)<>0) do Dec(Result); end; procedure TProjectGroup.RemoveTarget(const AFileName: String); begin RemoveTarget(IndexOfTarget(AFileName)) end; procedure TProjectGroup.RemoveTarget(Target: TPGCompileTarget); begin RemoveTarget(IndexOfTarget(Target)) end; procedure TProjectGroup.IncreaseChangeStamp; begin LUIncreaseChangeStamp64(FChangeStamp); if Parent<>nil then Parent.IncreaseChangeStamp; end; procedure TProjectGroup.RemoveAllHandlersOfObject(AnObject: TObject); var HandlerType: TProjectGroupHandler; begin for HandlerType in TProjectGroupHandler do FHandlers[HandlerType].RemoveAllMethodsOfObject(AnObject); end; procedure TProjectGroup.AddHandlerOnDestroy(const OnDestroy: TNotifyEvent; AsLast: boolean); begin AddHandler(pghDestroy,TMethod(OnDestroy),AsLast); end; procedure TProjectGroup.RemoveHandlerOnDestroy(const OnDestroy: TNotifyEvent); begin RemoveHandler(pghDestroy,TMethod(OnDestroy)); end; { TPGCompileTarget } function TPGCompileTarget.GetIndex: Integer; var Group: TProjectGroup; begin if Parent=nil then exit(0); Group:=Parent.ProjectGroup; if Group=nil then exit(0); Result:=Group.IndexOfTarget(Self); end; function TPGCompileTarget.CallRunLazbuildHandlers(Tool: TAbstractExternalTool ): boolean; var Group: TProjectGroup; begin Group:=GetOwnerProjectGroup; if Group<>nil then Result:=Group.CallRunLazbuildHandlers(Self,Tool) else Result:=true; end; function TPGCompileTarget.GetAllowedActions: TPGTargetActions; begin Result:=PGTargetActions[TargetType]; end; procedure TPGCompileTarget.SetTargetType(AValue: TPGTargetType); begin if FTargetType=AValue then Exit; FTargetType:=AValue; end; procedure TPGCompileTarget.DoDeactivateChildren; var i: Integer; begin if ProjectGroup=nil then exit; for i:=0 to ProjectGroup.TargetCount-1 do ProjectGroup.Targets[i].DoDeActivate(false); end; procedure TPGCompileTarget.DoActivate(DeactivateChildren: boolean); var OldActive: TPGCompileTarget; PG: TProjectGroup; begin if DeactivateChildren then DoDeactivateChildren; if Active then exit; if Parent<>nil then begin PG:=Parent.ProjectGroup; if PG<>nil then begin OldActive:=PG.ActiveTarget; if OldActive<>nil then OldActive.DoDeActivate(false); end; Parent.DoActivate(false); PG.IncreaseChangeStamp; end; FActive:=True; end; procedure TPGCompileTarget.DoDeActivate(DeactivateParents: boolean); begin if not Active then exit; if ProjectGroup<>nil then begin ProjectGroup.IncreaseChangeStamp; DoDeactivateChildren; end; FActive:=False; if DeactivateParents and (Parent<>nil) then Parent.DoDeActivate(true); end; constructor TPGCompileTarget.Create(aParent: TPGCompileTarget); begin FParent:=aParent; end; procedure TPGCompileTarget.SetFilename(const AValue: string); begin if FFileName=AValue then Exit; FFileName:=AValue; TargetType:=TargetTypeFromExtension(ExtractFileExt(AValue)); if ProjectGroup<>nil then ProjectGroup.FileName:=Filename; end; procedure TPGCompileTarget.SetMissing(const AValue: boolean); begin if Missing=AValue then exit; FMissing:=AValue; end; procedure TPGCompileTarget.Activate; begin if Active then exit; DoActivate(true); ActiveChanged(Self); end; procedure TPGCompileTarget.DeActivate; begin if not Active then exit; DoDeActivate(true); ActiveChanged(Self); end; function TPGCompileTarget.GetOwnerProjectGroup: TProjectGroup; var aTarget: TPGCompileTarget; begin aTarget:=Self; while (aTarget<>nil) do begin Result:=aTarget.ProjectGroup; if Result<>nil then exit; aTarget:=aTarget.Parent; end; Result:=nil; end; function TPGCompileTarget.GetRootProjectGroup: TProjectGroup; var aTarget: TPGCompileTarget; begin aTarget:=Self; while (aTarget.Parent<>nil) do aTarget:=aTarget.Parent; Result:=aTarget.ProjectGroup; end; function TPGCompileTarget.GetNext(SkipChildren: boolean): TPGCompileTarget; var aTarget: TPGCompileTarget; PG: TProjectGroup; i: Integer; begin // check first child if (not SkipChildren) and (ProjectGroup<>nil) and (ProjectGroup.TargetCount>0) then exit(ProjectGroup.Targets[0]); // check next sibling aTarget:=Self; while aTarget.Parent<>nil do begin PG:=aTarget.Parent.ProjectGroup; if PG<>nil then begin i:=PG.IndexOfTarget(aTarget); if (i>=0) and (i+1=0) and (CompareText(aName,BuildModes[Result].Identifier)<>0) do dec(Result); end; function TPGCompileTarget.FindBuildMode(aName: string): TPGBuildMode; var i: Integer; begin i:=IndexOfBuildMode(aName); if i>=0 then Result:=BuildModes[i] else Result:=nil; end; function TPGCompileTarget.Perform(AAction: TPGTargetAction): TPGActionResult; begin if Not (AAction in AllowedActions) then Result:=arNotAllowed else Result:=PerformAction(AAction); end; end.