projectgroups: added Info form showing source paths

git-svn-id: trunk@61564 -

.gitattributes

@@ -4215,6 +4215,8 @@ components/projectgroups/languages/projectgroupstrconst.uk.po svneol=native#text
 components/projectgroups/languages/projectgroupstrconst.zh_CN.po svneol=native#text/plain
 components/projectgroups/lazprojectgroups.lpk svneol=native#text/plain
 components/projectgroups/lazprojectgroups.pas svneol=native#text/plain
+components/projectgroups/prjgrpinfofrm.lfm svneol=native#text/plain
+components/projectgroups/prjgrpinfofrm.pas svneol=native#text/plain
 components/projectgroups/prjgrpoptionsfrm.lfm svneol=native#text/plain
 components/projectgroups/prjgrpoptionsfrm.pas svneol=native#text/plain
 components/projectgroups/projectgroup.pp svneol=native#text/plain

components/projectgroups/lazprojectgroups.lpk

@@ -17,7 +17,7 @@
     <License Value="Same as IDEIntf.
 GPL-2."/>
     <Version Minor="7"/>
-    <Files Count="7">
+    <Files Count="8">
       <Item1>
         <Filename Value="projectgroupintf.pp"/>
         <UnitName Value="ProjectGroupIntf"/>
@@ -45,8 +45,12 @@ GPL-2."/>
       </Item6>
       <Item7>
         <Filename Value="prjgrpoptionsfrm.pas"/>
-        <UnitName Value="prjgrpoptionsfrm"/>
+        <UnitName Value="PrjGrpOptionsFrm"/>
       </Item7>
+      <Item8>
+        <Filename Value="prjgrpinfofrm.pas"/>
+        <UnitName Value="PrjGrpInfoFrm"/>
+      </Item8>
     </Files>
     <i18n>
       <EnableI18N Value="True"/>

components/projectgroups/lazprojectgroups.pas

@@ -9,7 +9,7 @@ interface
 
 uses
   ProjectGroupIntf, ProjectGroup, ProjectGroupEditor, RegProjectGroup, 
-  ProjectGroupStrConst, PrjGrpOptionsFrm, LazarusPackageIntf;
+  ProjectGroupStrConst, PrjGrpOptionsFrm, PrjGrpInfoFrm, LazarusPackageIntf;
 
 implementation
 

components/projectgroups/prjgrpinfofrm.lfm

@@ -0,0 +1,40 @@
+object PrjGrpInfoForm: TPrjGrpInfoForm
+  Left = 374
+  Height = 240
+  Top = 281
+  Width = 320
+  Caption = 'PrjGrpInfoForm'
+  ClientHeight = 240
+  ClientWidth = 320
+  Position = poScreenCenter
+  LCLVersion = '2.1.0.0'
+  object Memo1: TMemo
+    Left = 6
+    Height = 186
+    Top = 6
+    Width = 308
+    Align = alClient
+    BorderSpacing.Around = 6
+    Lines.Strings = (
+      'Memo1'
+    )
+    ScrollBars = ssAutoVertical
+    TabOrder = 0
+  end
+  object ButtonPanel1: TButtonPanel
+    Left = 6
+    Height = 36
+    Top = 198
+    Width = 308
+    OKButton.Name = 'OKButton'
+    OKButton.DefaultCaption = True
+    HelpButton.Name = 'HelpButton'
+    HelpButton.DefaultCaption = True
+    CloseButton.Name = 'CloseButton'
+    CloseButton.DefaultCaption = True
+    CancelButton.Name = 'CancelButton'
+    CancelButton.DefaultCaption = True
+    TabOrder = 1
+    ShowButtons = [pbOK]
+  end
+end

components/projectgroups/prjgrpinfofrm.pas

@@ -0,0 +1,51 @@
+unit PrjGrpInfoFrm;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ButtonPanel,
+  ProjectGroup, LazStringUtils;
+
+type
+
+  { TPrjGrpInfoForm }
+
+  TPrjGrpInfoForm = class(TForm)
+    ButtonPanel1: TButtonPanel;
+    Memo1: TMemo;
+  private
+  public
+  end;
+
+procedure ShowPrgGrpInfo(Target: TIDECompileTarget);
+
+implementation
+
+procedure ShowPrgGrpInfo(Target: TIDECompileTarget);
+var
+  PrjGrpInfoForm: TPrjGrpInfoForm;
+  sl: TStringList;
+  s: String;
+begin
+  sl:=TStringList.Create;
+  PrjGrpInfoForm:=TPrjGrpInfoForm.Create(nil);
+  try
+    if Target<>nil then
+      ;// ToDo: show only SrcPath for this target
+    sl.Add('Source directories of project group:');
+    s:=IDEProjectGroupManager.GetSrcPaths;
+    SplitString(s,';',sl,false);
+    PrjGrpInfoForm.Memo1.Lines.Assign(sl);
+    PrjGrpInfoForm.ShowModal;
+  finally
+    PrjGrpInfoForm.Free;
+    sl.Free;
+  end;
+end;
+
+{$R *.lfm}
+
+end.
+

