pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

systools: Add code pattern and text data units (plus demos)

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6147 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-01-17 18:44:39 +00:00
parent 36b42951dd
commit 133a3b98d7
35 changed files with 6060 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

83
components/systools/examples/data_merge/datamerg.lpi Normal file
View File

@ -0,0 +1,83 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<Flags>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="datamerg"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="datamerg.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="DataMerg"/>
</Unit0>
<Unit1>
<Filename Value="datamrg0.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="datamerg"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

46
components/systools/examples/data_merge/datamerg.lpr Normal file
View File

@ -0,0 +1,46 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program DataMerg;
uses
Interfaces,
Forms, lclversion,
datamrg0 in 'datamrg0.pas' {Form1};
{$R *.res}
begin
{$IFDEF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

331
components/systools/examples/data_merge/datamrg0.lfm Normal file
View File

@ -0,0 +1,331 @@
object Form1: TForm1
Left = 241
Height = 601
Top = 131
Width = 854
Caption = 'Data Merge Example'
ClientHeight = 601
ClientWidth = 854
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
OnDestroy = FormDestroy
LCLVersion = '1.9.0.0'
object Splitter1: TSplitter
Cursor = crVSplit
Left = 0
Height = 3
Top = 408
Width = 854
Align = alBottom
ResizeAnchor = akBottom
end
object Splitter2: TSplitter
Left = 185
Height = 408
Top = 0
Width = 5
end
object Panel1: TPanel
AnchorSideTop.Side = asrCenter
Left = 0
Height = 38
Top = 563
Width = 854
Align = alBottom
ClientHeight = 38
ClientWidth = 854
TabOrder = 0
object Button1: TButton
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 5
Height = 25
Top = 7
Width = 108
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Open Template'
OnClick = Button1Click
TabOrder = 0
end
object Button2: TButton
AnchorSideLeft.Control = Button5
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 224
Height = 25
Top = 7
Width = 98
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Load Data Set'
OnClick = Button2Click
TabOrder = 2
end
object Button3: TButton
AnchorSideLeft.Control = Button6
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 431
Height = 25
Top = 7
Width = 60
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Merge'
OnClick = Button3Click
TabOrder = 4
end
object Panel5: TPanel
Left = 696
Height = 36
Top = 1
Width = 157
Align = alRight
ClientHeight = 36
ClientWidth = 157
TabOrder = 6
object SpeedButton1: TSpeedButton
AnchorSideTop.Control = Panel5
AnchorSideTop.Side = asrCenter
Left = 13
Height = 22
Top = 7
Width = 23
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
0400000000000001000000000000000000001000000010000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
33333333333333333333EEEEEEEEEEEEEEE333FFFFFFFFFFFFF3E00000000000
00E337777777777777F3E0F77777777770E337F33333333337F3E0F333333333
70E337F33333333337F3E0F33333333370E337F3333F3FF337F3E0F333030033
70E337F3337F77F337F3E0F33003003370E337F3377F77F337F3E0F300030033
70E337F3777F77F337F3E0F33003003370E337F3377F77F337F3E0F333030033
70E337F33373773337F3E0F33333333370E337F33333333337F3E0F333333333
70E337F33333333337F3E0FFFFFFFFFFF0E337FFFFFFFFFFF7F3E00000000000
00E33777777777777733EEEEEEEEEEEEEEE33333333333333333
}
NumGlyphs = 2
OnClick = NavClick
end
object SpeedButton2: TSpeedButton
AnchorSideTop.Control = Panel5
AnchorSideTop.Side = asrCenter
Left = 49
Height = 22
Top = 7
Width = 23
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
0400000000000001000000000000000000001000000010000000000000000000
8000008000000080800080000000800080008080000080808000C0C0C0000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
33333333333333333333EEEEEEEEEEEEEEE333FFFFFFFFFFFFF3E00000000000
00E337777777777777F3E0F77777777770E337F33333333337F3E0F333333333
70E337F33333F33337F3E0F33333033370E337F3333FF73337F3E0F333300333
70E337F333FF773337F3E0F33300033370E337F33FF7773337F3E0F330000333
70E337F33377773337F3E0F33300033370E337F33337773337F3E0F333300333
70E337F33333773337F3E0F33333033370E337F33333373337F3E0F333333333
70E337F33333333337F3E0FFFFFFFFFFF0E337FFFFFFFFFFF7F3E00000000000
00E33777777777777733EEEEEEEEEEEEEEE33333333333333333
}
NumGlyphs = 2
OnClick = NavClick
end
object SpeedButton3: TSpeedButton
AnchorSideTop.Control = Panel5
AnchorSideTop.Side = asrCenter
Left = 85
Height = 22
Top = 7
Width = 23
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
0400000000000001000000000000000000001000000010000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
33333333333333333333EEEEEEEEEEEEEEE333FFFFFFFFFFFFF3E00000000000
00E337777777777777F3E0F77777777770E337F33333333337F3E0F333333333
70E337F3333F333337F3E0F33303333370E337F3337FF33337F3E0F333003333
70E337F33377FF3337F3E0F33300033370E337F333777FF337F3E0F333000033
70E337F33377773337F3E0F33300033370E337F33377733337F3E0F333003333
70E337F33377333337F3E0F33303333370E337F33373333337F3E0F333333333
70E337F33333333337F3E0FFFFFFFFFFF0E337FFFFFFFFFFF7F3E00000000000
00E33777777777777733EEEEEEEEEEEEEEE33333333333333333
}
NumGlyphs = 2
OnClick = NavClick
end
object SpeedButton4: TSpeedButton
AnchorSideTop.Control = Panel5
AnchorSideTop.Side = asrCenter
Left = 121
Height = 22
Top = 7
Width = 23
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
0400000000000001000000000000000000001000000010000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
33333333333333333333EEEEEEEEEEEEEEE333FFFFFFFFFFFFF3E00000000000
00E337777777777777F3E0F77777777770E337F33333333337F3E0F333333333
70E337F33333333337F3E0F33333333370E337F333FF3F3337F3E0F330030333
70E337F3377F7FF337F3E0F33003003370E337F3377F77FF37F3E0F330030003
70E337F3377F777337F3E0F33003003370E337F3377F773337F3E0F330030333
70E337F33773733337F3E0F33333333370E337F33333333337F3E0F333333333
70E337F33333333337F3E0FFFFFFFFFFF0E337FFFFFFFFFFF7F3E00000000000
00E33777777777777733EEEEEEEEEEEEEEE33333333333333333
}
NumGlyphs = 2
OnClick = NavClick
end
end
object Button4: TButton
AnchorSideLeft.Control = Button3
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 495
Height = 25
Top = 7
Width = 87
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Save Merge'
OnClick = Button4Click
TabOrder = 5
end
object Button5: TButton
AnchorSideLeft.Control = Button1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 117
Height = 25
Top = 7
Width = 103
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Save Template'
OnClick = Button5Click
TabOrder = 1
end
object Button6: TButton
AnchorSideLeft.Control = Button2
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 326
Height = 25
Top = 7
Width = 101
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Close Data Set'
OnClick = Button6Click
TabOrder = 3
end
end
object Panel2: TPanel
Left = 0
Height = 152
Top = 411
Width = 854
Align = alBottom
ClientHeight = 152
ClientWidth = 854
TabOrder = 3
object Memo1: TMemo
Left = 1
Height = 150
Top = 1
Width = 852
Align = alClient
OnDblClick = ClearMemo
ScrollBars = ssBoth
TabOrder = 0
WordWrap = False
end
end
object Panel3: TPanel
Left = 0
Height = 408
Top = 0
Width = 185
Align = alLeft
ClientHeight = 408
ClientWidth = 185
TabOrder = 1
object Memo2: TMemo
Left = 1
Height = 406
Top = 1
Width = 183
Align = alClient
OnDblClick = ClearMemo
ScrollBars = ssBoth
TabOrder = 0
WordWrap = False
end
end
object Panel4: TPanel
Left = 190
Height = 408
Top = 0
Width = 664
Align = alClient
ClientHeight = 408
ClientWidth = 664
TabOrder = 2
object Memo3: TMemo
Left = 1
Height = 406
Top = 1
Width = 662
Align = alClient
OnDblClick = ClearMemo
ScrollBars = ssBoth
TabOrder = 0
WordWrap = False
end
end
object OpenDialog1: TOpenDialog
DefaultExt = '.txt'
FileName = '*.txt'
Filter = 'Text Files (*.txt)|*.txt|dlg'
left = 504
top = 64
end
object OpenDialog2: TOpenDialog
Title = 'Open Schema File'
DefaultExt = '.sch'
FileName = '*.sch'
Filter = 'Schema Files (*.sch)|*.sch|All Files (*.*)|*.*'
InitialDir = 'c:\cache\Data'
left = 504
top = 120
end
object OpenDialog3: TOpenDialog
Title = 'Open CSV File'
DefaultExt = '.csv'
FileName = '*.csv'
Filter = 'CSV Files (*.csv)|*.csv|All Files (*.*)|*.*'
InitialDir = 'c:\cache\data'
left = 504
top = 176
end
object SaveDialog1: TSaveDialog
left = 504
top = 232
end
object SaveDialog2: TSaveDialog
left = 504
top = 288
end
end

260
components/systools/examples/data_merge/datamrg0.pas Normal file
View File

