← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to examples/fpdocmanager/umanager.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/fpdocmanager/umanager.pas
 
1
unit uManager;
 
2
(* Manager object for FPDoc GUI, by DoDi
 
3
Holds configuration and packages.
 
4
 
 
5
Packages (shall) contain extended descriptions for:
 
6
- default OSTarget (FPCDocs: Unix/Linux)
 
7
- inputs: by OSTarget
 
8
- directories: project(file), InputDir, DescrDir[by language?]
 
9
- FPCVersion, LazVersion: variations of inputs
 
10
- Skeleton and Output options, depending on DocType/Level and Format.
 
11
Units can be described in multiple XML docs, so that it's possible to
 
12
have specific parts depending on Laz/FPC version, OSTarget, Language, Widgetset.
 
13
 
 
14
This version is decoupled from the fpdoc classes, introduces the classes
 
15
  TFPDocManager for all packages
 
16
  TDocPackage for a single package
 
17
  TFPDocHelper for fpdoc projects
 
18
*)
 
19
 
 
20
(* Currently registered writers:
 
21
TFPDocWriter in 'dwriter.pp'
 
22
  template: TTemplateWriter(TFPDocWriter) in 'dw_tmpl.pp'
 
23
  man:  TMANWriter(TFPDocWriter) in 'dw_man.pp' --> <pkg>.man /unit.
 
24
  dxml:  TDXMLWriter(TFPDocWriter) in 'dw_dxml.pp'
 
25
  xml:  TXMLWriter(TFPDocWriter) in 'dw_xml.pp'
 
26
  html: THTMLWriter(TFPDocWriter) in 'dw_html.pp'
 
27
    htm:  THTMWriter(THTMLWriter)
 
28
    chm:  TCHMHTMLWriter(THTMLWriter)
 
29
  TLinearWriter in 'dwlinear.pp'
 
30
    template: TTemplateWriter(TLinearWriter) in 'dw_lintmpl.pp'
 
31
    ipf:  TIPFNewWriter(TLinearWriter) in 'dw_ipflin.pas'
 
32
    latex:  TLaTeXWriter(TLinearWriter) in 'dw_latex.pp'
 
33
    rtf:  TRTFWriter(TLinearWriter) in 'dw_linrtf.pp'
 
34
    txt:  TTXTWriter(TLinearWriter) in 'dw_txt.pp'
 
35
 
 
36
TLinearWriter based writers create an single output file for a package:
 
37
  <path>/pkg .<ext>
 
38
TFPDocWriter based writers create an file for every module:
 
39
  <path>/pkg /unit.<ext>
 
40
 
 
41
*)
 
42
{$mode objfpc}{$H+}
 
43
 
 
44
{$DEFINE EasyImports} //EasyImports.patch applied?
 
45
 
 
46
interface
 
47
 
 
48
uses
 
49
  Classes, SysUtils,
 
50
  umakeskel, ConfigFile, fpdocproj, dw_HTML;
 
51
 
 
52
type
 
53
  TFPDocHelper = class;
 
54
 
 
55
  { TDocPackage }
 
56
 
 
57
(* TDocPackage describes a package documentation project.
 
58
*)
 
59
  TDocPackage = class
 
60
  private
 
61
    FAllDirs: boolean;
 
62
    FAltDir: string;
 
63
    FCompOpts: string;
 
64
    FDescrDir: string;
 
65
    FDescriptions: TStrings;
 
66
    FIncludePath: string;
 
67
    FInputDir: string;
 
68
    FLazPkg: string;
 
69
    FLoaded: boolean;
 
70
    FName: string;
 
71
    FProjectDir: string;
 
72
    FProjectFile: string;
 
73
    FSrcDirs: TStrings;
 
74
    FRequires: TStrings;
 
75
    FUnitPath: string;
 
76
    FUnits: TStrings;
 
77
    function GetAltDir: string;
 
78
    procedure SetAllDirs(AValue: boolean);
 
79
    procedure SetAltDir(AValue: string);
 
80
    procedure SetCompOpts(AValue: string);
 
81
    procedure SetDescrDir(AValue: string);
 
82
    procedure SetDescriptions(AValue: TStrings);
 
83
    procedure SetIncludePath(AValue: string);
 
84
    procedure SetInputDir(AValue: string);
 
85
    procedure SetLazPkg(AValue: string);
 
86
    procedure SetLoaded(AValue: boolean);
 
87
    procedure SetName(AValue: string);
 
88
    procedure SetProjectDir(AValue: string);
 
89
    procedure SetProjectFile(AValue: string);
 
90
    procedure SetRequires(AValue: TStrings);
 
91
    procedure SetUnitPath(AValue: string);
 
92
    procedure SetUnits(AValue: TStrings);
 
93
  protected
 
94
    Config: TConfigFile;
 
95
    procedure ReadConfig; virtual;
 
96
  public
 
97
    constructor Create; virtual;
 
98
    destructor Destroy; override;
 
99
    function  IniFileName: string;
 
100
    function  CreateProject(APrj: TFPDocHelper; const AFile: string): boolean; virtual; //new package project
 
101
    function  ImportProject(APrj: TFPDocHelper; APkg: TFPDocPackage; const AFile: string): boolean;
 
102
    procedure UpdateConfig;
 
103
    procedure EnumUnits(AList: TStrings); virtual;
 
104
    function  DescrFileName(const AUnit: string): string;
 
105
    property Name: string read FName write SetName;
 
106
    property Loaded: boolean read FLoaded write SetLoaded;
 
107
    property ProjectFile: string read FProjectFile write SetProjectFile; //xml?
 
108
  //from LazPkg
 
109
    procedure AddUnit(const AFile: string);
 
110
    property AllDirs: boolean read FAllDirs write SetAllDirs;
 
111
    property CompOpts: string read FCompOpts write SetCompOpts;
 
112
    property LazPkg: string read FLazPkg write SetLazPkg; //LPK name?
 
113
    property ProjectDir: string read FProjectDir write SetProjectDir;
 
114
    property DescrDir: string read FDescrDir write SetDescrDir;
 
115
    property Descriptions: TStrings read FDescriptions write SetDescriptions;
 
116
    property AltDir: string read GetAltDir write SetAltDir;
 
117
    property InputDir: string read FInputDir write SetInputDir;
 
118
    property SrcDirs: TStrings read FSrcDirs;
 
119
    property Units: TStrings read FUnits write SetUnits;
 
120
    property Requires: TStrings read FRequires write SetRequires; //only string?
 
121
    property IncludePath: string read FIncludePath write SetIncludePath; //-Fi
 
122
    property UnitPath: string read FUnitPath write SetUnitPath; //-Fu
 
123
  end;
 
124
 
 
125
  { TFCLDocPackage }
 
126
 
 
127
  TFCLDocPackage = class(TDocPackage)
 
128
  protected
 
129
    procedure ReadConfig; override;
 
130
  public
 
131
    function  CreateProject(APrj: TFPDocHelper; const AFile: string): boolean; override;
 
132
  end;
 
133
 
 
134
  { TFPDocHelper }
 
135
 
 
136
//holds temporary project
 
137
 
 
138
  TFPDocHelper = class(TFPDocMaker)
 
139
  private
 
140
    FProjectDir: string;
 
141
    procedure SetProjectDir(AValue: string);
 
142
  public
 
143
    InputList, DescrList: TStringList; //still required?
 
144
  public
 
145
    constructor Create(AOwner: TComponent); override;
 
146
    destructor Destroy; override;
 
147
    function  BeginTest(APkg: TDocPackage): boolean;
 
148
    function  BeginTest(ADir: string): boolean;
 
149
    procedure EndTest;
 
150
    function  CmdToPrj(const AFileName: string): boolean;
 
151
    function  TestRun(APkg: TDocPackage; AUnit: string): boolean;
 
152
    function  Update(APkg: TDocPackage; const AUnit: string): boolean;
 
153
    function  MakeDocs(APkg: TDocPackage; const AUnit: string; AOutput: string): boolean;
 
154
    property ProjectDir: string read FProjectDir write SetProjectDir;
 
155
  end;
 
156
 
 
157
  TLogHandler = Procedure (Sender : TObject; Const Msg : String) of object;
 
