paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-06 14:26:55 +02:00
Code Issues Packages Projects Releases Wiki Activity

examples/fpdocmanager added.

Browse Source 
git-svn-id: trunk@34537 -
This commit is contained in:
dodi 2012-01-02 04:45:54 +00:00
parent 914d05910c
commit ed5ef5dec3
17 changed files with 3960 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
.gitattributes vendored
View File

@ -3694,6 +3694,22 @@ examples/fontenum/fontenumeration.lpr svneol=native#text/pascal
examples/fontenum/mainunit.lfm svneol=native#text/plain
examples/fontenum/mainunit.lrs svneol=native#text/pascal
examples/fontenum/mainunit.pas svneol=native#text/pascal
examples/fpdocmanager/FPDocManager.lpi svneol=native#text/plain
examples/fpdocmanager/FPDocManager.lpr svneol=native#text/plain
examples/fpdocmanager/README.txt svneol=native#text/plain
examples/fpdocmanager/fconfig.lfm svneol=native#text/plain
examples/fpdocmanager/fconfig.pas svneol=native#text/pascal
examples/fpdocmanager/flogview.lfm svneol=native#text/plain
examples/fpdocmanager/flogview.pas svneol=native#text/pascal
examples/fpdocmanager/fmain.lfm svneol=native#text/plain
examples/fpdocmanager/fmain.pas svneol=native#text/pascal
examples/fpdocmanager/fpdocengine.lpk svneol=native#text/plain
examples/fpdocmanager/fupdateview.lfm svneol=native#text/plain
examples/fpdocmanager/fupdateview.pas svneol=native#text/pascal
examples/fpdocmanager/ucmdline.pas svneol=native#text/pascal
examples/fpdocmanager/ulpk.pp svneol=native#text/pascal
examples/fpdocmanager/umakeskel.pas svneol=native#text/pascal
examples/fpdocmanager/umanager.pas svneol=native#text/pascal
examples/gridexamples/grid_semaphor/TSemaphorDBGrid.xpm -text svneol=native#image/x-xpixmap
examples/gridexamples/grid_semaphor/example/project1.lpi svneol=native#text/plain
examples/gridexamples/grid_semaphor/example/project1.lpr svneol=native#text/pascal

145
examples/fpdocmanager/FPDocManager.lpi Normal file
View File

@ -0,0 +1,145 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="FPDocManager"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<WorkingDirectory Value="D:\AllDocs"/>
</local>
</RunParams>
<RequiredPackages Count="3">
<Item1>
<PackageName Value="FPDocEngine"/>
</Item1>
<Item2>
<PackageName Value="SynEdit"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="10">
<Unit0>
<Filename Value="FPDocManager.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="FPDocManager"/>
</Unit0>
<Unit1>
<Filename Value="fmain.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Main"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="fMain"/>
</Unit1>
<Unit2>
<Filename Value="fconfig.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="CfgWizard"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="fConfig"/>
</Unit2>
<Unit3>
<Filename Value="ucmdline.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="uCmdLine"/>
</Unit3>
<Unit4>
<Filename Value="umakeskel.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="umakeskel"/>
</Unit4>
<Unit5>
<Filename Value="umanager.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="uManager"/>
</Unit5>
<Unit6>
<Filename Value="flogview.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="LogView"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="fLogView"/>
</Unit6>
<Unit7>
<Filename Value="fupdateview.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="UpdateView"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="fUpdateView"/>
</Unit7>
<Unit8>
<Filename Value="ulpk.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="uLpk"/>
</Unit8>
<Unit9>
<Filename Value="$(FPCDir)\utils\fpdoc\dw_html.pp"/>
<IsPartOfProject Value="True"/>
<UnitName Value="dw_HTML"/>
</Unit9>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="FPDocManager"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="$(FPCDir)\utils\fpdoc"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CustomOptions Value="-dDoDi"/>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

24
examples/fpdocmanager/FPDocManager.lpr Normal file
View File

@ -0,0 +1,24 @@
program FPDocManager;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, dw_HTML, umakeskel, fMain, fConfig, uCmdLine, uManager, fLogView,
fUpdateView, ulpk;
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TMain, Main);
Application.CreateForm(TCfgWizard, CfgWizard);
Application.CreateForm(TLogView, LogView);
Application.CreateForm(TUpdateView, UpdateView);
Application.Run;
end.

26
examples/fpdocmanager/README.txt Normal file
View File

@ -0,0 +1,26 @@
The FPDoc documentation manager
===============================
This project simplifies the maintenance of (local) documentation.
A configuration wizard helps in the setup of the basic RTL, FCL and LCL docs.
Configuration and output is kept in a single user selectable directory.
A package FPDocEngine is supplied for use in commandline or GUI applications.
uMakeSkel is a copy of parts of the FPDoc and MakeSkel programs, modified
with workarounds for known problems with these FPC tools.
Release notes 1.0
-----------------
The FPDoc Manager requires FPC 2.7 (rev. 19947) for proper operation of the
FPDoc units.
A package FPDocEngine.lpk has been created for the FPDoc units, please move it
into your $FPC/utils/fpdoc/ directory and compile the package there.
The project (FPDocManager.lpi) did not fully compile on my machine. Unit
dw_HTML could not be found, even if all other units of the package worked.
Adding the unit directly to the project made it compile, please remove or
update this entry as required, and give hints on how to fix the problem.
DoDi

216
examples/fpdocmanager/fconfig.lfm Normal file
View File

@ -0,0 +1,216 @@
object CfgWizard: TCfgWizard
Left = 362
Height = 302
Top = 165
Width = 318
Caption = 'Configuration Assistant'
ClientHeight = 302
ClientWidth = 318
OnShow = FormShow
LCLVersion = '0.9.31'
object Steps: TPageControl
Left = 0
Height = 241
Top = 0
Width = 318
ActivePage = MkRTL
Align = alClient
TabIndex = 2
TabOrder = 0
object SelRoot: TTabSheet
Caption = 'RootDir'
ClientHeight = 195
ClientWidth = 312
OnShow = SelRootShow
object Label1: TLabel
Left = 10
Height = 121
Top = 10
Width = 264
Caption = 'The Root directory contains the configuration '#13#10'and all generated documentation.'#13#10#13#10'You can make this directory the working directory'#13#10'of the Documentation Manager, so that you don''t'#13#10'have to specify the root directory on every start.'#13#10#13#10'Please select this directory now.'
ParentColor = False
end
object buSelRoot: TButton
Left = 10
Height = 25
Top = 152
Width = 75
Caption = 'Browse...'
OnClick = buSelRootClick
TabOrder = 0
end
object edRoot: TEdit
Left = 92
Height = 23
Top = 154
Width = 216
OnChange = edRootChange
TabOrder = 1
end
end
object SelFPDir: TTabSheet
Caption = 'FPC'
ClientHeight = 195
ClientWidth = 312
OnShow = SelFPDirShow
object Label2: TLabel
Left = 10
Height = 91
Top = 10
Width = 272
Caption = 'The Free Pascal documentation is used everywhere.'#13#10'If you didn''t download the documentation sources'#13#10'already, you should do so now.'#13#10#13#10'Select the FPC documentation directory,'#13#10'or skip to the Lazarus configuration page.'
ParentColor = False
end
object buDownload: TButton
Left = 10
Height = 25
Top = 112
Width = 90
Caption = 'Download...'
Enabled = False
TabOrder = 0
end
object buSelFpc: TButton
Left = 12
Height = 25
Top = 144
Width = 75
Caption = 'Browse...'
OnClick = buSelFpcClick
TabOrder = 1
end
object edFpcDir: TEdit
Left = 100
Height = 23
Top = 144
Width = 200
Anchors = [akTop, akLeft, akRight]
OnChange = edFpcDirChange
TabOrder = 2
end
object Button2: TButton
Left = 124
Height = 25
Top = 112
Width = 75
Caption = 'Goto LCL'
Enabled = False
TabOrder = 3
end
end
object MkRTL: TTabSheet
Caption = 'RTL'
ClientHeight = 213
ClientWidth = 310
object Label3: TLabel
Left = 10
Height = 136
Top = 10
Width = 264
Caption = 'Now we''ll create the RTL documentation projects.'#13#10'Please open a console, '#13#10'CD to the FPC documentation directory,'#13#10'and enter "make rtl.chk -n >rtl.bat".'#13#10'Then select the just created file (i.e. rtl.bat), '#13#10'from which the RTL project will be created.'#13#10#13#10'Repeat with "make fcl.chk -n > fcl.bat" '#13#10'and select this file for the FCL project.'
ParentColor = False
end
object buRtlBat: TButton
Left = 10
Height = 25
Top = 152
Width = 43
Caption = 'RTL'
OnClick = buRtlBatClick
TabOrder = 0
end
object edRtlBat: TEdit
Left = 60
Height = 23
Top = 152
Width = 238
Anchors = [akTop, akLeft, akRight]
OnChange = edRtlBatChange
TabOrder = 1
end
object edFclBat: TEdit
Left = 60
Height = 23
Top = 182
Width = 238
Anchors = [akTop, akLeft, akRight]
OnChange = edRtlBatChange
TabOrder = 2
end
object buFclBat: TButton
Left = 10
Height = 25
Top = 182
Width = 43
Caption = 'FCL'
OnClick = buFclBatClick
TabOrder = 3
end
end
end
object sb: TStatusBar
Left = 0
Height = 23
Top = 279
Width = 318
Panels = <>
end
object Panel1: TPanel
Left = 0
Height = 38
Top = 241
Width = 318
Align = alBottom
ClientHeight = 38
ClientWidth = 318
TabOrder = 2
object buBack: TButton
Left = 8
Height = 25
Top = 5
Width = 75
Caption = 'Back'
OnClick = buBackClick
TabOrder = 0
end
object buCancel: TButton
Left = 96
Height = 25
Top = 5
Width = 75
Cancel = True
Caption = 'Cancel'
ModalResult = 2
TabOrder = 1
end
object buNext: TButton
Left = 230
Height = 25
Top = 5
Width = 75
Anchors = [akTop, akRight]
Caption = 'Next'
OnClick = buNextClick
TabOrder = 2
end
object Button1: TButton
Left = 182
Height = 25
Top = 5
Width = 35
Anchors = [akTop, akRight]
Caption = 'OK'
ModalResult = 1
TabOrder = 3
end
end
object dlgSelRoot: TSelectDirectoryDialog
Title = 'Select Documentation Root Directory'
left = 280
top = 128
end
object dlgOpen: TOpenDialog
left = 280
top = 80
end
end