components/projectgroups/projectgroup.pp

@@ -35,7 +35,8 @@ interface
 uses
   Classes, SysUtils, contnrs,
   // LazUtils
-  LazFileUtils, FileUtil, LazFileCache, LazConfigStorage, Laz2_XMLCfg, LazTracer,
+  LazFileUtils, FileUtil, LazFileCache, LazConfigStorage, Laz2_XMLCfg,
+  LazTracer, LazUtilities, AvgLvlTree, LazStringUtils,
   // LCL
   Controls, Forms, Dialogs,
   // CodeTools
@@ -43,7 +44,7 @@ uses
   // IdeIntf
   PackageIntf, ProjectIntf, MenuIntf, LazIDEIntf, IDEDialogs, CompOptsIntf,
   BaseIDEIntf, IDECommands, IDEExternToolIntf, MacroIntf, IDEMsgIntf,
-  ToolBarIntf,
+  ToolBarIntf, MacroDefIntf, PackageDependencyIntf, PackageLinkIntf,
   // ProjectGroups
   ProjectGroupIntf, ProjectGroupStrConst;
 
@@ -213,8 +214,16 @@ type
     FOptions: TIDEProjectGroupOptions;
     procedure AddToRecentGroups(aFilename: string);
     function GetNewFileName: Boolean;
+    function GetPGSrcPaths(const s: string; const {%H-}Data: PtrInt;
+      var Abort: boolean): string;
     procedure OnIdle(Sender: TObject; var {%H-}Done: Boolean);
     procedure SetIdleConnected(const AValue: boolean);
+    procedure AddSrcPathOfFile(SrcPaths: TFilenameToStringTree; Filename: string);
+    procedure AddProjectSrcPaths(Target: TIDECompileTarget; SrcPaths, LPKFiles: TFilenameToStringTree);
+    procedure AddPackageSrcPaths(Target: TIDECompileTarget; SrcPaths, LPKFiles: TFilenameToStringTree);
+    procedure AddPackageNameSrcPaths(PkgName, PreferredFile, DefaultFile: string; SrcPaths, LPKFiles: TFilenameToStringTree);
+    procedure AddLPKSrcPaths(LPKFilename: string; SrcPaths, LPKFiles: TFilenameToStringTree);
+    procedure AddGroupSrcPaths(Group: TProjectGroup; SrcPaths, LPKFiles: TFilenameToStringTree);
   protected
     FIDEStarted: boolean;
     FProjectGroup: TIDEProjectGroup;
@@ -241,6 +250,7 @@ type
     procedure Redo; override;
     procedure LoadProjectGroup(AFileName: string; AOptions: TProjectGroupLoadOptions); override;
     procedure SaveProjectGroup; override;
+    function GetSrcPaths: string; override;
   public
     property Options: TIDEProjectGroupOptions read FOptions;
     property IdleConnected: boolean read FIdleConnected write SetIdleConnected;
@@ -593,6 +603,8 @@ begin
   FUndoList:=TObjectList.Create(true);
   FRedoList:=TObjectList.Create(true);
   IdleConnected:=true;
+
+  IDEMacros.Add(TTransferMacro.Create('PGSrcPaths','','Project groups source paths',@GetPGSrcPaths,[]));
 end;
 
 destructor TIDEProjectGroupManager.Destroy;
@@ -706,6 +718,15 @@ begin
   end;
 end;
 
+function TIDEProjectGroupManager.GetPGSrcPaths(const s: string;
+  const Data: PtrInt; var Abort: boolean): string;
+begin
+  Abort:=false;
+  if (s<>'') and (ConsoleVerbosity>=0) then
+    debugln(['Hint: (lazarus) [TIDEProjectGroupManager.GetPGSrcPaths] ignoring macro PGSrcPaths parameter "',s,'"']);
+  Result:=GetSrcPaths;
+end;
+
 procedure TIDEProjectGroupManager.OnIdle(Sender: TObject; var Done: Boolean);
 begin
   if FIDEStarted then