158
 
 
159
  { TFPDocManager }
 
160
 
 
161
(* Holds configuration and package projects.
 
162
*)
 
163
  TFPDocManager = class(TComponent)
 
164
  private
 
165
    FExcludedUnits: boolean;
 
166
    FFpcDir: string;
 
167
    FFPDocDir: string;
 
168
    FLazarusDir: string;
 
169
    FModified: boolean;
 
170
    FNoParseUnits: TStringList;
 
171
    FOnChange: TNotifyEvent;
 
172
    FOnLog: TLogHandler;
 
173
    FOptions: TCmdOptions;
 
174
    FPackage: TDocPackage;
 
175
    FPackages: TStrings;
 
176
    FProfile: string;
 
177
    FProfiles: string; //CSV list of profile names
 
178
    FRootDir: string;
 
179
    UpdateCount: integer;
 
180
    function  GetNoParseUnits: TStrings;
 
181
    procedure SetExcludedUnits(AValue: boolean);
 
182
    procedure SetFpcDir(AValue: string);
 
183
    procedure SetFPDocDir(AValue: string);
 
184
    procedure SetLazarusDir(AValue: string);
 
185
    procedure SetNoParseUnits(AValue: TStrings);
 
186
    procedure SetOnChange(AValue: TNotifyEvent);
 
187
    procedure SetPackage(AValue: TDocPackage);
 
188
    procedure SetProfile(AValue: string);
 
189
    procedure SetRootDir(AValue: string);
 
190
  protected
 
191
    Helper: TFPDocHelper; //temporary
 
192
    procedure Changed;
 
193
    function  BeginTest(const ADir: string): boolean;
 
194
    procedure EndTest;
 
195
    function  RegisterPackage(APkg: TDocPackage): integer;
 
196
    Procedure DoLog(Const Msg : String);
 
197
  public
 
198
    Config: TConfigFile; //extend class
 
199
    constructor Create(AOwner: TComponent); override;
 
200
    destructor Destroy; override;
 
201
    procedure BeginUpdate;
 
202
    procedure EndUpdate;
 
203
    function  LoadConfig(const ADir: string; Force: boolean = False): boolean;
 
204
    function  SaveConfig: boolean;
 
205
    procedure AddProfile(const AName: string);
 
206
    function  AddProject(const APkg, AFile: string): boolean; //from config
 
207
    function  CreateProject(const AFileName: string; APkg: TDocPackage): boolean;
 
208
    function  AddPackage(AName: string): TDocPackage;
 
209
    function  IsExtended(const APkg: string): string;
 
210
    function  ImportLpk(const AFile: string): TDocPackage;
 
211
    procedure ImportProject(APkg: TFPDocPackage; const AFile: string);
 
212
    function  ImportCmd(const AFile: string): boolean;
 
213
    procedure UpdatePackage(const AName: string);
 
214
    function  UpdateFCL(enabled: boolean): boolean;
 
215
  //actions
 
216
    function  MakeDoc(APkg: TDocPackage; const AUnit, AOutput: string): boolean;
 
217
    function  TestRun(APkg: TDocPackage; AUnit: string): boolean;
 
218
    function  Update(APkg: TDocPackage; const AUnit: string): boolean;
 
219
  public //published?
 
220
    property ExcludeUnits: boolean read FExcludedUnits write SetExcludedUnits;
 
221
    property NoParseUnits: TStrings read GetNoParseUnits write SetNoParseUnits;
 
222
    property FpcDir: string read FFpcDir write SetFpcDir;
 
223
    property FpcDocDir: string read FFPDocDir write SetFPDocDir;
 
224
    property LazarusDir: string read FLazarusDir write SetLazarusDir;
 
225
    property RootDir: string read FRootDir write SetRootDir;
 
226
    property Options: TCmdOptions read FOptions;
 
227
    property Profile: string read FProfile write SetProfile;
 
228
    property Profiles: string read FProfiles;
 
229
    property Packages: TStrings read FPackages;
 
230
    property Package: TDocPackage read FPackage write SetPackage;
 
231
    property Modified: boolean read FModified; //app
 
232
    property OnChange: TNotifyEvent read FOnChange write SetOnChange;
 
233
    Property OnLog : TLogHandler Read FOnLog Write FOnLog;
 
234
  end;
 
235
 
 
236
var
 
237
  Manager: TFPDocManager = nil; //init by application
 
238
 
 
239
function  FixPath(const s: string): string;
 
240
procedure ListDirs(const ARoot: string; AList: TStrings);
 
241
procedure ListUnits(const AMask: string; AList: TStrings);
 
242
function  MatchUnits(const ADir: string; AList: TStrings): integer;
 
243
 
 
244
implementation
 
245
 
 
246
uses
 
247
  uLpk, PParser;
 
248
 
 
249
const
 
250
  ConfigName = 'docmgr.ini';
 
251
  SecProjects = 'projects';
 
252
  SecGen = 'dirs';
 
253
  SecDoc = 'project';
 
254
 
 
255
function FixPath(const s: string): string;
 
256
var
 
257
  c: string;
 
258
begin
 
259
  if DirectorySeparator = '/' then
 
260
    c := '\'
 
261
  else
 
262
    c := '/';
 
263
  Result := StringReplace(s, c, DirectorySeparator, [rfReplaceAll]);
 
264
end;
 
265
 
 
266
procedure ListDirs(const ARoot: string; AList: TStrings);
 
267
var
 
268
  Info : TSearchRec;
 
269
  s: string;
 
270
begin
 
271
  if FindFirst (ARoot+'/*',faDirectory,Info)=0 then begin
 
272
    repeat
 
273
      if not ((Info.Attr and faDirectory) = faDirectory) then
 
274
        continue;
 
275
      s := Info.Name;
 
276
      if (s[1] <> '.')
 
277
      and (AList.IndexOf(s) < 0) then //exclude dupes
 
278
        AList.Add(s); //name only, allow to create relative refs
 
279
    until FindNext(info)<>0;
 
280
  end;
 
281
  FindClose(Info);
 
282
end;
 
283
 
 
284
procedure ListUnits(const AMask: string; AList: TStrings);
 
285
var
 
286
  Info : TSearchRec;
 
287
  s, f: string;
 
288
begin
 
289
  if FindFirst (AMask,faArchive,Info)=0 then begin
 
290
    repeat
 
291
      s := Info.Name;
 
292
      if s[1] <> '.' then begin
 
293
        f := ChangeFileExt(s, ''); //unit name only
 
294
        if Manager.ExcludeUnits and (Manager.NoParseUnits.IndexOf(f) >= 0) then
 
295
          continue; //excluded unit!
 
296
        AList.Add(f);
 
297
      end;
 
298
    until FindNext(info)<>0;
 
299
  end;
 
300
  FindClose(Info);
 
301
end;
 
302
 
 
303
function MatchUnits(const ADir: string; AList: TStrings): integer;
 
304
var
 
305
  Info : TSearchRec;
 
306
  s, ext: string;
 
307
begin
 
308
  Result := -1;
 
309
  if FindFirst(ADir+DirectorySeparator+'*',faArchive,Info)=0 then begin
 
310
    repeat
 
311
      s := Info.Name;
 
312
      ext := ExtractFileExt(s);
 
313
      if (ext = '.pas') or (ext = '.pp') then begin
 
314
        ext := ChangeFileExt(s, '');
 
315
        Result := AList.IndexOf(ext); //ChangeFileExt(s, '.xml'));
 
316
        if Result >= 0 then begin
 
317
          //AList.Delete(Result); //don't search any more
 
318
          break;
 
319
        end;
 
320
      end;
 
321
    Until FindNext(info)<>0;
 
322
  end;
 
323
  FindClose(Info);
 
324
end;
 
325
 
 
326
{ TFCLDocPackage }
 
327
 
 
328
procedure TFCLDocPackage.ReadConfig;
 
329
begin
 
330
  inherited ReadConfig;
 
331
  if FSrcDirs = nil then
 
332
    FSrcDirs := TStringList.Create;
 
333
  Config.ReadSection('SrcDirs', FSrcDirs);
 
334
end;
 
335
 
 
336
function TFCLDocPackage.CreateProject(APrj: TFPDocHelper; const AFile: string
 
337
  ): boolean;
 