@ -0,0 +1,260 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit datamrg0;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, Buttons,
StTxtDat, StMerge;
type
TForm1 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Splitter1: TSplitter;
Panel3: TPanel;
Splitter2: TSplitter;
Panel4: TPanel;
Memo1: TMemo;
Memo2: TMemo;
Memo3: TMemo;
Button1: TButton;
OpenDialog1: TOpenDialog;
OpenDialog2: TOpenDialog;
OpenDialog3: TOpenDialog;
Button2: TButton;
Button3: TButton;
Panel5: TPanel;
SpeedButton1: TSpeedButton;
SpeedButton2: TSpeedButton;
SpeedButton3: TSpeedButton;
SpeedButton4: TSpeedButton;
Button4: TButton;
SaveDialog1: TSaveDialog;
Button5: TButton;
SaveDialog2: TSaveDialog;
Button6: TButton;
procedure Button2Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure NavClick(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure ClearMemo(Sender: TObject);
procedure Button6Click(Sender: TObject);
private
procedure UpdateButtons;
procedure UpdateTagDisplay;
function NextFile: string;
procedure DoUnknownTag(Sender: TObject; Tag: AnsiString;
var Value: AnsiString; var Discard: Boolean);
procedure DisableButtons;
{ Private declarations }
public
TemplateName : string;
MergeNo : Integer;
Schema : TStTextDataSchema;
DataSet : TStTextDataRecordSet;
Merger : TStTextMerge;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TForm1.Button2Click(Sender: TObject);
begin
if OpenDialog2.Execute and OpenDialog3.Execute then begin
Schema.Free;
Schema := TStTextDataSchema.Create;
Schema.LoadFromFile(OpenDialog2.FileName);
DataSet.Free;
DataSet := TStTextDataRecordSet.Create;
DataSet.Schema := Schema;
DataSet.LoadFromFile(OpenDialog3.FileName);
DataSet.First;
UpdateButtons;
UpdateTagDisplay;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Schema.Free;
DataSet.Free;
Merger.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
TemplateName := OpenDialog1.FileName;
MergeNo := 1;
Merger.LoadTemplateFromFile(TemplateName);
Memo3.Lines.Assign(Merger.Template);
end;
end;
procedure TForm1.UpdateTagDisplay;
begin
Memo2.Lines.Assign(DataSet.CurrentRecord.FieldList);
end;
procedure TForm1.DisableButtons;
begin
SpeedButton1.Enabled := False;
SpeedButton2.Enabled := False;
SpeedButton3.Enabled := False;
SpeedButton4.Enabled := False;
end;
procedure TForm1.UpdateButtons;
begin
if DataSet.Active then begin
SpeedButton1.Enabled := True;
SpeedButton2.Enabled := True;
SpeedButton3.Enabled := True;
SpeedButton4.Enabled := True;
if DataSet.BOF then begin
SpeedButton1.Enabled := False;
SpeedButton2.Enabled := False;
end;
if DataSet.EOF then begin
SpeedButton3.Enabled := False;
SpeedButton4.Enabled := False;
end;
end else
DisableButtons;
end;
procedure TForm1.NavClick(Sender: TObject);
begin
if Sender = SpeedButton1 then DataSet.First;
if Sender = SpeedButton2 then DataSet.Prior;
if Sender = SpeedButton3 then DataSet.Next;
if Sender = SpeedButton4 then DataSet.Last;
UpdateButtons;
UpdateTagDisplay;
end;
function TForm1.NextFile : string;
begin
Result := ChangeFileExt(ExtractFileName(TemplateName),
Format('.M%.2d', [MergeNo]));
Inc(MergeNo);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
SaveDialog1.FileName := NextFile;
if SaveDialog1.Execute then begin
Memo3.Lines.SaveToFile(SaveDialog1.FileName);
end;
end;
procedure TForm1.DoUnknownTag(Sender : TObject; Tag : AnsiString;
var Value : AnsiString; var Discard : Boolean);
begin
if Tag = 'TIME' then
Value := FormatDateTime('hh:mm:ss', Now)
else
Value := InputBox('Unknown Tag', 'Value for ' + Tag, '');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Merger := TStTextMerge.Create;
Merger.DefaultTags.Add('FIRST_NAME=Sir or Madam');
Merger.DefaultTags.Add('CITY=ANYTOWN');
Merger.DefaultTags.Add('COLOR=BLUE');
Merger.OnGotUnknownTag := DoUnknownTag;
DisableButtons;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Merger.MergeTags.Assign(Memo2.Lines);
Merger.Merge;
Memo1.Lines.Assign(Merger.MergedText);
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
SaveDialog2.FileName := TemplateName;
if SaveDialog2.Execute then begin
TemplateName := SaveDialog2.FileName;
Memo3.Lines.SaveToFile(TemplateName);
Merger.Template.Assign(Memo3.Lines);
end;
end;
procedure TForm1.ClearMemo(Sender: TObject);
begin
(Sender as TMemo).Lines.Clear;
end;
procedure TForm1.Button6Click(Sender: TObject);
begin
if Assigned(DataSet) and DataSet.Active then begin
DataSet.Active := False;
DataSet.Free;
DataSet := nil;
Memo2.Lines.Clear;
DisableButtons;
end;
end;
end.

3
components/systools/examples/grid_fill/data.csv Normal file
View File

@ -0,0 +1,3 @@
"John Smith","A+",08/01/1995,135.32
"Jane Doe","B",08/12/1995,120.25
"John Q. Public","CCC",08/03/1995,145.11
1 John Smith A+ 08/01/1995 135.32
2 Jane Doe B 08/12/1995 120.25
3 John Q. Public CCC 08/03/1995 145.11

9
components/systools/examples/grid_fill/data.sch Normal file
View File

@ -0,0 +1,9 @@
[DATES]
Field3=Data,DATA,10,00,22
Separator=,
CharSet=ascii
Field2=Rating,CHAR,2,00,20
Filetype=VARYING
Field4=Weight,Float,7,2,32
Field1=Name,CHAR,20,00,00
Delimiter="

83
components/systools/examples/grid_fill/gridfil0.lfm Normal file
View File

@ -0,0 +1,83 @@
object Form1: TForm1
Left = 307
Height = 373
Top = 165
Width = 536
Caption = 'Grid Filler Example'
ClientHeight = 373
ClientWidth = 536
Color = clBtnFace
Font.Color = clWindowText
OnDestroy = FormDestroy
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 0
Height = 41
Top = 332
Width = 536
Align = alBottom
ClientHeight = 41
ClientWidth = 536
TabOrder = 0
object Button1: TButton
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 9
Height = 25
Top = 8
Width = 97
AutoSize = True
BorderSpacing.Left = 8
Caption = 'Load Schema'
OnClick = Button1Click
TabOrder = 0
end
object Button2: TButton
AnchorSideLeft.Control = Button1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 114
Height = 25
Top = 8
Width = 103
AutoSize = True
BorderSpacing.Left = 8
Caption = 'Open Data File'
OnClick = Button2Click
TabOrder = 1
end
end
object StringGrid1: TStringGrid
Left = 0
Height = 332
Top = 0
Width = 536
Align = alClient
DefaultColWidth = 100
FixedCols = 0
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goColSizing]
RowCount = 2
TabOrder = 1
TitleFont.Color = clWindowText
end
object OpenDialog1: TOpenDialog
Title = 'Open Schema File'
DefaultExt = '.sch'
FileName = '*.sch'
Filter = 'Schema Files (*.sch)|*.sch|All Files (*.*)|*.*'
InitialDir = 'c:\cache\Data'
left = 232
top = 136
end
object OpenDialog2: TOpenDialog
Title = 'Open CSV File'
DefaultExt = '.csv'
FileName = '*.csv'
Filter = 'CSV Files (*.csv)|*.csv|All Files (*.*)|*.*'
InitialDir = 'c:\cache\data'
left = 232
top = 200
end
end

137
components/systools/examples/grid_fill/gridfil0.pas Normal file
View File

@ -0,0 +1,137 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit gridfil0;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, ExtCtrls,
StTxtDat;
type
TForm1 = class(TForm)
Panel1: TPanel;
Button1: TButton;
StringGrid1: TStringGrid;
Button2: TButton;
OpenDialog1: TOpenDialog;
OpenDialog2: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
procedure ClearGrid(ClearCaptions: Boolean);
procedure FillCaptions;
procedure FillCells;
{ Private declarations }
public
Schema : TStTextDataSchema;
DataSet : TStTextDataRecordSet;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TForm1.ClearGrid(ClearCaptions : Boolean);
var
i : Integer;
begin
if ClearCaptions then
StringGrid1.Rows[0].Clear;
for i := 1 to Pred(StringGrid1.RowCount) do
StringGrid1.Rows[i].Clear;
end;
procedure TForm1.FillCaptions;
begin
StringGrid1.ColCount := Schema.Captions.Count;
StringGrid1.Rows[0].Assign(Schema.Captions);
end;
procedure TForm1.FillCells;
var
i : Integer;
begin
StringGrid1.RowCount := DataSet.Count + 1;
i := 1;
DataSet.First;
while not DataSet.EOF do begin
StringGrid1.Rows[i].Assign(DataSet.CurrentRecord.Values);
DataSet.Next;
Inc(i);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
ClearGrid(True);
Schema.Free;
Schema := TStTextDataSchema.Create;
Schema.LoadFromFile(OpenDialog1.FileName);
FillCaptions;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if OpenDialog2.Execute then begin
ClearGrid(False);
DataSet.Free;
DataSet := TStTextDataRecordSet.Create;
DataSet.Schema := Schema;
DataSet.LoadFromFile(OpenDialog2.FileName);
FillCells;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Schema.Free;
DataSet.Free;
end;
end.

84
components/systools/examples/grid_fill/gridfill.lpi Normal file
View File

@ -0,0 +1,84 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<Flags>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="gridfill"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="gridfill.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="GridFill"/>
</Unit0>
<Unit1>
<Filename Value="gridfil0.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="gridfill"/>
</Target>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

43
components/systools/examples/grid_fill/gridfill.lpr Normal file
View File

@ -0,0 +1,43 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program GridFill;
uses
Interfaces,
Forms, lclversion,
gridfil0 in 'gridfil0.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

190
components/systools/examples/patterns/chain.lfm Normal file
View File

@ -0,0 +1,190 @@
object ChainForm: TChainForm
Left = 731
Height = 199
Top = 301
Width = 385
BorderStyle = bsDialog
Caption = 'The Chain Test Form'
ClientHeight = 199
ClientWidth = 385
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
OnDestroy = FormDestroy
LCLVersion = '1.9.0.0'
object Panel2: TPanel
Left = 0
Height = 137
Top = 56
Width = 385
BevelOuter = bvNone
ClientHeight = 137
ClientWidth = 385
TabOrder = 0
object Ch1Lbl: TLabel
Left = 16
Height = 15
Top = 8
Width = 64
Caption = 'Handle < 10'
ParentColor = False
end
object Ch2Lbl: TLabel
Left = 16
Height = 15
Top = 32
Width = 53
Caption = 'Handle 10'
ParentColor = False
end
object Ch3Lbl: TLabel
Left = 16
Height = 15
Top = 56
Width = 64
Caption = 'Handle Odd'
ParentColor = False
end
object Ch4Lbl: TLabel
Left = 16
Height = 15
Top = 80
Width = 67
Caption = 'Handle >100'
ParentColor = False
end
object Ch5Lbl: TLabel
Left = 16
Height = 15
Top = 104
Width = 83
Caption = 'Default Handler'
ParentColor = False
end
object Ch1Value: TEdit
Left = 120
Height = 23
Top = 8
Width = 50
Enabled = False
TabOrder = 0
end
object Ch2Value: TEdit
Left = 120
Height = 23
Top = 32
Width = 50
Enabled = False
TabOrder = 1
end
object Ch3Value: TEdit
Left = 120
Height = 23
Top = 56
Width = 50
Enabled = False
TabOrder = 2
end
object Ch4Value: TEdit
Left = 120
Height = 23
Top = 80
Width = 50
Enabled = False
TabOrder = 3
end
object Ch5Value: TEdit
Left = 120
Height = 23
Top = 104
Width = 50
Enabled = False
TabOrder = 4
end
object Ch1Msg: TEdit
Left = 170
Height = 23
Top = 8
Width = 200
Enabled = False
TabOrder = 5
end
object Ch2Msg: TEdit
Left = 170
Height = 23
Top = 32
Width = 200
Enabled = False
TabOrder = 6
end
object Ch3Msg: TEdit
Left = 170
Height = 23
Top = 56
Width = 200
Enabled = False
TabOrder = 7
end
object Ch4Msg: TEdit
Left = 170
Height = 23
Top = 80
Width = 200
Enabled = False
TabOrder = 8
end
object Ch5Msg: TEdit
Left = 170
Height = 23
Top = 104
Width = 200
Enabled = False
TabOrder = 9
end
end
object Panel1: TPanel
Left = 0
Height = 49
Top = 0
Width = 385
ClientHeight = 49
ClientWidth = 385
TabOrder = 1
object RadioButton1: TRadioButton
Left = 8
Height = 19
Top = 14
Width = 78
Caption = 'Hot Potato'
Checked = True
OnClick = RadioButton1Click
TabOrder = 0
TabStop = True
end
object RadioButton2: TRadioButton
Left = 104
Height = 19
Top = 14
Width = 64
Caption = 'Additive'
OnClick = RadioButton2Click
TabOrder = 1
end
object InputValue: TEdit
Left = 200
Height = 23
Top = 12
Width = 73
TabOrder = 2
end
object Start: TButton
Left = 288
Height = 25
Top = 11
Width = 82
Caption = 'Start'
OnClick = StartClick
TabOrder = 3
end
end
end