@@ -737,6 +758,168 @@ begin
     Application.RemoveOnIdleHandler(@OnIdle);
 end;
 
+procedure TIDEProjectGroupManager.AddSrcPathOfFile(
+  SrcPaths: TFilenameToStringTree; Filename: string);
+var
+  SrcPath: String;
+begin
+  //debugln(['TIDEProjectGroupManager.AddSrcPathOfFile ',Filename]);
+  SrcPath:=ChompPathDelim(ExtractFilePath(ResolveDots(Filename)));
+  SrcPaths[SrcPath]:='1';
+end;
+
+procedure TIDEProjectGroupManager.AddProjectSrcPaths(Target: TIDECompileTarget;
+  SrcPaths, LPKFiles: TFilenameToStringTree);
+var
+  aProject: TLazProject;
+  p, i: Integer;
+  Paths, Path: String;
+begin
+  aProject:=LazarusIDE.ActiveProject;
+  if (aProject<>nil)
+      and (CompareFilenames(aProject.ProjectInfoFile,Target.Filename)=0) then
+  begin
+    // active project, can be virtual
+    //debugln(['TIDEProjectGroupManager.AddProjectSrcPaths Active project']);
+    AddSrcPathOfFile(SrcPaths,aProject.ProjectInfoFile);
+    Paths:=aProject.LazCompilerOptions.GetSrcPath(false);
+    //debugln(['TIDEProjectGroupManager.AddProjectSrcPaths Active project Paths="',Paths,'"']);
+    p:=1;
+    repeat
+      Path:=GetNextDelimitedItem(Paths,';',p);
+      if p>length(Paths) then break;
+      SrcPaths[Path]:='1';
+    until false;
+  end else begin
+    // lpi on disk -> use files in Target
+    //debugln(['TIDEProjectGroupManager.AddProjectSrcPaths Inactive project']);
+    AddSrcPathOfFile(SrcPaths,Target.Filename);
+    for i:=0 to Target.FileCount-1 do
+      AddSrcPathOfFile(SrcPaths,Target.Files[i]);
+  end;
+  // add SrcPaths of required packages
+  for i:=0 to Target.RequiredPackageCount-1 do
+    AddPackageNameSrcPaths(Target.RequiredPackages[i].PackageName,'','',SrcPaths,LPKFiles);
+end;
+
+procedure TIDEProjectGroupManager.AddPackageSrcPaths(Target: TIDECompileTarget;
+  SrcPaths, LPKFiles: TFilenameToStringTree);
+begin
+  AddLPKSrcPaths(Target.Filename,SrcPaths,LPKFiles);
+end;
+
+procedure TIDEProjectGroupManager.AddPackageNameSrcPaths(PkgName,
+  PreferredFile, DefaultFile: string; SrcPaths, LPKFiles: TFilenameToStringTree
+  );
+var
+  LPKFilename: String;
+  Link: TPackageLink;
+begin
+  if not IsValidPkgName(PkgName) then exit;
+  if FilenameIsAbsolute(PreferredFile) and FileExistsCached(PreferredFile) then
+    LPKFilename:=PreferredFile
+  else if FilenameIsAbsolute(DefaultFile) and FileExistsCached(DefaultFile) then
+    LPKFilename:=DefaultFile
+  else begin
+    Link:=PkgLinks.FindLinkWithPkgName(PkgName);
+    if Link=nil then begin
+      debugln(['Warning: (lazarus) [TIDEProjectGroupManager.AddPackageNameSrcPaths] package "',PkgName,'" not found']);
+      exit;
+    end;
+    LPKFilename:=Link.GetEffectiveFilename;
+    if not FilenameIsAbsolute(LPKFilename) then
+      exit;
+  end;
+  AddLPKSrcPaths(LPKFilename,SrcPaths,LPKFiles);
+end;
+
+procedure TIDEProjectGroupManager.AddLPKSrcPaths(LPKFilename: string; SrcPaths,
+  LPKFiles: TFilenameToStringTree);
+var
+  xml: TXMLConfig;
+  Path, SubPath, CurFilename, PkgName, PreferredFilename,
+    DefaultFilename, Paths, BaseDir: String;
+  Cnt, i, p: Integer;
+  Pkg: TIDEPackage;
+begin
+  if LPKFiles.Contains(LPKFilename) then exit;
+  //debugln(['TIDEProjectGroupManager.AddLPKSrcPaths ',LPKFilename]);
+  for i:=0 to PackageEditingInterface.GetPackageCount-1 do
+  begin
+    Pkg:=PackageEditingInterface.GetPackages(i);
+    if CompareFilenames(Pkg.Filename,LPKFilename)=0 then
+    begin
+      // loaded package, can be virtual
+      //debugln(['TIDEProjectGroupManager.AddPackageSrcPaths LOADED Pkg.Filename=',Pkg.Filename]);
+      AddSrcPathOfFile(SrcPaths,Pkg.Filename);
+      Paths:=Pkg.LazCompilerOptions.GetSrcPath(false);
+      //debugln(['TIDEProjectGroupManager.AddPackageSrcPaths LOADED Paths=',Paths]);
+      p:=1;
+      repeat
+        Path:=GetNextDelimitedItem(Paths,';',p);
+        if p>length(Paths) then break;
+        SrcPaths[Path]:='1';
+      until false;
+      exit;
+    end;
+  end;
+  // not loaded lpk -> parse xml
+  // Note: do not open package, as this might clash with active packages
+  xml:=LoadXML(LPKFilename,true);
+  try
+    if xml=nil then exit;
+    AddSrcPathOfFile(SrcPaths,LPKFilename);
+    BaseDir:=ExtractFilePath(LPKFilename);
+    // list of files
+    Path:='Files/';
+    Cnt:=xml.GetValue(Path+'Count',0);
+    for i:=1 to Cnt do begin
+      SubPath:=Path+'Item'+IntToStr(i)+'/';
+      CurFilename:=xml.GetValue(SubPath+'Filename/Value','');
+      if CurFilename='' then continue;
+      AddSrcPathOfFile(SrcPaths,CurFilename);
+    end;
+
+    // load list of RequiredPackages from lpk
+    Path:='Package/RequiredPkgs/';
+    Cnt:=xml.GetValue(Path+'Count',0);
+    for i:=1 to Cnt do begin
+      SubPath:=Path+'Item'+IntToStr(i)+'/';
+      PkgName:=xml.GetValue(SubPath+'PackageName/Value','');
+      if not IsValidPkgName(PkgName) then continue;
+      PreferredFilename:=xml.GetValue(SubPath+'DefaultFilename/Prefer','');
+      if (PreferredFilename<>'') and not FilenameIsAbsolute(PreferredFilename) then
+        PreferredFilename:=ResolveDots(BaseDir+PreferredFilename);
+      DefaultFilename:=xml.GetValue(SubPath+'DefaultFilename/Value','');
+      if (DefaultFilename<>'') and not FilenameIsAbsolute(DefaultFilename) then
+        DefaultFilename:=ResolveDots(BaseDir+DefaultFilename);
+      AddPackageNameSrcPaths(PkgName,PreferredFilename,DefaultFilename,SrcPaths,LPKFiles);
+    end;
+  finally
+    xml.Free;
+  end;
+end;
+
+procedure TIDEProjectGroupManager.AddGroupSrcPaths(Group: TProjectGroup;
+  SrcPaths, LPKFiles: TFilenameToStringTree);
+var
+  i: Integer;
+  Target: TIDECompileTarget;
+begin
+  if Group=nil then exit;
+  //debugln(['TIDEProjectGroupManager.AddGroupSrcPaths ',Group.FileName,' Group.TargetCount=',Group.TargetCount]);
+  for i:=0 to Group.TargetCount-1 do
+  begin
+    Target:=TIDECompileTarget(Group.Targets[i]);
+    case Target.TargetType of
+      ttProject: AddProjectSrcPaths(Target,SrcPaths,LPKFiles);
+      ttPackage: AddPackageSrcPaths(Target,SrcPaths,LPKFiles);
+      ttProjectGroup: AddGroupSrcPaths(Target.ProjectGroup,SrcPaths,LPKFiles);
+      ttPascalFile: AddSrcPathOfFile(SrcPaths,Target.Filename);
+    end;
+  end;
+end;
+
 procedure TIDEProjectGroupManager.AddToRecentGroups(aFilename: string);
 begin
   Options.AddToRecentProjectGroups(AFileName);