338
var
 
339
  i: integer;
 
340
  s, d, f: string;
 
341
  dirs, descs: TStringList;
 
342
  incl, excl: boolean;
 
343
begin
 
344
(* Add Lazarus FCL, and explicit or added or all FCL dirs
 
345
*)
 
346
  if APrj.Package <> nil then
 
347
    exit(True); //already configured
 
348
  Result:=inherited CreateProject(APrj, AFile);
 
349
  descs := TStringList.Create;
 
350
//add lazdir
 
351
  if AltDir <> '' then begin
 
352
  (* Add inputs for all descrs found in AltDir.
 
353
    For *MakeSkel* add all units in the selected(!) fcl packages to inputs.
 
354
    How to distinguish both modes?
 
355
  *)
 
356
    s := Manager.LazarusDir + 'docs' + DirectorySeparator + 'xml' + DirectorySeparator + 'fcl';
 
357
    //APrj.ParseFPDocOption(Format('--descr-dir="%s"', [s])); //todo: add includes
 
358
    //APrj.AddDirToFileList(descs, s, '*.xml');
 
359
    ListUnits(s+ DirectorySeparator+ '*.xml', descs); //exclude NoParseUnits
 
360
    descs.Sorted := True;
 
361
  end;
 
362
//scan fcl dirs
 
363
  dirs := TStringList.Create; //use prepared list?
 
364
  s := Manager.FFpcDir + 'packages' + DirectorySeparator;
 
365
  ListDirs(s, dirs);
 
366
//now match all files in the source dirs
 
367
  for i := dirs.Count - 1 downto 0 do begin
 
368
    d := s + dirs[i] + DirectorySeparator + 'src';
 
369
    if not DirectoryExists(d) then continue; //can this happen?
 
370
  (* skip explicitly excluded packages, and exclude selected units.
 
371
  *)
 
372
    excl := not FAllDirs
 
373
      and assigned(FSrcDirs)
 
374
      and (SrcDirs.IndexOfName(dirs[i]) >= 0)
 
375
      and (SrcDirs.Values[dirs[i]] <= '0');
 
376
    if excl then begin
 
377
      //Manager.DoLog('Skipping directory ' + dirs[i]);
 
378
    end else begin
 
379
      incl := FAllDirs
 
380
      or (assigned(FSrcDirs)
 
381
        and (SrcDirs.IndexOfName(dirs[i]) >= 0)
 
382
        and (SrcDirs.Values[dirs[i]] > '0'))
 
383
      or (MatchUnits(d, descs) >= 0); //!!! descs now is empty!
 
384
      if incl then begin
 
385
      //add dir
 
386
        Manager.DoLog('Adding directory ' + dirs[i]);
 
387
        APrj.ParseFPDocOption(Format('--input-dir="%s"', [d])); //todo: add includes?
 
388
      end;
 
389
    end;
 
390
  end;
 
391
//exclude explicit units - only for FCL?
 
392
  if Manager.ExcludeUnits and (Manager.NoParseUnits.Count > 0) then begin
 
393
  //exclude inputs
 
394
    for i := APrj.InputList.Count - 1 downto 0 do begin
 
395
      s := ExtractUnitName(APrj.InputList, i);
 
396
      if Manager.NoParseUnits.IndexOf(s) >= 0 then //case?
 
397
        APrj.InputList.Delete(i);
 
398
    end;
 
399
  end;
 
400
//re-create project? The normal project was already created by inherited!
 
401
  if AFile <> '' then begin
 
402
    f := ChangeFileExt(AFile, '_ext.xml'); //preserve unmodified project?
 
403
    APrj.CreateProjectFile(f);
 
404
  end; // else APrj.CreateProjectFile(Manager.RootDir + 'fcl_ext.xml'); //preserve unmodified project?
 
405
//finally
 
406
  dirs.Free;
 
407
  descs.Free;
 
408
end;
 
409
 
 
410
{ TDocPackage }
 
411
 
 
412
procedure TDocPackage.SetDescrDir(AValue: string);
 
413
begin
 
414
  if FDescrDir=AValue then Exit;
 
415
  FDescrDir:=AValue;
 
416
end;
 
417
 
 
418
procedure TDocPackage.SetCompOpts(AValue: string);
 
419
begin
 
420
(* collect all compiler options
 
421
*)
 
422
  if FCompOpts=AValue then Exit;
 
423
  if AValue = '' then exit;
 
424
  if FCompOpts = '' then
 
425
    FCompOpts:=AValue
 
426
  else
 
427
    FCompOpts:= FCompOpts + ' ' + AValue;
 
428
end;
 
429
 
 
430
procedure TDocPackage.SetAltDir(AValue: string);
 
431
begin
 
432
  AValue:=FixPath(AValue);
 
433
  if FAltDir=AValue then Exit;
 
434
  FAltDir:=AValue;
 
435
//we must signal config updated
 
436
  Config.WriteString(SecDoc, 'AltDir', AltDir);
 
437
end;
 
438
 
 
439
procedure TDocPackage.SetAllDirs(AValue: boolean);
 
440
begin
 
441
  if FAllDirs=AValue then Exit;
 
442
  FAllDirs:=AValue;
 
443
end;
 
444
 
 
445
function TDocPackage.GetAltDir: string;
 
446
begin
 
447
{$IFDEF FCLadds}
 
448
  Result := FAltDir;
 
449
{$ELSE}
 
450
  Result := '';
 
451
{$ENDIF}
 
452
end;
 
453
 
 
454
procedure TDocPackage.SetDescriptions(AValue: TStrings);
 
455
(* Shall we allow for multiple descriptions? (general + OS specific!?)
 
456
*)
 
457
begin
 
458
  if FDescriptions=AValue then Exit;
 
459
  if AValue = nil then exit; //clear?
 
460
  if AValue.Count = 0 then exit;
 
461
  FDescriptions.Assign(AValue);
 
462
end;
 
463
 
 
464
(* Requires[] only contain package names.
 
465
  Internal use: Get/Set CommaText
 
466
*)
 
467
procedure TDocPackage.SetRequires(AValue: TStrings);
 
468
 
 
469
  procedure Import;
 
470
  var
 
471
    i: integer;
 
472
    s: string;
 
473
  begin
 
474
    FRequires.Clear; //assume full replace
 
475
    for i := 0 to AValue.Count - 1 do begin
 
476
      s := AValue[i]; //<name.xct>,<prefix>
 
477
      FRequires.Add(ExtractImportName(s));  // + '=' + s);
 
478
    end;
 
479
  end;
 
480
 
 
481
begin
 
482
  if FRequires=AValue then Exit;
 
483
  if AValue = nil then exit;
 
484
  if AValue.Count = 0 then exit;
 
485
  Import;
 
486
end;
 
487
 
 
488
procedure TDocPackage.SetUnits(AValue: TStrings);
 
489
 
 
490
  procedure Import;
 
491
  var
 
492
    i: integer;
 
493
    s: string;
 
494
  begin
 
495
    FUnits.Clear; //assume full replace
 
496
    for i := 0 to AValue.Count - 1 do begin
 
497
      s := AValue[i]; //filespec
 
498
      FUnits.Add(ExtractUnitName(AValue, i) + '=' + s);
 
499
    end;
 
500
  end;
 
501
 
 
502
begin
 
503
  if FUnits=AValue then Exit;
 
504
  if AValue = nil then exit;
 
505
  if AValue.Count = 0 then exit;
 
506
//import formatted: <unit>=<descr file> (multiple???)
 
507
  if Pos('=', AValue[0]) > 0 then
 
508
    FUnits.Assign(AValue) //clears previous content
 
509
  else //if AValue.Count > 0 then
 
510
    Import;
 
511
end;
 
512
 
 
513
procedure TDocPackage.SetIncludePath(AValue: string);
 
514
begin
 
515
  if FIncludePath=AValue then Exit;
 
516
  FIncludePath:=AValue;
 
517
end;
 
518
 
 
519
procedure TDocPackage.SetInputDir(AValue: string);
 
520
begin
 
521
  if FInputDir=AValue then Exit;
 
522
  FInputDir:=AValue;
 
523
end;
 
