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

2
components/systools/laz_systools.pas
View File

@@ -14,7 +14,7 @@ uses
StAstro, StEclpse, StList, StMerc, StAstroP, StVenus, StMars, StJup, StAstro, StEclpse, StList, StMerc, StAstroP, StVenus, StMars, StJup,
StSaturn, StUranus, StNeptun, StPluto, StJupsat, StBits, StColl, StDQue, StSaturn, StUranus, StNeptun, StPluto, StJupsat, StBits, StColl, StDQue,
StVArr, StPQueue, StTree, StNVCont, StNVTree, StNVBits, StNVColl, StNVDict, StVArr, StPQueue, StTree, StNVCont, StNVTree, StNVBits, StNVColl, StNVDict,
StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol; StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol, StPtrns, StMerge, StTxtDat;
implementation 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."/> <Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - designtime package."/>
<License Value="MPL-1.1"/> <License Value="MPL-1.1"/>
<Version Major="4" Release="4"/> <Version Major="4" Release="4"/>
<Files Count="1"> <Files Count="2">
<Item1> <Item1>
<Filename Value="source\design\StReg.pas"/> <Filename Value="source\design\stproped.pas"/>
<HasRegisterProc Value="True"/> <UnitName Value="StPropEd"/>
<UnitName Value="StReg"/>
</Item1>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1> </Item1>
<Item2> <Item2>
<PackageName Value="FCL"/> <Filename Value="source\design\streg.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="StReg"/>
</Item2> </Item2>
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
<Item2>
<PackageName Value="laz_systools"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
</Item3>
</RequiredPkgs> </RequiredPkgs>
<UsageOptions> <UsageOptions>
<UnitPath Value="$(PkgOutDir)"/> <UnitPath Value="$(PkgOutDir)"/>
@@ -38,5 +45,8 @@
<PublishOptions> <PublishOptions>
<Version Value="2"/> <Version Value="2"/>
</PublishOptions> </PublishOptions>
<CustomOptions Items="ExternHelp" Version="2">
<_ExternHelp Items="Count"/>
</CustomOptions>
</Package> </Package>
</CONFIG> </CONFIG>

2
components/systools/laz_systools_design.pas
View File

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

6
components/systools/laz_systoolsdb_design.lpk
View File

@@ -11,7 +11,7 @@
<SearchPaths> <SearchPaths>
<IncludeFiles Value="source\design"/> <IncludeFiles Value="source\design"/>
<OtherUnitFiles Value="source\design"/> <OtherUnitFiles Value="source\design"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths> </SearchPaths>
</CompilerOptions> </CompilerOptions>
<Description Value="Lazarus port of TurboPower SysTools database components - designtime package"/> <Description Value="Lazarus port of TurboPower SysTools database components - designtime package"/>
@@ -19,9 +19,9 @@
<Version Major="4" Release="4"/> <Version Major="4" Release="4"/>
<Files Count="1"> <Files Count="1">
<Item1> <Item1>
<Filename Value="source\design\StRegDb.pas"/> <Filename Value="source\design\stregdb.pas"/>
<HasRegisterProc Value="True"/> <HasRegisterProc Value="True"/>
<AddToUsesPkgSection Value="False"/> <UnitName Value="StRegDb"/>
</Item1> </Item1>
</Files> </Files>
<RequiredPkgs Count="3"> <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} //{$I StDefine.inc}
{$R StReg.r32} {$R streg.r32}
unit StReg; unit StReg;
interface interface
uses uses
Classes Classes,
{$IFDEF FPC} {$IFDEF FPC}
;//PropEdits //, LazarusPackageIntf //, FieldsEditor, ComponentEditors PropEdits //, LazarusPackageIntf //, FieldsEditor, ComponentEditors
{$ELSE} {$ELSE}
{$IFDEF VERSION6} {$IFDEF VERSION6}
DesignIntf, DesignIntf,
@@ -49,6 +49,7 @@ uses
DsgnIntfM DsgnIntfM
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
;
procedure Register; procedure Register;
@@ -149,14 +150,14 @@ uses
StVenus, StVenus,
{ new units in ver 4: } { new units in ver 4: }
StIniStm, StIniStm,
(*
StMerge, StMerge,
(*
StSystem, StSystem,
*)
StTxtDat, StTxtDat,
StDecMth, StDecMth,
*)
StMoney, StMoney,
StRandom StRandom,
(* (*
StNTLog, StNTLog,
{ !!! StExpEng unit designed to handle problem with initialization } { !!! StExpEng unit designed to handle problem with initialization }
@@ -165,12 +166,10 @@ uses
{StExpEng,} {StExpEng,}
StExpLog, StExpLog,
StGenLog, StGenLog,
*)
StPtrns, StPtrns,
{^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^} {^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^}
StPropEd StPropEd;
*);
procedure Register; procedure Register;
begin begin
@@ -183,6 +182,7 @@ begin
TStVersionProperty); TStVersionProperty);
RegisterPropertyEditor(TypeInfo(string), TStPNBarCode, 'Version', RegisterPropertyEditor(TypeInfo(string), TStPNBarCode, 'Version',
TStVersionProperty); TStVersionProperty);
*)
RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'InputFile', RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'InputFile',
TStGenericFileNameProperty); TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'OutputFile', RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'OutputFile',
@@ -191,6 +191,7 @@ begin
TStGenericFileNameProperty); TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStFileToHTML, 'OutFileName', RegisterPropertyEditor(TypeInfo(string), TStFileToHTML, 'OutFileName',
TStGenericFileNameProperty); TStGenericFileNameProperty);
(*
RegisterPropertyEditor(TypeInfo(string), TStVersionInfo, 'FileName', RegisterPropertyEditor(TypeInfo(string), TStVersionInfo, 'FileName',
TStFileNameProperty); TStFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStSpawnApplication, 'FileName', 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} {$ENDIF}
//{$I StDefine.inc} //{$I StDefine.inc}
{$R StRegDb.r32} {$R stregdb.r32}
unit StRegDb; 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