304
components/systools/examples/patterns/chain.pas Normal file
View File

@ -0,0 +1,304 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Chain;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StPtrns, ExtCtrls;
type
TInputData = class
public
{ Public declarations }
InData : integer;
end;
type
TOutputData = class
public
{ Public declarations }
OutData : integer;
end;
type
TChainForm = class(TForm)
Panel2: TPanel;
Ch1Lbl: TLabel;
Ch2Lbl: TLabel;
Ch3Lbl: TLabel;
Ch4Lbl: TLabel;
Ch5Lbl: TLabel;
Ch1Value: TEdit;
Ch2Value: TEdit;
Ch3Value: TEdit;
Ch4Value: TEdit;
Ch5Value: TEdit;
Ch1Msg: TEdit;
Ch2Msg: TEdit;
Ch3Msg: TEdit;
Ch4Msg: TEdit;
Ch5Msg: TEdit;
Panel1: TPanel;
RadioButton1: TRadioButton;
RadioButton2: TRadioButton;
InputValue: TEdit;
Start: TButton;
procedure RadioButton1Click(Sender: TObject);
procedure RadioButton2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure StartClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
// Code for the chain
TheChain : TStChain;
procedure Chain1Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure Chain2Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure Chain3Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure Chain4Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure Chain5Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure ClearScreen;
public
{ Public declarations }
end;
var
ChainForm: TChainForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
var
ChainPotato : Boolean;
TheChain: TStChain;
procedure TChainForm.RadioButton1Click(Sender: TObject);
begin
if (RadioButton1.Checked) then begin
Ch1Lbl.Caption := 'Handle < 10';
Ch2Lbl.Caption := 'Handle 10';
Ch3Lbl.Caption := 'Handle Odd';
Ch4Lbl.Caption := 'Handle > 100';
Ch5Lbl.Caption := 'Default Handler';
ChainPotato := true;
ClearScreen;
end;
end;
procedure TChainForm.RadioButton2Click(Sender: TObject);
begin
if (RadioButton2.Checked) then begin
Ch1Lbl.Caption := 'Add 10';
Ch2Lbl.Caption := 'Multiply by 10';
Ch3Lbl.Caption := 'Add 3';
Ch4Lbl.Caption := 'Subtract 4';
Ch5Lbl.Caption := 'Zero out';
ChainPotato := false;
ClearScreen;
end;
end;
procedure TChainForm.Chain1Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
if (myInputData.InData < 10) then begin
Ch1Value.text := Inttostr(myInputData.InData);
Ch1Msg.Text := 'I handled it';
aStopNow := true;
end else begin
Ch1Value.text := ' ';
Ch1Msg.Text := 'Not here';
aStopNow := false;
end
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := myOutputData.OutData + 10;
Ch1Value.text := Inttostr(myOutputData.OutData);
Ch1Msg.Text := 'Added 10';
end
end;
procedure TChainForm.Chain2Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
if (myInputData.InData = 10) then begin
Ch2Value.text := Inttostr(myInputData.InData);
Ch2Msg.Text := 'I handled it';
aStopNow := true;
end else begin
Ch2Value.text := ' ';
Ch2Msg.Text := 'Not here';
aStopNow := false;
end
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := myOutputData.OutData * 10;
Ch2Value.text := Inttostr(myOutputData.OutData);
Ch2Msg.Text := 'Mulitplied by 10';
end
end;
procedure TChainForm.Chain3Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
if odd(myInputData.InData) then begin
Ch3Value.text := Inttostr(myInputData.InData);
Ch3Msg.Text := 'I handled it';
aStopNow := true;
end else begin
Ch3Value.text := ' ';
Ch3Msg.Text := 'Not here';
aStopNow := false;
end
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := myOutputData.OutData + 3;
Ch3Value.text := Inttostr(myOutputData.OutData);
Ch3Msg.Text := 'Added 3';
end
end;
procedure TChainForm.Chain4Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
if (myInputData.InData > 100) then begin
Ch4Value.text := Inttostr(myInputData.InData);
Ch4Msg.Text := 'I handled it';
aStopNow := true;
end else begin
Ch4Value.text := ' ';
Ch4Msg.Text := 'Not here';
aStopNow := false;
end
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := myOutputData.OutData -4;
Ch4Value.text := Inttostr(myOutputData.OutData);
Ch4Msg.Text := 'Subtracted 4';
end
end;
procedure TChainForm.Chain5Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
Ch5Value.text := Inttostr(myInputData.InData);
Ch5Msg.Text := 'I handled it';
aStopNow := true;
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := 0;
Ch5Value.text := Inttostr(myOutputData.OutData);
Ch5Msg.Text := 'Zeroed out';
end
end;
procedure TChainForm.FormCreate(Sender: TObject);
begin
ChainPotato := true;
TheChain:= TStChain.create;
TheChain.Add(Chain1Proc);
TheChain.Add(Chain2Proc);
TheChain.Add(Chain3Proc);
TheChain.Add(Chain4Proc);
TheChain.Add(Chain5Proc);
end;
procedure TChainForm.StartClick(Sender: TObject);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
myInputData := nil;
myOutputData := nil;
try
myInputData := TInputData.Create;
myOutputData := TOutputData.Create;
myInputData.InData := Strtoint(InputValue.Text);
myOutputData.OutData := Strtoint(InputValue.Text);
ClearScreen;
TheChain.Handle(myInputData, myOutputData);
finally;
myInputData.free;
myOutputData.free;
end;
end;
procedure TChainForm.ClearScreen;
begin
Ch1Value.text := ' ';
Ch1Msg.Text := ' ';
Ch2Value.text := ' ';
Ch2Msg.Text := ' ';
Ch3Value.text := ' ';
Ch3Msg.Text := ' ';
Ch4Value.text := ' ';
Ch4Msg.Text := ' ';
Ch5Value.text := ' ';
Ch5Msg.Text := ' ';
end;
procedure TChainForm.FormDestroy(Sender: TObject);
begin
TheChain.free;
end;
end.

284
components/systools/examples/patterns/medtr.lfm Normal file
View File

@ -0,0 +1,284 @@
object MediatorForm: TMediatorForm
Left = 661
Height = 278
Top = 112
Width = 561
BorderStyle = bsDialog
Caption = 'The Mediator Test Form'
ClientHeight = 278
ClientWidth = 561
Color = clBtnFace
Font.Color = clWindowText
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 16
Height = 114
Top = 152
Width = 232
BevelOuter = bvNone
ClientHeight = 114
ClientWidth = 232
TabOrder = 0
object ASelectBox: TCheckBox
Left = 8
Height = 19
Top = 8
Width = 60
Caption = 'A Event'
TabOrder = 0
end
object BSelectBox: TCheckBox
Left = 7
Height = 19
Top = 28
Width = 59
Caption = 'B Event'
TabOrder = 1
end
object CSelectBox: TCheckBox
Left = 8
Height = 19
Top = 48
Width = 60
Caption = 'C Event'
TabOrder = 2
end
object DSelectBox: TCheckBox
Left = 8
Height = 19
Top = 68
Width = 60
Caption = 'D Event'
TabOrder = 3
end
object ESelectBox: TCheckBox
Left = 8
Height = 19
Top = 88
Width = 58
Caption = 'E Event'
TabOrder = 4
end
object Start: TButton
Left = 120
Height = 49
Top = 28
Width = 82
Caption = 'Start'
OnClick = StartClick
TabOrder = 5
end
end
object Panel2: TPanel
Left = 280
Height = 114
Top = 152
Width = 272
BevelOuter = bvNone
ClientHeight = 114
ClientWidth = 272
TabOrder = 1
object Ch1Lbl: TLabel
Left = 16
Height = 15
Top = 8
Width = 51
Caption = 'Handler 1'
ParentColor = False
end
object Ch2Lbl: TLabel
Left = 16
Height = 15
Top = 32
Width = 51
Caption = 'Handler 2'
ParentColor = False
end
object Ch3Lbl: TLabel
Left = 16
Height = 15
Top = 56
Width = 51
Caption = 'Handler 3'
ParentColor = False
end
object Ch4Lbl: TLabel
Left = 16
Height = 15
Top = 80
Width = 51
Caption = 'Handler 4'
ParentColor = False
end
object H1Result: TLabel
Left = 70
Height = 1
Top = 8
Width = 1
ParentColor = False
end
object H2Result: TLabel
Left = 70
Height = 1
Top = 32
Width = 1
ParentColor = False
end
object H3Result: TLabel
Left = 70
Height = 1
Top = 56
Width = 1
ParentColor = False
end
object H4Result: TLabel
Left = 70
Height = 1
Top = 80
Width = 1
ParentColor = False
end
end
object Panel3: TPanel
Left = 0
Height = 144
Top = 0
Width = 552
BevelOuter = bvNone
ClientHeight = 144
ClientWidth = 552
Font.Color = clWindowText
ParentFont = False
TabOrder = 2
object AEvents: TRadioGroup
Left = 16
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event A'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 0
end
object BEvents: TRadioGroup
Left = 120
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event B'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 1
end
object CEvents: TRadioGroup
Left = 216
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event C'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 2
end
object DEvents: TRadioGroup
Left = 328
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event D'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 3
end
object EEvents: TRadioGroup
Left = 440
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event E'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 4
end
end
end