524
 
 
525
procedure TDocPackage.SetLazPkg(AValue: string);
 
526
begin
 
527
  if FLazPkg=AValue then Exit;
 
528
  if AValue = '' then exit;
 
529
  FLazPkg:=AValue;
 
530
  FProjectDir := ExtractFilePath(AValue);
 
531
  //todo: import
 
532
end;
 
533
 
 
534
procedure TDocPackage.SetLoaded(AValue: boolean);
 
535
begin
 
536
  if FLoaded=AValue then Exit;
 
537
  FLoaded:=AValue;
 
538
  if not FLoaded then
 
539
    exit; //???
 
540
  if Manager.RegisterPackage(self) < 0 then //now definitely loaded
 
541
    exit; //really exit?
 
542
  if Config = nil then
 
543
    UpdateConfig; //create INI file when loaded
 
544
end;
 
545
 
 
546
procedure TDocPackage.SetName(AValue: string);
 
547
begin
 
548
  if FName=AValue then Exit;
 
549
  FName:=AValue;
 
550
  ReadConfig;
 
551
end;
 
552
 
 
553
procedure TDocPackage.SetProjectDir(AValue: string);
 
554
begin
 
555
  if FProjectDir=AValue then Exit;
 
556
  FProjectDir:=AValue;
 
557
end;
 
558
 
 
559
procedure TDocPackage.SetProjectFile(AValue: string);
 
560
begin
 
561
  if FProjectFile=AValue then Exit;
 
562
  FProjectFile:=AValue;
 
563
//really do more?
 
564
  if FProjectFile = '' then
 
565
    exit;
 
566
  ProjectDir:=ExtractFilePath(FProjectFile);
 
567
  if ExtractFileExt(FProjectFile) <> '.xml' then
 
568
    ; //really change here???
 
569
  //import requires fpdocproject - must be created by Manager!
 
570
end;
 
571
 
 
572
procedure TDocPackage.SetUnitPath(AValue: string);
 
573
begin
 
574
  if FUnitPath=AValue then Exit;
 
575
  FUnitPath:=AValue;
 
576
//save to config?
 
577
end;
 
578
 
 
579
constructor TDocPackage.Create;
 
580
begin
 
581
  FUnits := TStringList.Create;
 
582
  FDescriptions := TStringList.Create;
 
583
  FRequires := TStringList.Create;
 
584
  //Config requires valid Name -> in SetName
 
585
end;
 
586
 
 
587
destructor TDocPackage.Destroy;
 
588
begin
 
589
  FreeAndNil(Config);
 
590
  FreeAndNil(FUnits);
 
591
  FreeAndNil(FDescriptions);
 
592
  FreeAndNil(FRequires);
 
593
  FreeAndNil(FSrcDirs);
 
594
  inherited Destroy;
 
595
end;
 
596
 
 
597
(* Create new(?) project.
 
598
Usage: after LoadLpk, in general for configured project (user options!)
 
599
(more options to come)
 
600
*)
 
601
function TDocPackage.CreateProject(APrj: TFPDocHelper; const AFile: string): boolean;
 
602
var
 
603
  s, imp: string;
 
604
  pkg: TFPDocPackage;
 
605
  i: integer;
 
606
  lst: TStringList;
 
607
begin
 
608
  Result := APrj.Package <> nil; //already configured?
 
609
  if Result then
 
610
    exit;
 
611
  Result := ProjectDir <> '';
 
612
  if not Result then
 
613
    exit; //dir must be known
 
614
//create pkg
 
615
  APrj.ParseFPDocOption('--package=' + Name); //selects or creates the pkg
 
616
  pkg := APrj.SelectedPackage;
 
617
//add Inputs
 
618
  //todo: common options? OS options?
 
619
  for i := 0 to Units.Count - 1 do begin
 
620
    s := Units.ValueFromIndex[i];
 
621
    if CompOpts <> '' then
 
622
      s := s + ' ' + CompOpts;
 
623
    //add further options?
 
624
    pkg.Inputs.Add(s);
 
625
  end;
 
626
//add Descriptions - either explicit or implicit
 
627
  if (DescrDir <> '') and (Descriptions.Count = 0) then begin
 
628
  //first check for existing directory
 
629
    if not DirectoryExists(DescrDir) then begin
 
630
      MkDir(DescrDir); //exclude \?
 
631
    end else if Descriptions.Count = 0 then begin
 
632
      APrj.ParseFPDocOption('--descr-dir=' + DescrDir); //adds all XML files
 
633
    end;
 
634
  end else begin
 
635
    APrj.DescrDir := DescrDir; //needed by Update
 
636
    for i := 0 to Descriptions.Count - 1 do begin
 
637
      s := Descriptions[i];
 
638
      if Pos('=', s) > 0 then
 
639
        pkg.Descriptions.Add(Descriptions.ValueFromIndex[i])
 
640
      else
 
641
        pkg.Descriptions.Add(s);
 
642
    end;
 
643
  end;
 
644
  if AltDir <> '' then begin
 
645
  //add descr files
 
646
    s := Manager.LazarusDir + AltDir;
 
647
    s := FixPath(s);
 
648
    if ForceDirectories(s) then begin
 
649
    //exclude NoParse units
 
650
      //APrj.ParseFPDocOption(Format('--descr-dir="%s"', [s]));
 
651
      lst := TStringList.Create;
 
652
      ListUnits(AltDir + '*.xml', lst); //unit names only
 
653
    (* add the unit names from lst to the pkg/project
 
654
    *)
 
655
      pkg := APrj.SelectedPackage;
 
656
      for i := 0 to lst.Count - 1 do begin
 
657
        s := AltDir + lst[i] + '.xml';
 
658
        pkg.Descriptions.Add(s);
 
659
      end;
 
660
    end;
 
661
  //add source files!?
 
662
  end;
 
663
//add Imports
 
664
  for i := 0 to Requires.Count - 1 do begin
 
665
    s := Requires[i];
 
666
  {$IFDEF EasyImports}
 
667
    imp := Manager.RootDir + s;
 
668
  {$ELSE}
 
669
    imp := Manager.RootDir + s + '.xct,../' + s + '/'; //valid for HTML, not for CHM!
 
670
  {$ENDIF}
 
671
    APrj.ParseFPDocOption('--import=' + imp);
 
672
  end;
 
673
//add options
 
674
  APrj.Options.Assign(Manager.Options);
 
675
//debug, looks good here!?
 
676
  if APrj.Options.Backend = '' then
 
677
    Manager.DoLog('No format, should be ' + Manager.Options.Backend);
 
678
  pkg.Output := Manager.RootDir + Name; //???
 
679
  pkg.ContentFile := Manager.RootDir + Name + '.xct';
 
680
//now create project file
 
681
  if AFile <> '' then begin
 
682
    if ExtractFileExt(AFile) <> '.xml' then
 
683
      FProjectFile := ExtractFilePath(AFile) + Name + '_prj.xml'
 
684
    else
 
685
      FProjectFile := AFile;
 
686
    APrj.CreateProjectFile(ProjectFile);
 
687
  end;
 
688
  Result := True; //assume okay
 
689
end;
 
690
 
 
691
(* Init from TFPDocPackage, into which AFile has been loaded.
 
692
*)
 
693
function TDocPackage.ImportProject(APrj: TFPDocHelper; APkg: TFPDocPackage; const AFile: string): boolean;
 
694
var
 
695
  s: string;
 
696
begin
 
697
//check loaded
 
698
  Result := Loaded;
 
699
  if Result then
 
700
    exit;
 
701
//init...
 
702
  s := UnitFile(APkg.Inputs, 0);
 
703
  if s <> '' then
 
704
    FUnitPath := ExtractFilePath(s);
 
705
  s := UnitFile(APkg.Descriptions, 0);
 
706
  if s <> '' then
 
707
    FDescrDir := ExtractFilePath(s);
 
708
//project file - empty if not applicable (multi-package project?!)
 
709
  if (AFile <> '') and (APrj.Packages.Count = 1) then
 
710
    ProjectFile := AFile //only if immediately applicable!
 
711
  else
 
712
    ProjectDir := ExtractFilePath(AFile);
 
713
//init lists
 
714
  Units := APkg.Inputs;
 
715
  Descriptions := APkg.Descriptions;
 