158
examples/fpdocmanager/fconfig.pas Normal file
View File

@ -0,0 +1,158 @@
unit fConfig;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
ComCtrls, StdCtrls;
type
{ TCfgWizard }
TCfgWizard = class(TForm)
buBack: TButton;
buNext: TButton;
buFclBat: TButton;
buSelRoot: TButton;
buDownload: TButton;
buSelFpc: TButton;
Button1: TButton;
Button2: TButton;
buCancel: TButton;
buRtlBat: TButton;
edFpcDir: TEdit;
edRtlBat: TEdit;
edRoot: TEdit;
edFclBat: TEdit;
Label1: TLabel;
dlgSelRoot: TSelectDirectoryDialog;
Label2: TLabel;
Label3: TLabel;
dlgOpen: TOpenDialog;
Panel1: TPanel;
Steps: TPageControl;
sb: TStatusBar;
SelRoot: TTabSheet;
SelFPDir: TTabSheet;
MkRTL: TTabSheet;
procedure buBackClick(Sender: TObject);
procedure buFclBatClick(Sender: TObject);
procedure buNextClick(Sender: TObject);
procedure buRtlBatClick(Sender: TObject);
procedure buSelFpcClick(Sender: TObject);
procedure buSelRootClick(Sender: TObject);
procedure edFpcDirChange(Sender: TObject);
procedure edRootChange(Sender: TObject);
procedure edRtlBatChange(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure SelFPDirShow(Sender: TObject);
procedure SelRootShow(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
CfgWizard: TCfgWizard;
implementation
uses
uManager, uCmdLine;
{$R *.lfm}
{ TCfgWizard }
procedure TCfgWizard.buSelRootClick(Sender: TObject);
begin
dlgSelRoot.Title := 'Documentation Root Directory';
if not dlgSelRoot.Execute then
exit;
edRoot.Text := AppendPathDelim(dlgSelRoot.FileName);
//buNext.Enabled := True;
end;
procedure TCfgWizard.edFpcDirChange(Sender: TObject);
begin
Manager.FpcDocDir := edFpcDir.Text;
buNext.Enabled := edFpcDir.Text <> '';
end;
procedure TCfgWizard.edRootChange(Sender: TObject);
begin
Manager.RootDir:=edRoot.Text;
buNext.Enabled := Manager.RootDir <> '';
end;
procedure TCfgWizard.FormShow(Sender: TObject);
begin
//ModalResult:=mrOK; exits!!!
Steps.ActivePage := SelRoot;
end;
procedure TCfgWizard.SelFPDirShow(Sender: TObject);
begin
edFpcDir.Text := Manager.FpcDocDir;
buBack.Enabled := True;
//buNext.Enabled := FpcDocDir <> '';
end;
procedure TCfgWizard.buBackClick(Sender: TObject);
begin
Steps.SelectNextPage(False);
end;
procedure TCfgWizard.buNextClick(Sender: TObject);
begin
Steps.SelectNextPage(True);
end;
procedure TCfgWizard.edRtlBatChange(Sender: TObject);
var
fn: string;
ed: TEdit absolute Sender;
begin
fn := ed.Text;
if fn = '' then
exit;
uCmdLine.CmdToPrj(fn);
end;
procedure TCfgWizard.buFclBatClick(Sender: TObject);
begin
dlgOpen.InitialDir := Manager.FpcDocDir;
dlgOpen.Title := 'FCL.bat command file';
if dlgOpen.Execute then
edFclBat.Text := dlgOpen.FileName;
end;
procedure TCfgWizard.buRtlBatClick(Sender: TObject);
begin
dlgOpen.InitialDir := Manager.FpcDocDir;
dlgOpen.Title := 'RTL.bat command file';
if dlgOpen.Execute then
edRtlBat.Text := dlgOpen.FileName;
end;
procedure TCfgWizard.buSelFpcClick(Sender: TObject);
begin
dlgSelRoot.Title := 'FPC Documentation Source Directory';
if not dlgSelRoot.Execute then
exit;
edFpcDir.Text := AppendPathDelim(dlgSelRoot.FileName);
end;
procedure TCfgWizard.SelRootShow(Sender: TObject);
begin
edRoot.Text := Manager.RootDir;
buBack.Enabled := False;
buNext.Enabled := Manager.RootDir <> '';
end;
end.

20
examples/fpdocmanager/flogview.lfm Normal file
View File

@ -0,0 +1,20 @@
object LogView: TLogView
Left = 485
Height = 394
Top = 249
Width = 611
Caption = 'LogView'
ClientHeight = 394
ClientWidth = 611
OnClose = FormClose
LCLVersion = '0.9.31'
object edLog: TMemo
Left = 0
Height = 394
Top = 0
Width = 611
Align = alClient
ScrollBars = ssAutoBoth
TabOrder = 0
end
end

39
examples/fpdocmanager/flogview.pas Normal file
View File

@ -0,0 +1,39 @@
unit fLogView;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TLogView }
TLogView = class(TForm)
edLog: TMemo;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
private
{ private declarations }
public
{ public declarations }
end;
var
LogView: TLogView;
implementation
{$R *.lfm}
{ TLogView }
procedure TLogView.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
edLog.Clear;
CloseAction := caHide;
end;
end.

696
examples/fpdocmanager/fmain.lfm Normal file
View File

@ -0,0 +1,696 @@
object Main: TMain
Left = 373
Height = 290
Top = 146
Width = 411
Align = alClient
Caption = 'Main'
ClientHeight = 270
ClientWidth = 411
Menu = MainMenu1
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
OnResize = FormResize
LCLVersion = '0.9.31'
object lbPackages: TComboBox
Left = 0
Height = 270
Top = 0
Width = 94
Align = alLeft
ItemHeight = 15
OnSelect = lbPackagesClick
Style = csSimple
TabOrder = 0
end
object Units: TPageControl
Left = 94
Height = 270
Top = 0
Width = 317
ActivePage = TabSheet2
Align = alClient
TabIndex = 1
TabOrder = 1
object ViewXML: TTabSheet
Caption = 'Project'
ClientHeight = 242
ClientWidth = 309
inline edXML: TSynEdit
Left = 0
Height = 242
Top = 0
Width = 309
Align = alClient
Font.Height = -13
Font.Name = 'Courier New'
Font.Pitch = fpFixed
Font.Quality = fqNonAntialiased
ParentColor = False
ParentFont = False
TabOrder = 0
OnExit = edXMLExit
Gutter.Visible = False
Gutter.Width = 57
Gutter.MouseActions = <>
RightGutter.Width = 0
RightGutter.MouseActions = <>
Highlighter = SynXMLSyn1
Keystrokes = <
item
Command = ecUp
ShortCut = 38
end
item
Command = ecSelUp
ShortCut = 8230
end
item
Command = ecScrollUp
ShortCut = 16422
end
item
Command = ecDown
ShortCut = 40
end
item
Command = ecSelDown
ShortCut = 8232
end
item
Command = ecScrollDown
ShortCut = 16424
end
item
Command = ecLeft
ShortCut = 37
end
item
Command = ecSelLeft
ShortCut = 8229
end
item
Command = ecWordLeft
ShortCut = 16421
end
item
Command = ecSelWordLeft
ShortCut = 24613
end
item
Command = ecRight
ShortCut = 39
end
item
Command = ecSelRight
ShortCut = 8231
end
item
Command = ecWordRight
ShortCut = 16423
end
item
Command = ecSelWordRight
ShortCut = 24615
end
item
Command = ecPageDown
ShortCut = 34
end
item
Command = ecSelPageDown
ShortCut = 8226
end
item
Command = ecPageBottom
ShortCut = 16418
end
item
Command = ecSelPageBottom
ShortCut = 24610
end
item
Command = ecPageUp
ShortCut = 33
end
item
Command = ecSelPageUp
ShortCut = 8225
end
item
Command = ecPageTop
ShortCut = 16417
end
item
Command = ecSelPageTop
ShortCut = 24609
end
item
Command = ecLineStart
ShortCut = 36
end
item
Command = ecSelLineStart
ShortCut = 8228
end
item
Command = ecEditorTop
ShortCut = 16420
end
item
Command = ecSelEditorTop
ShortCut = 24612
end
item
Command = ecLineEnd
ShortCut = 35
end
item
Command = ecSelLineEnd
ShortCut = 8227
end
item
Command = ecEditorBottom
ShortCut = 16419
end
item
Command = ecSelEditorBottom
ShortCut = 24611
end
item
Command = ecToggleMode
ShortCut = 45
end
item
Command = ecCopy
ShortCut = 16429
end
item
Command = ecPaste
ShortCut = 8237
end
item
Command = ecDeleteChar
ShortCut = 46
end
item
Command = ecCut
ShortCut = 8238
end
item
Command = ecDeleteLastChar
ShortCut = 8
end
item
Command = ecDeleteLastChar
ShortCut = 8200
end
item
Command = ecDeleteLastWord
ShortCut = 16392
end
item
Command = ecUndo
ShortCut = 32776
end
item
Command = ecRedo
ShortCut = 40968
end
item
Command = ecLineBreak
ShortCut = 13
end
item
Command = ecSelectAll
ShortCut = 16449
end
item
Command = ecCopy
ShortCut = 16451
end
item
Command = ecBlockIndent
ShortCut = 24649
end
item
Command = ecLineBreak
ShortCut = 16461
end
item
Command = ecInsertLine
ShortCut = 16462
end
item
Command = ecDeleteWord
ShortCut = 16468
end
item
Command = ecBlockUnindent
ShortCut = 24661
end
item
Command = ecPaste
ShortCut = 16470
end
item
Command = ecCut
ShortCut = 16472
end
item
Command = ecDeleteLine
ShortCut = 16473
end
item
Command = ecDeleteEOL
ShortCut = 24665
end
item
Command = ecUndo
ShortCut = 16474
end
item
Command = ecRedo
ShortCut = 24666
end
item
Command = ecGotoMarker0
ShortCut = 16432
end
item
Command = ecGotoMarker1
ShortCut = 16433
end
item
Command = ecGotoMarker2
ShortCut = 16434
end
item
Command = ecGotoMarker3
ShortCut = 16435
end
item
Command = ecGotoMarker4
ShortCut = 16436
end
item
Command = ecGotoMarker5
ShortCut = 16437
end
item
Command = ecGotoMarker6
ShortCut = 16438
end
item
Command = ecGotoMarker7
ShortCut = 16439
end
item
Command = ecGotoMarker8
ShortCut = 16440
end
item
Command = ecGotoMarker9
ShortCut = 16441
end
item
Command = ecSetMarker0
ShortCut = 24624
end
item
Command = ecSetMarker1
ShortCut = 24625
end
item
Command = ecSetMarker2
ShortCut = 24626
end
item
Command = ecSetMarker3
ShortCut = 24627
end
item
Command = ecSetMarker4
ShortCut = 24628
end
item
Command = ecSetMarker5
ShortCut = 24629
end
item
Command = ecSetMarker6
ShortCut = 24630
end
item
Command = ecSetMarker7
ShortCut = 24631
end
item
Command = ecSetMarker8
ShortCut = 24632
end
item
Command = ecSetMarker9
ShortCut = 24633
end
item
Command = EcFoldLevel1
ShortCut = 41009
end
item
Command = EcFoldLevel2
ShortCut = 41010
end
item
Command = EcFoldLevel1
ShortCut = 41011
end
item
Command = EcFoldLevel1
ShortCut = 41012
end
item
Command = EcFoldLevel1
ShortCut = 41013
end
item
Command = EcFoldLevel6
ShortCut = 41014
end
item
Command = EcFoldLevel7
ShortCut = 41015
end
item
Command = EcFoldLevel8
ShortCut = 41016
end
item
Command = EcFoldLevel9
ShortCut = 41017
end
item
Command = EcFoldLevel0
ShortCut = 41008
end
item
Command = EcFoldCurrent
ShortCut = 41005
end
item
Command = EcUnFoldCurrent
ShortCut = 41003
end
item
Command = EcToggleMarkupWord
ShortCut = 32845
end
item
Command = ecNormalSelect
ShortCut = 24654
end
item
Command = ecColumnSelect
ShortCut = 24643
end
item
Command = ecLineSelect
ShortCut = 24652
end
item
Command = ecTab
ShortCut = 9
end
item
Command = ecShiftTab
ShortCut = 8201
end
item
Command = ecMatchBracket
ShortCut = 24642
end
item
Command = ecColSelUp
ShortCut = 40998
end
item
Command = ecColSelDown
ShortCut = 41000
end
item
Command = ecColSelLeft
ShortCut = 40997
end
item
Command = ecColSelRight
ShortCut = 40999
end
item
Command = ecColSelPageDown
ShortCut = 40994
end
item
Command = ecColSelPageBottom
ShortCut = 57378
end
item
Command = ecColSelPageUp
ShortCut = 40993
end
item
Command = ecColSelPageTop
ShortCut = 57377
end
item
Command = ecColSelLineStart
ShortCut = 40996
end
item
Command = ecColSelLineEnd
ShortCut = 40995
end
item
Command = ecColSelEditorTop
ShortCut = 57380
end
item
Command = ecColSelEditorBottom
ShortCut = 57379
end>
MouseActions = <>
MouseSelActions = <>
Lines.Strings = (
''
)
VisibleSpecialChars = [vscSpace, vscTabAtLast]
BracketHighlightStyle = sbhsBoth
inline SynLeftGutterPartList1: TSynGutterPartList
object SynGutterMarks1: TSynGutterMarks
Width = 24
MouseActions = <>
end
object SynGutterLineNumber1: TSynGutterLineNumber
Width = 17
MouseActions = <>
MarkupInfo.Background = clBtnFace
MarkupInfo.Foreground = clNone
DigitCount = 2
ShowOnlyLineNumbersMultiplesOf = 1
ZeroStart = False
LeadingZeros = False
end
object SynGutterChanges1: TSynGutterChanges
Width = 4
MouseActions = <>
ModifiedColor = 59900
SavedColor = clGreen
end
object SynGutterSeparator1: TSynGutterSeparator
Width = 2
MouseActions = <>
end
object SynGutterCodeFolding1: TSynGutterCodeFolding
MouseActions = <>
MarkupInfo.Background = clNone
MarkupInfo.Foreground = clGray
MouseActionsExpanded = <>
MouseActionsCollapsed = <>
end
end
end
end
object TabSheet2: TTabSheet
Caption = 'Units'
ClientHeight = 242
ClientWidth = 309
object lbUnits: TListBox
Left = 0
Height = 242
Top = 0
Width = 100
Align = alLeft
ItemHeight = 0
OnClick = lbUnitsClick
TabOrder = 0
end
object GroupBox1: TGroupBox
Left = 100
Height = 242
Top = 0
Width = 209
Align = alClient
Caption = 'Actions'
ClientHeight = 224
ClientWidth = 205
TabOrder = 1
object swAll: TRadioButton
Left = 10
Height = 19
Top = 10
Width = 32
Caption = 'all'
Checked = True
TabOrder = 0
TabStop = True
end
object swSingle: TRadioButton
Left = 48
Height = 19
Top = 10
Width = 43
Caption = 'only'
OnClick = swSingleClick
TabOrder = 1
end
object edUnit: TEdit
Left = 96
Height = 23
Top = 10
Width = 104
Anchors = [akTop, akLeft, akRight]
ReadOnly = True
TabOrder = 2
end
object buRefresh: TButton
Left = 10
Height = 25
Top = 40
Width = 188
Caption = 'Refresh'
OnClick = buRefreshClick
TabOrder = 3
end
object buSkel: TButton
Left = 20
Height = 25
Top = 72
Width = 104
Caption = 'Create Skeleton'
Enabled = False
TabOrder = 4
end
object buUpdate: TButton
Left = 132
Height = 25
Top = 72
Width = 54
Caption = 'Update'
Enabled = False
TabOrder = 5
end
object buShowLog: TButton
Left = 9
Height = 25
Top = 184
Width = 68
Caption = 'Show Log'
TabOrder = 6
end
object edLog: TEdit
Left = 87
Height = 23
Top = 184
Width = 111
Anchors = [akTop, akLeft, akRight]
OnChange = edLogChange
TabOrder = 7
end
object buTest: TButton
Left = 10
Height = 25
Top = 144
Width = 75
Caption = 'Test only'
OnClick = buTestClick
TabOrder = 8
end
object swShowUpdate: TCheckBox
Left = 10
Height = 19
Top = 104
Width = 90
Caption = 'Show Update'
OnChange = swShowUpdateChange
TabOrder = 9
end
end
end
end
object MainMenu1: TMainMenu
left = 10
top = 10
object MenuItem1: TMenuItem
Caption = '&File'
object mnConfig: TMenuItem
Caption = '&Config'
OnClick = mnConfigClick
end
object MenuItem3: TMenuItem
Caption = '-'
end
object mnExit: TMenuItem
Caption = 'E&xit'
OnClick = mnExitClick
end
end
object mnPackage: TMenuItem
Caption = 'P&ackage'
object mnImportLpk: TMenuItem
Caption = 'Import &LPK'
OnClick = mnImportLpkClick
end
end
end
object dlgSelRoot: TSelectDirectoryDialog
Title = 'Select Common Documentation Directory'
left = 16
top = 80
end
object SynXMLSyn1: TSynXMLSyn
DefaultFilter = 'XML Document (*.xml,*.xsd,*.xsl,*.xslt,*.dtd)|*.xml;*.xsd;*.xsl;*.xslt;*.dtd'
Enabled = False
ElementAttri.FrameEdges = sfeAround
AttributeAttri.FrameEdges = sfeAround
NamespaceAttributeAttri.FrameEdges = sfeAround
AttributeValueAttri.FrameEdges = sfeAround
NamespaceAttributeValueAttri.FrameEdges = sfeAround
TextAttri.FrameEdges = sfeAround
CDATAAttri.FrameEdges = sfeAround
EntityRefAttri.FrameEdges = sfeAround
ProcessingInstructionAttri.FrameEdges = sfeAround
CommentAttri.FrameEdges = sfeAround
DocTypeAttri.FrameEdges = sfeAround
SpaceAttri.FrameEdges = sfeAround
SymbolAttri.FrameEdges = sfeAround
WantBracesParsed = False
left = 24
top = 144
end
object dlgSelLpk: TOpenDialog
Title = 'Open Lazarus package file'
Filter = 'Lazarus Package|*.lpk'
Options = [ofFileMustExist, ofEnableSizing, ofViewDetail]
left = 16
top = 200
end
end

391
examples/fpdocmanager/fmain.pas Normal file
View File

@ -0,0 +1,391 @@
unit fMain;
(* Documentation manager GUI.
View/Edit configuration, packages
Add/Import packages
Create/Update skeletons
Create documentation (final, test)
*)
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, SynHighlighterXML, SynEdit, Forms,
Controls, Graphics, Dialogs, Menus, StdCtrls, ComCtrls,
uManager;
type
{ TMain }
TMain = class(TForm)
buSkel: TButton;
buUpdate: TButton;
buRefresh: TButton;
buShowLog: TButton;
buTest: TButton;
dlgSelLpk: TOpenDialog;
swShowUpdate: TCheckBox;
edLog: TEdit;
lbPackages: TComboBox;
edUnit: TEdit;
GroupBox1: TGroupBox;
lbUnits: TListBox;
MainMenu1: TMainMenu;
MenuItem1: TMenuItem;
mnImportLpk: TMenuItem;
mnPackage: TMenuItem;
mnConfig: TMenuItem;
MenuItem3: TMenuItem;
mnExit: TMenuItem;
dlgSelRoot: TSelectDirectoryDialog;
Units: TPageControl;
swAll: TRadioButton;
swSingle: TRadioButton;
edXML: TSynEdit;
SynXMLSyn1: TSynXMLSyn;
ViewXML: TTabSheet;
TabSheet2: TTabSheet;
procedure buRefreshClick(Sender: TObject);
procedure buTestClick(Sender: TObject);
procedure edLogChange(Sender: TObject);
procedure edXMLExit(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure lbPackagesClick(Sender: TObject);
procedure lbUnitsClick(Sender: TObject);
procedure mnConfigClick(Sender: TObject);
procedure mnExitClick(Sender: TObject);
procedure mnImportLpkClick(Sender: TObject);
procedure swShowUpdateChange(Sender: TObject);
procedure swSingleClick(Sender: TObject);
private
LogName: string;
LogFile: TStream;
procedure ProjectsChanged(Sender: TObject);
procedure LogToFile(Sender: TObject; const msg: string);
procedure LogToMsgBox(Sender: TObject; const msg: string);
procedure LogStart;
procedure LogDone;
procedure ShowUpdate;
procedure OnParseImport(Sender: TObject; var ASource, ALink: string);
public
CurPkg: TDocPackage;
CurUnit: string;
procedure UpdateDocs;
end;
var
Main: TMain;
implementation
uses
fConfig, fLogView, fUpdateView,
//dw_HTML, //more writers?
uLpk;
{$R *.lfm}
{ TMain }
procedure TMain.FormCreate(Sender: TObject);
var
r: TRect;
s: string;
l: TStringList;
begin
Manager := TFPDocManager.Create(self);
Manager.OnChange := @ProjectsChanged;
if not Manager.LoadConfig(GetCurrentDir) then begin
//query root directory
if not dlgSelRoot.Execute then
exit;
if not Manager.LoadConfig(dlgSelRoot.FileName, True) then begin
//InitConfig(dlgSelRoot.FileName); ?
mnConfigClick(self); //does an UpdateDocs
exit; //nothing to init from?
end;
end;
//init...
if Manager.Config.SectionExists('GUI') then begin
s := Manager.Config.ReadString('GUI', 'position', '');
if s <> '' then begin
l := TStringList.Create;
try
l.DelimitedText := s;
if l.Count = 4 then begin
//SetBounds(l[0], l[1], );
r.Left := StrToInt(l[0]);
r.Top := StrToInt(l[1]);
r.Right := StrToInt(l[2]);
r.Bottom:= StrToInt(l[3]);
BoundsRect := r;
end;
finally
l.Free;
end;
end;
end;
end;
procedure TMain.FormResize(Sender: TObject);
var
r: TRect;
begin
r := BoundsRect;
Manager.Config.WriteString('GUI', 'position', Format('%d,%d,%d,%d',[r.Left, r.Top, r.Right, r.Bottom]));
end;
// --------------- events ------------------
procedure TMain.FormCloseQuery(Sender: TObject; var CanClose: boolean);
begin
//is this really required?
//CanClose :=
Manager.SaveConfig; //what if fails?
end;
procedure TMain.mnExitClick(Sender: TObject);
begin
Close;
end;
procedure TMain.swShowUpdateChange(Sender: TObject);
begin
if swShowUpdate.Checked then
ShowUpdate;
end;
procedure TMain.edLogChange(Sender: TObject);
begin
LogName:=edLog.Text;
end;
procedure TMain.LogStart;
begin
if LogName = '' then
edLog.Text := Manager.RootDir + 'doclog.txt';
LogFile.Free;
LogFile := TFileStream.Create(LogName, fmCreate); //fmWrite
Manager.OnLog := @LogToFile;
//Manager.OnImport:=@OnParseImport;
end;
procedure TMain.LogDone;
begin
if not assigned(LogFile) then
exit;
FreeAndNil(LogFile);
Manager.OnLog := @LogToMsgBox;
//view messages
LogView.Caption := 'View ' + LogName;
LogView.edLog.Lines.LoadFromFile(LogName); //direct log???
LogView.Show;
end;
procedure TMain.ShowUpdate;
var
v: TUpdateView;
fn: string;
begin
if not swShowUpdate.Checked then
exit;
if lbUnits.ItemIndex < 0 then
exit;
fn := 'upd.' + edUnit.Text + '.xml';
if not FileExists(fn) then
exit;
//problem with files kept open???
if UpdateView = nil then
v := TUpdateView.Create(self)
else
v := UpdateView;
v.Caption := 'Update of ' + edUnit.Text;
v.edUpdate.Lines.LoadFromFile(fn);
v.Show;
end;
procedure TMain.LogToFile(Sender: TObject; const msg: string);
var
s: string;
begin
if assigned(LogFile) then begin
s := msg + LineEnding;
LogFile.WriteBuffer(s[1], Length(s))
end
else
LogToMsgBox(Sender, msg);
end;
procedure TMain.LogToMsgBox(Sender: TObject; const msg: string);
begin
ShowMessage(msg);
end;
procedure TMain.OnParseImport(Sender: TObject; var ASource, ALink: string);
var
i: integer;
pn: string;
begin
(* Provide ASource-->content file, ALink depends on format.
ASource can be a package name (only), or a CSV spec.
Sender is Manager.
An extended model could store a list of required packages,
and provide the list of imports.
*)
i := Pos(',', ASource);
if i > 0 then
exit; //default format, handled by caller
pn := ExtractFileNameOnly(ASource);
ASource := Manager.RootDir + pn + '.xct';
//if Manager.Options.??? - where's the output format?
ALink := '../' + pn + '/';
end;
procedure TMain.ProjectsChanged(Sender: TObject);
begin
UpdateDocs; //immediately or delayed (OnIdle?)
end;
procedure TMain.UpdateDocs;
var
i: integer;
begin
lbPackages.Clear;
for i := 0 to Manager.Projects.Count - 1 do begin
lbPackages.AddItem(Manager.Projects.Names[i], Manager.Projects.Objects[i]);
end;
end;
procedure TMain.mnConfigClick(Sender: TObject);
begin
Manager.BeginUpdate;
if CfgWizard.ShowModal <> mrCancel then begin
//UpdateDocs; - by Manager!?
//Manager.Config.;
end;
Manager.EndUpdate;
end;
// ---------------- pages ------------------
procedure TMain.lbPackagesClick(Sender: TObject);
var
i: integer;
pkg: TDocPackage;
fn: string;
begin
i := lbPackages.ItemIndex; //clicked?
pkg := lbPackages.Items.Objects[i] as TDocPackage;
if pkg = nil then
exit; //not really created?
fn := pkg.ProjectFile; //initialized where?
if fn <> '' then
edXML.Lines.LoadFromFile(fn);
//load units...
lbUnits.Items.BeginUpdate;
lbUnits.Clear;
for i := 0 to pkg.Units.Count - 1 do begin
//fn := Manager.UnitName(pkg.Inputs, i);
fn := pkg.Units.Names[i];
lbUnits.AddItem(fn, nil);
end;
lbUnits.Sorted := True;
lbUnits.Items.EndUpdate;
//remember selection
CurPkg := pkg;
CurUnit:='';
end;
procedure TMain.mnImportLpkClick(Sender: TObject);
var
pkName, pkPrj: string;
begin
if not dlgSelLpk.Execute then
exit;
pkName:=dlgSelLpk.FileName;
Manager.ImportLpk(pkName);
{
Manager.BeginUpdate;
try
if not uLpk.ImportLpk(pkName) then begin
LogToMsgBox(self, 'Import failed on ' + pkName);
exit;
end;
//create project file - preprocess options!?
pkPrj:=ChangeFileExt(pkName, '.xml');
Manager.CreateProject(pkPrj, Manager.SelectedPackage);
finally
Manager.EndUpdate; //not modified???
end;
//
}
end;
procedure TMain.edXMLExit(Sender: TObject);
begin
if edXML.Modified then begin
case MessageDlg('Project was changed', 'Save changes?',
mtConfirmation, mbYesNoCancel, 0) of
mrYes: edXML.Lines.SaveToFile(CurPkg.ProjectFile);
mrNo: exit;
else
edXML.SetFocus;
end;
end;
end;
// ------------------- actions ----------------------
procedure TMain.lbUnitsClick(Sender: TObject);
var
i: integer;
begin
i := lbUnits.ItemIndex;
if i < 0 then
CurUnit := ''
else
CurUnit := lbUnits.Items[i];
edUnit.Text := CurUnit; //further depends on swSingle
swSingle.Checked := True; //assume test single unit
ShowUpdate;
end;
procedure TMain.swSingleClick(Sender: TObject);
begin
edUnit.Enabled := swSingle.Checked;
end;
(* FPDoc dry run, with logfile
*)
procedure TMain.buTestClick(Sender: TObject);
var
u: string;
begin
LogStart;
if swSingle.Checked then
u := CurUnit
else
u := '';
Manager.TestRun(CurPkg, u);
LogDone;
end;
procedure TMain.buRefreshClick(Sender: TObject);
var
u: string;
begin
LogStart;
if swSingle.Checked then
u := CurUnit
else
u := '';
Manager.Update(CurPkg, u);
LogDone;
end;
end.

108
examples/fpdocmanager/fpdocengine.lpk Normal file
View File

@ -0,0 +1,108 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="FPDocEngine"/>
<Author Value="DoDi"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="FPDoc tools as a package."/>
<Version Major="1"/>
<Files Count="18">
<Item1>
<Filename Value="dglobals.pp"/>
<UnitName Value="dGlobals"/>
</Item1>
<Item2>
<Filename Value="dwlinear.pp"/>
<UnitName Value="dwlinear"/>
</Item2>
<Item3>
<Filename Value="dwriter.pp"/>
<UnitName Value="dWriter"/>
</Item3>
<Item4>
<Filename Value="dw_dxml.pp"/>
<UnitName Value="dw_dXML"/>
</Item4>
<Item5>
<Filename Value="dw_html.pp"/>
<UnitName Value="dw_HTML"/>
</Item5>
<Item6>
<Filename Value="dw_htmlchm.inc"/>
<Type Value="Include"/>
</Item6>
<Item7>
<Filename Value="dw_ipflin.pas"/>
<UnitName Value="dw_ipflin"/>
</Item7>
<Item8>
<Filename Value="dw_latex.pp"/>
<UnitName Value="dw_LaTeX"/>
</Item8>
<Item9>
<Filename Value="dw_linrtf.pp"/>
<UnitName Value="dw_LinRTF"/>
</Item9>
<Item10>
<Filename Value="dw_lintmpl.pp"/>
<UnitName Value="dw_lintmpl"/>
</Item10>
<Item11>
<Filename Value="dw_man.pp"/>
<UnitName Value="dw_man"/>
</Item11>
<Item12>
<Filename Value="dw_txt.pp"/>
<UnitName Value="dw_txt"/>
</Item12>
<Item13>
<Filename Value="dw_xml.pp"/>
<UnitName Value="dw_XML"/>
</Item13>
<Item14>
<Filename Value="fpdocproj.pas"/>
<UnitName Value="fpdocproj"/>
</Item14>
<Item15>
<Filename Value="fpdocxmlopts.pas"/>
<UnitName Value="fpdocxmlopts"/>
</Item15>
<Item16>
<Filename Value="mgrfpdocproj.pp"/>
<UnitName Value="mgrfpdocproj"/>
</Item16>
<Item17>
<Filename Value="mkfpdoc.pp"/>
<UnitName Value="mkfpdoc"/>
</Item17>
<Item18>
<Filename Value="sh_pas.pp"/>
<UnitName Value="sh_pas"/>
</Item18>
</Files>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="FCL"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

19
examples/fpdocmanager/fupdateview.lfm Normal file
View File

@ -0,0 +1,19 @@
object UpdateView: TUpdateView
Left = 369
Height = 273
Top = 480
Width = 421
Caption = 'UpdateView'
ClientHeight = 273
ClientWidth = 421
LCLVersion = '0.9.31'
object edUpdate: TMemo
Left = 0
Height = 273
Top = 0
Width = 421
Align = alClient
ScrollBars = ssAutoBoth
TabOrder = 0
end
end

30
examples/fpdocmanager/fupdateview.pas Normal file
View File

@ -0,0 +1,30 @@
unit fUpdateView;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TUpdateView }
TUpdateView = class(TForm)
edUpdate: TMemo;
private
{ private declarations }
public
{ public declarations }
end;
var
UpdateView: TUpdateView;
implementation
{$R *.lfm}
end.

57
examples/fpdocmanager/ucmdline.pas Normal file
View File

@ -0,0 +1,57 @@
unit uCmdLine;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
function CmdToPrj(const AFileName: string): boolean;
implementation
uses
uManager, umakeskel;
(* Create an project file from an FPDoc commandline
*)
function CmdToPrj(const AFileName: string): boolean;
var
lst: TStringList;
l, w: string;
prj: TFPDocMaker;
begin
(* Need a temporary project, that only includes the given files etc.
*)
Result := False; //in case of errors
lst := TStringList.Create;
prj := TFPDocMaker.Create(nil);
//prj.OnLog := @prj.LogToStdOut; -->ShowMsg???
try
lst.LoadFromFile(AFileName);
l := lst[0];
w := GetNextWord(l);
if w <> 'fpdoc' then
exit; //expected fpdoc command
while l <> '' do begin
w := GetNextWord(l);
prj.ParseFPDocOption(w);
end;
w := prj.SelectedPackage.Name;
if w = '' then
exit; //no project name???
l := ChangeFileExt(AFileName, '_prj.xml'); //same directory!!!
Result := prj.CreateProject(l, prj.SelectedPackage);
//now load the project into the manager
if Result then
//add package/project to the manager
Manager.AddProject(w, l, True); //.Packages.Add(w + '=' + l);
finally
prj.Free;
lst.Free;
end;
end;
end.

145
examples/fpdocmanager/ulpk.pp Normal file
View File

@ -0,0 +1,145 @@
unit uLpk;
(* Convert LPK package into FPDoc project/package.
Relevant entries:
<Name Value="LCLBase"/> //here: rename into LCL
<IncludeFiles Value="..."/> //-Fi
<OtherUnitFiles Value="forms;widgetset"/> //-Fu
<CustomOptions Value="$(IDEBuildOptions)"/> ???
<Files Count="291"> //Item1..Item291
<Filename Value="...pas"/> //ignore .inc etc.
<LazDoc Paths="../docs/xml/lcl"/>
<RequiredPkgs Count="1">
<PackageName Value="LazUtils"/> //required
*)
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
uManager;
//function ImportLpk(const AFile: string): boolean;
function ImportLpk(const AFile: string): TDocPackage;
implementation
//uses
type
eKey = (kvEof, kvName, kvIncl, kvOther, kvFilename, kvDocPaths, kvReq
);
const
aKey: array[eKey] of string = (
'', 'Name', 'IncludeFiles', 'OtherUnitFiles',
'Filename', 'LazDoc' ,'PackageName'
);
FirstKeys = 'NIOFLP';
var
f: TextFile;
ln, value, ext: string;
lt, eq, q2: integer;
key: eKey;
function ImportCompiled(const LpkFile: string): boolean;
var
mfc: string;
f: TextFile;
begin
mfc := ExtractFilePath(LpkFile) + 'Makefile.compiled';
Result := FileExists(mfc);
if not Result then
exit;
//import Makefile.compiled
AssignFile(f, mfc);
Reset(f);
try
//parse
ReadLn(f, ln);
//todo...
finally
CloseFile(f);
end;
end;
function GetLine: boolean;
var
i: integer;
begin
while not EOF(f) do begin
ReadLn(f, ln);
//get key
lt := Pos('<', ln);
if lt <= 0 then
continue;
//filter key
i := Pos(ln[lt+1], FirstKeys);
if i < 1 then
continue;
key := eKey(i);
if Copy(ln, lt+1, Length(aKey[key])) <> aKey[key] then
continue;
//check value
eq := Pos('=', ln);
if (eq <= lt) or (ln[eq+1] <> '"') then
continue;
q2 := Length(ln) - 2;
if ln[q2] <> '"' then
continue;
value:=Copy(ln, eq+2, q2-eq-2);
exit(True);
end;
Result := False;
end;
function ImportLpk(const AFile: string): TDocPackage;
var
pkg: TDocPackage;
begin
Result := Nil; // False; //assume fail
AssignFile(f, AFile);
Reset(f);
try
//read lines
//get Name
if not GetLine or (key <> kvName) then
exit; //missing package name
//fix case and LCLBase
value := LowerCase(value);
if value = 'lclbase' then
value := 'lcl';
pkg := Manager.AddPackage(value);
pkg.LazPkg := AFile;
//Manager.Package := pkg; //!DocPkg
//remaining keys
while GetLine do begin
case key of
kvName: ; //ignore any but first occurence
kvIncl: pkg.IncludePath:=value;
kvOther: pkg.UnitPath := value;
kvFilename:
begin
ext := ExtractFileExt(value);
if (ext = '.pas') or (ext = '.pp') then
pkg.Units.Add(value); //!!! no dupes!?
end;
kvDocPaths: pkg.DescrDir := value;
kvReq: pkg.Requires.Add(LowerCase(value));
{
begin
ext := Manager.RootDir + '/' + value + ',../' + value;
pkg.Imports.Add(ext);
end;
}
end;
end;
Result := pkg; // True;
finally
CloseFile(f);
end;
end;
end.

1176
examples/fpdocmanager/umakeskel.pas Normal file
View File

File diff suppressed because it is too large Load Diff

694
examples/fpdocmanager/umanager.pas Normal file
View File

@ -0,0 +1,694 @@
unit uManager;
(* Manager object for FPDoc GUI, by DoDi
Holds configuration and packages.
Packages (shall) contain extended descriptions for:
- default OSTarget (FPCDocs: Unix/Linux)
- inputs: by OSTarget
- directories: project(file), InputDir, DescrDir[by language?]
- FPCVersion, LazVersion: variations of inputs
- Skeleton and Output options, depending on DocType/Level and Format.
Units can be described in multiple XML docs, so that it's possible to
have specific parts depending on Laz/FPC version, OSTarget, Language, Widgetset.
Since the package (collection item) class is hardwired in the Packages collection,
a variable PackageClass has been introduced in FPDocProj.
*)
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, IniFiles,
umakeskel, fpdocproj, dw_HTML;
type
{ TDocPackage }
(* TDocPackage describes a package documentation project.
*)
TDocPackage = class(TComponent) // (TFPDocPackage)
private
FDescrDir: string;
FDocPkg: TFPDocPackage;
FIncludePath: string;
FInputDir: string;
FLazPkg: string;
FName: string;
FProjectFile: string;
FRequires: TStrings;
FUnitPath: string;
FUnits: TStrings;
procedure SetDescrDir(AValue: string);
procedure SetDocPkg(AValue: TFPDocPackage);
procedure SetIncludePath(AValue: string);
procedure SetInputDir(AValue: string);
procedure SetLazPkg(AValue: string);
procedure SetName(AValue: string);
procedure SetProjectFile(AValue: string);
procedure SetRequires(AValue: TStrings);
procedure SetUnitPath(AValue: string);
procedure SetUnits(AValue: TStrings);
protected
FPackage: TFPDocPackage;
procedure ReadConfig(cf: TIniFile);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function CreateProject: TFPDocPackage;
procedure UpdateConfig(cf: TIniFile; APkg: TFPDocPackage);
property Name: string read FName write SetName;
property DocPkg: TFPDocPackage read FDocPkg write SetDocPkg;
property ProjectFile: string read FProjectFile write SetProjectFile; //xml?
//from LazPkg
property LazPkg: string read FLazPkg write SetLazPkg; //LPK name?
property DescrDir: string read FDescrDir write SetDescrDir;
property InputDir: string read FInputDir write SetInputDir;
property Units: TStrings read FUnits write SetUnits;
property Requires: TStrings read FRequires write SetRequires; //only string?
property IncludePath: string read FIncludePath write SetIncludePath; //-Fi
property UnitPath: string read FUnitPath write SetUnitPath; //-Fu
//property DefOS: string; - variations!
end;
{ TFPDocManager }
(* Holds configuration, projects and packages.
Projects[] effectively represents packages.
*)
TFPDocManager = class(TFPDocMaker)
private
FDirty: boolean;
FFPDocDir: string;
FLazarusDir: string;
FModified: boolean;
FOnChange: TNotifyEvent;
FProjects: TStrings;
FRootDir: string;
UpdateCount: integer;
procedure SetFPDocDir(AValue: string);
procedure SetLazarusDir(AValue: string);
procedure SetOnChange(AValue: TNotifyEvent);
procedure SetRootDir(AValue: string);
protected
InputList, DescrList: TStringList;
procedure Changed;
function BeginTest(APkg: TDocPackage): boolean;
procedure EndTest;
public
Config: TIniFile;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure BeginUpdate;
procedure EndUpdate;
function LoadConfig(const ADir: string; Force: boolean = False): boolean;
function SaveConfig: boolean;
function AddProject(const APkg, AFile: string; UpdateCfg: boolean): boolean; //from config
{$IFDEF v0}
function CreateProject(const AFileName: string; APackage: TFPDocPackage): boolean;
{$ELSE}
//function CreateProject(const AFileName: string; APackage: TFPDocPackage): boolean;
{$ENDIF}
function AddPackage(AName: string): TDocPackage;
function ImportLpk(const AName: string): TDocPackage;
//actions
//function MakeDoc(APkg: TDocPackage; AUnit: string): boolean; configure???
function TestRun(APkg: TDocPackage; AUnit: string): boolean;
function Update(APkg: TDocPackage; const AUnit: string): boolean;
procedure CleanXML(const FileName: string);
public //published?
property FpcDocDir: string read FFPDocDir write SetFPDocDir;
property LazarusDir: string read FLazarusDir write SetLazarusDir;
property RootDir: string read FRootDir write SetRootDir;
//property Packages: TStrings read FPackages;
property Projects: TStrings read FProjects;
property Dirty: boolean read FDirty; //inifile
property Modified: boolean read FModified; //app
property OnChange: TNotifyEvent read FOnChange write SetOnChange;
end;
var
Manager: TFPDocManager = nil; //init by application
implementation
uses
uLpk;
const
ConfigName = 'docmgr.ini';
SecProjects = 'projects';
{ TDocPackage }
procedure TDocPackage.SetDescrDir(AValue: string);
begin
if FDescrDir=AValue then Exit;
FDescrDir:=AValue;
end;
(* Init from package
*)
procedure TDocPackage.SetDocPkg(AValue: TFPDocPackage);
var
s: string;
begin
if FDocPkg=AValue then Exit;
FDocPkg:=AValue;
//init using Manager
Manager.Package := DocPkg;
FDescrDir := Manager.DescrDir;
FInputDir := Manager.InputDir;
end;
procedure TDocPackage.SetIncludePath(AValue: string);
begin
if FIncludePath=AValue then Exit;
FIncludePath:=AValue;
end;
procedure TDocPackage.SetInputDir(AValue: string);
begin
if FInputDir=AValue then Exit;
FInputDir:=AValue;
end;
procedure TDocPackage.SetLazPkg(AValue: string);
begin
if FLazPkg=AValue then Exit;
FLazPkg:=AValue;
//todo: import
end;
procedure TDocPackage.SetName(AValue: string);
begin
if FName=AValue then Exit;
FName:=AValue;
end;
procedure TDocPackage.SetProjectFile(AValue: string);
begin
if FProjectFile=AValue then Exit;
FProjectFile:=AValue;
//todo: import?
//FDocPkg; - must be created IN Manager
end;
procedure TDocPackage.SetRequires(AValue: TStrings);
begin
if FRequires=AValue then Exit;
FRequires:=AValue;
end;
procedure TDocPackage.SetUnitPath(AValue: string);
begin
if FUnitPath=AValue then Exit;
FUnitPath:=AValue;
end;
procedure TDocPackage.SetUnits(AValue: TStrings);
begin
if FUnits=AValue then Exit;
FUnits:=AValue;
end;
procedure TDocPackage.ReadConfig(cf: TIniFile);
begin
//FProjectFile := cf.ReadString(Name, 'projectfile', '');
FDescrDir := cf.ReadString(Name, 'descrdir', '');
FInputDir := cf.ReadString(Name, 'inputdir', '');
//more?
end;
constructor TDocPackage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FUnits := TStringList.Create;
FRequires := TStringList.Create;
end;
destructor TDocPackage.Destroy;
begin
FreeAndNil(FUnits);
FreeAndNil(FRequires);
inherited Destroy;
end;
(* Create new(?) package and project.
*)
function TDocPackage.CreateProject: TFPDocPackage;
var
s, imp: string;
pkg: TFPDocPackage;
i: integer;
begin
//get the package
Result := DocPkg;
if Result <> nil then
exit; //for now, implement update later
//create new pkg
Result := Manager.Packages.FindPackage(Name);
if Result = nil then begin
//create pkg
Manager.Package := nil; //!!!nothing selected!!!
Manager.ParseFPDocOption('--package=' + Name); //selects or creates the pkg
pkg := Manager.SelectedPackage;
//add Inputs
if pkg.Inputs.Count = 0 then begin //else pkg exists already?
//if Units.Count = 0 then ???; --input-dir?
//todo: common options? OS options?
for i := 0 to Units.Count - 1 do begin
pkg.Inputs.Add(Units.ValueFromIndex[i]);
end;
end;
//add Descriptions
if pkg.Descriptions.Count = 0 then begin
if DescrDir <> '' then begin
//first check for existing directory
if not DirectoryExists(DescrDir) then begin
MkDir(DescrDir); //exclude \?
end else begin
Manager.ParseFPDocOption('--descr-dir=' + DescrDir);
end;
end;
end;
//add Imports
if (pkg.Imports.Count = 0) then begin
for i := 0 to Requires.Count - 1 do begin
s := Requires[i];
imp := Manager.RootDir + s + '.xct,../' + s + '/';
Manager.ParseFPDocOption('--import=' + imp);
end;
end;
//add options
pkg.Output := Manager.RootDir + Name;
pkg.ContentFile := Manager.RootDir + Name + '.xct';
//upate result when reached this
Result := pkg;
end;
DocPkg := Result;
//create project file?
if (ProjectFile = '') and (LazPkg <> '') then begin
s := ChangeFileExt(LazPkg, '.xml');
if Manager.CreateProject(s, DocPkg) then
ProjectFile := s;
//let manager register?
end;
end;
(* Initialize the package, write global config (+local?)
*)
procedure TDocPackage.UpdateConfig(cf: TIniFile; APkg: TFPDocPackage);
begin
//to come?
end;
{ TFPDocManager }
constructor TFPDocManager.Create(AOwner: TComponent);
begin
//PackageClass:=TDocPackage; //extended package class
FProjects := TStringList.Create;
InputList := TStringList.Create;
DescrList := TStringList.Create;
inherited Create(AOwner);
end;
destructor TFPDocManager.Destroy;
begin
FreeAndNil(Config); //save?
FreeAndNil(FProjects);
FreeAndNil(InputList);
FreeAndNil(DescrList);
inherited Destroy;
end;
procedure TFPDocManager.SetFPDocDir(AValue: string);
begin
if FFPDocDir=AValue then Exit;
FFPDocDir:=AValue;
FDirty := True;
end;
procedure TFPDocManager.SetLazarusDir(AValue: string);
begin
if FLazarusDir=AValue then Exit;
FLazarusDir:=AValue;
FDirty := True;
end;
procedure TFPDocManager.SetOnChange(AValue: TNotifyEvent);
begin
if FOnChange=AValue then Exit;
FOnChange:=AValue;
end;
(* Try load config from new dir - this may fail on the first run.
*)
procedure TFPDocManager.SetRootDir(AValue: string);
var
s: string;
begin
s := IncludeTrailingPathDelimiter(AValue);
if FRootDir=s then Exit; //prevent recursion
FRootDir:=s;
//load config?
//LoadConfig(s, False);
FDirty := True;
end;
procedure TFPDocManager.Changed;
begin
if not Modified or (UpdateCount > 0) then
exit; //should not be called directly
FModified := False;
if Assigned(OnChange) then
FOnChange(self);
end;
procedure TFPDocManager.BeginUpdate;
begin
inc(UpdateCount);
end;
procedure TFPDocManager.EndUpdate;
begin
dec(UpdateCount);
if UpdateCount <= 0 then begin
UpdateCount := 0;
if Modified then
Changed;
end;
end;
(* Try load config.
Init RootDir (only when config found?)
*)
function TFPDocManager.LoadConfig(const ADir: string; Force: boolean): boolean;
var
s, pf, cf: string;
i: integer;
pkg: TDocPackage;
begin
s := IncludeTrailingPathDelimiter(ADir);
cf := s + ConfigName;
Result := FileExists(cf);
if not Result and not Force then
exit;
RootDir:=s; //recurse if RootDir changed
//sanity check: only one config file!
if assigned(Config) then begin
if (Config.FileName = cf) then
exit(false) //nothing new?
else
Config.Free;
//clear packages???
end;
Config := TIniFile.Create(cf);
FDirty := True; //to be saved
if not Result then
exit; //nothing to read
//read directories
FFPDocDir := Config.ReadString('dirs', 'fpc', '');
//read packages
Config.ReadSectionValues(SecProjects, Projects); //<prj>=<file>
//read detailed package information - possibly multiple packages per project!
BeginUpdate; //turn of app notification!
for i := 0 to Projects.Count - 1 do begin
//read package config (=project file name?)
s := Projects.Names[i];
pf := Projects.ValueFromIndex[i];
if pf <> '' then begin
AddProject(s, pf, False); //add and load project file, don't update config!
FModified := True; //force app notification
end;
end;
//more? (preferences?)
//done, nothing modified
EndUpdate;
FDirty := False;
end;
function TFPDocManager.SaveConfig: boolean;
begin
if Dirty then begin
Config.UpdateFile;
FDirty := False;
end;
Result := not Dirty;
end;
(* Load FPDoc (XML) project file.
Not Dirty when loaded from INI!
*)
function TFPDocManager.AddProject(const APkg, AFile: string; UpdateCfg: boolean): boolean;
var
i, j, ipkg: integer;
pn, s: string;
pkg: TDocPackage;
fpkg: TFPDocPackage;
begin
{$IFDEF v0}
//load the project
LoadProjectFile(AFile); //override for init project/packages?
//update contained packages
for i := 0 to Packages.Count - 1 do begin
pkg := Packages[i] as TDocPackage;
if pkg.ProjectFile = '' then
pkg.ProjectFile := AFile;
end;
Config.WriteString(SecProjects, APkg, AFile); //unique entry!?
FModified := true;
FDirty:=true;
{$ELSE}
//load the project
LoadProjectFile(AFile); //override for init project/packages?
//update contained packages
for i := 0 to Packages.Count - 1 do begin
Package := Packages[i];
pkg := AddPackage(Package.Name);
if pkg.ProjectFile = '' then begin
pkg.ProjectFile := AFile;
pkg.DocPkg := Package;
//init Units
for j := 0 to Package.Inputs.Count - 1 do begin
s := UnitName(Package.Inputs, j);
pkg.Units.Add(s + '=' + Package.Inputs[j]);
//strip OS -Fi?
end;
//init imports
for j := 0 to Package.Imports.Count - 1 do begin
//s := Package.Imports[j];
s := ImportName(j);
//package reference?
pkg.Requires.AddObject(s, AddPackage(s));
end;
if UpdateCfg then begin //update config?
Config.WriteString(SecProjects, pkg.Name, AFile);
FModified := true;
FDirty:=true;
end;
end;
end;
{$ENDIF}
//notify app?
Changed;
end;
{$IFDEF v0}
(* Creates an FPDoc project file, adds the project to Projects[]
*)
function TFPDocManager.CreateProject(const AFileName: string;
APackage: TFPDocPackage): boolean;
var
APkg: TDocPackage absolute APackage;
begin
Result:=inherited CreateProject(AFileName, APackage);
if not Result then
exit;
if APkg.ProjectFile = AFileName then
exit; //already done
APkg.ProjectFile := AFileName;
Config.WriteString(SecProjects, APackage.Name, AFileName); //unique entry!?
FDirty:=true;
FModified:=true;
Changed;
end;
{$ELSE}
{$ENDIF}
(* Return the named package, create if not found.
Rename: GetPackage?
*)
function TFPDocManager.AddPackage(AName: string): TDocPackage;
var
i: integer;
begin
AName := LowerCase(AName);
{$IFDEF v0}
Result := Packages.FindPackage(AName) as TDocPackage;
if assigned(Result) then
exit;
//create new package
Result := Packages.Add as TDocPackage;
Result.Name := AName;
fDirty := True;
fModified := True;
Changed;
{$ELSE}
i := FProjects.IndexOfName(AName);
if i < 0 then
i := FProjects.Add(AName); //create new entry
Result := FProjects.Objects[i] as TDocPackage;
if Result = nil then begin
Result := TDocPackage.Create(self);
Result.Name := AName;
FProjects.Objects[i] := Result; //add object
end;
{$ENDIF}
end;
function TFPDocManager.ImportLpk(const AName: string): TDocPackage;
begin
BeginUpdate;
//import the LPK file into
Result := uLpk.ImportLpk(AName);
if Result = nil then
DoLog('Import failed on ' + AName)
else begin
if Result.CreateProject <> nil then begin //create new(?) package project
Config.WriteString(SecProjects, Result.Name, Result.ProjectFile);
FDirty := True;
end;
FModified := True; //always?
Changed;
end;
EndUpdate;
end;
function TFPDocManager.BeginTest(APkg: TDocPackage): boolean;
var
pf, dir: string;
begin
if not assigned(APkg) then
exit(False);
pf := APkg.ProjectFile;
if pf = '' then
exit(False);
Package := APkg.DocPkg;
dir := ExtractFileDir(pf);
SetCurrentDir(dir);
ParseFPDocOption('--project='+APkg.ProjectFile);
//okay, so far
Result := True;
end;
procedure TFPDocManager.EndTest;
begin
SetCurrentDir(ExtractFileDir(RootDir));
end;
function TFPDocManager.TestRun(APkg: TDocPackage; AUnit: string): boolean;
var
pf, dir: string;
begin
(* more detailed error handling?
Must CD to the project file directory!?
*)
Result := BeginTest(APkg);
if not Result then
exit;
ParseFPDocOption('--format=html');
ParseFPDocOption('-n');
{$IFDEF v0}
if AUnit <> '' then begin
InputList.Clear;
InputList.Add(Maker.UnitSpec(AUnit));
DescrList.Clear;
DescrList.Add(APkg.DescrDir + AUnit+'.xml');
CreateUnitDocumentation(APkg, InputList, DescrList, True);
end else begin
CreateDocumentation(APkg,True);
end;
{$ELSE}
CreateUnitDocumentation(APkg.DocPkg, AUnit, True);
{$ENDIF}
EndTest;
end;
(* MakeSkel functionality - create skeleton or update file
*)
function TFPDocManager.Update(APkg: TDocPackage; const AUnit: string): boolean;
function DocumentUnit(const AUnit: string): boolean;
var
OutName, msg: string;
begin
InputList.Clear;
InputList.Add(UnitSpec(AUnit));
DescrList.Clear;
OutName := DescrDir + AUnit + '.xml';
Options.UpdateMode := FileExists(OutName);
if Options.UpdateMode then begin
DescrList.Add(APkg.DescrDir + AUnit + '.xml');
OutName:=RootDir + 'upd.' + AUnit + '.xml';
DoLog('Update ' + OutName);
end else begin
DoLog('Create ' + OutName);
end;
msg := DocumentPackage(APkg.Name, OutName, InputList, DescrList);
Result := msg = '';
if not Result then
DoLog(msg) //+unit?
else if Options.UpdateMode then begin
CleanXML(OutName);
end;
end;
var
i: integer;
u: string;
begin
Result := BeginTest(APkg);
if not Result then
exit;
if AUnit <> '' then begin
Result := DocumentUnit(AUnit);
end else begin
for i := 0 to Package.Inputs.Count - 1 do begin
u := UnitName(Package.Inputs, i);
DocumentUnit(u);
end;
end;
EndTest;
end;
(* Kill file if no "<element" found
*)
procedure TFPDocManager.CleanXML(const FileName: string);
var
f: TextFile;
s: string;
begin
AssignFile(f, FileName);
Reset(f);
try
while not EOF(f) do begin
ReadLn(f, s);
if Pos('<element ', s) > 0 then
exit; //file not empty
end;
finally
CloseFile(f);
end;
//nothing found, delete the file
if DeleteFile(FileName) then
DoLog('File ' + FileName + ' has no elements. Deleted.')
else
DoLog('File ' + FileName + ' has no elements. Delete failed.');
end;
end.