DocMgr: added selectable FCL packages

git-svn-id: trunk@35414 -

examples/fpdocmanager/configfile.pas

@@ -187,6 +187,8 @@ procedure TConfigFile.WriteSection(const Section: string; Strings: TStrings);
 var
   sec: TStringList;
 begin
+  if Strings.Count = 0 then
+    exit; //delete section???
   sec := AddSection(Section);
   if not sec.Equals(Strings) then begin
     sec.Assign(Strings);

examples/fpdocmanager/docs/umanager.xml

@@ -1079,6 +1079,11 @@ This method searches the units for the given description files and adds them to
         <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>
       </element>
+      <element name="TFCLDocPackage.SrcDirs">
+        <short>List of all FCL source directories, with include indicators.</short>
+        <descr>The list constains name/value pairs. The name is the directory part of $FPC/packages/NAME/src/, or ../packages/NAME/src/.
+A nonzero value indicates that the directory is included into the docs.</descr>
+      </element>
     </module>
     <!-- uManager -->
   </package>

examples/fpdocmanager/fconfig.lfm

@@ -1,7 +1,7 @@
 object CfgWizard: TCfgWizard
-  Left = 362
+  Left = 368
   Height = 300
-  Top = 165
+  Top = 116
   Width = 317
   Caption = 'Configuration Assistant'
   ClientHeight = 300
@@ -214,12 +214,46 @@ object CfgWizard: TCfgWizard
       object swFCLads: TCheckBox
         Left = 12
         Height = 19
+        Hint = 'Add lazarus/docs/xml/fcl to the FCL descriptions'
         Top = 56
         Width = 169
         Caption = 'Add Lazarus docs to the FCL'
         OnChange = swFCLadsChange
         TabOrder = 0
       end
+      object swDirs: TCheckListBox
+        Left = 12
+        Height = 128
+        Hint = 'Check the directories to include into the FCL docs'
+        Top = 80
+        Width = 280
+        Anchors = [akTop, akLeft, akRight, akBottom]
+        Columns = 2
+        Items.Strings = (
+          'fcl-base'
+          'fcl-db'
+          'fcl-extra'
+          'fcl-process'
+          'fcl-web'
+          'paszlib'
+        )
+        ItemHeight = 17
+        OnExit = swDirsExit
+        TabOrder = 1
+        Data = {
+          06000000010101010101
+        }
+      end
+      object buScanFcl: TButton
+        Left = 217
+        Height = 25
+        Hint = 'Scan the FCL source directory'
+        Top = 50
+        Width = 75
+        Caption = 'Scan FCL'
+        OnClick = buScanFclClick
+        TabOrder = 2
+      end
     end
   end
   object sb: TStatusBar

examples/fpdocmanager/fconfig.pas

@@ -24,6 +24,8 @@ type
     buCancel: TButton;
     buRtlBat: TButton;
     buLazDir: TButton;
+    buScanFcl: TButton;
+    swDirs: TCheckListBox;
     swFCLads: TCheckBox;
     edFpcDir: TEdit;
     edFpcDocs: TEdit;
@@ -52,6 +54,7 @@ type
     procedure buLazDirClick(Sender: TObject);
     procedure buNextClick(Sender: TObject);
     procedure buRtlBatClick(Sender: TObject);
+    procedure buScanFclClick(Sender: TObject);
     procedure buSelFpcClick(Sender: TObject);
     procedure buSelFpcDocsClick(Sender: TObject);
     procedure buSelRootClick(Sender: TObject);
@@ -66,9 +69,12 @@ type
     procedure MkRTLShow(Sender: TObject);
     procedure SelFPDirShow(Sender: TObject);
     procedure SelRootShow(Sender: TObject);
+    procedure swDirsExit(Sender: TObject);
     procedure swFCLadsChange(Sender: TObject);
   private
     NoRun: boolean;
+    procedure GetFclDirs;
+    procedure PutFclDirs;
   public
     { public declarations }
   end; 
@@ -80,6 +86,8 @@ implementation
 
 uses
   uManager;
+var
+  FclPkg: TDocPackage;
 
 {$R *.lfm}
 
@@ -158,6 +166,7 @@ begin
     swFCLads.Checked := False;
     ShowMessage('Please select FPC and Lazarus directories first!');
   end;
+  GetFclDirs;
 end;
 
 procedure TCfgWizard.MkLCLShow(Sender: TObject);
@@ -246,10 +255,75 @@ begin
   buNext.Enabled := Manager.RootDir <> '';
 end;
 