716
  Requires := APkg.Imports;
 
717
//more?
 
718
//save config!
 
719
  UpdateConfig;
 
720
//finish
 
721
  Result := Loaded;
 
722
end;
 
723
 
 
724
procedure TDocPackage.ReadConfig;
 
725
var
 
726
  s: string;
 
727
begin
 
728
  if Loaded then
 
729
    exit;
 
730
  if Config = nil then
 
731
    Config := TConfigFile.Create(IniFileName);
 
732
//check config
 
733
  s := Config.ReadString(SecDoc, 'projectdir', '');
 
734
  if s = '' then begin
 
735
    FreeAndNil(Config); //must create and fill later!
 
736
    exit; //project directory MUST be known
 
737
  end;
 
738
  ProjectFile := Config.ReadString(SecDoc, 'projectfile', '');
 
739
  FInputDir := Config.ReadString(SecDoc, 'inputdir', '');
 
740
  FCompOpts := Config.ReadString(SecDoc, 'options', '');
 
741
  FDescrDir := Config.ReadString(SecDoc, 'descrdir', '');
 
742
  FAltDir := Config.ReadString(SecDoc, 'AltDir', '');
 
743
  FAllDirs:= Config.ReadBool(SecDoc, 'AllDirs', False);
 
744
  Requires.CommaText := Config.ReadString(SecDoc, 'requires', '');
 
745
//units
 
746
  Config.ReadSection('units', Units);
 
747
  Config.ReadSection('descrs', Descriptions);
 
748
//more?
 
749
//all done
 
750
  Loaded := True;
 
751
end;
 
752
 
 
753
(* Initialize the package, write global config (+local?)
 
754
*)
 
755
procedure TDocPackage.UpdateConfig;
 
756
begin
 
757
//create ini file, if not already created
 
758
  if Config = nil then
 
759
    Config := TConfigFile.Create(IniFileName); //in document RootDir
 
760
//general information
 
761
  Config.WriteString(SecDoc, 'projectdir', ProjectDir);
 
762
  Config.WriteString(SecDoc, 'projectfile', ProjectFile);
 
763
  Config.WriteString(SecDoc, 'inputdir', InputDir);
 
764
  Config.WriteString(SecDoc, 'options', CompOpts);
 
765
  Config.WriteString(SecDoc, 'descrdir', DescrDir);
 
766
  Config.WriteString(SecDoc, 'AltDir', FAltDir);
 
767
  Config.WriteBool(SecDoc, 'AllDirs', AllDirs);
 
768
  Config.WriteString(SecDoc, 'requires', Requires.CommaText);
 
769
//units
 
770
  Config.WriteSectionValues('units', Units);
 
771
  Config.WriteSectionValues('descrs', Descriptions);
 
772
  Config.WriteSectionValues('SrcDirs', SrcDirs);
 
773
//all done
 
774
  Config.Flush;
 
775
  Loaded := True;
 
776
end;
 
777
 
 
778
procedure TDocPackage.EnumUnits(AList: TStrings);
 
779
var
 
780
  i: integer;
 
781
begin
 
782
//override to add further units (from AltDir...)
 
783
  for i := 0 to Units.Count - 1 do
 
784
    AList.Add(Units.Names[i]);
 
785
end;
 
786
 
 
787
function TDocPackage.DescrFileName(const AUnit: string): string;
 
788
begin
 
789
(* [ProjectDir +] DescrDir + AUnit + .xml
 
790
*)
 
791
  Result := DescrDir;
 
792
  if (Result = '') or (Result[1] = '.') then
 
793
    Result := ProjectDir + Result;
 
794
  Result := Result + DirectorySeparator + AUnit + '.xml';
 
795
end;
 
796
 
 
797
function TDocPackage.IniFileName: string;
 
798
begin
 
799
  Result := Manager.RootDir + Name + '.ini';
 
800
end;
 
801
 
 
802
procedure TDocPackage.AddUnit(const AFile: string);
 
803
var
 
804
  s: string;
 
805
begin
 
806
  s := ExtractUnitName(AFile);
 
807
  if s = '' then
 
808
    Manager.DoLog('No unit: ' + AFile)
 
809
  else
 
810
    Units.Add(s + '=' + AFile);
 
811
end;
 
812
 
 
813
{ TFPDocManager }
 
814
 
 
815
constructor TFPDocManager.Create(AOwner: TComponent);
 
816
var
 
817
  lst: TStringList;
 
818
begin
 
819
  inherited Create(AOwner);
 
820
  lst := TStringList.Create;
 
821
  lst.OwnsObjects := True;
 
822
  FPackages := lst;
 
823
  FOptions := TCmdOptions.Create;
 
824
  FNoParseUnits := TStringList.Create;
 
825
end;
 
826
 
 
827
destructor TFPDocManager.Destroy;
 
828
begin
 
829
  SaveConfig;
 
830
  FreeAndNil(Config);
 
831
  //FPackages.Clear; //destructor seems NOT to clear/destroy owned object!?
 
832
  FreeAndNil(FPackages);
 
833
  FreeAndNil(FOptions);
 
834
  FreeAndNil(FNoParseUnits);
 
835
  inherited Destroy;
 
836
end;
 
837
 
 
838
procedure TFPDocManager.SetFPDocDir(AValue: string);
 
839
begin
 
840
  if FFPDocDir=AValue then Exit;
 
841
  FFPDocDir:=AValue;
 
842
  Config.WriteString(SecGen, 'FpcDocDir', FpcDocDir);
 
843
end;
 
844
 
 
845
procedure TFPDocManager.SetFpcDir(AValue: string);
 
846
begin
 
847
  if FFpcDir=AValue then Exit;
 
848
  FFpcDir:=AValue;
 
849
  Config.WriteString(SecGen, 'FpcDir', FpcDir);
 
850
end;
 
851
 
 
852
procedure TFPDocManager.SetExcludedUnits(AValue: boolean);
 
853
begin
 
854
  if FExcludedUnits=AValue then Exit;
 
855
  FExcludedUnits:=AValue;
 
856
  Config.WriteBool(SecGen, 'ExcludeUnits', AValue);
 
857
end;
 
858
 
 
859
procedure TFPDocManager.UpdatePackage(const AName: string);
 
860
var
 
861
  pkg: TDocPackage;
 
862
  i: integer;
 
863
  s: string;
 
864
begin
 
865
  if LazarusDir = '' then exit;
 
866
  s := {LazarusDir +} 'docs/xml/'+AName;
 
867
  if not DirectoryExists(FixPath(LazarusDir + s)) then
 
868
    exit;
 
869
  i := Packages.IndexOfName(AName);
 
870
  if i < 0 then
 
871
    exit;
 
872
  pkg := Packages.Objects[i] as TDocPackage;
 
873
  pkg.AltDir := s; //add descriptors when configuring the project/helper
 
874
end;
 
875
 
 
876
function TFPDocManager.UpdateFCL(enabled: boolean): boolean;
 
877
var
 
878
  pkg: TFCLDocPackage;
 
879
begin
 
880
(* Adding to the FCL requires valid FPC and Lazarus directories (caller checks).
 
881
  Then laz/docs/xml/fcl/ is added to fpc descr-dirs.
 
882
  The related units have to be added as input-dirs.
 
883
  Scan fpc/packages/ for candidates.
 
884
*)
 
885
//todo: implement
 
886
  pkg := AddPackage('fcl') as TFCLDocPackage;
 
887
  if pkg = nil then
 
888
    exit(False);
 
889
  if enabled then
 
890
    pkg.AltDir := 'docs/xml/fcl'
 
891
  else
 
892
    pkg.AltDir := '';
 
893
  Result := True;
 
894
end;
 
895
 
 
896
procedure TFPDocManager.SetLazarusDir(AValue: string);
 
897
begin
 
898
  if FLazarusDir=AValue then Exit;
 
899
  FLazarusDir:=AValue;
 
900
  Config.WriteString(SecGen, 'LazarusDir', FLazarusDir);
 
901
//update RTL and FCL - if exist and Dir exists
 
902
  UpdatePackage('rtl');
 
903
  UpdatePackage('fcl');
 
904
end;
 