@@ -832,6 +1015,29 @@ begin
   end;
 end;
 
+function TIDEProjectGroupManager.GetSrcPaths: string;
+var
+  SrcPaths, LPKFiles: TFilenameToStringTree;
+  s: PStringToStringItem;
+begin
+  Result:='';
+  if not Assigned(FProjectGroup) then exit;
+  LPKFiles:=TFilenameToStringTree.Create(false);
+  SrcPaths:=TFilenameToStringTree.Create(false);
+  try
+    AddGroupSrcPaths(FProjectGroup,SrcPaths,LPKFiles);
+    for s in SrcPaths do begin
+      if s^.Name='' then continue;
+      if Result<>'' then
+        Result:=Result+';';
+      Result:=Result+s^.Name;
+    end;
+  finally
+    SrcPaths.Free;
+    LPKFiles.Free;
+  end;
+end;
+
 { TRootProjectGroupTarget }
 
 procedure TRootProjectGroupTarget.SetTargetType(AValue: TPGTargetType);

components/projectgroups/projectgroupeditor.lfm

@@ -980,6 +980,9 @@ object ProjectGroupEditorForm: TProjectGroupEditorForm
     object PMIOptions: TMenuItem
       Action = AProjectGroupOptions
     end
+    object PMIInfo: TMenuItem
+      Action = ATargetInfo
+    end
   end
   object ActionListMain: TActionList
     Images = ImageListMain