+procedure TCfgWizard.swDirsExit(Sender: TObject);
+begin
+  if swDirs.Count > 0 then
+    PutFclDirs;
+end;
+
 procedure TCfgWizard.swFCLadsChange(Sender: TObject);
 begin
   Manager.UpdateFCL(swFCLads.Checked);
 end;
 
+procedure TCfgWizard.buScanFclClick(Sender: TObject);
+var
+  s: string;
+begin
+  s := Manager.FpcDir + 'packages' + DirectorySeparator;
+  ListDirs(s, swDirs.Items); //dupes suppressed
+  swDirs.Sorted := True; //sort?
+  PutFclDirs;
+end;
+
+procedure TCfgWizard.GetFclDirs;
+var
+  i, il: integer;
+  s: string;
+  b: boolean;
+  lst: TStrings;
+begin
+//read fcl.SrcDirs
+  FclPkg := Manager.AddPackage('fcl');
+  if FclPkg = nil then
+    exit;
+  lst := FclPkg.SrcDirs;
+  if (lst = nil) or (lst.Count = 0) then begin
+  //scan FCL
+    buScanFclClick(nil);
+    exit;
+  end;
+//read from config
+  swDirs.Clear;
+  for i := 0 to lst.Count - 1 do begin
+    s := lst.Names[i];
+    b := lst.ValueFromIndex[i] > '0';
+    il := swDirs.Items.Add(s); //dupes?
+    swDirs.Checked[il] := b;
+  end;
+end;
+
+procedure TCfgWizard.PutFclDirs;
+var
+  i, il: integer;
+  s: string;
+  b: boolean;
+  lst: TStrings;
+const
+  tf: array[boolean] of string = ('0','1');
+begin
+  if FclPkg = nil then
+    exit;
+  lst := FclPkg.SrcDirs;
+  if (lst = nil) then
+    exit;
+  for i := 0 to swDirs.Count - 1 do begin
+    s := swDirs.Items[i];
+    b := swDirs.Checked[i];
+    lst.Values[s] := tf[b];
+  end;
+  FclPkg.UpdateConfig;
+end;
+
 end.
 

examples/fpdocmanager/fmain.pas

@@ -587,7 +587,12 @@ begin
     u := CurUnit
   else
     u := '';
-  Manager.Update(CurPkg, u);
+  try
+    Manager.Update(CurPkg, u);
+  except
+    on e: Exception do
+    LogToFile(self, e.Message);
+  end;
   LogDone;
 end;
 

examples/fpdocmanager/umakeskel.pas

@@ -174,7 +174,8 @@ type
     function  CheckSkelOptions: string;
     function  CleanXML(const FileName: string): boolean;
     function  SelectedPackage: TFPDocPackage;
-    property Package: TFPDocPackage read SelectedPackage write SetPackage;
+    //property Package: TFPDocPackage read SelectedPackage write SetPackage;
+    property Package: TFPDocPackage read FPackage write SetPackage; //without message
     property CmdAction: TCreatorAction read FCmdAction write SetCmdAction;
     property DryRun: boolean read FDryRun write SetDryRun;
     property ReadProject: boolean read FProjectFile;
@@ -1020,7 +1021,6 @@ begin
 end;
 
 function TFPDocMaker.ParseFPDocOption(const S: string):  TCreatorAction;
-//procedure TFPDocAplication.Parseoption(Const S : String);
 var
   Cmd, Arg: String;
 begin
@@ -1030,7 +1030,9 @@ begin
   if Result <> caInvalid then
     exit;
   Result := caDefault; //assume succ
-  if Cmd = '--content' then
+  if (Cmd = '-t') or (Cmd = '--emit-notes') then
+    Options.EmitNotes := True
+  else if Cmd = '--content' then
     SelectedPackage.ContentFile := Arg
   else if Cmd = '--import' then
     SelectedPackage.Imports.Add(Arg)

examples/fpdocmanager/umanager.pas

@@ -69,6 +69,7 @@ type
     FName: string;
     FProjectDir: string;
     FProjectFile: string;
+    FSrcDirs: TStrings;
     FRequires: TStrings;
     FUnitPath: string;
     FUnits: TStrings;
@@ -88,9 +89,9 @@ type
     procedure SetUnits(AValue: TStrings);
   protected
     Config: TConfigFile;
-    procedure ReadConfig;
+    procedure ReadConfig; virtual;
   public
-    constructor Create;
+    constructor Create; virtual;
     destructor Destroy; override;
     function  IniFileName: string;
     function  CreateProject(APrj: TFPDocHelper; const AFile: string): boolean; virtual; //new package project