905
 
 
906
function TFPDocManager.GetNoParseUnits: TStrings;
 
907
begin
 
908
  Result := FNoParseUnits;
 
909
end;
 
910
 
 
911
procedure TFPDocManager.SetNoParseUnits(AValue: TStrings);
 
912
begin
 
913
  FNoParseUnits.Assign(AValue);
 
914
  FNoParseUnits.Sorted := True;
 
915
  Config.WriteSection('NoParseUnits', NoParseUnits);
 
916
end;
 
917
 
 
918
procedure TFPDocManager.SetOnChange(AValue: TNotifyEvent);
 
919
begin
 
920
  if FOnChange=AValue then Exit;
 
921
  FOnChange:=AValue;
 
922
end;
 
923
 
 
924
procedure TFPDocManager.SetPackage(AValue: TDocPackage);
 
925
begin
 
926
  if FPackage=AValue then Exit;
 
927
  FPackage:=AValue;
 
928
end;
 
929
 
 
930
procedure TFPDocManager.SetProfile(AValue: string);
 
931
begin
 
932
  if AValue = '' then exit;
 
933
  if FProfile=AValue then Exit;
 
934
  if Options.Modified then
 
935
    Options.SaveConfig(Config, FProfile);
 
936
  FProfile:=AValue;
 
937
  if not Config.SectionExists(AValue) then begin
 
938
    FProfiles := FProfiles + ',' + AValue;
 
939
    Config.WriteString(SecGen, 'Profiles', FProfiles);
 
940
  end;
 
941
  Config.WriteString(SecGen, 'Profile', FProfile);
 
942
  Options.LoadConfig(Config, Profile);
 
943
end;
 
944
 
 
945
(* Try load config from new dir - this may fail on the first run.
 
946
*)
 
947
procedure TFPDocManager.SetRootDir(AValue: string);
 
948
var
 
949
  s: string;
 
950
begin
 
951
  s := IncludeTrailingPathDelimiter(AValue);
 
952
  if FRootDir=s then Exit; //prevent recursion
 
953
  FRootDir:=s;
 
954
//load config - not here!
 
955
end;
 
956
 
 
957
procedure TFPDocManager.Changed;
 
958
begin
 
959
  if not Modified or (UpdateCount > 0) then
 
960
    exit; //should not be called directly
 
961
  FModified := False;
 
962
  if Assigned(OnChange) then
 
963
    FOnChange(self);
 
964
end;
 
965
 
 
966
function TFPDocManager.BeginTest(const ADir: string): boolean;
 
967
begin
 
968
  Helper.Free; //should have been done
 
969
  Helper := TFPDocHelper.Create(nil);
 
970
  Helper.OnLog := OnLog;
 
971
  Result := Helper.BeginTest(ADir);
 
972
  if Result then
 
973
    Helper.CmdOptions := Options; //set reference AND propagate!?
 
974
end;
 
975
 
 
976
procedure TFPDocManager.EndTest;
 
977
begin
 
978
  SetCurrentDir(ExtractFileDir(RootDir));
 
979
  FreeAndNil(Helper);
 
980
end;
 
981
 
 
982
procedure TFPDocManager.BeginUpdate;
 
983
begin
 
984
  inc(UpdateCount);
 
985
end;
 
986
 
 
987
procedure TFPDocManager.EndUpdate;
 
988
begin
 
989
  dec(UpdateCount);
 
990
  if UpdateCount <= 0 then begin
 
991
    UpdateCount := 0;
 
992
    if Modified then
 
993
      Changed;
 
994
  end;
 
995
end;
 
996
 
 
997
(* Try load config.
 
998
  Init RootDir (only when config found?)
 
999
  Try load packages from their INI files
 
1000
*)
 
1001
function TFPDocManager.LoadConfig(const ADir: string; Force: boolean): boolean;
 
1002
var
 
1003
  s, pf, cf: string;
 
1004
  i: integer;
 
1005
begin
 
1006
  s := IncludeTrailingPathDelimiter(ADir);
 
1007
  cf := s + ConfigName;
 
1008
  Result := FileExists(cf);
 
1009
  if not Result and not Force then
 
1010
    exit;
 
1011
  RootDir:=s; //recurse if RootDir changed
 
1012
//sanity check: only one config file!
 
1013
  if assigned(Config) then begin
 
1014
    if (Config.FileName = cf) then
 
1015
      exit(false) //nothing new?
 
1016
    else
 
1017
      Config.Free;
 
1018
    //clear packages???
 
1019
  end;
 
1020
  Config := TConfigFile.Create(cf);
 
1021
  //Config.CacheUpdates := True;
 
1022
  if not Result then
 
1023
    exit; //nothing to read
 
1024
//read directories
 
1025
  FFpcDir := Config.ReadString(SecGen, 'FpcDir', '');
 
1026
  FFPDocDir := Config.ReadString(SecGen, 'FpcDocDir', '');
 
1027
  FLazarusDir:=Config.ReadString(SecGen, 'LazarusDir', '');
 
1028
//read packages
 
1029
  Config.ReadSection(SecProjects, FPackages); //<prj>=<file>
 
1030
//read detailed package information - possibly multiple packages per project!
 
1031
  BeginUpdate;  //turn of app notification!
 
1032
  for i := 0 to Packages.Count - 1 do begin
 
1033
  //read package config (=project file name?)
 
1034
    s := Packages.Names[i];
 
1035
    pf := Packages.ValueFromIndex[i];
 
1036
    if pf <> '' then begin
 
1037
      AddProject(s, pf); //add and load project file, don't update config!
 
1038
      FModified := True; //force app notification
 
1039
    end;
 
1040
  end;
 
1041
//more? (preferences?)
 
1042
  FProfiles:=Config.ReadString(SecGen, 'Profiles', 'default');
 
1043
  FProfile := Config.ReadString(SecGen,'Profile', 'default');
 
1044
  Options.LoadConfig(Config, Profile);
 
1045
  FExcludedUnits := Config.ReadBool(SecGen, 'ExcludeUnits', True);
 
1046
  Config.ReadSection('NoParseUnits', NoParseUnits);
 
1047
//done, nothing modified
 
1048
  EndUpdate;
 
1049
end;
 
1050
 
 
1051
function TFPDocManager.SaveConfig: boolean;
 
1052
begin
 
1053
//Options? assume saved by application?
 
1054
  if Options.Modified then begin
 
1055
    Options.SaveConfig(Config, Profile);
 
1056
  end;
 
1057
  Config.Flush;
 
1058
  Result := True; //for now
 
1059
end;
 
1060
 
 
1061
procedure TFPDocManager.AddProfile(const AName: string);
 
1062
begin
 
1063
//add and select - obsolete!
 
1064
  Profile := AName;
 
1065
end;
 
1066
 
 
1067
(* Add a DocPackage to Packages and INI.
 
1068
  Return package Index.
 
1069
  For exclusive use by Package.SetLoaded!
 
1070
*)
 
1071
function TFPDocManager.RegisterPackage(APkg: TDocPackage): integer;
 
1072
begin
 
1073
  Result := Packages.IndexOfName(APkg.Name);
 
1074
  if Result < 0 then begin
 
1075
  //add package
 
1076
    Result := Packages.AddObject(APkg.Name + '=' + APkg.ProjectFile, APkg);
 
1077
  end else if Packages.Objects[Result] = nil then
 
1078
    Packages.Objects[Result] := APkg;
 
1079
  if APkg.Loaded then begin
 
1080
  //check/create project file?
 
1081
    if APkg.ProjectFile = '' then begin
 
1082
      if APkg.ProjectDir = '' then begin
 
1083
        DoLog('Missing project directory for package ' + APkg.Name);
 
1084
        exit(-1); //???
 
1085
      end;
 
1086
      APkg.ProjectFile := APkg.ProjectDir + APkg.Name; //to be fixed by pkg
 
1087
    end;
 
1088
    if (ExtractFileExt(APkg.ProjectFile) <> '.xml') then begin
 
1089
    //create project file
 
1090
      APkg.ProjectFile := ChangeFileExt(APkg.ProjectFile, '_prj.xml');
 
1091
      CreateProject(APkg.ProjectFile, APkg);
 
1092
    //update Packages[] string
 