169
components/systools/examples/patterns/medtr.pas Normal file
View File

@ -0,0 +1,169 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Medtr;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StPtrns, ExtCtrls;
type
{ TMediatorForm }
TMediatorForm = class(TForm)
Panel1: TPanel;
ASelectBox: TCheckBox;
BSelectBox: TCheckBox;
CSelectBox: TCheckBox;
DSelectBox: TCheckBox;
ESelectBox: TCheckBox;
Start: TButton;
Panel2: TPanel;
Ch1Lbl: TLabel;
Ch2Lbl: TLabel;
Ch3Lbl: TLabel;
Ch4Lbl: TLabel;
Panel3: TPanel;
AEvents: TRadioGroup;
H1Result: TLabel;
H2Result: TLabel;
H3Result: TLabel;
H4Result: TLabel;
BEvents: TRadioGroup;
CEvents: TRadioGroup;
DEvents: TRadioGroup;
EEvents: TRadioGroup;
procedure StartClick(Sender: TObject);
private
TheMediator: TStMediator;
procedure MediatedFunction1(aInputData, aResultData : TObject);
procedure MediatedFunction2(aInputData, aResultData : TObject);
procedure MediatedFunction3(aInputData, aResultData : TObject);
procedure MediatedFunction4(aInputData, aResultData : TObject);
procedure SetupMediator(Letter: String; Which: TRadioGroup);
{ Private declarations }
public
{ Public declarations }
end;
var
MediatorForm: TMediatorForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TMediatorForm.StartClick(Sender: TObject);
begin
TheMediator := TStMediator.create;
H1Result.Caption := '';
H2Result.Caption := '';
H3Result.Caption := '';
H4Result.Caption := '';
SetupMediator('A', AEvents);
SetupMediator('B', BEvents);
SetupMediator('C', CEvents);
SetupMediator('D', DEvents);
SetupMediator('E', EEvents);
if (ASelectBox.Checked) then
TheMediator.Handle('A', nil, nil);
if (BSelectBox.Checked) then
TheMediator.Handle('B', nil, nil);
if (CSelectBox.Checked) then
TheMediator.Handle('C', nil, nil);
if (DSelectBox.Checked) then
TheMediator.Handle('D', nil, nil);
if (ESelectBox.Checked) then
TheMediator.Handle('E', nil, nil);
TheMediator.free;
end;
procedure TMediatorForm.SetupMediator(Letter: String; Which: TRadioGroup);
begin
If (Which.ItemIndex = 0) then
TheMediator.Add(Letter, MediatedFunction1)
else If (Which.ItemIndex = 1) then
TheMediator.Add(Letter, MediatedFunction2)
else If (Which.ItemIndex = 2) then
TheMediator.Add(Letter, MediatedFunction3)
else If (Which.ItemIndex = 3) then
TheMediator.Add(Letter, MediatedFunction4);
end;
procedure TMediatorForm.MediatedFunction1(aInputData, aResultData : TObject);
begin
H1Result.Caption := 'I worked';
end;
procedure TMediatorForm.MediatedFunction2(aInputData, aResultData : TObject);
begin
H2Result.Caption := 'I worked';
end;
procedure TMediatorForm.MediatedFunction3(aInputData, aResultData : TObject);
begin
H3Result.Caption := 'I worked';
end;
procedure TMediatorForm.MediatedFunction4(aInputData, aResultData : TObject);
begin
H4Result.Caption := 'I worked';
end;
procedure InitUnit;
begin
end;
procedure DoneUnit;
begin
end;
initialization
InitUnit;
finalization
DoneUnit;
end.

86
components/systools/examples/patterns/observer.lfm Normal file
View File

@ -0,0 +1,86 @@
object ObserverForm: TObserverForm
Left = 484
Height = 179
Top = 295
Width = 207
BorderStyle = bsDialog
Caption = 'The Observer Test Form'
ClientHeight = 179
ClientWidth = 207
Color = clBtnFace
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
OnCreate = FormCreate
OnDestroy = FormDestroy
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 0
Height = 179
Top = 0
Width = 207
Align = alClient
ClientHeight = 179
ClientWidth = 207
Font.Color = clWindowText
ParentFont = False
TabOrder = 0
object Label1: TLabel
Left = 19
Height = 15
Top = 16
Width = 45
Caption = 'Caption:'
ParentColor = False
end
object Button1: TButton
Left = 48
Height = 25
Top = 40
Width = 130
AutoSize = True
Caption = 'Caption for Buttons'
OnClick = Button1Click
TabOrder = 0
end
object Edit1: TEdit
Left = 72
Height = 23
Top = 12
Width = 105
OnChange = Edit1Change
TabOrder = 1
Text = 'Caption for Buttons'
end
object Button2: TButton
Left = 47
Height = 25
Top = 72
Width = 130
AutoSize = True
Caption = 'Caption for Buttons'
OnClick = Button2Click
TabOrder = 2
end
object Button3: TButton
Left = 48
Height = 25
Top = 104
Width = 130
AutoSize = True
Caption = 'Caption for Buttons'
OnClick = Button3Click
TabOrder = 3
end
object Button4: TButton
Left = 47
Height = 25
Top = 136
Width = 130
AutoSize = True
Caption = 'Caption for Buttons'
OnClick = Button4Click
TabOrder = 4
end
end
end

143
components/systools/examples/patterns/observer.pas Normal file
View File

@ -0,0 +1,143 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Observer;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StPtrns, ExtCtrls;
type
TObserverForm = class(TForm)
Panel1: TPanel;
Button1: TButton;
Edit1: TEdit;
Label1: TLabel;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Edit1Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
// Code for the observer
{ Private declarations }
public
TheObserver: TStObserver;
procedure ReceiveNotification1(WhatChanged: TObject);
procedure ReceiveNotification2(WhatChanged: TObject);
procedure ReceiveNotification3(WhatChanged: TObject);
procedure ReceiveNotification4(WhatChanged: TObject);
{ Public declarations }
end;
var
ObserverForm: TObserverForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TObserverForm.Edit1Change(Sender: TObject);
begin
TheObserver.Notify(TObject(Edit1.Text));
end;
procedure TObserverForm.ReceiveNotification1(WhatChanged: TObject);
begin
Button1.Caption := String(WhatChanged);
end;
procedure TObserverForm.ReceiveNotification2(WhatChanged: TObject);
begin
Button2.Caption := String(WhatChanged);
end;
procedure TObserverForm.ReceiveNotification3(WhatChanged: TObject);
begin
Button3.Caption := String(WhatChanged);
end;
procedure TObserverForm.ReceiveNotification4(WhatChanged: TObject);
begin
Button4.Caption := String(WhatChanged);
end;
procedure TObserverForm.Button1Click(Sender: TObject);
begin
Edit1.Text:= 'Reset 1';
end;
procedure TObserverForm.Button2Click(Sender: TObject);
begin
Edit1.Text:= 'Reset 2';
end;
procedure TObserverForm.Button3Click(Sender: TObject);
begin
Edit1.Text:= 'Reset 3';
end;
procedure TObserverForm.Button4Click(Sender: TObject);
begin
Edit1.Text:= 'Reset 4';
end;
procedure TObserverForm.FormCreate(Sender: TObject);
begin
TheObserver := TStObserver.Create;
TheObserver.Add(ReceiveNotification1);
TheObserver.Add(ReceiveNotification2);
TheObserver.Add(ReceiveNotification3);
TheObserver.Add(ReceiveNotification4);
end;
procedure TObserverForm.FormDestroy(Sender: TObject);
begin
TheObserver.Free;
end;
end.

104
components/systools/examples/patterns/patntest.lpi Normal file
View File

@ -0,0 +1,104 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<Flags>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="patntest"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="6">
<Unit0>
<Filename Value="patntest.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="PatnTest"/>
</Unit0>
<Unit1>
<Filename Value="root.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit1>
<Unit2>
<Filename Value="chain.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
<UnitName Value="Chain"/>
</Unit2>
<Unit3>
<Filename Value="medtr.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit3>
<Unit4>
<Filename Value="observer.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
<UnitName Value="Observer"/>
</Unit4>
<Unit5>
<Filename Value="singlton.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit5>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="patntest"/>
</Target>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

47
components/systools/examples/patterns/patntest.lpr Normal file
View File

@ -0,0 +1,47 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program PatnTest;
uses
Interfaces,
Forms, lclversion,
Observer in 'Observer.pas' {ObserverForm},
Chain in 'Chain.pas' {ChainForm},
Medtr in 'Medtr.pas' {MediatorForm},
Root in 'Root.pas' {RootForm},
Singlton in 'Singlton.pas' {SingletonForm};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TRootForm, RootForm);
Application.Run;
end.

92
components/systools/examples/patterns/root.lfm Normal file
View File

@ -0,0 +1,92 @@
object RootForm: TRootForm
Left = 241
Height = 173
Top = 127
Width = 304
BorderStyle = bsDialog
Caption = 'Pick Your Example'
ClientHeight = 173
ClientWidth = 304
Color = clBtnFace
Font.Color = clWindowText
LCLVersion = '1.9.0.0'
Scaled = False
object ObserverBtn: TButton
AnchorSideLeft.Control = Owner
AnchorSideLeft.Side = asrCenter
Left = 116
Height = 25
Top = 16
Width = 73
AutoSize = True
Caption = 'Observer'
OnClick = ObserverBtnClick
TabOrder = 0
end
object MediatorBtn: TButton
AnchorSideLeft.Control = ObserverBtn
AnchorSideTop.Control = ChainBtn
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = ObserverBtn
AnchorSideRight.Side = asrBottom
Left = 116
Height = 25
Top = 70
Width = 73
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Top = 2
Caption = 'Mediator'
OnClick = MediatorBtnClick
TabOrder = 1
end
object ChainBtn: TButton
AnchorSideLeft.Control = ObserverBtn
AnchorSideTop.Control = ObserverBtn
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = ObserverBtn
AnchorSideRight.Side = asrBottom
Left = 116
Height = 25
Top = 43
Width = 73
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Top = 2
Caption = 'Chain'
OnClick = ChainBtnClick
TabOrder = 2
end
object SingletonBtn: TButton
AnchorSideLeft.Control = ObserverBtn
AnchorSideTop.Control = MediatorBtn
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = ObserverBtn
AnchorSideRight.Side = asrBottom
Left = 116
Height = 25
Top = 97
Width = 73
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Top = 2
Caption = 'Singleton'
OnClick = SingletonBtnClick
TabOrder = 3
end
object ExitBtn: TButton
AnchorSideLeft.Control = Owner
AnchorSideLeft.Side = asrCenter
AnchorSideTop.Control = SingletonBtn
AnchorSideTop.Side = asrBottom
Left = 130
Height = 25
Top = 138
Width = 44
AutoSize = True
BorderSpacing.Top = 16
Caption = '&Exit'
OnClick = ExitBtnClick
TabOrder = 4
end
end