@@ -108,6 +109,7 @@ type
     property Descriptions: TStrings read FDescriptions write SetDescriptions;
     property AltDir: string read FAltDir write SetAltDir;
     property InputDir: string read FInputDir write SetInputDir;
+    property SrcDirs: TStrings read FSrcDirs;
     property Units: TStrings read FUnits write SetUnits;
     property Requires: TStrings read FRequires write SetRequires; //only string?
     property IncludePath: string read FIncludePath write SetIncludePath; //-Fi
@@ -117,6 +119,8 @@ type
   { TFCLDocPackage }
 
   TFCLDocPackage = class(TDocPackage)
+  protected
+    procedure ReadConfig; override;
   public
     function  CreateProject(APrj: TFPDocHelper; const AFile: string): boolean; override;
   end;
@@ -256,7 +260,8 @@ begin
       if not ((Info.Attr and faDirectory) = faDirectory) then
         continue;
       s := Info.Name;
-      if s[1] <> '.' then
+      if (s[1] <> '.')
+      and (AList.IndexOf(s) < 0) then //exclude dupes
         AList.Add(s); //name only, allow to create relative refs
     until FindNext(info)<>0;
   end;
@@ -303,17 +308,34 @@ end;
 
 { TFCLDocPackage }
 
+procedure TFCLDocPackage.ReadConfig;
+begin
+  inherited ReadConfig;
+  if FSrcDirs = nil then
+    FSrcDirs := TStringList.Create;
+  Config.ReadSection('SrcDirs', FSrcDirs);
+end;
+
 function TFCLDocPackage.CreateProject(APrj: TFPDocHelper; const AFile: string
   ): boolean;
 var
   i: integer;
   s, d, f: string;
   dirs, descs: TStringList;
+  incl, excl: boolean;
 begin
+(* This seems to be called twice for Refresh???
+*)
+  if APrj.Package <> nil then
+    exit(True); //already configured
   Result:=inherited CreateProject(APrj, AFile);
 //add lazdir
   if AltDir = '' then exit;
-  dirs := TStringList.Create;
+(* 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
@@ -327,12 +349,31 @@ begin
   for i := dirs.Count - 1 downto 0 do begin
     d := s + dirs[i] + DirectorySeparator + 'src';
     if not DirectoryExists(d) then continue;
-    if MatchUnits(d, descs) >= 0 then begin
-    //add dir
-      APrj.ParseFPDocOption(Format('--input-dir="%s"', [d])); //todo: add includes?
+(* 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)
+      and (SrcDirs.IndexOfName(dirs[i]) >= 0)
+      and (SrcDirs.Values[dirs[i]] <= '0'));
+    if excl then begin
+      //todo: add only selected units
+      Manager.DoLog('Skipping directory ' + dirs[i]);
+    end else begin
+      incl := (assigned(FSrcDirs)
+        and (SrcDirs.IndexOfName(dirs[i]) >= 0)
+        and (SrcDirs.Values[dirs[i]] > '0'))
+      or (MatchUnits(d, descs) >= 0);
+      if incl then begin
+      //add dir
+        Manager.DoLog('Adding directory ' + dirs[i]);
+        APrj.ParseFPDocOption(Format('--input-dir="%s"', [d])); //todo: add includes?
+      end;
     end;
   end;
-//re-create project?
+//re-create project? The normal project was already created by inherited!
   if AFile <> '' then begin
     f := ChangeFileExt(AFile, '_ext.xml'); //preserve unmodified project?
     APrj.CreateProjectFile(f);
@@ -506,10 +547,11 @@ end;
 
 destructor TDocPackage.Destroy;
 begin
+  FreeAndNil(Config);
   FreeAndNil(FUnits);
   FreeAndNil(FDescriptions);
   FreeAndNil(FRequires);
-  FreeAndNil(Config);
+  FreeAndNil(FSrcDirs);
   inherited Destroy;
 end;
 
@@ -523,8 +565,11 @@ var
   pkg: TFPDocPackage;
   i: integer;
 begin
-  Result := False;
-  if ProjectDir = '' then
+  Result := APrj.Package <> nil; //already configured?
+  if Result then
+    exit;
+  Result := ProjectDir <> '';
+  if not Result then
     exit; //dir must be known
 //create pkg
   APrj.ParseFPDocOption('--package=' + Name); //selects or creates the pkg
@@ -670,6 +715,7 @@ begin
 //units
   Config.WriteSectionValues('units', Units);
   Config.WriteSectionValues('descrs', Descriptions);
+  Config.WriteSectionValues('SrcDirs', SrcDirs);
 //all done
   Config.Flush;
   Loaded := True;