1093
      Packages[Result] := APkg.Name + '=' + APkg.ProjectFile;
 
1094
    end;
 
1095
    Config.WriteString(SecProjects, APkg.Name, APkg.ProjectFile);
 
1096
  end;
 
1097
  FModified := True;
 
1098
end;
 
1099
 
 
1100
(* Load FPDoc (XML) project file.
 
1101
Called by
 
1102
- init - not Dirty!
 
1103
*)
 
1104
function TFPDocManager.AddProject(const APkg, AFile: string): boolean;
 
1105
var
 
1106
  pkg: TDocPackage;
 
1107
  i: integer;
 
1108
begin
 
1109
//create DocPackage
 
1110
  pkg := AddPackage(APkg);
 
1111
  if pkg.Loaded then
 
1112
    exit(True); //assume registered!?
 
1113
//check project file
 
1114
  if ExtractFileExt(AFile) <> '.xml' then begin
 
1115
    DoLog('Not a project file: ' + AFile);
 
1116
    Exit(False);
 
1117
  end;
 
1118
  if not FileExists(AFile) then begin
 
1119
    DoLog('Missing project file: ' + AFile);
 
1120
    exit(False);
 
1121
  end;
 
1122
//create helper
 
1123
  BeginTest(AFile);
 
1124
  try
 
1125
  //load the project file into Helper
 
1126
    Helper.LoadProjectFile(AFile);
 
1127
    if Helper.Packages.Count = 1 then begin
 
1128
      Helper.Package := Helper.Packages[0]; //in LoadProject?
 
1129
      Result := pkg.ImportProject(Helper, Helper.Package, AFile);
 
1130
      exit;
 
1131
    end;
 
1132
  //load all packages
 
1133
    for i := 0 to Helper.Packages.Count - 1 do begin
 
1134
      Helper.Package := Helper.Packages[i];
 
1135
      pkg := AddPackage(Helper.Package.Name);
 
1136
      if pkg.Loaded then
 
1137
        continue; //already initialized
 
1138
      pkg.ImportProject(Helper, Helper.Package, '');
 
1139
    end;
 
1140
  finally
 
1141
    EndTest;
 
1142
  end;
 
1143
end;
 
1144
 
 
1145
(* Ask DocPackage to create an projectfile.
 
1146
  Overwrite if exists???
 
1147
  AFileName is any file in the project directory, required for CD!
 
1148
  !!! prevent recursive calls, destroying Helper !!!
 
1149
*)
 
1150
function TFPDocManager.CreateProject(const AFileName: string; APkg: TDocPackage
 
1151
  ): boolean;
 
1152
begin
 
1153
  if Helper = nil then begin
 
1154
    BeginTest(AFileName); //CD into project dir
 
1155
    try
 
1156
      Result := APkg.CreateProject(Helper, AFileName);
 
1157
    finally
 
1158
      EndTest;
 
1159
    end;
 
1160
  end else begin
 
1161
  //assume that Helper IS for APkg
 
1162
    Result := APkg.CreateProject(Helper, AFileName);
 
1163
  end;
 
1164
end;
 
1165
 
 
1166
(* Return the named package, create if not found.
 
1167
  Rename: GetPackage?
 
1168
*)
 
1169
function TFPDocManager.AddPackage(AName: string): TDocPackage;
 
1170
var
 
1171
  i: integer;
 
1172
begin
 
1173
  AName := LowerCase(AName);
 
1174
  i := FPackages.IndexOfName(AName);
 
1175
  if i < 0 then
 
1176
    Result := nil
 
1177
  else
 
1178
    Result := FPackages.Objects[i] as TDocPackage;
 
1179
  if Result = nil then begin
 
1180
  {$IFDEF FCLadds}
 
1181
    if AName = 'fcl' then
 
1182
      Result := TFCLDocPackage.Create
 
1183
    else
 
1184
  {$ELSE}
 
1185
  {$ENDIF}
 
1186
      Result := TDocPackage.Create;
 
1187
    Result.Name := AName; //triggers load config --> register
 
1188
    i := FPackages.IndexOfName(AName); //already registered?
 
1189
  end;
 
1190
  if i < 0 then begin
 
1191
  //we MUST create an entry
 
1192
    Packages.AddObject(AName + '=' + Result.ProjectFile, Result);
 
1193
  end;
 
1194
end;
 
1195
 
 
1196
function TFPDocManager.IsExtended(const APkg: string): string;
 
1197
var
 
1198
  pkg: TDocPackage;
 
1199
begin
 
1200
{$IFDEF FCLadds}
 
1201
  pkg := AddPackage(APkg);
 
1202
  if pkg = nil then
 
1203
    Result := ''
 
1204
  else
 
1205
    Result := pkg.AltDir;
 
1206
{$ELSE}
 
1207
  Result := '';
 
1208
{$ENDIF}
 
1209
end;
 
1210
 
 
1211
function TFPDocManager.ImportLpk(const AFile: string): TDocPackage;
 
1212
begin
 
1213
  BeginUpdate;
 
1214
//import the LPK file into? Here: TDocPackage, could be FPDocProject?
 
1215
  Result := uLpk.ImportLpk(AFile);
 
1216
  if Result = nil then
 
1217
    DoLog('Import failed on ' + AFile)
 
1218
  else begin
 
1219
    Result.Loaded := True; //import and write config file
 
1220
  end;
 
1221
  EndUpdate;
 
1222
end;
 
1223
 
 
1224
(* Add the project, just created from cmdline or projectfile
 
1225
*)
 
1226
procedure TFPDocManager.ImportProject(APkg: TFPDocPackage; const AFile: string);
 
1227
var
 
1228
  pkg: TDocPackage;
 
1229
begin
 
1230
  pkg := AddPackage(APkg.Name);
 
1231
  pkg.ImportProject(Helper, APkg, AFile);
 
1232
//update config?
 
1233
  Config.WriteString(SecProjects, pkg.Name, AFile);
 
1234
  FModified := true;
 
1235
//notify app?
 
1236
  //Changed;
 
1237
end;
 
1238
 
 
1239
function TFPDocManager.ImportCmd(const AFile: string): boolean;
 
1240
var
 
1241
  pkg: TDocPackage;
 
1242
begin
 
1243
  Result := False;
 
1244
  BeginTest(AFile); //directory!!!
 
1245
  try
 
1246
    Result := Helper.CmdToPrj(AFile);
 
1247
    if not Result then
 
1248
      exit;
 
1249
    pkg := AddPackage(Helper.SelectedPackage.Name); //create [and register]
 
1250
    pkg.Loaded := False; //force reload
 
1251
    if not pkg.Loaded then begin
 
1252
      Result := pkg.ImportProject(Helper, Helper.Package, AFile);
 
1253
    end;
 
1254
  finally
 
1255
    EndTest;
 
1256
  end;
 
1257
  if Result then
 
1258
    Changed;
 
1259
end;
 
1260
 
 
1261
function TFPDocManager.MakeDoc(APkg: TDocPackage; const AUnit, AOutput: string): boolean;
 
1262
begin
 
1263
  Result := assigned(APkg)
 
1264
  and BeginTest(APkg.ProjectDir)
 
1265
  and APkg.CreateProject(Helper, ''); //only configure, don't create file
 
1266
  if not Result then
 
1267
    exit;
 
1268
  try
 
1269
    Helper.ParseFPDocOption(Format('--output="%s"', [AOutput]));
 
1270
    if Options.Backend = 'chm' then begin
 
1271
      Helper.ParseFPDocOption('--auto-toc');
 
1272
      Helper.ParseFPDocOption('--auto-index');
 
1273
    end;
 
1274
      Helper.ParseFPDocOption('--make-searchable'); //always?
 
1275
    //Result :=
 
1276
    Helper.CreateUnitDocumentation(AUnit, False);
 
1277
  finally
 
1278
    EndTest;
 
1279
  end;
 
1280
end;
 
1281
 
 
1282
function TFPDocManager.TestRun(APkg: TDocPackage; AUnit: string): boolean;
 
1283
begin
 
1284
  BeginTest(APkg.ProjectFile);
 
1285
  try
 
1286
    try
 
1287
      Result := Helper.TestRun(APkg, AUnit);
 
1288
    except
 