@@ -1119,6 +1122,12 @@ object ProjectGroupEditorForm: TProjectGroupEditorForm
       Caption = 'Options'
       OnExecute = AProjectGroupOptionsExecute
     end
+    object ATargetInfo: TAction
+      Category = 'TargetAction'
+      Caption = 'Info'
+      OnExecute = ATargetInfoExecute
+      OnUpdate = ATargetInfoUpdate
+    end
   end
   object PopupMenuTree: TPopupMenu
     Images = ImageListMain

components/projectgroups/projectgroupeditor.pas

@@ -22,7 +22,7 @@ uses
   LazIDEIntf, PackageIntf, ProjectIntf, ProjectGroupIntf, MenuIntf, IDEWindowIntf,
   IDEDialogs, IDECommands,
   // ProjectGroups
-  ProjectGroupStrConst, ProjectGroup, PrjGrpOptionsFrm;
+  ProjectGroupStrConst, ProjectGroup, PrjGrpOptionsFrm, PrjGrpInfoFrm;
 
 type
   TNodeType = (
@@ -47,6 +47,7 @@ type
   { TProjectGroupEditorForm }
 
   TProjectGroupEditorForm = class(TForm)
+    ATargetInfo: TAction;
     AProjectGroupOptions: TAction;
     AProjectGroupRedo: TAction;
     AProjectGroupUndo: TAction;
@@ -70,6 +71,7 @@ type
     AProjectGroupSave: TAction;
     ActionListMain: TActionList;
     ImageListMain: TImageList;
+    PMIInfo: TMenuItem;
     PMIOptions: TMenuItem;
     PMIRedo: TMenuItem;
     PMIUndo: TMenuItem;
@@ -127,6 +129,8 @@ type
     procedure ATargetCopyFilenameUpdate(Sender: TObject);
     procedure ATargetEarlierExecute(Sender: TObject);
     procedure ATargetEarlierUpdate(Sender: TObject);
+    procedure ATargetInfoExecute(Sender: TObject);
+    procedure ATargetInfoUpdate(Sender: TObject);
     procedure ATargetInstallExecute(Sender: TObject);
     procedure ATargetInstallUpdate(Sender: TObject);
     procedure ATargetLaterExecute(Sender: TObject);
@@ -480,6 +484,16 @@ begin
   UpdateIDEMenuCommandFromAction(Sender,MnuCmdTargetEarlier);
 end;
 
+procedure TProjectGroupEditorForm.ATargetInfoExecute(Sender: TObject);
+begin
+  ShowPrgGrpInfo(SelectedTarget as TIDECompileTarget);
+end;
+
+procedure TProjectGroupEditorForm.ATargetInfoUpdate(Sender: TObject);
+begin
+
+end;
+
 procedure TProjectGroupEditorForm.ATargetLaterExecute(Sender: TObject);
 Var
   T: TNodeData;

components/projectgroups/projectgroupintf.pp

@@ -204,6 +204,7 @@ Type
   public
     procedure LoadProjectGroup(AFileName: string; AOptions: TProjectGroupLoadOptions); virtual; abstract;
     procedure SaveProjectGroup; virtual; abstract;
+    function GetSrcPaths: string; virtual; abstract;
     function CanUndo: boolean; virtual; abstract;
     function CanRedo: boolean; virtual; abstract;
     procedure Undo; virtual; abstract;