101
components/systools/examples/patterns/root.pas Normal file
View File

@ -0,0 +1,101 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Root;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TRootForm = class(TForm)
ObserverBtn: TButton;
MediatorBtn: TButton;
ChainBtn: TButton;
SingletonBtn: TButton;
ExitBtn: TButton;
procedure ObserverBtnClick(Sender: TObject);
procedure ChainBtnClick(Sender: TObject);
procedure MediatorBtnClick(Sender: TObject);
procedure SingletonBtnClick(Sender: TObject);
procedure ExitBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
RootForm: TRootForm;
implementation
uses Chain, Medtr, Observer, Singlton;
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TRootForm.ObserverBtnClick(Sender: TObject);
begin
Application.CreateForm(TObserverForm, ObserverForm);
ObserverForm.ShowModal;
end;
procedure TRootForm.ChainBtnClick(Sender: TObject);
begin
Application.CreateForm(TChainForm, ChainForm);
ChainForm.ShowModal;
end;
procedure TRootForm.MediatorBtnClick(Sender: TObject);
begin
Application.CreateForm(TMediatorForm, MediatorForm);
MediatorForm.ShowModal;
end;
procedure TRootForm.SingletonBtnClick(Sender: TObject);
begin
Application.CreateForm(TSingletonForm, SingletonForm);
SingletonForm.ShowModal;
end;
procedure TRootForm.ExitBtnClick(Sender: TObject);
begin
Close;
end;
end.

213
components/systools/examples/patterns/singlton.lfm Normal file
View File

@ -0,0 +1,213 @@
object SingletonForm: TSingletonForm
Left = 608
Height = 139
Top = 122
Width = 440
AutoSize = True
BorderStyle = bsDialog
Caption = 'The Singleton Test Form'
ClientHeight = 139
ClientWidth = 440
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 0
Height = 128
Top = 8
Width = 440
BevelOuter = bvNone
ClientHeight = 128
ClientWidth = 440
TabOrder = 0
object Label1: TLabel
Left = 88
Height = 15
Top = 8
Width = 89
Caption = 'Singleton Count:'
ParentColor = False
end
object Display1: TEdit
Left = 288
Height = 23
Top = 40
Width = 45
TabOrder = 0
Text = '(empty)'
end
object CnR1: TButton
Left = 220
Height = 25
Top = 40
Width = 52
AutoSize = True
Caption = 'Read'
OnClick = CnR1Click
TabOrder = 1
end
object Set1: TButton
Left = 344
Height = 25
Top = 40
Width = 74
AutoSize = True
Caption = 'Set Value'
OnClick = Set1Click
TabOrder = 2
end
object CnR2: TButton
Left = 220
Height = 25
Top = 64
Width = 52
AutoSize = True
Caption = 'Read'
OnClick = CnR2Click
TabOrder = 3
end
object Display2: TEdit
Left = 288
Height = 23
Top = 64
Width = 45
TabOrder = 4
Text = '(empty)'
end
object Set2: TButton
Left = 344
Height = 25
Top = 64
Width = 74
AutoSize = True
Caption = 'Set Value'
OnClick = Set2Click
TabOrder = 5
end
object CnR3: TButton
Left = 220
Height = 25
Top = 88
Width = 52
AutoSize = True
Caption = 'Read'
OnClick = CnR3Click
TabOrder = 6
end
object Display3: TEdit
Left = 288
Height = 23
Top = 88
Width = 45
TabOrder = 7
Text = '(empty)'
end
object Set3: TButton
Left = 344
Height = 25
Top = 88
Width = 74
AutoSize = True
Caption = 'Set Value'
OnClick = Set3Click
TabOrder = 8
end
object Create1: TButton
Left = 20
Height = 25
Top = 40
Width = 60
AutoSize = True
Caption = 'Create'
OnClick = Create1Click
TabOrder = 9
end
object Create2: TButton
Left = 20
Height = 25
Top = 64
Width = 60
AutoSize = True
Caption = 'Create'
OnClick = Create2Click
TabOrder = 10
end
object Create3: TButton
Left = 20
Height = 25
Top = 88
Width = 60
AutoSize = True
Caption = 'Create'
OnClick = Create3Click
TabOrder = 11
end
object Free1: TButton
Left = 160
Height = 25
Top = 40
Width = 48
AutoSize = True
Caption = 'Free'
OnClick = Free1Click
TabOrder = 12
end
object Free2: TButton
Left = 160
Height = 25
Top = 64
Width = 48
AutoSize = True
Caption = 'Free'
OnClick = Free2Click
TabOrder = 13
end
object Free3: TButton
Left = 160
Height = 25
Top = 88
Width = 48
AutoSize = True
Caption = 'Free'
OnClick = Free3Click
TabOrder = 14
end
object Counter: TEdit
Left = 184
Height = 23
Top = 4
Width = 33
Enabled = False
TabOrder = 15
Text = '0'
end
object Ref1: TEdit
Left = 94
Height = 23
Top = 40
Width = 50
Enabled = False
TabOrder = 16
Text = 'ref is nil'
end
object Ref2: TEdit
Left = 94
Height = 23
Top = 64
Width = 50
Enabled = False
TabOrder = 17
Text = 'ref is nil'
end
object Ref3: TEdit
Left = 94
Height = 23
Top = 88
Width = 50
Enabled = False
TabOrder = 18
Text = 'ref is nil'
end
end
end

237
components/systools/examples/patterns/singlton.pas Normal file
View File

@ -0,0 +1,237 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Singlton;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StPtrns, ExtCtrls;
type
TSingleData = class(TStSingleton)
public
{ Public declarations }
TheData : integer;
end;
type
TSingletonForm = class(TForm)
Panel1: TPanel;
Display1: TEdit;
CnR1: TButton;
Set1: TButton;
CnR2: TButton;
Display2: TEdit;
Set2: TButton;
CnR3: TButton;
Display3: TEdit;
Set3: TButton;
Create1: TButton;
Create2: TButton;
Create3: TButton;
Free1: TButton;
Free2: TButton;
Free3: TButton;
Counter: TEdit;
Label1: TLabel;
Ref1: TEdit;
Ref2: TEdit;
Ref3: TEdit;
procedure CnR1Click(Sender: TObject);
procedure CnR2Click(Sender: TObject);
procedure CnR3Click(Sender: TObject);
procedure Set1Click(Sender: TObject);
procedure Set2Click(Sender: TObject);
procedure Set3Click(Sender: TObject);
procedure Create1Click(Sender: TObject);
procedure Create2Click(Sender: TObject);
procedure Create3Click(Sender: TObject);
procedure Free1Click(Sender: TObject);
procedure Free2Click(Sender: TObject);
procedure Free3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure UpdateDisplays;
public
{ Public declarations }
end;
var
SingletonForm: TSingletonForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
var
SingleCounter : integer;
MySingleton1: TSingleData;
MySingleton2: TSingleData;
MySingleton3: TSingleData;
procedure TSingletonForm.CnR1Click(Sender: TObject);
begin
if (MySingleton1 <> nil) then
Display1.Text := IntToStr(MySingleton1.TheData);
end;
procedure TSingletonForm.CnR2Click(Sender: TObject);
begin
if (MySingleton2 <> nil) then
Display2.Text := IntToStr(MySingleton2.TheData);
end;
procedure TSingletonForm.CnR3Click(Sender: TObject);
begin
if (MySingleton3 <> nil) then
Display3.Text := IntToStr(MySingleton3.TheData);
end;
procedure TSingletonForm.Set1Click(Sender: TObject);
begin
if (MySingleton1 = nil) then
exit;
MySingleton1.TheData := Strtoint(Display1.text);
UpdateDisplays;
end;
procedure TSingletonForm.Set2Click(Sender: TObject);
begin
if (MySingleton2 = nil) then
exit;
MySingleton2.TheData := Strtoint(Display2.text);
UpdateDisplays;
end;
procedure TSingletonForm.Set3Click(Sender: TObject);
begin
if (MySingleton3 = nil) then
exit;
MySingleton3.TheData := Strtoint(Display3.text);
UpdateDisplays;
end;
procedure TSingletonForm.Create1Click(Sender: TObject);
begin
if (MySingleton1 = nil) then begin
MySingleton1 := TSingleData.create;
SingleCounter := SingleCounter + 1;
Counter.Text := Inttostr(SingleCounter);
Display1.Text := IntToStr(MySingleton1.TheData);
Ref1.Text := 'ref exists';
end
end;
procedure TSingletonForm.Create2Click(Sender: TObject);
begin
if (MySingleton2 = nil) then begin
MySingleton2 := TSingleData.create;
SingleCounter := SingleCounter + 1;
Counter.Text := Inttostr(SingleCounter);
Display2.Text := IntToStr(MySingleton2.TheData);
Ref2.Text := 'ref exists';
end
end;
procedure TSingletonForm.Create3Click(Sender: TObject);
begin
if (MySingleton3 = nil) then begin
MySingleton3 := TSingleData.create;
SingleCounter := SingleCounter + 1;
Counter.Text := Inttostr(SingleCounter);
Display3.Text := IntToStr(MySingleton3.TheData);
Ref3.Text := 'ref exists';
end
end;
procedure TSingletonForm.Free1Click(Sender: TObject);
begin
if (MySingleton1 = nil) then
exit;
MySingleton1.free;
MySingleton1 := nil;
if (SingleCounter > 0) then
SingleCounter := SingleCounter - 1;
Counter.Text := Inttostr(SingleCounter);
Display1.Text := '(empty)';
Ref1.Text := 'ref is nil';
end;
procedure TSingletonForm.Free2Click(Sender: TObject);
begin
if (MySingleton2 = nil) then
exit;
MySingleton2.free;
MySingleton2 := nil;
if (SingleCounter > 0) then
SingleCounter := SingleCounter - 1;
Counter.Text := Inttostr(SingleCounter);
Display2.Text := '(empty)';
Ref2.Text := 'ref is nil';
end;
procedure TSingletonForm.Free3Click(Sender: TObject);
begin
if (MySingleton3 = nil) then
exit;
MySingleton3.free;
MySingleton3 := nil;
if (SingleCounter > 0) then
SingleCounter := SingleCounter - 1;
Counter.Text := Inttostr(SingleCounter);
Display3.Text := '(empty)';
Ref3.Text := 'ref is nil';
end;
procedure TSingletonForm.FormCreate(Sender: TObject);
begin
SingleCounter := 0;
end;
procedure TSingletonForm.UpdateDisplays;
begin
if (MySingleton1 <> nil) then
Display1.Text := IntToStr(MySingleton1.TheData);
if (MySingleton2 <> nil) then
Display2.Text := IntToStr(MySingleton2.TheData);
if (MySingleton3 <> nil) then
Display3.Text := IntToStr(MySingleton3.TheData);
end;
end.