1289
      on E: EParserError do
 
1290
        DoLog(Format('%s(%d,%d): %s',[e.Filename, e.Row, e.Column, e.Message]));
 
1291
      on E: Exception do
 
1292
        DoLog(E.Message);
 
1293
    end;
 
1294
  finally
 
1295
    EndTest;
 
1296
  end;
 
1297
end;
 
1298
 
 
1299
function TFPDocManager.Update(APkg: TDocPackage; const AUnit: string): boolean;
 
1300
begin
 
1301
  Result := assigned(APkg)
 
1302
  and BeginTest(APkg.ProjectFile);
 
1303
  if not Result then
 
1304
    exit;
 
1305
  try
 
1306
    Result := APkg.CreateProject(Helper, ''); //only configure, don't create file
 
1307
    if not Result then
 
1308
      exit;
 
1309
    Result := Helper.Update(APkg, AUnit);
 
1310
  finally
 
1311
    EndTest;
 
1312
  end;
 
1313
end;
 
1314
 
 
1315
procedure TFPDocManager.DoLog(const Msg: String);
 
1316
begin
 
1317
  if Assigned(FOnLog) then
 
1318
    FOnLog(self, msg);
 
1319
end;
 
1320
 
 
1321
{ TFPDocHelper }
 
1322
 
 
1323
constructor TFPDocHelper.Create(AOwner: TComponent);
 
1324
begin
 
1325
  inherited Create(AOwner);
 
1326
  InputList := TStringList.Create;
 
1327
  DescrList := TStringList.Create;
 
1328
end;
 
1329
 
 
1330
destructor TFPDocHelper.Destroy;
 
1331
begin
 
1332
  FreeAndNil(InputList);
 
1333
  FreeAndNil(DescrList);
 
1334
  inherited Destroy;
 
1335
end;
 
1336
 
 
1337
(* Prepare MakeSkel on temporary FPDocPackage
 
1338
*)
 
1339
function TFPDocHelper.BeginTest(APkg: TDocPackage): boolean;
 
1340
begin
 
1341
  if not assigned(APkg) then
 
1342
    exit(False);
 
1343
  Result := BeginTest(APkg.ProjectFile); //directory would be sufficient!
 
1344
  if not Result then
 
1345
    exit;
 
1346
  APkg.CreateProject(self, ''); //create project file?
 
1347
  Package := Packages.FindPackage(APkg.Name);
 
1348
  //Options?
 
1349
//okay, so far
 
1350
  Result := assigned(Package);
 
1351
end;
 
1352
 
 
1353
procedure TFPDocHelper.EndTest;
 
1354
begin
 
1355
//???
 
1356
end;
 
1357
 
 
1358
function TFPDocHelper.BeginTest(ADir: string): boolean;
 
1359
begin
 
1360
  Result := ADir <> '';
 
1361
  if not Result then
 
1362
    exit;
 
1363
//remember dir!
 
1364
  if ExtractFileExt(ADir) <> '' then //todo: better check for directory!?
 
1365
    ADir := ExtractFileDir(ADir);
 
1366
  ProjectDir:=ADir;
 
1367
  SetCurrentDir(ProjectDir);
 
1368
end;
 
1369
 
 
1370
(* Create a project from an FPDoc commandline.
 
1371
  Do NOT create an project file!(?)
 
1372
*)
 
1373
function TFPDocHelper.CmdToPrj(const AFileName: string): boolean;
 
1374
var
 
1375
  l, w: string;
 
1376
  i: integer;
 
1377
begin
 
1378
  Result := False; //in case of errors
 
1379
//read the commandline
 
1380
  InputList.LoadFromFile(AFileName);
 
1381
  for i := 0 to InputList.Count - 1 do begin
 
1382
    l := InputList[i];
 
1383
    w := GetNextWord(l);
 
1384
    if w = 'fpdoc' then begin //contains!?
 
1385
      Result := True; //so far
 
1386
      break; //fpdoc command found
 
1387
    end;
 
1388
  end;
 
1389
  InputList.Clear;
 
1390
  if not Result then
 
1391
    exit;
 
1392
//parse commandline
 
1393
  while l <> '' do begin
 
1394
    w := GetNextWord(l);
 
1395
    ParseFPDocOption(w);
 
1396
  end;
 
1397
  Result := True;
 
1398
end;
 
1399
 
 
1400
function TFPDocHelper.MakeDocs(APkg: TDocPackage; const AUnit: string;
 
1401
  AOutput: string): boolean;
 
1402
begin
 
1403
  Result := BeginTest(APkg); //configure and select package
 
1404
  if not Result then
 
1405
    exit;
 
1406
  try
 
1407
    ParseFPDocOption(Format('--output="%s"', [AOutput]));
 
1408
    CreateDocumentation(Package, False);
 
1409
  finally
 
1410
    EndTest;
 
1411
  end;
 
1412
end;
 
1413
 
 
1414
function TFPDocHelper.TestRun(APkg: TDocPackage; AUnit: string): boolean;
 
1415
begin
 
1416
(* more detailed error handling?
 
1417
  Must CD to the project file directory!?
 
1418
*)
 
1419
  Result := BeginTest(APkg);
 
1420
  if not Result then
 
1421
    exit;
 
1422
  try
 
1423
  //override options for test
 
1424
    ParseFPDocOption('--format=html');
 
1425
    ParseFPDocOption('-v');
 
1426
    ParseFPDocOption('-n');
 
1427
    //verbose?
 
1428
    CreateUnitDocumentation(AUnit, True);
 
1429
  finally
 
1430
    EndTest;
 
1431
  end;
 
1432
end;
 
1433
 
 
1434
(* MakeSkel functionality - create skeleton or update file
 
1435
  using temporary Project
 
1436
*)
 
1437
function TFPDocHelper.Update(APkg: TDocPackage; const AUnit: string): boolean;
 
1438
 
 
1439
  function DocumentUnit(const AUnit: string): boolean;
 
1440
  var
 
1441
    OutName, msg: string;
 
1442
  begin
 
1443
    if Manager.NoParseUnits.IndexOf(AUnit) >= 0 then begin
 
1444
      DoLog('NoParse ' + AUnit);
 
1445
      exit(False);
 
1446
    end;
 
1447
    InputList.Clear;
 
1448
    InputList.Add(UnitSpec(AUnit));
 
1449
    DescrList.Clear;
 
1450
    OutName := AUnit + '.xml';
 
1451
    if DescrDir <> '' then
 
1452
      OutName := IncludeTrailingBackslash(DescrDir) + OutName;
 
1453
    CmdOptions.UpdateMode := FileExists(OutName);
 
1454
    if CmdOptions.UpdateMode then begin
 
1455
      DescrList.Add(OutName);
 
1456
      OutName:=Manager.RootDir + 'upd.' + AUnit + '.xml';
 
1457
      DoLog('Update ' + OutName);
 
1458
    end else begin
 
1459
      DoLog('Create ' + OutName);
 
1460
    end;
 
1461
    msg := DocumentPackage(APkg.Name, OutName, InputList, DescrList);
 
1462
    Result := msg = '';
 
1463
    if not Result then
 
1464
      DoLog(msg) //+unit?
 
1465
    else if CmdOptions.UpdateMode then begin
 
1466
      CleanXML(OutName);
 
1467
    end;
 
1468
  end;
 
1469
 
 
1470
var
 
1471
  i: integer;
 
1472
  u: string;
 
1473
begin
 
1474
  Result := BeginTest(APkg);
 
1475
  if not Result then
 
1476
    exit;
 
1477
  if AUnit <> '' then begin
 
1478
    Result := DocumentUnit(AUnit);
 
1479
  end else begin
 
1480
    for i := 0 to Package.Inputs.Count - 1 do begin
 
1481
      u := ExtractUnitName(Package.Inputs, i);
 
1482
      DocumentUnit(u);
 
1483
    end;
 
1484
  end;
 
1485
  EndTest;
 
1486
end;
 
1487
 
 
1488
procedure TFPDocHelper.SetProjectDir(AValue: string);
 
1489
begin
 
1490
  if FProjectDir=AValue then Exit;
 
1491
  FProjectDir:=AValue;
 
1492
end;
 
1493
 
 
1494
end.
 
1495