paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-18 05:29:38 +02:00
Code Issues Packages Projects Releases Wiki Activity

DocMgr: more support for FCL packages

Browse Source 
git-svn-id: trunk@35658 -
This commit is contained in:
dodi 2012-03-03 08:35:00 +00:00
parent 95659a5d58
commit b052eb6172
6 changed files with 206 additions and 60 deletions

3
examples/fpdocmanager/docs/umanager.xml
View File

@ -1074,10 +1074,11 @@ This method searches the units for the given description files and adds them to
</element>
<element name="ListUnits">
<short>Adds the filenames (without extension) specified by AMask (dir+mask) to AList. Used to collect XML description files.</short>
<descr>Units in NoParseUnits are not added.</descr>
</element>
<element name="MatchUnits">
<short>Searches for source files in ADir, which match an unit name in AList, and returns -1 if none matches.</short>
<descr>Used to find input files for description files. The Result is not very useful, because the matched entry is removed from AList.</descr>
<descr>Used to find input files for description files.</descr>
</element>
<element name="TFCLDocPackage.SrcDirs">
<short>List of all FCL source directories, with include indicators.</short>

86
examples/fpdocmanager/fconfig.lfm
View File

@ -1,26 +1,26 @@
object CfgWizard: TCfgWizard
Left = 368
Height = 300
Height = 301
Top = 116
Width = 317
Width = 315
Caption = 'Configuration Assistant'
ClientHeight = 300
ClientWidth = 317
ClientHeight = 301
ClientWidth = 315
OnShow = FormShow
LCLVersion = '0.9.31'
object Steps: TPageControl
Left = 0
Height = 239
Height = 240
Top = 0
Width = 317
Width = 315
ActivePage = SelRoot
Align = alClient
TabIndex = 0
TabOrder = 0
object SelRoot: TTabSheet
Caption = 'RootDir'
ClientHeight = 211
ClientWidth = 309
ClientHeight = 212
ClientWidth = 307
OnShow = SelRootShow
object Label1: TLabel
Left = 10
@ -200,8 +200,8 @@ object CfgWizard: TCfgWizard
end
object MkFCL: TTabSheet
Caption = 'FCL'
ClientHeight = 211
ClientWidth = 309
ClientHeight = 212
ClientWidth = 307
OnShow = MkFCLShow
object Label6: TLabel
Left = 10
@ -215,7 +215,7 @@ object CfgWizard: TCfgWizard
Left = 12
Height = 19
Hint = 'Add lazarus/docs/xml/fcl to the FCL descriptions'
Top = 56
Top = 50
Width = 169
Caption = 'Add Lazarus docs to the FCL'
OnChange = swFCLadsChange
@ -223,12 +223,12 @@ object CfgWizard: TCfgWizard
end
object swDirs: TCheckListBox
Left = 12
Height = 128
Height = 113
Hint = 'Check the directories to include into the FCL docs'
Top = 80
Width = 280
Top = 96
Width = 278
Anchors = [akTop, akLeft, akRight, akBottom]
Columns = 2
Columns = 3
Items.Strings = (
'fcl-base'
'fcl-db'
@ -254,23 +254,65 @@ object CfgWizard: TCfgWizard
OnClick = buScanFclClick
TabOrder = 2
end
object swAllFclDirs: TCheckBox
Left = 12
Height = 19
Top = 72
Width = 115
Caption = 'Include entire FCL'
OnChange = swAllFclDirsChange
TabOrder = 3
end
end
object NoParse: TTabSheet
Caption = 'NoParse'
ClientHeight = 211
ClientWidth = 307
object Label7: TLabel
Left = 10
Height = 46
Top = 10
Width = 232
Caption = 'Some FCL units don''t parse without specific'#13#10'compiler options. Unselect their packages, '#13#10'or add their unit names to this list.'
ParentColor = False
end
object swNoParse: TCheckBox
Left = 12
Height = 19
Top = 64
Width = 184
Caption = 'Never parse the following units'
Checked = True
OnChange = swNoParseChange
State = cbChecked
TabOrder = 0
end
object edNoParse: TMemo
Left = 12
Height = 122
Top = 88
Width = 288
Anchors = [akTop, akLeft, akRight, akBottom]
OnExit = edNoParseExit
TabOrder = 1
end
end
end
object sb: TStatusBar
Left = 0
Height = 23
Top = 277
Width = 317
Top = 278
Width = 315
Panels = <>
end
object Panel1: TPanel
Left = 0
Height = 38
Top = 239
Width = 317
Top = 240
Width = 315
Align = alBottom
ClientHeight = 38
ClientWidth = 317
ClientWidth = 315
TabOrder = 2
object buBack: TButton
Left = 8
@ -292,7 +334,7 @@ object CfgWizard: TCfgWizard
TabOrder = 1
end
object buNext: TButton
Left = 229
Left = 227
Height = 25
Top = 5
Width = 75
@ -302,7 +344,7 @@ object CfgWizard: TCfgWizard
TabOrder = 2
end
object Button1: TButton
Left = 181
Left = 179
Height = 25
Top = 5
Width = 35

28
examples/fpdocmanager/fconfig.pas
View File

@ -25,6 +25,10 @@ type
buRtlBat: TButton;
buLazDir: TButton;
buScanFcl: TButton;
swAllFclDirs: TCheckBox;
swNoParse: TCheckBox;
Label7: TLabel;
edNoParse: TMemo;
swDirs: TCheckListBox;
swFCLads: TCheckBox;
edFpcDir: TEdit;
@ -49,6 +53,7 @@ type
MkRTL: TTabSheet;
MkLCL: TTabSheet;
MkFCL: TTabSheet;
NoParse: TTabSheet;
procedure buBackClick(Sender: TObject);
procedure buFclBatClick(Sender: TObject);
procedure buLazDirClick(Sender: TObject);
@ -61,6 +66,7 @@ type
procedure edFpcDirChange(Sender: TObject);
procedure edFpcDocsChange(Sender: TObject);
procedure edLazDirChange(Sender: TObject);
procedure edNoParseExit(Sender: TObject);
procedure edRootChange(Sender: TObject);
procedure edRtlBatChange(Sender: TObject);
procedure FormShow(Sender: TObject);
@ -69,8 +75,10 @@ type
procedure MkRTLShow(Sender: TObject);
procedure SelFPDirShow(Sender: TObject);
procedure SelRootShow(Sender: TObject);
procedure swAllFclDirsChange(Sender: TObject);
procedure swDirsExit(Sender: TObject);
procedure swFCLadsChange(Sender: TObject);
procedure swNoParseChange(Sender: TObject);
private
NoRun: boolean;
procedure GetFclDirs;
@ -127,6 +135,12 @@ begin
Manager.ImportLpk(Manager.LazarusDir + 'lcl/lclbase.lpk');
end;
procedure TCfgWizard.edNoParseExit(Sender: TObject);
begin
if edNoParse.Modified then
Manager.NoParseUnits := edNoParse.Lines;
end;
procedure TCfgWizard.edRootChange(Sender: TObject);
begin
if NoRun then exit;
@ -151,6 +165,9 @@ begin
edLazDir.Text := Manager.LazarusDir;
swFCLads.Checked := Manager.IsExtended('fcl') <> '';
swNoParse.Checked := Manager.ExcludeUnits;
edNoParse.Lines.Assign(Manager.NoParseUnits);
NoRun:=False;
end;
@ -255,6 +272,12 @@ begin
buNext.Enabled := Manager.RootDir <> '';
end;
procedure TCfgWizard.swAllFclDirsChange(Sender: TObject);
begin
if FclPkg <> nil then
FclPkg.AllDirs := swAllFclDirs.Checked;
end;
procedure TCfgWizard.swDirsExit(Sender: TObject);
begin
if swDirs.Count > 0 then
@ -266,6 +289,11 @@ begin
Manager.UpdateFCL(swFCLads.Checked);
end;
procedure TCfgWizard.swNoParseChange(Sender: TObject);
begin
Manager.ExcludeUnits := swNoParse.Checked;
end;
procedure TCfgWizard.buScanFclClick(Sender: TObject);
var
s: string;

13
examples/fpdocmanager/fmain.pas
View File

@ -588,12 +588,15 @@ begin
else
u := '';
try
Manager.Update(CurPkg, u);
except
on e: Exception do
LogToFile(self, e.Message);
try
Manager.Update(CurPkg, u);
except
on e: Exception do
LogToFile(self, e.Message);
end;
finally
LogDone;
end;
LogDone;
end;
procedure TMain.buNewProfileClick(Sender: TObject);

5
examples/fpdocmanager/umakeskel.pas
View File

@ -677,7 +677,7 @@ begin
FEmittedList:=TStringList.Create;
FEmittedList.Sorted:=True;
try
Module:=ParseSource(Self,AFileName,ATarget,ACPU);
Module:=ParseSource(Self,AFileName,ATarget,ACPU, True); //use streams
If Options.UpdateMode then
begin
N:=FindDocNode(Module);
@ -1108,6 +1108,9 @@ begin
WriteLn(f, '</package>');
WriteLn(f, '</fpdoc-descriptions>');
Close(f);
if Result <> '' then begin
DeleteFile(AOutputName); //remove invalid file
end;
end;
end;

131
examples/fpdocmanager/umanager.pas
View File

@ -58,6 +58,7 @@ type
*)
TDocPackage = class
private
FAllDirs: boolean;
FAltDir: string;
FCompOpts: string;
FDescrDir: string;
@ -73,6 +74,7 @@ type
FRequires: TStrings;
FUnitPath: string;
FUnits: TStrings;
procedure SetAllDirs(AValue: boolean);
procedure SetAltDir(AValue: string);
procedure SetCompOpts(AValue: string);
procedure SetDescrDir(AValue: string);
@ -102,6 +104,7 @@ type
property ProjectFile: string read FProjectFile write SetProjectFile; //xml?
//from LazPkg
procedure AddUnit(const AFile: string);
property AllDirs: boolean read FAllDirs write SetAllDirs;
property CompOpts: string read FCompOpts write SetCompOpts;
property LazPkg: string read FLazPkg write SetLazPkg; //LPK name?
property ProjectDir: string read FProjectDir write SetProjectDir;
@ -156,10 +159,12 @@ type
*)
TFPDocManager = class(TComponent)
private
FExcludedUnits: boolean;
FFpcDir: string;
FFPDocDir: string;
FLazarusDir: string;
FModified: boolean;
FNoParseUnits: TStringList;
FOnChange: TNotifyEvent;
FOnLog: TLogHandler;
FOptions: TCmdOptions;
@ -169,9 +174,12 @@ type
FProfiles: string; //CSV list of profile names
FRootDir: string;
UpdateCount: integer;
function GetNoParseUnits: TStrings;
procedure SetExcludedUnits(AValue: boolean);
procedure SetFpcDir(AValue: string);
procedure SetFPDocDir(AValue: string);
procedure SetLazarusDir(AValue: string);
procedure SetNoParseUnits(AValue: TStrings);
procedure SetOnChange(AValue: TNotifyEvent);
procedure SetPackage(AValue: TDocPackage);
procedure SetProfile(AValue: string);
@ -206,6 +214,8 @@ type
function TestRun(APkg: TDocPackage; AUnit: string): boolean;
function Update(APkg: TDocPackage; const AUnit: string): boolean;
public //published?
property ExcludeUnits: boolean read FExcludedUnits write SetExcludedUnits;
property NoParseUnits: TStrings read GetNoParseUnits write SetNoParseUnits;
property FpcDir: string read FFpcDir write SetFpcDir;
property FpcDocDir: string read FFPDocDir write SetFPDocDir;
property LazarusDir: string read FLazarusDir write SetLazarusDir;
@ -271,13 +281,17 @@ end;
procedure ListUnits(const AMask: string; AList: TStrings);
var
Info : TSearchRec;
s: string;
s, f: string;
begin
if FindFirst (AMask,faArchive,Info)=0 then begin
repeat
s := Info.Name;
if s[1] <> '.' then
AList.Add(ChangeFileExt(s, '')); //unit name only
if s[1] <> '.' then begin
f := ChangeFileExt(s, ''); //unit name only
if Manager.ExcludeUnits and (Manager.NoParseUnits.IndexOf(f) >= 0) then
continue; //excluded unit!
AList.Add(f);
end;
until FindNext(info)<>0;
end;
FindClose(Info);
@ -297,7 +311,7 @@ begin
ext := ChangeFileExt(s, '');
Result := AList.IndexOf(ext); //ChangeFileExt(s, '.xml'));
if Result >= 0 then begin
AList.Delete(Result); //don't search any more
//AList.Delete(Result); //don't search any more
break;
end;
end;
@ -324,48 +338,46 @@ var
dirs, descs: TStringList;
incl, excl: boolean;
begin
(* This seems to be called twice for Refresh???
(* Add Lazarus FCL, and explicit or added or all FCL dirs
*)
if APrj.Package <> nil then
exit(True); //already configured
Result:=inherited CreateProject(APrj, AFile);
//add lazdir
if AltDir = '' then exit;
(* Add inputs for all descrs found in AltDir.
For *MakeSkel* add all units in the selected(!) fcl packages to inputs.
How to distinguish both modes?
*)
dirs := TStringList.Create; //use prepared list?
descs := TStringList.Create;
s := Manager.LazarusDir + 'docs' + DirectorySeparator + 'xml' + DirectorySeparator + 'fcl';
//APrj.ParseFPDocOption(Format('--descr-dir="%s"', [s])); //todo: add includes
//APrj.AddDirToFileList(descs, s, '*.xml');
ListUnits(s+ DirectorySeparator+ '*.xml', descs);
descs.Sorted := True;
//add lazdir
if AltDir <> '' then begin
(* Add inputs for all descrs found in AltDir.
For *MakeSkel* add all units in the selected(!) fcl packages to inputs.
How to distinguish both modes?
*)
s := Manager.LazarusDir + 'docs' + DirectorySeparator + 'xml' + DirectorySeparator + 'fcl';
//APrj.ParseFPDocOption(Format('--descr-dir="%s"', [s])); //todo: add includes
//APrj.AddDirToFileList(descs, s, '*.xml');
ListUnits(s+ DirectorySeparator+ '*.xml', descs); //exclude NoParseUnits
descs.Sorted := True;
end;
//scan fcl dirs
dirs := TStringList.Create; //use prepared list?
s := Manager.FFpcDir + 'packages' + DirectorySeparator;
ListDirs(s, dirs);
//now match all files in the source dirs
for i := dirs.Count - 1 downto 0 do begin
d := s + dirs[i] + DirectorySeparator + 'src';
if not DirectoryExists(d) then continue;
(* Problem: some files may not parse without specific compiler options.
Creating skeletons will fail for these files, but how can we in/exclude
specific source files from skeleton creation?
For now: skip explicitly excluded packages!
*)
excl := (assigned(FSrcDirs)
if not DirectoryExists(d) then continue; //can this happen?
(* skip explicitly excluded packages, and exclude selected units.
*)
excl := not FAllDirs
and assigned(FSrcDirs)
and (SrcDirs.IndexOfName(dirs[i]) >= 0)
and (SrcDirs.Values[dirs[i]] <= '0'));
and (SrcDirs.Values[dirs[i]] <= '0');
if excl then begin
//todo: add only selected units
Manager.DoLog('Skipping directory ' + dirs[i]);
//Manager.DoLog('Skipping directory ' + dirs[i]);
end else begin
incl := (assigned(FSrcDirs)
incl := FAllDirs
or (assigned(FSrcDirs)
and (SrcDirs.IndexOfName(dirs[i]) >= 0)
and (SrcDirs.Values[dirs[i]] > '0'))
or (MatchUnits(d, descs) >= 0);
or (MatchUnits(d, descs) >= 0); //!!! descs now is empty!
if incl then begin
//add dir
Manager.DoLog('Adding directory ' + dirs[i]);
@ -373,6 +385,15 @@ begin
end;
end;
end;
//exclude explicit units - only for FCL?
if Manager.ExcludeUnits and (Manager.NoParseUnits.Count > 0) then begin
//exclude inputs
for i := APrj.InputList.Count - 1 downto 0 do begin
s := ExtractUnitName(APrj.InputList, i);
if Manager.NoParseUnits.IndexOf(s) >= 0 then //case?
APrj.InputList.Delete(i);
end;
end;
//re-create project? The normal project was already created by inherited!
if AFile <> '' then begin
f := ChangeFileExt(AFile, '_ext.xml'); //preserve unmodified project?
@ -412,6 +433,12 @@ begin
Config.WriteString(SecDoc, 'AltDir', AltDir);
end;
procedure TDocPackage.SetAllDirs(AValue: boolean);
begin
if FAllDirs=AValue then Exit;
FAllDirs:=AValue;
end;
procedure TDocPackage.SetDescriptions(AValue: TStrings);
(* Shall we allow for multiple descriptions? (general + OS specific!?)
*)
@ -564,6 +591,7 @@ var
s, imp: string;
pkg: TFPDocPackage;
i: integer;
lst: TStringList;
begin
Result := APrj.Package <> nil; //already configured?
if Result then
@ -605,7 +633,19 @@ begin
//add descr files
s := Manager.LazarusDir + AltDir;
s := FixPath(s);
APrj.ParseFPDocOption(Format('--descr-dir="%s"', [s]));
if ForceDirectories(s) then begin
//exclude NoParse units
//APrj.ParseFPDocOption(Format('--descr-dir="%s"', [s]));
lst := TStringList.Create;
ListUnits(AltDir + '*.xml', lst); //unit names only
(* add the unit names from lst to the pkg/project
*)
pkg := APrj.SelectedPackage;
for i := 0 to lst.Count - 1 do begin
s := AltDir + lst[i] + '.xml';
pkg.Descriptions.Add(s);
end;
end;
//add source files!?
end;
//add Imports
@ -688,6 +728,7 @@ begin
FCompOpts := Config.ReadString(SecDoc, 'options', '');
FDescrDir := Config.ReadString(SecDoc, 'descrdir', '');
FAltDir := Config.ReadString(SecDoc, 'AltDir', '');
FAllDirs:= Config.ReadBool(SecDoc, 'AllDirs', False);
Requires.CommaText := Config.ReadString(SecDoc, 'requires', '');
//units
Config.ReadSection('units', Units);
@ -711,6 +752,7 @@ begin
Config.WriteString(SecDoc, 'options', CompOpts);
Config.WriteString(SecDoc, 'descrdir', DescrDir);
Config.WriteString(SecDoc, 'AltDir', AltDir);
Config.WriteBool(SecDoc, 'AllDirs', AllDirs);
Config.WriteString(SecDoc, 'requires', Requires.CommaText);
//units
Config.WriteSectionValues('units', Units);
@ -748,6 +790,7 @@ begin
lst.OwnsObjects := True;
FPackages := lst;
FOptions := TCmdOptions.Create;
FNoParseUnits := TStringList.Create;
end;
destructor TFPDocManager.Destroy;
@ -757,6 +800,7 @@ begin
//FPackages.Clear; //destructor seems NOT to clear/destroy owned object!?
FreeAndNil(FPackages);
FreeAndNil(FOptions);
FreeAndNil(FNoParseUnits);
inherited Destroy;
end;
@ -774,6 +818,13 @@ begin
Config.WriteString(SecGen, 'FpcDir', FpcDir);
end;
procedure TFPDocManager.SetExcludedUnits(AValue: boolean);
begin
if FExcludedUnits=AValue then Exit;
FExcludedUnits:=AValue;
Config.WriteBool(SecGen, 'ExcludeUnits', AValue);
end;
procedure TFPDocManager.UpdatePackage(const AName: string);
var
pkg: TDocPackage;
@ -821,6 +872,18 @@ begin
UpdatePackage('fcl');
end;
function TFPDocManager.GetNoParseUnits: TStrings;
begin
Result := FNoParseUnits;
end;
procedure TFPDocManager.SetNoParseUnits(AValue: TStrings);
begin
FNoParseUnits.Assign(AValue);
FNoParseUnits.Sorted := True;
Config.WriteSection('NoParseUnits', NoParseUnits);
end;
procedure TFPDocManager.SetOnChange(AValue: TNotifyEvent);
begin
if FOnChange=AValue then Exit;
@ -948,6 +1011,8 @@ begin
FProfiles:=Config.ReadString(SecGen, 'Profiles', 'default');
FProfile := Config.ReadString(SecGen,'Profile', 'default');
Options.LoadConfig(Config, Profile);
FExcludedUnits := Config.ReadBool(SecGen, 'ExcludeUnits', True);
Config.ReadSection('NoParseUnits', NoParseUnits);
//done, nothing modified
EndUpdate;
end;
@ -1337,6 +1402,10 @@ function TFPDocHelper.Update(APkg: TDocPackage; const AUnit: string): boolean;
var
OutName, msg: string;
begin
if Manager.NoParseUnits.IndexOf(AUnit) >= 0 then begin
DoLog('NoParse ' + AUnit);
exit(False);
end;
InputList.Clear;
InputList.Add(UnitSpec(AUnit));
DescrList.Clear;