14
components/systools/laz_systools.lpk
View File

@ -16,7 +16,7 @@
<Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - runtime package"/>
<License Value="MPL 1.1"/>
<Version Major="4" Release="4"/>
<Files Count="56">
<Files Count="59">
<Item1>
<Filename Value="source\run\stbarc.pas"/>
<UnitName Value="StBarC"/>
@ -241,6 +241,18 @@
<Filename Value="source\run\stnvscol.pas"/>
<UnitName Value="StNVSCol"/>
</Item56>
<Item57>
<Filename Value="source\run\stptrns.pas"/>
<UnitName Value="StPtrns"/>
</Item57>
<Item58>
<Filename Value="source\run\stmerge.pas"/>
<UnitName Value="StMerge"/>
</Item58>
<Item59>
<Filename Value="source\run\sttxtdat.pas"/>
<UnitName Value="StTxtDat"/>
</Item59>
</Files>
<RequiredPkgs Count="2">
<Item1>

2
components/systools/laz_systools.pas
View File

@ -14,7 +14,7 @@ uses
StAstro, StEclpse, StList, StMerc, StAstroP, StVenus, StMars, StJup,
StSaturn, StUranus, StNeptun, StPluto, StJupsat, StBits, StColl, StDQue,
StVArr, StPQueue, StTree, StNVCont, StNVTree, StNVBits, StNVColl, StNVDict,
StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol;
StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol, StPtrns, StMerge, StTxtDat;
implementation

30
components/systools/laz_systools_design.lpk
View File

@ -17,20 +17,27 @@
<Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - designtime package."/>
<License Value="MPL-1.1"/>
<Version Major="4" Release="4"/>
<Files Count="1">
<Files Count="2">
<Item1>
<Filename Value="source\design\StReg.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="StReg"/>
</Item1>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="laz_systools"/>
<Filename Value="source\design\stproped.pas"/>
<UnitName Value="StPropEd"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
<Filename Value="source\design\streg.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="StReg"/>
</Item2>
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
<Item2>
<PackageName Value="laz_systools"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
@ -38,5 +45,8 @@
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<CustomOptions Items="ExternHelp" Version="2">
<_ExternHelp Items="Count"/>
</CustomOptions>
</Package>
</CONFIG>

2
components/systools/laz_systools_design.pas
View File

@ -8,7 +8,7 @@ unit laz_systools_design;
interface
uses
StReg, LazarusPackageIntf;
StPropEd, StReg, LazarusPackageIntf;
implementation

6
components/systools/laz_systoolsdb_design.lpk
View File

@ -11,7 +11,7 @@
<SearchPaths>
<IncludeFiles Value="source\design"/>
<OtherUnitFiles Value="source\design"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Lazarus port of TurboPower SysTools database components - designtime package"/>
@ -19,9 +19,9 @@
<Version Major="4" Release="4"/>
<Files Count="1">
<Item1>
<Filename Value="source\design\StRegDb.pas"/>
<Filename Value="source\design\stregdb.pas"/>
<HasRegisterProc Value="True"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="StRegDb"/>
</Item1>
</Files>
<RequiredPkgs Count="3">

137
components/systools/source/design/stproped.pas Normal file
View File

@ -0,0 +1,137 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* SysTools: StPropEd.pas 4.04 *}
{*********************************************************}
{* SysTools: Property Editors *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StPropEd;
interface
uses
Dialogs,
{$IFDEF FPC}
PropEdits,
{$ELSE}
{$IFDEF VERSION6}
DesignIntf,
DesignEditors,
{$ELSE}
DsgnIntf,
{$ENDIF}
{$ENDIF}
Forms,
Controls;
type
TStFileNameProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
TStGenericFileNameProperty = class(TStringProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure Edit; override;
end;
implementation
function TStFileNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
procedure TStFileNameProperty.Edit;
var
Dlg : TOpenDialog;
begin
Dlg := TOpenDialog.Create(Application);
try
Dlg.DefaultExt := '*.exe';
Dlg.Filter := 'Executable Files (*.exe)|*.exe' +
'|Dynamic Link Libraries (*.dll)|*.dll';
Dlg.FilterIndex := 0;
Dlg.Options := [];
if GetName = 'ShortcutFileName' then
Dlg.Options := [ofNoDereferenceLinks];
{$IFDEF FPC}
Dlg.FileName := GetValue;
if Dlg.Execute then
SetValue(Dlg.Filename);
{$ELSE}
Dlg.FileName := Value;
if Dlg.Execute then
Value := Dlg.FileName;
{$ENDIF}
finally
Dlg.Free;
end;
end;
function TStGenericFileNameProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog];
end;
procedure TStGenericFileNameProperty.Edit;
var
Dlg : TOpenDialog;
begin
Dlg := TOpenDialog.Create(Application);
try
Dlg.DefaultExt := '*.*';
Dlg.Filter := 'Text files (*.txt)|*.txt' +
'|Pascal files (.pas)|*.pas' +
'|C++ files (*.cpp)|*.cpp' +
'|All files (*.*)|*.*';
Dlg.FilterIndex := 0;
Dlg.Options := [];
{$IFDEF FPC}
Dlg.FileName := GetValue;
if Dlg.Execute then
SetValue(Dlg.FileName);
{$ELSE}
Dlg.FileName := Value;
if Dlg.Execute then
Value := Dlg.FileName;
{$ENDIF}
finally
Dlg.Free;
end;
end;
end.

21
components/systools/source/design/StReg.pas → components/systools/source/design/streg.pas
View File

@ -31,16 +31,16 @@
//{$I StDefine.inc}
{$R StReg.r32}
{$R streg.r32}
unit StReg;
interface
uses
Classes
Classes,
{$IFDEF FPC}
;//PropEdits //, LazarusPackageIntf //, FieldsEditor, ComponentEditors
PropEdits //, LazarusPackageIntf //, FieldsEditor, ComponentEditors
{$ELSE}
{$IFDEF VERSION6}
DesignIntf,
@ -49,6 +49,7 @@ uses
DsgnIntfM
{$ENDIF}
{$ENDIF}
;
procedure Register;
@ -149,14 +150,14 @@ uses
StVenus,
{ new units in ver 4: }
StIniStm,
(*
StMerge,
(*
StSystem,
*)
StTxtDat,
StDecMth,
*)
StMoney,
StRandom
StRandom,
(*
StNTLog,
{ !!! StExpEng unit designed to handle problem with initialization }
@ -165,12 +166,10 @@ uses
{StExpEng,}
StExpLog,
StGenLog,
*)
StPtrns,
{^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^}
StPropEd
*);
StPropEd;
procedure Register;
begin
@ -183,6 +182,7 @@ begin
TStVersionProperty);
RegisterPropertyEditor(TypeInfo(string), TStPNBarCode, 'Version',
TStVersionProperty);
*)
RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'InputFile',
TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'OutputFile',
@ -191,6 +191,7 @@ begin
TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStFileToHTML, 'OutFileName',
TStGenericFileNameProperty);
(*
RegisterPropertyEditor(TypeInfo(string), TStVersionInfo, 'FileName',
TStFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStSpawnApplication, 'FileName',

0
components/systools/source/design/StReg.rc → components/systools/source/design/streg.rc
View File

2
components/systools/source/design/StRegDb.pas → components/systools/source/design/stregdb.pas
View File

@ -34,7 +34,7 @@
{$ENDIF}
//{$I StDefine.inc}
{$R StRegDb.r32}
{$R stregdb.r32}
unit StRegDb;

0
components/systools/source/design/StRegDb.rc → components/systools/source/design/stregdb.rc
View File

457
components/systools/source/run/stmerge.pas Normal file
View File

@ -0,0 +1,457 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* SysTools: StMerge.pas 4.04 *}
{*********************************************************}
{* SysTools: "Mail Merge" functionality *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$include StDefine.inc}
unit StMerge;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils, Classes;
const
StDefaultTagStart = '<';
StDefaultTagEnd = '>';
StDefaultEscapeChar = '\';
type
TStGotMergeTagEvent = procedure (Sender : TObject; Tag : AnsiString;
var Value : AnsiString; var Discard : Boolean) of object;
TStMergeProgressEvent = procedure (Sender : TObject; Index : Integer; var Abort : Boolean);
TStTextMerge = class
private
FBadTag: AnsiString;
FDefaultTags: TStrings;
FEscapeChar: AnsiChar;
FMergedText : TStrings;
FMergeTags: TStrings;
FTagEnd: AnsiString;
FTagStart: AnsiString;
FTemplate : TStrings;
FOnMergeStart: TNotifyEvent;
FOnMergeDone: TNotifyEvent;
FOnLineStart: TStMergeProgressEvent;
FOnLineDone: TStMergeProgressEvent;
FOnGotMergeTag: TStGotMergeTagEvent;
FOnGotUnknownTag: TStGotMergeTagEvent;
protected {private}
procedure DoGotUnknownTag(Tag: AnsiString; var Value: AnsiString;
var Discard: Boolean);
procedure DoGotMergeTag(Tag : AnsiString; var Value : AnsiString;
var Discard : Boolean);
procedure SetEscapeChar(const Value: AnsiChar);
procedure SetTagEnd(const Value: AnsiString);
procedure SetTagStart(const Value: AnsiString);
public
constructor Create;
destructor Destroy; override;
{ Access and Update Methods }
procedure Merge;
{ Persistence and streaming methods }
{template }
procedure LoadTemplateFromFile(const AFile : TFileName);
procedure LoadTemplateFromStream(AStream : TStream);
procedure SaveTemplateToFile(const AFile : TFileName);
procedure SaveTemplateToStream(AStream : TStream);
{ merge result text }
procedure SaveMergeToFile(const AFile : TFileName);
procedure SaveMergeToStream(AStream : TStream);
{ properties }
property BadTag : AnsiString
read FBadTag write FBadTag;
property DefaultTags : TStrings
read FDefaultTags;
property EscapeChar : AnsiChar
read FEscapeChar write SetEscapeChar;
property MergedText : TStrings
read FMergedText;
property MergeTags : TStrings
read FMergeTags;
property TagEnd : AnsiString
read FTagEnd write SetTagEnd;
property TagStart : AnsiString
read FTagStart write SetTagStart;
property Template : TStrings
read FTemplate;
{ events }
property OnGotMergeTag : TStGotMergeTagEvent
read FOnGotMergeTag write FOnGotMergeTag;
property OnGotUnknownTag : TStGotMergeTagEvent
read FOnGotUnknownTag write FOnGotUnknownTag;
property OnLineDone : TStMergeProgressEvent
read FOnLineDone write FOnLineDone;
property OnLineStart : TStMergeProgressEvent
read FOnLineStart write FOnLineStart;
property OnMergeDone : TNotifyEvent
read FOnMergeDone write FOnMergeDone;
property OnMergeStart : TNotifyEvent
read FOnMergeStart write FOnMergeStart;
end;
implementation
{ TStTextMerge }
constructor TStTextMerge.Create;
begin
inherited Create;
FDefaultTags := TStringList.Create;
FMergeTags := TStringList.Create;
FMergedText := TStringList.Create;
FTemplate := TStringList.Create;
FTagEnd := StDefaultTagEnd;
FTagStart := StDefaultTagStart;
FEscapeChar := StDefaultEscapeChar;
FBadTag := '';
end;
destructor TStTextMerge.Destroy;
begin
FDefaultTags.Free;
FMergeTags.Free;
FMergedText.Free;
FTemplate.Free;
inherited Destroy;
end;
procedure TStTextMerge.DoGotMergeTag(Tag : AnsiString;
var Value : AnsiString; var Discard : Boolean);
begin
if Assigned(FOnGotMergeTag) then
FOnGotMergeTag(self, Tag, Value, Discard);
end;
procedure TStTextMerge.DoGotUnknownTag(Tag : AnsiString;
var Value : AnsiString; var Discard : Boolean);
begin
if Assigned(FOnGotUnknownTag) then
FOnGotUnknownTag(self, Tag, Value, Discard)
else
Value := FBadTag;
end;
procedure TStTextMerge.LoadTemplateFromFile(const AFile: TFileName);
var
FS : TFileStream;
begin
FS := TFileStream.Create(AFile, fmOpenRead or fmShareDenyNone);
try
LoadTemplateFromStream(FS);
finally
FS.Free;
end;
end;
procedure TStTextMerge.LoadTemplateFromStream(AStream: TStream);
begin
FTemplate.Clear;
FTemplate.LoadFromStream(AStream);
end;
procedure TStTextMerge.Merge;
{ merge template with current DataTags }
const
TagIDChars = ['A'..'Z', 'a'..'z', '0'..'9', '_'];
function MatchDelim(Delim : AnsiString; var PC : PAnsiChar) : Boolean;
{ see if current sequence matches specified Tag delimiter }
var
Match : PAnsiChar;
Len : Integer;
begin
{ compare text starting at PC with Tag delimiter }
Len := Length(Delim);
GetMem(Match, Len + 1);
FillChar(Match^, Len + 1, #0);
StrLCopy(Match, PC, Len);
Result := StrPas(Match) = Delim;
if Result then
Inc(PC, Len); {advance past Tag delimiter }
FreeMem(Match, Len + 1);
end;
function GetTag(const Tag: AnsiString; var Discard : Boolean) : AnsiString;
var
IdxMerge, IdxDef : Integer;
TagID : AnsiString;
begin
{ extract TagID from delimiters }
TagID := Copy(Tag, Length(TagStart) + 1, Length(Tag));
TagID := Copy(TagID, 1, Length(TagID) - Length(TagEnd));
{ see if it matches Tag in MergeTags or DefaultTags }
IdxMerge := FMergeTags.IndexOfName(TagID);
IdxDef := FDefaultTags.IndexOfName(TagID);
{ fire events as needed }
if (IdxMerge < 0) and (IdxDef < 0) then begin { no match }
DoGotUnknownTag(TagID, Result, Discard)
end
else begin { found match }
if (IdxMerge > -1) then begin { match in MergeTags }
Result := FMergeTags.Values[TagID];
DoGotMergeTag(TagID, Result, Discard);
end
else { not in MergTags, use Default }
if (IdxDef > -1) then begin
Result := FDefaultTags.Values[TagID];
DoGotMergeTag(TagID, Result, Discard);
end;
end;
end;
procedure ReplaceTags(Idx : Integer);
type
TagSearchStates = (fsCollectingText, fsCollectingTagID);
var
i, Len : Integer;
P, Cur : PAnsiChar;
Buff, NewBuff, TagBuff, DataBuff, TextBuff : AnsiString;
State : TagSearchStates;
FS, FE, Prev : AnsiChar;
{Escaped,} Discard : Boolean;
begin
{ copy current template line }
Buff := FTemplate[Idx];
Len := Length(Buff);
{ output line starts empty }
NewBuff := '';
TagBuff := '';
TextBuff := '';
{ starts of delimiter strings }
FS := FTagStart[1];
FE := FTagEnd[1];
Prev := ' ';
{ point at start of current line }
P := PAnsiChar(Buff);
Cur := P;
{ start looking for Tags }
State := fsCollectingText;
for i := 1 to Len do begin
case State of
{ accumulating non-Tag text }
fsCollectingText: begin
{ matching the start of a Tag? }
if (Cur^ = FS) and (Prev <> EscapeChar) and
MatchDelim(FTagStart, Cur) then
begin
{ dump what we've got }
NewBuff := NewBuff + TextBuff;
TextBuff := '';
{ start accumulating a TagID }
TagBuff := TagStart;
State := fsCollectingTagID;
end
else
if (Cur^ = FS) and (Prev = EscapeChar) and
MatchDelim(FTagStart, Cur) then
begin
{ overwrite escape character }
TextBuff[Length(TextBuff)] := Cur^;
{ go to next character }
Prev := Cur^;
Inc(Cur);
end
else
{ accumulate text }
begin
TextBuff := TextBuff + Cur^;
{ go to next character }
Prev := Cur^;
Inc(Cur);
end;
end;
{ accumulating a possible Tag }
fsCollectingTagID: begin
{ matching the end of a Tag? }
if (Cur^ = FE) and (Prev <> EscapeChar) and
MatchDelim(FTagEnd, Cur) then
begin
{ insert Tag value in place of TagID }
TagBuff := TagBuff + TagEnd;
DataBuff := GetTag(TagBuff, Discard);
if not Discard then
NewBuff := NewBuff + DataBuff;
{ switch back to accumulating non-Tag text }
State := fsCollectingText;
end
else
{ accumulate TagID }
if (Cur^ in TagIDChars) then begin
TagBuff := TagBuff + Cur^;
{ go to next character }
Prev := Cur^;
Inc(Cur);
end
else
{ doesn't look like a TagID; pass it back to text collection logic }
begin
{ turn the "failed Tag" into regular accumulated text }
TextBuff := TagBuff + Cur^;
TagBuff := '';
{ go to next character }
Prev := Cur^;
Inc(Cur);
{ switch back to accumulating non-Tag text }
State := fsCollectingText;
end;
end;
end; {case State}
end; {for}
{ append anything remaining }
if State = fsCollectingText then
NewBuff := NewBuff + TextBuff
else
NewBuff := NewBuff + TagBuff;
{ update merge text with current line }
FMergedText.Add(NewBuff);
end;
var
i : Integer;
Abort : Boolean;
begin
{ notify start of merge }
if Assigned(FOnMergeStart) then
FOnMergeStart(self);
FMergedText.Clear;
Abort := False;
{ iterate Template }
for i := 0 to Pred(FTemplate.Count) do begin
if Assigned(FOnLineStart) then
FOnLineStart(self, i, Abort);
if Abort then Break;
ReplaceTags(i);
if Assigned(FOnLineDone) then
FOnLineDone(self, i, Abort);
if Abort then Break;
end; {for}
{ notify end of merge }
if Assigned(FOnMergeDone) then
FOnMergeDone(self);
end;
procedure TStTextMerge.SaveMergeToFile(const AFile: TFileName);
var
FS : TFileStream;
begin
FS := TFileStream.Create(AFile, fmCreate);
try
SaveMergeToStream(FS);
finally
FS.Free;
end;
end;
procedure TStTextMerge.SaveMergeToStream(AStream: TStream);
begin
FMergedText.SaveToStream(AStream);
end;
procedure TStTextMerge.SaveTemplateToFile(const AFile: TFileName);
var
FS : TFileStream;
begin
FS := TFileStream.Create(AFile, fmCreate);
try
SaveTemplateToStream(FS);
finally
FS.Free;
end;
end;
procedure TStTextMerge.SaveTemplateToStream(AStream: TStream);
begin
FTemplate.SaveToStream(AStream);
end;
procedure TStTextMerge.SetEscapeChar(const Value: AnsiChar);
begin
FEscapeChar := Value;
end;
procedure TStTextMerge.SetTagEnd(const Value: AnsiString);
begin
FTagEnd := Value;
end;
procedure TStTextMerge.SetTagStart(const Value: AnsiString);
begin
FTagStart := Value;
end;
end.

508
components/systools/source/run/stptrns.pas Normal file
View File

@ -0,0 +1,508 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* SysTools: StPtrns.pas 4.04 *}
{*********************************************************}
{* SysTools: Pattern Classes *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$include StDefine.inc}
unit StPtrns;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LCLProc,
{$ELSE}
Windows,
{$ENDIF}
SysUtils, Classes;
{------ S I N G L E T O N ---------------------}
type
TStSingleton = class(TObject)
private
FRefCount : integer;
protected
public
class function NewInstance : TObject; override;
procedure FreeInstance; override;
procedure AllocResources; virtual;
procedure FreeResources; virtual;
end;
{------ M E D I A T O R ------------------------}
type
TStMediatorAction = procedure(aInputData, aResultData : TObject) of object;
TStMediator = class
private
FEventTable : TStringList;
protected
function GetCount : Integer;
public
constructor Create;
destructor Destroy; override;
procedure Add(const aEventName : string; aHandler : TStMediatorAction);
procedure Remove(const aEventName : string);
procedure Handle(const aEventName : string; aInputData, aResultData : TObject);
function IsHandled(const aEventName : string) : boolean;
property Count : Integer read GetCount;
end;
{-------O B S E R V E R ------------------------}
type
TStObserverAction = procedure(aInputData : TObject) of object;
TStObserver = class
private
FEventTable : TList;
protected
function GetObserver(Index : Integer) : TStObserverAction;
procedure SetObserver(Index : Integer; InObserver : TStObserverAction);
function GetCount : Integer;
public
constructor Create;
destructor Destroy; override;
procedure Add(aHandler : TStObserverAction);
procedure Remove(aIndex : Integer);
procedure Notify(aInputData : TObject);
property Handler[aIndex : Integer] : TStObserverAction
read GetObserver write SetObserver;
property Count : Integer read GetCount;
end;
{------- C H A I N ---------------------------------}
type
TStChainAction = procedure(aInputData, aResultData : TObject; var aStopNow : boolean) of object;
TStChain = class
private
FEventTable : TList;
protected
function GetHandler(Index : Integer) : TStChainAction;
procedure SetHandler(Index : Integer; InHandler : TStChainAction);
function GetCount : Integer;
public
constructor Create;
destructor Destroy; override;
procedure Add(aHandler : TStChainAction);
procedure Remove(aIndex : Integer);
procedure Handle(aInputData, aResultData : TObject);
procedure Insert(aIndex : Integer; aHandler : TStChainAction);
property Handler[aIndex : Integer] : TStChainAction
read GetHandler write SetHandler;
property Count : Integer read GetCount;
end;
{====================================================================}
{====================================================================}
implementation
{------ S I N G L E T O N ---------------------}
var
Instances : TStringList;
SingletonLock : {$IFDEF FPC}TCriticalSection{$ELSE}TRTLCriticalSection{$ENDIF};
procedure TStSingleton.AllocResources;
begin
{nothing at this level}
end;
{--------}
procedure TStSingleton.FreeInstance;
var
Temp : pointer;
Inx : integer;
begin
EnterCriticalSection(SingletonLock);
try
dec(FRefCount);
if (FRefCount = 0) then begin
FreeResources;
Temp := Self;
CleanupInstance;
if Instances.Find(ClassName, Inx) then
Instances.Delete(Inx);
FreeMem(Temp);
end;
finally
LeaveCriticalSection(SingletonLock);
end;
end;
{--------}
procedure TStSingleton.FreeResources;
begin
{nothing at this level}
end;
{--------}
class function TStSingleton.NewInstance : TObject;
var
Inx : integer;
begin
EnterCriticalSection(SingletonLock);
try
if not Instances.Find(ClassName, Inx) then begin
GetMem(pointer(Result), InstanceSize);
InitInstance(Result);
Instances.AddObject(ClassName, Result);
TStSingleton(Result).AllocResources;
end
else
Result := Instances.Objects[Inx];
inc(TStSingleton(Result).FRefCount);
finally
LeaveCriticalSection(SingletonLock);
end;
end;
{====================================================================}
{------ M E D I A T O R ------------------------}
{The action holder is a class that encapsulates the action method}
type
TStMedActionHolder = class(TObject)
private
FAction : TStMediatorAction;
public
property Action : TStMediatorAction read FAction write FAction;
end;
{--------}
constructor TStMediator.Create;
begin
inherited Create;
FEventTable := TStringList.Create;
FEventTable.Sorted := true;
end;
destructor TStMediator.Destroy;
var
i : integer;
begin
if (FEventTable <> nil) then begin
for i := 0 to pred(FEventTable.Count) do
FEventTable.Objects[i].Free;
FEventTable.Free;
end;
inherited Destroy;
end;
procedure TStMediator.Add(const aEventName : string; aHandler : TStMediatorAction);
var
MedAction : TStMedActionHolder;
begin
MedAction := TStMedActionHolder.Create;
MedAction.Action := aHandler;
if (FEventTable.AddObject(aEventName, MedAction) = -1) then begin
MedAction.Free;
raise Exception.Create(
Format('TStMediator.Add: event name [%s] already exists',
[aEventName]));
end;
end;
function TStMediator.GetCount : Integer;
begin
Result := FEventTable.Count;
end;
procedure TStMediator.Handle(const aEventName : string; aInputData, aResultData : TObject);
var
Index : Integer;
MediatorActionHolder : TStMedActionHolder;
begin
Index := FEventTable.IndexOf(aEventName);
if (Index < 0) then
raise Exception.Create(
Format('TStMediator.Handle: event name [%s] not found',
[aEventName]));
MediatorActionHolder := TStMedActionHolder(FEventTable.Objects[Index]);
MediatorActionHolder.Action(aInputData, aResultData);
end;
function TStMediator.IsHandled(const aEventName : string) : boolean;
var
Index : Integer;
begin
Result := FEventTable.Find(aEventName, Index);
end;
procedure TStMediator.Remove(const aEventName : string);
var
Index : Integer;
begin
Index := FEventTable.IndexOf(aEventName);
if (Index >= 0) then begin
FEventTable.Objects[Index].Free;
FEventTable.Delete(Index);
end;
end;
{====================================================================}
{-------O B S E R V E R ------------------------}
{The action holder is a class that encapsulates the action method}
type
TStObActionHolder = class(TObject)
private
FAction : TStObserverAction;
public
property Action : TStObserverAction read FAction write FAction;
end;
{--------}
constructor TStObserver.Create;
begin
inherited Create;
FEventTable := TList.Create;
end;
destructor TStObserver.Destroy;
var
i : integer;
begin
if (FEventTable <> nil) then begin
for i := 0 to pred(FEventTable.Count) do
TStObActionHolder(FEventTable[i]).Free;
FEventTable.Free;
end;
inherited Destroy;
end;
procedure TStObserver.Add(aHandler : TStObserverAction);
var
ObsAction : TStObActionHolder;
begin
ObsAction := TStObActionHolder.Create;
try
ObsAction.Action := aHandler;
FEventTable.Add(TObject(ObsAction));
except
ObsAction.Free;
raise;
end;
end;
function TStObserver.GetCount : Integer;
begin
Result := FEventTable.Count;
end;
function TStObserver.GetObserver(Index : Integer) : TStObserverAction;
var
ObserverHolder : TStObActionHolder;
begin
Assert((Index >= 0) and (Index < FEventTable.Count),
Format('TStObserver.GetObserver: Invalid index value: %d', [Index]));
ObserverHolder := TStObActionHolder(FEventTable.Items[Index]);
Result := ObserverHolder.Action;
end;
procedure TStObserver.Notify(aInputData : TObject);
var
Index : integer;
ObserverHolder : TStObActionHolder;
begin
for Index := 0 to FEventTable.Count-1 do begin
ObserverHolder := TStObActionHolder(FEventTable.Items[Index]);
ObserverHolder.Action(aInputData);
end;
end;
procedure TStObserver.Remove(aIndex : Integer);
begin
Assert((aIndex >= 0) and (aIndex < FEventTable.Count),
Format('TStObserver.Remove: Invalid index value: %d', [aIndex]));
TStObActionHolder(FEventTable.Items[aIndex]).Free;
FEventTable.Delete(aIndex);
end;
procedure TStObserver.SetObserver(Index : Integer;
InObserver : TStObserverAction);
begin
Assert((Index >= 0) and (Index < FEventTable.Count),
Format('TStObserver.SetObserver: Invalid index value: %d', [Index]));
TStObActionHolder(FEventTable.Items[Index]).Action := InObserver;
end;
{====================================================================}
{------- C H A I N ---------------------------------}
{The action holder is a class that encapsulates the action method}
type
TStChActionHolder = class(TObject)
private
FAction : TStChainAction;
public
property Action : TStChainAction read FAction write FAction;
end;
{--------}
constructor TStChain.Create;
begin
inherited Create;
FEventTable := TList.create;
end;
destructor TStChain.Destroy;
var
i : integer;
begin
if (FEventTable <> nil) then begin
for i := 0 to pred(FEventTable.Count) do
TStChActionHolder(FEventTable[i]).Free;
FEventTable.Free;
end;
inherited Destroy;
end;
procedure TStChain.Add(aHandler : TStChainAction);
var
ChainAction : TStChActionHolder;
begin
ChainAction := TStChActionHolder.Create;
try
ChainAction.Action := aHandler;
FEventTable.Add(TObject(ChainAction));
except
ChainAction.Free;
raise;
end;
end;
function TStChain.GetCount : Integer;
begin
Result := FEventTable.Count;
end;
function TStChain.GetHandler(Index : Integer) : TStChainAction;
var
ChainAction : TStChActionHolder;
begin
Assert((Index >= 0) and (Index < FEventTable.Count),
Format('TStChain.GetHandler: Invalid index value: %d', [Index]));
ChainAction := TStChActionHolder(FEventTable.Items[Index]);
Result := ChainAction.Action;
end;
procedure TStChain.Handle(aInputData, aResultData : TObject);
var
Index : integer;
Stop : boolean;
ChainAction : TStChActionHolder;
begin
Stop := false;
for Index := 0 to (FEventTable.Count - 1) do begin
ChainAction := TStChActionHolder(FEventTable.Items[Index]);
ChainAction.Action(aInputData, aResultData, Stop);
if Stop then
Exit;
end;
end;
procedure TStChain.Insert(aIndex : integer; aHandler : TStChainAction);
var
ChainAction : TStChActionHolder;
begin
ChainAction := TStChActionHolder.Create;
try
ChainAction.Action := aHandler;
FEventTable.Insert(aIndex, ChainAction);
except
ChainAction.Free;
raise;
end;
end;
procedure TStChain.Remove(aIndex : Integer);
begin
Assert((aIndex >= 0) and (aIndex < FEventTable.Count),
Format('TStChain.Remove: Invalid index value: %d', [aIndex]));
TStChActionHolder(FEventTable.Items[aIndex]).Free;
FEventTable.Delete(aIndex);
end;
procedure TStChain.SetHandler(Index : Integer; InHandler : TStChainAction);
begin
Assert((Index >= 0) and (Index < FEventTable.Count),
Format('TStObserver.SetObserver: Invalid index value: %d', [Index]));
TStChActionHolder(FEventTable.Items[Index]).Action := InHandler;
end;
procedure InitUnit;
begin
InitializeCriticalSection(SingletonLock);
Instances := TStringList.Create;
Instances.Sorted := true;
end;
procedure DoneUnit;
var
i : integer;
OldCount : integer;
begin
EnterCriticalSection(SingletonLock);
{continue 'freeing' the last singleton object in the Instances
stringlist until its FreeInstance method actually frees the object
and removes the class name from the stringlist: we detect this
condition by the fact that the number of items in the stringlist
decreases.}
OldCount := Instances.Count;
for i := pred(OldCount) downto 0 do begin
repeat
Instances.Objects[i].Free;
until (Instances.Count <> OldCount);
OldCount := Instances.Count;
end;
{free the global variables}
Instances.Free;
DeleteCriticalSection(SingletonLock);
end;
initialization
InitUnit;
finalization
DoneUnit;
end.

1859
components/systools/source/run/sttxtdat.pas Normal file
View File

File diff suppressed because it is too large Load Diff