diff --git a/components/systools/examples/data_merge/datamerg.lpi b/components/systools/examples/data_merge/datamerg.lpi
new file mode 100644
index 000000000..76fee6471
--- /dev/null
+++ b/components/systools/examples/data_merge/datamerg.lpi
@@ -0,0 +1,83 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/data_merge/datamerg.lpr b/components/systools/examples/data_merge/datamerg.lpr
new file mode 100644
index 000000000..3cd7ea48b
--- /dev/null
+++ b/components/systools/examples/data_merge/datamerg.lpr
@@ -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.
diff --git a/components/systools/examples/data_merge/datamrg0.lfm b/components/systools/examples/data_merge/datamrg0.lfm
new file mode 100644
index 000000000..17bcb1dff
--- /dev/null
+++ b/components/systools/examples/data_merge/datamrg0.lfm
@@ -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
diff --git a/components/systools/examples/data_merge/datamrg0.pas b/components/systools/examples/data_merge/datamrg0.pas
new file mode 100644
index 000000000..9f744ee84
--- /dev/null
+++ b/components/systools/examples/data_merge/datamrg0.pas
@@ -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.
diff --git a/components/systools/examples/grid_fill/data.csv b/components/systools/examples/grid_fill/data.csv
new file mode 100644
index 000000000..5cbae0adb
--- /dev/null
+++ b/components/systools/examples/grid_fill/data.csv
@@ -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
\ No newline at end of file
diff --git a/components/systools/examples/grid_fill/data.sch b/components/systools/examples/grid_fill/data.sch
new file mode 100644
index 000000000..2d310e00c
--- /dev/null
+++ b/components/systools/examples/grid_fill/data.sch
@@ -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="
diff --git a/components/systools/examples/grid_fill/gridfil0.lfm b/components/systools/examples/grid_fill/gridfil0.lfm
new file mode 100644
index 000000000..64d657320
--- /dev/null
+++ b/components/systools/examples/grid_fill/gridfil0.lfm
@@ -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
diff --git a/components/systools/examples/grid_fill/gridfil0.pas b/components/systools/examples/grid_fill/gridfil0.pas
new file mode 100644
index 000000000..f0b50c508
--- /dev/null
+++ b/components/systools/examples/grid_fill/gridfil0.pas
@@ -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.
diff --git a/components/systools/examples/grid_fill/gridfill.lpi b/components/systools/examples/grid_fill/gridfill.lpi
new file mode 100644
index 000000000..cd550a7eb
--- /dev/null
+++ b/components/systools/examples/grid_fill/gridfill.lpi
@@ -0,0 +1,84 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/grid_fill/gridfill.lpr b/components/systools/examples/grid_fill/gridfill.lpr
new file mode 100644
index 000000000..c225c1079
--- /dev/null
+++ b/components/systools/examples/grid_fill/gridfill.lpr
@@ -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.
diff --git a/components/systools/examples/patterns/chain.lfm b/components/systools/examples/patterns/chain.lfm
new file mode 100644
index 000000000..30bdead41
--- /dev/null
+++ b/components/systools/examples/patterns/chain.lfm
@@ -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
diff --git a/components/systools/examples/patterns/chain.pas b/components/systools/examples/patterns/chain.pas
new file mode 100644
index 000000000..1011453fa
--- /dev/null
+++ b/components/systools/examples/patterns/chain.pas
@@ -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.
diff --git a/components/systools/examples/patterns/medtr.lfm b/components/systools/examples/patterns/medtr.lfm
new file mode 100644
index 000000000..56a3aaac2
--- /dev/null
+++ b/components/systools/examples/patterns/medtr.lfm
@@ -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
diff --git a/components/systools/examples/patterns/medtr.pas b/components/systools/examples/patterns/medtr.pas
new file mode 100644
index 000000000..af8c6253d
--- /dev/null
+++ b/components/systools/examples/patterns/medtr.pas
@@ -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.
diff --git a/components/systools/examples/patterns/observer.lfm b/components/systools/examples/patterns/observer.lfm
new file mode 100644
index 000000000..44a9d6aeb
--- /dev/null
+++ b/components/systools/examples/patterns/observer.lfm
@@ -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
diff --git a/components/systools/examples/patterns/observer.pas b/components/systools/examples/patterns/observer.pas
new file mode 100644
index 000000000..d32cf7316
--- /dev/null
+++ b/components/systools/examples/patterns/observer.pas
@@ -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.
diff --git a/components/systools/examples/patterns/patntest.lpi b/components/systools/examples/patterns/patntest.lpi
new file mode 100644
index 000000000..04ab0198d
--- /dev/null
+++ b/components/systools/examples/patterns/patntest.lpi
@@ -0,0 +1,104 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/patterns/patntest.lpr b/components/systools/examples/patterns/patntest.lpr
new file mode 100644
index 000000000..68c0dfcef
--- /dev/null
+++ b/components/systools/examples/patterns/patntest.lpr
@@ -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.
diff --git a/components/systools/examples/patterns/root.lfm b/components/systools/examples/patterns/root.lfm
new file mode 100644
index 000000000..b38d5383c
--- /dev/null
+++ b/components/systools/examples/patterns/root.lfm
@@ -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
diff --git a/components/systools/examples/patterns/root.pas b/components/systools/examples/patterns/root.pas
new file mode 100644
index 000000000..1e6ae3b4b
--- /dev/null
+++ b/components/systools/examples/patterns/root.pas
@@ -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.
diff --git a/components/systools/examples/patterns/singlton.lfm b/components/systools/examples/patterns/singlton.lfm
new file mode 100644
index 000000000..1bd659c54
--- /dev/null
+++ b/components/systools/examples/patterns/singlton.lfm
@@ -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
diff --git a/components/systools/examples/patterns/singlton.pas b/components/systools/examples/patterns/singlton.pas
new file mode 100644
index 000000000..804599e48
--- /dev/null
+++ b/components/systools/examples/patterns/singlton.pas
@@ -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.
diff --git a/components/systools/laz_systools.lpk b/components/systools/laz_systools.lpk
index 17e744647..de9982599 100644
--- a/components/systools/laz_systools.lpk
+++ b/components/systools/laz_systools.lpk
@@ -16,7 +16,7 @@
-
+
@@ -241,6 +241,18 @@
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/laz_systools.pas b/components/systools/laz_systools.pas
index 567850aa8..5039f861f 100644
--- a/components/systools/laz_systools.pas
+++ b/components/systools/laz_systools.pas
@@ -14,7 +14,7 @@ uses
StAstro, StEclpse, StList, StMerc, StAstroP, StVenus, StMars, StJup,
StSaturn, StUranus, StNeptun, StPluto, StJupsat, StBits, StColl, StDQue,
StVArr, StPQueue, StTree, StNVCont, StNVTree, StNVBits, StNVColl, StNVDict,
- StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol;
+ StNVDQ, StNVLAry, StNVList, StNVLMat, StNVSCol, StPtrns, StMerge, StTxtDat;
implementation
diff --git a/components/systools/laz_systools_design.lpk b/components/systools/laz_systools_design.lpk
index 4f44f5c49..10b7ed023 100644
--- a/components/systools/laz_systools_design.lpk
+++ b/components/systools/laz_systools_design.lpk
@@ -17,20 +17,27 @@
-
+
-
-
-
-
-
-
-
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
@@ -38,5 +45,8 @@
+
+ <_ExternHelp Items="Count"/>
+
diff --git a/components/systools/laz_systools_design.pas b/components/systools/laz_systools_design.pas
index e3fafd059..361b51780 100644
--- a/components/systools/laz_systools_design.pas
+++ b/components/systools/laz_systools_design.pas
@@ -8,7 +8,7 @@ unit laz_systools_design;
interface
uses
- StReg, LazarusPackageIntf;
+ StPropEd, StReg, LazarusPackageIntf;
implementation
diff --git a/components/systools/laz_systoolsdb_design.lpk b/components/systools/laz_systoolsdb_design.lpk
index 1fea18023..efc2b0112 100644
--- a/components/systools/laz_systoolsdb_design.lpk
+++ b/components/systools/laz_systoolsdb_design.lpk
@@ -11,7 +11,7 @@
-
+
@@ -19,9 +19,9 @@
-
+
-
+
diff --git a/components/systools/source/design/stproped.pas b/components/systools/source/design/stproped.pas
new file mode 100644
index 000000000..a0a56026f
--- /dev/null
+++ b/components/systools/source/design/stproped.pas
@@ -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.
diff --git a/components/systools/source/design/StReg.pas b/components/systools/source/design/streg.pas
similarity index 96%
rename from components/systools/source/design/StReg.pas
rename to components/systools/source/design/streg.pas
index c68df2445..d55093644 100644
--- a/components/systools/source/design/StReg.pas
+++ b/components/systools/source/design/streg.pas
@@ -31,16 +31,16 @@
//{$I StDefine.inc}
-{$R StReg.r32}
+{$R streg.r32}
unit StReg;
interface
uses
- Classes
+ Classes,
{$IFDEF FPC}
- ;//PropEdits //, LazarusPackageIntf //, FieldsEditor, ComponentEditors
+ PropEdits //, LazarusPackageIntf //, FieldsEditor, ComponentEditors
{$ELSE}
{$IFDEF VERSION6}
DesignIntf,
@@ -49,6 +49,7 @@ uses
DsgnIntfM
{$ENDIF}
{$ENDIF}
+ ;
procedure Register;
@@ -149,14 +150,14 @@ uses
StVenus,
{ new units in ver 4: }
StIniStm,
- (*
StMerge,
+ (*
StSystem,
+ *)
StTxtDat,
StDecMth,
- *)
StMoney,
- StRandom
+ StRandom,
(*
StNTLog,
{ !!! StExpEng unit designed to handle problem with initialization }
@@ -165,12 +166,10 @@ uses
{StExpEng,}
StExpLog,
StGenLog,
+ *)
StPtrns,
-
-
{^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^}
- StPropEd
- *);
+ StPropEd;
procedure Register;
begin
@@ -183,6 +182,7 @@ begin
TStVersionProperty);
RegisterPropertyEditor(TypeInfo(string), TStPNBarCode, 'Version',
TStVersionProperty);
+ *)
RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'InputFile',
TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'OutputFile',
@@ -191,6 +191,7 @@ begin
TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStFileToHTML, 'OutFileName',
TStGenericFileNameProperty);
+ (*
RegisterPropertyEditor(TypeInfo(string), TStVersionInfo, 'FileName',
TStFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStSpawnApplication, 'FileName',
diff --git a/components/systools/source/design/StReg.rc b/components/systools/source/design/streg.rc
similarity index 100%
rename from components/systools/source/design/StReg.rc
rename to components/systools/source/design/streg.rc
diff --git a/components/systools/source/design/StRegDb.pas b/components/systools/source/design/stregdb.pas
similarity index 98%
rename from components/systools/source/design/StRegDb.pas
rename to components/systools/source/design/stregdb.pas
index d64bf07c5..47fd33d75 100644
--- a/components/systools/source/design/StRegDb.pas
+++ b/components/systools/source/design/stregdb.pas
@@ -34,7 +34,7 @@
{$ENDIF}
//{$I StDefine.inc}
-{$R StRegDb.r32}
+{$R stregdb.r32}
unit StRegDb;
diff --git a/components/systools/source/design/StRegDb.rc b/components/systools/source/design/stregdb.rc
similarity index 100%
rename from components/systools/source/design/StRegDb.rc
rename to components/systools/source/design/stregdb.rc
diff --git a/components/systools/source/run/stmerge.pas b/components/systools/source/run/stmerge.pas
new file mode 100644
index 000000000..7827319f5
--- /dev/null
+++ b/components/systools/source/run/stmerge.pas
@@ -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.
diff --git a/components/systools/source/run/stptrns.pas b/components/systools/source/run/stptrns.pas
new file mode 100644
index 000000000..d996079c2
--- /dev/null
+++ b/components/systools/source/run/stptrns.pas
@@ -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.
+
diff --git a/components/systools/source/run/sttxtdat.pas b/components/systools/source/run/sttxtdat.pas
new file mode 100644
index 000000000..a412ea081
--- /dev/null
+++ b/components/systools/source/run/sttxtdat.pas
@@ -0,0 +1,1859 @@
+// 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: StTxtDat.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Formatted Text Data Handling *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+//{$include StDefine.inc}
+
+unit StTxtDat;
+
+interface
+uses
+ SysUtils, Classes, TypInfo, StConst, StBase, StStrms, StStrL;
+
+const
+ StDefaultDelim = ',';
+ StDefaultQuote = '"';
+ StDefaultComment = ';';
+ StDefaultFixedSep = ' '; {!!.01}
+ StDefaultLineTerm = #13#10;
+ St_WhiteSpace = #8#9#10#13' '; {page feed, tab, LF, CR, space} {!!.01}
+
+type
+ TStSchemaLayoutType = (ltUnknown, ltFixed, ltVarying);
+ TStSchemaFieldType = (sftUnknown, sftChar, sftFloat, sftNumber, sftBool, sftLongInt, sftDate, sftTime, sftTimeStamp);
+ TStOnQuoteFieldEvent = procedure (Sender : TObject; var Field : String) of object;
+
+ { Text Data Layout descriptors (Schemas)}
+ TStDataField = class
+ protected {private}
+ FFieldDecimals: Integer;
+ FFieldLen: Integer;
+ FFieldName: String;
+ FFieldOffset: Integer;
+ FFieldType: TStSchemaFieldType;
+ function GetAsString: String;
+ procedure SetFieldDecimals(const Value: Integer);
+ procedure SetFieldLen(const Value: Integer);
+ procedure SetFieldName(const Value: String);
+ procedure SetFieldOffset(const Value: Integer);
+ procedure SetFieldType(const Value: TStSchemaFieldType);
+ public
+ { properties }
+ property AsString : String read GetAsString;
+ property FieldDecimals: Integer read FFieldDecimals write SetFieldDecimals;
+ property FieldLen: Integer read FFieldLen write SetFieldLen;
+ property FieldName : String read FFieldName write SetFieldName;
+ property FieldOffset: Integer read FFieldOffset write SetFieldOffset;
+ property FieldType: TStSchemaFieldType read FFieldType write SetFieldType;
+ end;
+
+
+ TStDataFieldList = class
+ private
+ FList : TStringList;
+ protected {private}
+ function GetCount: Integer;
+ function GetField(Index: Integer): TStDataField;
+ function GetFieldByName(const FieldName: String): TStDataField;
+ procedure SetField(Index: Integer; const Value: TStDataField);
+ procedure SetFieldByName(const FieldName: String;
+ const Value: TStDataField);
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ { Access and Update Methods }
+ procedure AddField(const FieldName: String; FieldType: TStSchemaFieldType;
+ FieldLen, FieldDecimals, FieldOffset: Integer);
+ procedure AddFieldStr(const FieldDef : String);
+ procedure Clear;
+ procedure RemoveField(const FieldName: String);
+
+ { properties }
+ property Count : Integer read GetCount;
+ property Fields[Index : Integer] : TStDataField
+ read GetField write SetField; default;
+ property FieldByName[const FieldName: String] : TStDataField
+ read GetFieldByName write SetFieldByName;
+ end;
+
+ TStTextDataSchema = class
+ private
+ FCommentDelimiter: Char;
+ FFieldDelimiter: Char;
+ FLayoutType: TStSchemaLayoutType;
+ FLineTermChar : Char;
+ FLineTerminator : TStLineTerminator;
+ FQuoteDelimiter: Char;
+ FFixedSeparator : Char; {!!.01}
+ FSchema: TStrings;
+ FSchemaName: String;
+ dsFieldList : TStDataFieldList;
+ protected {private}
+ function GetCaptions: TStrings;
+ function GetField(Index: Integer): TStDataField;
+ function GetFieldByName(const FieldName: String): TStDataField;
+ function GetFieldCount: Integer;
+ function GetSchema: TStrings;
+ procedure SetCommentDelimiter(const Value: Char);
+ procedure SetField(Index: Integer; const Value: TStDataField);
+ procedure SetFieldByName(const FieldName: String; const Value: TStDataField);
+ procedure SetFieldDelimiter(const Value: Char);
+ procedure SetLayoutType(const Value: TStSchemaLayoutType);
+ procedure SetQuoteDelimiter(const Value: Char);
+ procedure SetFixedSeparator(const Value: Char); {!!.01}
+ procedure SetSchema(const Value: TStrings);
+ procedure SetSchemaName(const Value: String);
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Assign(ASchema : TStTextDataSchema);
+
+ { Access and Update Methods }
+ procedure AddField(const FieldName : String; FieldType : TStSchemaFieldType;
+ FieldLen, FieldDecimals : Integer);
+ function IndexOf(const FieldName : String) : Integer;
+ procedure RemoveField(const FieldName: String);
+ procedure Update(AList : TStrings); {!!.01}
+ procedure ClearFields; {!!.01}
+ procedure BuildSchema(AList: TStrings); {!!.01}
+
+ { Persistence and streaming methods }
+ procedure LoadFromFile(const AFileName : TFileName);
+ procedure LoadFromStream(AStream : TStream);
+ procedure SaveToFile(const AFileName : TFileName);
+ procedure SaveToStream(AStream : TStream);
+
+ { properties }
+ property Captions : TStrings
+ read GetCaptions;
+ property CommentDelimiter : Char
+ read FCommentDelimiter write SetCommentDelimiter default StDefaultComment;
+ property FieldByName[const FieldName: String] : TStDataField
+ read GetFieldByName write SetFieldByName;
+ property FieldCount : Integer
+ read GetFieldCount;
+ property FieldDelimiter : Char
+ read FFieldDelimiter write SetFieldDelimiter default StDefaultDelim;
+ property Fields[Index : Integer] : TStDataField
+ read GetField write SetField; default;
+ property LayoutType : TStSchemaLayoutType
+ read FLayoutType write SetLayoutType;
+ property LineTermChar : Char
+ read FLineTermChar write FLineTermChar default #0;
+ property LineTerminator : TStLineTerminator
+ read FLineTerminator write FLineTerminator default ltCRLF;
+ property QuoteDelimiter : Char
+ read FQuoteDelimiter write SetQuoteDelimiter default StDefaultQuote;
+ property FixedSeparator : Char {!!.01}
+ read FFixedSeparator write SetFixedSeparator default StDefaultFixedSep; {!!.01}
+ property Schema : TStrings
+ read GetSchema write SetSchema;
+ property SchemaName : String
+ read FSchemaName write SetSchemaName;
+ end;
+
+ { Text Data Records and Data Sets }
+ TStTextDataRecord = class
+ private
+ FFieldList: TStrings;
+ FQuoteAlways: Boolean;
+ FQuoteIfSpaces: Boolean;
+ FSchema: TStTextDataSchema;
+ FValue : String;
+ FOnQuoteField : TStOnQuoteFieldEvent;
+ protected {private}
+ function GetField(Index: Integer): String;
+ function GetFieldCount: Integer;
+ function GetFieldByName(const FieldName: String): String;
+ function GetFieldList: TStrings;
+ function GetValues: TStrings;
+ procedure SetField(Index: Integer; const NewValue: String);
+ procedure SetFieldByName(const FieldName: String; const NewValue: String);
+ procedure SetQuoteAlways(const Value: Boolean);
+ procedure SetQuoteIfSpaces(const Value: Boolean);
+ procedure SetSchema(const Value: TStTextDataSchema);
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ { Access and Update Methods }
+ procedure BuildRecord(Values: TStrings; var NewRecord: String); virtual;
+ function GetRecord : String; {!!.02}
+ procedure DoQuote(var Value: String); virtual;
+ procedure FillRecordFromArray(Values: array of const);
+ procedure FillRecordFromList(Items: TStrings);
+ procedure FillRecordFromValues(Values: TStrings);
+ procedure MakeEmpty; virtual;
+
+ { properties }
+ property AsString : String {!!.02}
+// read FValue {write SetValue}; {!!.02}
+ read GetRecord;
+ property FieldByName[const FieldName : String] : String
+ read GetFieldByName write SetFieldByName;
+ property FieldCount : Integer
+ read GetFieldCount;
+ property FieldList : TStrings
+ read GetFieldList;
+ property Fields[Index : Integer] : String
+ read GetField write SetField;
+ property QuoteAlways : Boolean
+ read FQuoteAlways write SetQuoteAlways default False;
+ property QuoteIfSpaces : Boolean
+ read FQuoteIfSpaces write SetQuoteIfSpaces default False;
+ property Schema : TStTextDataSchema
+ read FSchema write SetSchema;
+ property Values : TStrings
+ read GetValues;
+
+ { events }
+ property OnQuoteField : TStOnQuoteFieldEvent
+ read FOnQuoteField write FOnQuoteField;
+ end;
+
+ TStTextDataRecordSet = class
+ private
+ FActive: Boolean;
+ FCurrentIndex : Integer;
+ FIsDirty: Boolean;
+ FRecords: TList;
+ FSchema: TStTextDataSchema;
+ FAtEndOfFile : Boolean; {!!.01}
+ FIgnoreStartingLines : Integer; {!!.02}
+ protected {private}
+ function GetCount: Integer;
+ function GetCurrentRecord: TStTextDataRecord;
+ function GetRecord(Index: Integer): TStTextDataRecord;
+ function GetSchema: TStTextDataSchema;
+ procedure SetActive(const Value: Boolean);
+ procedure SetCurrentRecord(const Value: TStTextDataRecord);
+ procedure SetRecord(Index: Integer; const Value: TStTextDataRecord);
+ procedure SetSchema(const Value: TStTextDataSchema);
+
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ { Access and Update Methods }
+ procedure Append;
+ procedure AppendArray(Values : array of const);
+ procedure AppendList(Items : TStrings);
+ procedure AppendValues(Values : TStrings);
+ procedure Clear;
+ procedure Delete;
+ procedure Insert(Index : Integer);
+ procedure InsertArray(Index: Integer; Values : array of const);
+ procedure InsertList(Index : Integer; Items : TStrings);
+ procedure InsertValues(Index : Integer; Values : TStrings);
+
+ { navigation methods }
+ function BOF : Boolean;
+ function EOF : Boolean;
+ procedure First;
+ procedure Last;
+ function Next : Boolean;
+ function Prior : Boolean;
+
+ { Persistence and streaming methods }
+ procedure LoadFromFile(const AFile : TFileName);
+ procedure LoadFromStream(AStream : TStream);
+ procedure SaveToFile(const AFile : TFileName);
+ procedure SaveToStream(AStream : TStream);
+
+ { properties }
+ property Active : Boolean
+ read FActive write SetActive;
+ property Count : Integer
+ read GetCount;
+ property CurrentRecord : TStTextDataRecord
+ read GetCurrentRecord write SetCurrentRecord;
+ property IsDirty : Boolean
+ read FIsDirty;
+ property Records[Index : Integer] : TStTextDataRecord
+ read GetRecord write SetRecord;
+ property Schema : TStTextDataSchema
+ read GetSchema write SetSchema;
+ property IgnoreStartingLines : Integer {!!.02}
+ read FIgnoreStartingLines write FIgnoreStartingLines default 0; {!!.02}
+ end;
+
+procedure StParseLine(const Data : String; Schema : TStTextDataSchema; Result : TStrings);
+function StFieldTypeToStr(FieldType : TStSchemaFieldType) : String;
+function StStrToFieldType(const S : String) : TStSchemaFieldType;
+function StDeEscape(const EscStr : String): Char;
+function StDoEscape(Delim : Char): String;
+function StTrimTrailingChars(const S : String; Trailer : Char) : String; {!!.01}
+
+implementation
+
+procedure StParseLine(const Data : String; Schema : TStTextDataSchema;
+ Result : TStrings);
+{ split a line of delimited data according to provided schema into
+ = pairs into Result }
+var
+ DataLine : TStTextDataRecord;
+ ownSchema : Boolean;
+begin
+ { need a valid TStrings to work with }
+ if not Assigned(Result) then Exit;
+
+
+ ownSchema := False;
+ { if no Schema to use passed in, create a default schema }
+ if not Assigned(Schema) then begin
+ Schema := TStTextDataSchema.Create;
+ ownSchema := True; { we made it we, s have to free it }
+ end;
+
+ DataLine := TStTextDataRecord.Create;
+ try
+ DataLine.Schema := Schema;
+ DataLine.FValue := Data;
+ Result.Assign(DataLine.FieldList);
+ finally
+ DataLine.Free;
+ { free the Schema if needed }
+ if ownSchema then
+ Schema.Free;
+ end;
+end;
+
+{ TStDataField }
+
+function StFieldTypeToStr(FieldType : TStSchemaFieldType) : String;
+{ convert TStSchemaFieldType enum into matching string for BDE schema }
+begin
+ Result := '';
+ case FieldType of
+ sftChar : Result := 'CHAR';
+ sftFloat : Result := 'FLOAT';
+ sftNumber : Result := 'NUMBER';
+ sftBool : Result := 'BOOL';
+ sftLongInt : Result := 'LONGINT';
+ sftDate : Result := 'DATE';
+ sftTime : Result := 'TIME';
+ sftTimeStamp : Result := 'TIMESTAMP';
+
+ else
+ Result := '';
+ end;
+end;
+
+function StStrToFieldType(const S : String) : TStSchemaFieldType;
+{ convert string to TStSchemaFieldType constant }
+var
+ Value : Integer;
+begin
+ Value := GetEnumValue(TypeInfo(TStSchemaFieldType), S);
+ if Value > -1 then
+ Result := TStSchemaFieldType(Value)
+ else
+ Result := sftUnknown;
+end;
+
+{!!.01 - Added}
+function StTrimTrailingChars(const S : String; Trailer : Char) : String;
+{
+Return a string with specified trailing character removed,
+useful for cleanup of fixed data records
+}
+var
+ Len : LongInt;
+begin
+ Result := S;
+ Len := Length(S);
+ while (Len > 0) and (Result[Len] = Trailer) do
+ Dec(Len);
+ SetLength(Result, Len);
+end;
+{!!.01 - End Added}
+
+function TStDataField.GetAsString: String;
+{ build string representation of field to match BDE style }
+{
+Format :
+ ,,,,
+}
+begin
+ Result := FFieldName + ',' + StFieldTypeToStr(FFieldType) + ',' +
+ { zero pad width, decimals, and offset to at least two places
+ to match BDE Schema formatting }
+ Format('%.2d,%.2d,%.2d', [FFieldLen, FFieldDecimals, FFieldOffset]);
+end;
+
+procedure TStDataField.SetFieldDecimals(const Value: Integer);
+begin
+ FFieldDecimals := Value;
+end;
+
+procedure TStDataField.SetFieldLen(const Value: Integer);
+begin
+ FFieldLen := Value;
+end;
+
+procedure TStDataField.SetFieldName(const Value: String);
+begin
+ FFieldName := Value;
+end;
+
+procedure TStDataField.SetFieldOffset(const Value: Integer);
+begin
+ FFieldOffset := Value;
+end;
+
+procedure TStDataField.SetFieldType(const Value: TStSchemaFieldType);
+begin
+ FFieldType := Value;
+end;
+
+
+{ TStDataFieldList }
+
+function CharPosIdx(C: Char; const S : String; Idx: Integer): Integer;
+{ Find leftmost occurrence of character C in string S past location Idx }
+{
+If C not found returns 0
+}
+var
+ Len : Integer;
+begin
+ Len := Length(S);
+ if (Idx > Len) or (Idx < 1) then begin
+ Result := 0;
+ Exit;
+ end;
+
+ Result := Idx;
+ while (Result <= Len) and (S[Result] <> C) do
+ Inc(Result);
+ if Result > Len then
+ Result := 0;
+end;
+
+procedure SplitFieldStr(const Source: String; var Name: String;
+ var FieldType: TStSchemaFieldType; var ValLen, Decimals, Offset: Integer);
+{ split field description string according to BDE Schema layout }
+{
+Format :
+ ,,,,
+}
+var
+ CommaPos, LastPos : Cardinal;
+ TempS : String;
+begin
+ CommaPos := 1;
+ LastPos := CommaPos;
+ CommaPos := CharPosIdx(',', Source, CommaPos);
+ if CommaPos = 0 then CommaPos := Length(Source) + 1;
+ Name := Copy(Source, LastPos, CommaPos - LastPos);
+
+ Inc(CommaPos);
+ LastPos := CommaPos;
+ CommaPos := CharPosIdx(',', Source, CommaPos);
+ if CommaPos = 0 then CommaPos := Length(Source) + 1;
+ TempS := Copy(Source, LastPos, CommaPos - LastPos);
+ FieldType := StStrToFieldType('sft' + TempS);
+
+ Inc(CommaPos);
+ LastPos := CommaPos;
+ CommaPos := CharPosIdx(',', Source, CommaPos);
+ if CommaPos = 0 then CommaPos := Length(Source) + 1;
+ ValLen := StrToInt(Copy(Source, LastPos, CommaPos - LastPos));
+
+ Inc(CommaPos);
+ LastPos := CommaPos;
+ CommaPos := CharPosIdx(',', Source, CommaPos);
+ if CommaPos = 0 then CommaPos := Length(Source) + 1;
+ Decimals := StrToInt(Copy(Source, LastPos, CommaPos - LastPos));
+
+ Inc(CommaPos);
+ LastPos := CommaPos;
+ CommaPos := CharPosIdx(',', Source, CommaPos);
+ if CommaPos = 0 then CommaPos := Length(Source) + 1;
+ Offset := StrToInt(Copy(Source, LastPos, CommaPos - LastPos));
+end;
+
+constructor TStDataFieldList.Create;
+begin
+ inherited Create;
+ FList := TStringList.Create;
+end;
+
+destructor TStDataFieldList.Destroy;
+begin
+ FList.Free;
+ inherited Destroy;
+end;
+
+procedure TStDataFieldList.AddField(const FieldName: String;
+ FieldType: TStSchemaFieldType; FieldLen, FieldDecimals, FieldOffset: Integer);
+var
+ Item : TStDataField;
+ Idx : Integer;
+begin
+ { see if another field with the name exists }
+ Idx := FList.IndexOf(FieldName);
+ if (Idx > -1) then
+ raise EStException.CreateResTP(stscTxtDatUniqueNameRequired, 0);
+
+ { build new item }
+ Item := TStDataField.Create;
+ try
+ Item.FieldName := FieldName;
+ Item.FieldType := FieldType;
+ Item.FieldLen := FieldLen;
+ Item.FieldDecimals := FieldDecimals;
+ Item.FieldOffset := FieldOffset;
+
+ { add to list }
+ FList.AddObject(FieldName, Item);
+ except
+ Item.Free;
+ end;
+end;
+
+procedure TStDataFieldList.AddFieldStr(const FieldDef: String);
+var
+ Name: String;
+ FieldType: TStSchemaFieldType;
+ ValLen, Decimals, Offset: Integer;
+begin
+ SplitFieldStr(FieldDef, Name, FieldType, ValLen, Decimals, Offset);
+ AddField(Name, FieldType, ValLen, Decimals, Offset);
+end;
+
+procedure TStDataFieldList.Clear;
+var
+ Idx : Integer;
+begin
+ for Idx := Pred(FList.Count) downto 0 do begin
+ { Free associated object and then delete the StringList entry }
+ FList.Objects[Idx].Free;
+ FList.Delete(Idx);
+ end;
+end;
+
+procedure TStDataFieldList.RemoveField(const FieldName: String);
+var
+ Idx : Integer;
+begin
+ { locate field }
+ Idx := FList.IndexOf(FieldName);
+
+ { if it exists }
+ if Idx > -1 then begin
+ { Free associated object and then delete the StringList entry }
+ FList.Objects[Idx].Free;
+ FList.Delete(Idx);
+ end
+ else
+ { no such field, complain... }
+ raise EStException.CreateResTP(stscTxtDatNoSuchField, 0);
+end;
+
+function TStDataFieldList.GetFieldByName(
+ const FieldName: String): TStDataField;
+var
+ Idx : Integer;
+begin
+ { locate field }
+ Idx := FList.IndexOf(FieldName);
+
+ { if it exists }
+ if Idx > -1 then begin
+ { return associated object }
+ Result := TStDataField(FList.Objects[Idx]);
+ end
+ else
+ { no such field, complain... }
+ raise EStException.CreateResTP(stscTxtDatNoSuchField, 0);
+end;
+
+function TStDataFieldList.GetField(Index: Integer): TStDataField;
+{ return requested field if in range }
+begin
+ if (Index > -1) and (Index < FList.Count) then
+ Result := TStDataField(FList.Objects[Index])
+ else
+ { no such field, complain... }
+ raise EStException.CreateResTP(stscBadIndex, 0);
+end;
+
+procedure TStDataFieldList.SetFieldByName(const FieldName: String;
+ const Value: TStDataField);
+var
+ Idx : Integer;
+begin
+ { see if another field with the name exists }
+ Idx := FList.IndexOf(FieldName);
+
+ { delete field at that index replace with new field }
+ if (Idx > -1) then begin
+ FList.Objects[Idx].Free;
+ FList.Objects[Idx] := Value;
+ end
+ else
+ { no such field, complain... }
+ raise EStException.CreateResTP(stscTxtDatNoSuchField, 0);
+end;
+
+procedure TStDataFieldList.SetField(Index: Integer;
+ const Value: TStDataField);
+var
+ Idx : Integer;
+begin
+ { see if another field with the name exists }
+ Idx := FList.IndexOf(Value.FieldName);
+ if (Idx > -1) and (Idx <> Index) then
+ raise EStException.CreateResTP(stscTxtDatUniqueNameRequired, 0);
+
+ { delete field at that index replace with new field }
+ if (Index > -1) and (Index < FList.Count) then begin
+ RemoveField(FList[Index]);
+ FList.InsertObject(Index, Value.FieldName, Value);
+ end else
+ { no such field, complain... }
+ raise EStException.CreateResTP(stscBadIndex, 0);
+end;
+
+
+function TStDataFieldList.GetCount: Integer;
+{ return count of maintained Field Items }
+begin
+ Result := FList.Count;
+end;
+
+
+{ TStTextDataSchema }
+
+constructor TStTextDataSchema.Create;
+begin
+ inherited Create;
+
+ { set default values }
+ FFieldDelimiter := StDefaultDelim;
+ FQuoteDelimiter := StDefaultQuote;
+ FCommentDelimiter := StDefaultComment;
+ FFixedSeparator := StDefaultFixedSep; {!!.01}
+ FLineTermChar := #0;
+ FLineTerminator := ltCRLF;
+ FLayoutType := ltUnknown;
+
+ { create internal instances }
+ dsFieldList := TStDataFieldList.Create;
+ FSchema := TStringList.Create;
+end;
+
+destructor TStTextDataSchema.Destroy;
+begin
+ { clean up the fields list }
+ dsFieldList.Clear;
+
+ { free internal instances }
+ dsFieldList.Free;
+ FSchema.Free;
+
+ inherited Destroy;
+end;
+
+procedure TStTextDataSchema.AddField(const FieldName : String;
+ FieldType : TStSchemaFieldType; FieldLen, FieldDecimals : Integer);
+{ add new field with requested characteristics }
+var
+ Offset : Integer;
+ LastField : TStDataField;
+begin
+ { calculate the offset based on the length and offset of previous fields }
+ if dsFieldList.Count > 0 then begin
+ LastField := dsFieldList.Fields[Pred(dsFieldList.Count)];
+ Offset := LastField.FieldOffset + LastField.FieldLen;
+ end
+ else
+ Offset := 0;
+
+ dsFieldList.AddField(FieldName, FieldType, FieldLen, FieldDecimals, Offset);
+end;
+
+procedure TStTextDataSchema.Assign(ASchema: TStTextDataSchema);
+{ deep copy another schema }
+var
+ i : Integer;
+begin
+ if not Assigned(ASchema) then Exit;
+
+ { copy properties }
+ FLayoutType := ASchema.LayoutType;
+ FFieldDelimiter := ASchema.FieldDelimiter;
+ FCommentDelimiter := ASchema.CommentDelimiter;
+ FQuoteDelimiter := ASchema.QuoteDelimiter;
+ FSchemaName := ASchema.SchemaName;
+ FLineTermChar := ASchema.LineTermChar;
+ FLineTerminator := ASchema.LineTerminator;
+
+ { copy fields }
+ dsFieldList.Clear;
+ for i := 0 to Pred(ASchema.FieldCount) do
+ dsFieldList.AddFieldStr(ASchema.Fields[i].AsString);
+end;
+
+{!!.01 -- Added }
+procedure TStTextDataSchema.BuildSchema(AList : TStrings);
+var
+ i : Integer;
+ Field : TStDataField;
+begin
+ { put schema name in brackets }
+ AList.Add('[' + FSchemaName + ']');
+
+ { layout type }
+ if FLayoutType = ltVarying then begin
+ AList.Add('FileType=VARYING');
+ AList.Add('Separator=' + StDoEscape(FFieldDelimiter));
+ end
+ else begin
+ AList.Add('FileType=FIXED');
+ AList.Add('Separator=' + StDoEscape(FFixedSeparator));
+ end;
+
+ { other parameters }
+ AList.Add('Delimiter=' + StDoEscape(FQuoteDelimiter));
+ AList.Add('Comment=' + StDoEscape(FCommentDelimiter));
+ AList.Add('CharSet=ASCII');
+
+ { write fields }
+ for i := 0 to Pred(dsFieldList.Count) do begin
+ Field := dsFieldList.Fields[i];
+ AList.Add('Field' + IntToStr(i + 1) + '=' + Field.AsString);
+ end;
+end;
+{!!.01 -- End Added }
+
+{!!.01 -- Added }
+procedure TStTextDataSchema.ClearFields;
+{ remove field definitions from schema }
+var
+ i : Integer;
+begin
+ dsFieldList.Clear;
+ for i := Pred(FSchema.Count) downto 0 do
+ if Pos('Field', Trim(FSchema[i])) = 1 then
+ FSchema.Delete(i);
+end;
+{!!.01 -- End Added }
+
+function TStTextDataSchema.GetCaptions: TStrings;
+begin
+ Result := dsFieldList.FList;
+end;
+
+function TStTextDataSchema.GetFieldByName(const FieldName: String): TStDataField;
+begin
+ Result := dsFieldList.FieldByName[FieldName];
+end;
+
+function TStTextDataSchema.GetFieldCount: Integer;
+begin
+ Result := dsFieldList.Count;
+end;
+
+function TStTextDataSchema.GetField(Index: Integer): TStDataField;
+begin
+ Result := dsFieldList.Fields[Index];
+end;
+
+{!!.01 -- Added }
+function TStTextDataSchema.GetSchema: TStrings;
+begin
+ FSchema.Clear;
+ BuildSchema(FSchema);
+ Result := FSchema;
+end;
+{!!.01 -- End Added }
+
+function TStTextDataSchema.IndexOf(const FieldName : String): Integer;
+{ return index of field with provided name, returns -1 if no such field is found }
+begin
+ Result := 0;
+ while (Result < dsFieldList.Count) and
+// (dsFieldList.Fields[Result].FieldName <> FieldName) do {!!.01}
+ (AnsiCompareText(dsFieldList.Fields[Result].FieldName, {!!.01}
+ FieldName) <> 0) {!!.01}
+ do {!!.01}
+ Inc(Result);
+ if Result >= dsFieldList.Count then
+ Result := -1; { not found }
+end;
+
+procedure TStTextDataSchema.LoadFromFile(const AFileName: TFileName);
+var
+ FS : TFileStream;
+begin
+ FS := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone);
+ try
+ LoadFromStream(FS);
+ finally
+ FS.Free;
+ end;
+end;
+
+function StDoEscape(Delim : Char): String;
+{
+Escapes non-printable characters to Borlandish Pascal "#nnn" constants
+}
+begin
+ if Delim in [#33..#126, #128..#255] then
+ Result := Delim
+ else
+ Result := '#' + IntToStr(Ord(Delim));
+end;
+
+
+function StDeEscape(const EscStr : String): Char;
+{
+converts "escaped" strings of the forms:
+ "#nn" Borlandish Pascal numeric character constants
+ ^l Borlandish Pascal control character constants
+into equivalent characters, "##" is treated as the '#' character alone
+
+if the string doesn't constitute such an escape sequence, the first
+character is returned
+}
+var
+ S : String;
+ C : Char;
+ ChrVal : Byte;
+begin
+ S := Trim(EscStr);
+
+ { if string doesn't start with escape or it's only one character long
+ just return first character }
+ if (Length(S) = 1) or ((S[1] <> '#') and (S[1] <> '^')) then begin
+ Result := S[1];
+ Exit;
+ end;
+
+ { treat '##' as escape for '#' and '^^' as escape for '^' }
+ if ((S[1] = '#') and (S[2] = '#')) or
+ ((S[1] = '^') and (S[2] = '^')) then
+ begin
+ Result := '#';
+ Exit;
+ end;
+
+ { otherwise try to handle escaped character }
+ case S[1] of
+ '#':begin
+ ChrVal := StrToIntDef(Copy(S, 2,Length(S)-1), Ord(StDefaultDelim));
+ if Chr(ChrVal) in [#1..#126] then
+ Result := Chr(ChrVal)
+ else
+ Result := StDefaultDelim;
+ end;
+
+ '^': begin { control character format }
+ C := Chr(Ord(S[2]) - $40);
+ if C in [^A..^_] then
+ Result := C
+ else
+ Result := StDefaultDelim;
+ end;
+
+ else
+ Result := S[1];
+ end; {case}
+end;
+
+procedure TStTextDataSchema.LoadFromStream(AStream: TStream);
+var
+ TS : TStAnsiTextStream;
+begin
+ TS := TStAnsiTextStream.Create(AStream);
+ try
+ FSchema.Clear; {!!.01}
+ while not TS.AtEndOfStream do
+ FSchema.Add(TS.ReadLine);
+ { code to extract Schema properties moved to Update routine } {!!.01}
+ Update(FSchema); {!!.01}
+
+ finally
+ TS.Free;
+ end;
+end;
+
+procedure TStTextDataSchema.RemoveField(const FieldName: String);
+begin
+ dsFieldList.RemoveField(FieldName);
+end;
+
+procedure TStTextDataSchema.SaveToFile(const AFileName: TFileName);
+var
+ FS : TFileStream;
+begin
+ if not FileExists(AFileName) then begin
+ FS := TFileStream.Create(AFileName, fmCreate);
+ FS.Free;
+ end;
+
+ if FSchemaName = '' then
+ FSchemaName := JustNameL(AFileName);
+
+ FS := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyNone);
+
+ try
+ SaveToStream(FS);
+ finally
+ FS.Free;
+ end;
+end;
+
+
+{
+General format of a Schema file, based on BDE ASCII driver schema files:
+
+; this is a comment
+[NAME]
+Filetype=|
+Separator=char (default = ',' comma)
+Delimiter=char (default = '"' double quote)
+FieldN=,,,,
+; example fields:
+Field1=Name,CHAR,20,00,00
+Field2=Rating,CHAR,2,00,20
+Field3=Date,DATE,10,00,22
+Field4=Weight,Float,7,2,32
+}
+
+{!!.01 -- Rewritten}
+procedure TStTextDataSchema.SaveToStream(AStream: TStream);
+var
+ TS : TStAnsiTextStream;
+ i : Integer;
+ SL : TStringList;
+begin
+ SL := nil;
+ TS := nil;
+
+ try
+ SL := TStringList.Create;
+ BuildSchema(SL);
+
+ TS := TStAnsiTextStream.Create(AStream);
+ for i := 0 to Pred(SL.Count) do
+ TS.WriteLine(SL[i]);
+
+ finally
+ TS.Free;
+ SL.Free;
+ end;
+end;
+{!!.01 -- End Rewritten}
+
+procedure TStTextDataSchema.SetCommentDelimiter(const Value: Char);
+begin
+ FCommentDelimiter := Value;
+end;
+
+procedure TStTextDataSchema.SetFieldByName(const FieldName: String;
+ const Value: TStDataField);
+begin
+ dsFieldList.FieldByName[FieldName] := Value;
+end;
+
+procedure TStTextDataSchema.SetFieldDelimiter(const Value: Char);
+begin
+ FFieldDelimiter := Value;
+end;
+
+procedure TStTextDataSchema.SetField(Index: Integer;
+ const Value: TStDataField);
+begin
+ dsFieldList.Fields[Index] := Value;
+end;
+
+{!!.01 -- Added }
+procedure TStTextDataSchema.SetFixedSeparator(const Value: Char);
+begin
+ FFixedSeparator := Value;
+end;
+{!!.01 -- End Added }
+
+procedure TStTextDataSchema.SetLayoutType(const Value: TStSchemaLayoutType);
+begin
+ FLayoutType := Value;
+end;
+
+procedure TStTextDataSchema.SetQuoteDelimiter(const Value: Char);
+begin
+ FQuoteDelimiter := Value;
+end;
+
+procedure TStTextDataSchema.SetSchema(const Value: TStrings);
+begin
+ FSchema.Assign(Value); {!!.01}
+ Update(FSchema); {!!.01}
+end;
+
+procedure TStTextDataSchema.SetSchemaName(const Value: String);
+begin
+ FSchemaName := Value;
+end;
+
+{!!.01 -- Added }
+procedure TStTextDataSchema.Update(AList : TStrings);
+var
+ ValStr : String;
+ Idx : Integer;
+begin
+ for Idx := 0 to Pred(AList.Count) do begin
+ ValStr := AList[Idx];
+
+ { if line isn't blank }
+ if ValStr <> '' then begin
+
+ { assume it's the schema name }
+ if (ValStr[1] = '[') and (ValStr[Length(ValStr)] = ']') then
+ SchemaName := Copy(ValStr, 2, Length(ValStr) - 2)
+ else
+ { assume the line is a comment }
+ if ValStr[1] = FCommentDelimiter {';'} then
+ { ignore it };
+ { else, it's blank, so skip it }
+ end;
+
+ end;
+
+ { extract other Schema Info }
+ { get layout type }
+ ValStr := AList.Values['Filetype'];
+ if UpperCase(ValStr) = 'VARYING' then
+ FLayoutType := ltVarying
+ else
+ if UpperCase(ValStr) = 'FIXED' then
+ FLayoutType := ltFixed
+ else
+ FLayoutType := ltUnknown;
+
+ { get field separator for schema }
+ ValStr := AList.Values['Separator'];
+ if Length(ValStr) > 0 then
+ FFieldDelimiter := StDeEscape(ValStr)
+ else
+ case FLayoutType of {!!.01}
+ ltFixed : FFieldDelimiter := StDefaultFixedSep; {!!.01}
+ ltVarying: FFieldDelimiter := StDefaultDelim; {!!.01}
+ end; {!!.01}
+
+ { get quote delimiter for schema }
+ ValStr := AList.Values['Delimiter'];
+ if Length(ValStr) > 0 then
+ FQuoteDelimiter := StDeEscape(ValStr)
+ else
+ FQuoteDelimiter := StDefaultQuote;
+
+ { get quote delimiter for schema }
+ ValStr := AList.Values['Comment'];
+ if Length(ValStr) > 0 then
+ FCommentDelimiter := StDeEscape(ValStr)
+ else
+ FCommentDelimiter := StDefaultQuote;
+
+ { build fields list }
+ Idx := 1;
+ dsFieldList.Clear;
+ ValStr := AList.Values['Field' + IntToStr(Idx)];
+ while ValStr <> '' do begin
+ dsFieldList.AddFieldStr(ValStr);
+ Inc(Idx);
+ ValStr := AList.Values['Field' + IntToStr(Idx)];
+ end;
+end;
+{!!.01 -- End Added }
+
+
+{ TStTextDataRecord }
+
+constructor TStTextDataRecord.Create;
+begin
+ inherited Create;
+
+ { set default values }
+ FValue := '';
+ FQuoteAlways := False;
+ FQuoteIfSpaces := False;
+
+ { create internal instances }
+ FFieldList := TStringList.Create;
+end;
+
+destructor TStTextDataRecord.Destroy;
+begin
+ { free internal instances }
+ FFieldList.Free;
+
+ inherited Destroy;
+end;
+
+procedure TStTextDataRecord.BuildRecord(Values : TStrings; var NewRecord : String);
+{ re-construct record structure from list of field values }
+var
+ i : Integer;
+ Temp : String;
+begin
+ NewRecord := '';
+
+ for i := 0 to Pred(Values.Count) do begin
+ Temp := Values[i];
+
+ { re-quote value if needed }
+ DoQuote(Temp);
+
+ { add value onto record }
+ if i = 0 then
+ NewRecord := Temp
+ else
+ NewRecord := NewRecord + FSchema.FieldDelimiter + Temp;
+ end;
+end;
+
+procedure TStTextDataRecord.DoQuote(var Value : String);
+{ quote field string if needed or desired }
+var
+ QuoteIt : Boolean;
+begin
+ { fire event if available }
+ if Assigned(FOnQuoteField) then begin
+ FOnQuoteField(self, Value);
+ end
+ else begin { use default quoting policy }
+ QuoteIt := False;
+ if FQuoteAlways then
+ QuoteIt := True
+ else
+ if ((Pos(' ', Value) > 0) and FQuoteIfSpaces)
+ or (Pos(FSchema.FieldDelimiter, Value) > 0)
+ then
+ QuoteIt := True;
+
+ if QuoteIt then
+ Value := FSchema.QuoteDelimiter + Value + FSchema.QuoteDelimiter;
+ end;
+end;
+
+function ConvertValue(Value : TVarRec) : String;
+{ convert variant record to equivalent string }
+const
+ BoolChars: array[Boolean] of Char = ('F', 'T');
+begin
+ case Value.VType of
+ vtAnsiString: Result := AnsiString(Value.VAnsiString);
+ {$IFDEF UNICODE}
+ vtUnicodeString: Result := UnicodeString(Value.VUnicodeString);
+ vtWideString: Result := WideString(Value.VWideString);
+ {$ENDIF}
+ vtBoolean: Result := BoolChars[Value.VBoolean];
+ vtChar: Result := Value.VChar;
+ vtCurrency: Result := CurrToStr(Value.VCurrency^);
+ vtExtended: Result := FloatToStr(Value.VExtended^);
+ vtInteger: Result := IntToStr(Value.VInteger);
+ vtPChar: Result := Value.VPChar;
+ vtString: Result := Value.VString^;
+ {$IFDEF VERSION4}
+ vtInt64: Result := IntToStr(Value.VInt64^);
+ {$ENDIF VERSION4}
+ else
+ raise EStException.CreateResTP(stscTxtDatUnhandledVariant, 0);
+ end;
+end;
+
+procedure TStTextDataRecord.FillRecordFromArray(Values : array of const);
+{ supply field values from a variant open array }
+var
+ i, j : Integer;
+begin
+ {$IFDEF Version4}
+ if Length(Values) > 0 then begin
+ {$ENDIF}
+ i := 0;
+ j := Low(Values);
+ while (j <= High(Values)) and (i < Schema.FieldCount) do begin
+ SetField(i, ConvertValue(Values[j]));
+ Inc(i);
+ Inc(j);
+ end;
+ {$IFDEF Version4}
+ end;
+ {$ENDIF}
+end;
+
+procedure TStTextDataRecord.FillRecordFromList(Items : TStrings);
+{ supply field values from = pairs }
+{
+ Fields filled from pairs provided in TStrings
+ entries in Items that don't match Field Names are ignored
+ Fields with Names having no corresponding entry in Items are left empty
+}
+var
+ i : Integer;
+ FN : String;
+begin
+ if Assigned(Items) then begin
+ for i := 0 to Pred(Schema.FieldCount) do begin
+ FN := Schema.Fields[i].FieldName;
+ FieldByName[FN] := Items.Values[FN];
+ end;
+ end;
+end;
+
+procedure TStTextDataRecord.FillRecordFromValues(Values : TStrings);
+{ supply field values from a list of values }
+{
+ Fields filled from Values provided in TStrings
+ if more Values than Fields, extras are ignored
+ if fewer Values than Fields, remaining Fields are left empty
+}
+var
+ i : Integer;
+begin
+ if Assigned(Values) then begin
+ i := 0;
+ while (i < Values.Count) and (i < Schema.FieldCount) do begin
+ SetField(i, Values[i]);
+ Inc(i);
+ end;
+ end;
+end;
+
+
+function TStTextDataRecord.GetFieldByName(const FieldName: String): String;
+{ retrieve value of field in current record with given name }
+var
+ Idx : Integer;
+begin
+ Result := '';
+ Idx := FSchema.IndexOf(FieldName);
+ if Idx > -1 then
+ Result := GetField(Idx)
+ else
+ raise EStException.CreateResTP(stscTxtDatNoSuchField, 0);
+end;
+
+function TStTextDataRecord.GetField(Index: Integer): String;
+{ retrieve value of field in current record at given index }
+var
+ Len, Offset: Integer;
+ DataField : TStDataField;
+ Fields : TStringList;
+begin
+ if (Index < -1) or (Index > Pred(FSchema.FieldCount)) then
+ raise EStException.CreateResTP(stscBadIndex, 0);
+
+ { get characteristics of the field of interest }
+ DataField := FSchema.Fields[Index];
+ Len := DataField.FieldLen;
+ { Decimals := DataField.FieldDecimals; }
+ Offset := DataField.FFieldOffset;
+
+
+ { extract field data from record }
+ case FSchema.LayoutType of
+ ltFixed : begin
+ { note: Offset is zero based, strings are 1 based } {!!.01}
+ Result := Copy(FValue, Offset + 1, Len); {!!.01}
+ end;
+
+ ltVarying : begin
+ Fields := TStringList.Create;
+ try
+ ExtractTokensL(FValue, FSchema.FieldDelimiter, FSchema.QuoteDelimiter,
+ True, Fields);
+ Result := Fields[Index];
+ finally
+ Fields.Free;
+ end;
+ end;
+
+ ltUnknown : begin
+ raise EStException.CreateResTP(stscTxtDatInvalidSchema, 0);
+ end;
+ end; {case}
+end;
+
+function TStTextDataRecord.GetFieldCount: Integer;
+begin
+ GetFieldList; {!!.02}
+ Result := FFieldList.Count;
+end;
+
+function TStTextDataRecord.GetFieldList: TStrings;
+{ convert fields of current record into TStrings collection
+ of = pairs }
+var
+ i : Integer;
+ FN : String;
+begin
+ FFieldList.Clear;
+
+ for i := 0 to Pred(FSchema.FieldCount) do begin
+ FN := FSchema.Fields[i].FieldName;
+ FFieldList.Add(FN + '=' + FieldByName[FN]);
+ end;
+
+ Result := FFieldList;
+end;
+
+function TStTextDataRecord.GetValues: TStrings;
+var
+ i : Integer;
+ FN : String;
+begin
+ FFieldList.Clear;
+
+ for i := 0 to Pred(FSchema.FieldCount) do begin
+ FN := FSchema.Fields[i].FieldName;
+ FFieldList.Add(FieldByName[FN]);
+ end;
+
+ Result := FFieldList;
+end;
+
+procedure TStTextDataRecord.MakeEmpty;
+{ create an empty record according to schema layout }
+var
+ i, Width, FieldPos : Integer;
+begin
+ case FSchema.LayoutType of
+ { string of spaces, length equal to total record width }
+ ltFixed: begin
+ Width := 0;
+ for i := 0 to Pred(FSchema.FieldCount) do begin {!!.01}
+ FieldPos := FSchema.Fields[i].FieldLen + {!!.01}
+ FSchema.Fields[i].FieldOffset + 1; {!!.01}
+ if Width < FieldPos then {!!.01}
+ Width := FieldPos; {!!.01}
+ end; {!!.01}
+ FValue := StringOfChar(FSchema.FixedSeparator, Width); {!!.01}
+ end;
+
+ { string of field separators, length equal to one less than no. of fields }
+ ltVarying: begin
+ FValue := StringOfChar(FSchema.FieldDelimiter, Pred(FSchema.FieldCount));
+ end;
+
+ ltUnknown : begin
+ raise EStException.CreateResTP(stscTxtDatInvalidSchema, 0);
+ end;
+ end;
+end;
+
+procedure TStTextDataRecord.SetFieldByName(const FieldName: String;
+ const NewValue: String);
+{ set value of field in current record with given name }
+var
+ Idx : Integer;
+begin
+ Idx := FSchema.IndexOf(FieldName);
+ if Idx > -1 then
+ SetField(Idx, NewValue)
+ else
+ raise EStException.CreateResTP(stscTxtDatNoSuchField, 0);
+end;
+
+procedure TStTextDataRecord.SetField(Index: Integer;
+ const NewValue: String);
+{ set value of field in current record at given index }
+var
+ Len, Offset: Integer;
+ Temp, FieldVal : String;
+ Fields : TStringList;
+ Idx : Integer;
+ DataField : TStDataField;
+begin
+ if (Index < -1) or (Index > Pred(FSchema.FieldCount)) then
+ raise EStException.CreateResTP(stscBadIndex, 0);
+
+ { get characteristics of the field of interest }
+ DataField := FSchema.Fields[Index];
+ Len := DataField.FieldLen;
+ Offset := DataField.FFieldOffset;
+
+ Temp := '';
+
+ case FSchema.LayoutType of
+ ltFixed : begin
+ for Idx := 0 to Pred(FSchema.FieldCount) do begin
+ if Idx = Index then begin
+ { replace field with Value right buffered or trimmed to to fit field length }
+ if Length(NewValue) < Len then
+ FieldVal := PadChL(NewValue, FSchema.FFixedSeparator, Len) {!!.01}
+ else
+ FieldVal := Copy(NewValue, 1, Len);
+
+ { note: Offset is zero based, strings are 1 based }
+ Move(FieldVal[1], FValue[Offset + 1], Len * SizeOf(Char));
+ end;
+ end;
+ end;
+
+ ltVarying : begin
+ Fields := TStringList.Create;
+ try
+ { parse out the field values }
+ ExtractTokensL(FValue, FSchema.FFieldDelimiter, {!!.01}
+ FSchema.QuoteDelimiter, True, Fields); {!!.01}
+
+
+{!!.02 - rewritten }
+// { find field of interest }
+// for Idx := 0 to Pred(FSchema.FieldCount) do begin
+// if Idx = Index then
+// { set the new value }
+// Fields[Idx] := NewValue;
+
+ { set field of interest }
+ Fields[Index] := NewValue;
+
+ { reconstruct the record }
+ BuildRecord(Fields, FValue);
+// end;
+{!!.02 - rewritten end }
+
+ finally
+ Fields.Free;
+ end;
+ end;
+
+ ltUnknown : begin
+ raise EStException.CreateResTP(stscTxtDatInvalidSchema, 0);
+ end;
+ end; {case}
+end;
+
+procedure TStTextDataRecord.SetQuoteAlways(const Value: Boolean);
+begin
+ FQuoteAlways := Value;
+end;
+
+procedure TStTextDataRecord.SetQuoteIfSpaces(const Value: Boolean);
+begin
+ FQuoteIfSpaces := Value;
+end;
+
+procedure TStTextDataRecord.SetSchema(const Value: TStTextDataSchema);
+begin
+ FSchema := Value;
+end;
+
+{!!.02 - Added }
+function TStTextDataRecord.GetRecord: String;
+var
+ Idx : Integer;
+ Field : String;
+begin
+ Result := '';
+ for Idx := 0 to (FSchema.FieldCount - 2) do begin
+ Field := self.Fields[Idx];
+ DoQuote(Field);
+ Result := Result + Field + FSchema.FFieldDelimiter;
+ end;
+ Field := self.Fields[FSchema.FieldCount-1];
+ DoQuote(Field);
+ Result := Result + Field;
+end;
+{!!.02 - End Added }
+
+{ TStTextDataRecordSet }
+
+(*
+TStLineTerminator = ( {possible line terminators...}
+ ltNone, {..no terminator, ie fixed length lines}
+ ltCR, {..carriage return (#13)}
+ ltLF, {..line feed (#10)}
+ ltCRLF, {..carriage return/line feed (#13/#10)}
+ ltOther); {..another character}
+*)
+
+constructor TStTextDataRecordSet.Create;
+begin
+ inherited Create;
+ FCurrentIndex := 0;
+ FRecords := TList.Create;
+ FIsDirty := False;
+ FAtEndOfFile := False; {!!.01}
+ FIgnoreStartingLines := 0; {!!.02}
+end;
+
+destructor TStTextDataRecordSet.Destroy;
+begin
+ FRecords.Free;
+ inherited Destroy;
+end;
+
+procedure TStTextDataRecordSet.Append;
+{ append new empty record to dataset }
+var
+ Rec : TStTextDataRecord;
+begin
+ Rec := TStTextDataRecord.Create;
+ Rec.Schema := Schema;
+ Rec.MakeEmpty;
+ FRecords.Add(Rec);
+ FIsDirty := True;
+ Last;
+end;
+
+procedure TStTextDataRecordSet.AppendArray(Values : array of const);
+{ append new record to dataset, set field values from a variant open array }
+begin
+ Append;
+ CurrentRecord.FillRecordFromArray(Values);
+end;
+
+procedure TStTextDataRecordSet.AppendList(Items: TStrings);
+{ append new record to dataset, set field values from = pairs}
+begin
+ Append;
+ CurrentRecord.FillRecordFromList(Items);
+end;
+
+procedure TStTextDataRecordSet.AppendValues(Values: TStrings);
+{ append new record to dataset, set field values from TStrings}
+begin
+ Append;
+ CurrentRecord.FillRecordFromValues(Values);
+end;
+
+function TStTextDataRecordSet.BOF: Boolean;
+{ test if at beginning of record set }
+begin
+ Result := (FCurrentIndex = 0);
+end;
+
+procedure TStTextDataRecordSet.Clear;
+{ empty record set }
+var
+ i : Integer;
+begin
+ for i := 0 to Pred(FRecords.Count) do
+ TStTextDataRecord(FRecords[i]).Free;
+ FRecords.Clear;
+ FIsDirty := False;
+end;
+
+procedure TStTextDataRecordSet.Delete;
+{ delete record at current position }
+begin
+ TStTextDataRecord(FRecords[FCurrentIndex]).Free;
+ FRecords.Delete(FCurrentIndex);
+ FIsDirty := True;
+ Next;
+end;
+
+function TStTextDataRecordSet.EOF: Boolean;
+{ test if at end of record set }
+begin
+ if FAtEndOfFile then {!!.01}
+ FAtEndOfFile := FCurrentIndex = Pred(FRecords.Count); {!!.01}
+ Result := FAtEndOfFile {!!.01}
+end;
+
+procedure TStTextDataRecordSet.First;
+{ make first record in set current }
+begin
+ FCurrentIndex := 0;
+end;
+
+function TStTextDataRecordSet.GetCount: Integer;
+{ return count of records in set }
+begin
+ Result := FRecords.Count;
+end;
+
+function TStTextDataRecordSet.GetRecord(Index: Integer): TStTextDataRecord;
+{ return particular record by index }
+begin
+ if (Index > -1) and (Index < FRecords.Count) then
+ Result := FRecords[Index]
+ else
+ raise EStException.CreateResTP(stscBadIndex, 0);
+end;
+
+function TStTextDataRecordSet.GetCurrentRecord: TStTextDataRecord;
+{ return current record }
+begin
+ Result := FRecords[FCurrentIndex];
+end;
+
+function TStTextDataRecordSet.GetSchema: TStTextDataSchema;
+{ return reference to associated schema, create default one if needed }
+begin
+ if not Assigned(FSchema) then
+ FSchema := TStTextDataSchema.Create;
+ Result := FSchema;
+end;
+
+procedure TStTextDataRecordSet.Insert(Index: Integer);
+{ insert new empty record into dataset at specified location,
+ shifts the record set down one }
+var
+ Rec : TStTextDataRecord;
+begin
+ Rec := TStTextDataRecord.Create;
+ Rec.Schema := Schema;
+ Rec.MakeEmpty;
+ FRecords.Insert(Index, Rec);
+ FIsDirty := True;
+ FCurrentIndex := Index;
+end;
+
+procedure TStTextDataRecordSet.InsertArray(Index: Integer; Values : array of const);
+{ insert new record into dataset dataset at specified location,
+ shifts the record set down one,
+ set field values from a variant open array }
+begin
+ Insert(Index);
+ CurrentRecord.FillRecordFromArray(Values);
+end;
+
+procedure TStTextDataRecordSet.InsertList(Index: Integer;
+ Items: TStrings);
+{ insert new record into dataset dataset at specified location,
+ shifts the record set down one,
+ set field values from = pairs}
+begin
+ Insert(Index);
+ CurrentRecord.FillRecordFromList(Items);
+end;
+
+procedure TStTextDataRecordSet.InsertValues(Index: Integer;
+ Values: TStrings);
+{ insert new record into dataset dataset at specified location,
+ shifts the record set down one,
+ set field values from TStrings}
+begin
+ Insert(Index);
+ CurrentRecord.FillRecordFromValues(Values);
+end;
+
+procedure TStTextDataRecordSet.Last;
+{ make final record in set current }
+begin
+ FCurrentIndex := Pred(FRecords.Count);
+end;
+
+procedure TStTextDataRecordSet.LoadFromFile(const AFile: TFileName);
+var
+ FS : TFileStream;
+begin
+ FS := TFileStream.Create(AFile, fmOpenRead or fmShareDenyNone);
+ try
+ LoadFromStream(FS);
+ finally
+ FS.Free;
+ end;
+end;
+
+procedure TStTextDataRecordSet.LoadFromStream(AStream: TStream);
+var
+ TS : TStAnsiTextStream;
+ NewRec : TStTextDataRecord;
+ i, Len : Integer; {!!.02}
+begin
+ if FActive then
+ raise EStException.CreateResTP(stscTxtDatRecordSetOpen, 0);
+
+ Clear;
+
+ TS := TStAnsiTextStream.Create(AStream);
+
+ { match Ansi Stream terminator to schema's }
+ TS.LineTermChar := AnsiChar(Schema.LineTermChar);
+ TS.LineTerminator := Schema.LineTerminator;
+
+{!!.02 - added }
+ { calculate length of fixed record }
+ if Schema.LayoutType = ltFixed then begin
+ Len := 0;
+ for i := 0 to Pred(Schema.FieldCount) do
+ Len := Len + Schema.Fields[i].FieldLen;
+ TS.FixedLineLength := Len;
+ end;
+{!!.02 - added end }
+
+ try
+{!!.02 - added }
+ { ignore starting lines }
+ for i := 1 to FIgnoreStartingLines do
+ TS.ReadLine;
+{!!.02 - added end }
+
+ while not TS.AtEndOfStream do begin
+ { new record }
+ NewRec := TStTextDataRecord.Create;
+
+ { set record data }
+ NewRec.FValue := TS.ReadLine;
+
+{!!.01 - Rewritten }
+ if TrimCharsL(NewRec.FValue, St_WhiteSpace) <> '' then begin
+ { set the schema to match }
+ NewRec.Schema := Schema;
+
+ { append new record }
+ FRecords.Add(NewRec);
+
+ end
+ else {ignore blank lines}
+ NewRec.Free;
+{!!.01 - End Rewritten }
+ end;
+
+
+ FActive := True;
+ FIsDirty := False;
+ finally
+ TS.Free;
+ end;
+end;
+
+function TStTextDataRecordSet.Next : Boolean;
+{ make next record in set current }
+begin
+ Result := True;
+
+ { if already on last record, stay there }
+ if FCurrentIndex = Pred(FRecords.Count) then begin {!!.01}
+ FAtEndOfFile := True; { yep, we're at the end } {!!.01}
+ Result := False; {!!.01}
+ end {!!.01}
+ else {!!.01}
+ Inc(FCurrentIndex); {!!.01}
+end;
+
+function TStTextDataRecordSet.Prior : Boolean;
+{ make previous record in set current }
+begin
+ Result := True;
+ Dec(FCurrentIndex);
+
+ { if already on first record, stay there }
+ if FCurrentIndex < 0 then begin
+ FCurrentIndex := 0;
+ Result := False;
+ end;
+end;
+
+procedure TStTextDataRecordSet.SaveToFile(const AFile: TFileName);
+var
+ FS : TFileStream;
+begin
+ if not FileExists(AFile) then begin
+ FS := TFileStream.Create(AFile, fmCreate);
+ FS.Free;
+ end;
+
+ FS := TFileStream.Create(AFile, fmOpenWrite or fmShareDenyNone);
+
+ try
+ SaveToStream(FS);
+ finally
+ FS.Free;
+ end;
+end;
+
+procedure TStTextDataRecordSet.SaveToStream(AStream: TStream);
+var
+ TS : TStAnsiTextStream;
+ i : Integer;
+begin
+ TS := TStAnsiTextStream.Create(AStream);
+
+ { match Ansi Stream terminator to schema's }
+ TS.LineTermChar := AnsiChar(Schema.LineTermChar);
+ TS.LineTerminator := Schema.LineTerminator;
+
+ { write the records }
+ try
+ for i := 0 to Pred(FRecords.Count) do
+ TS.WriteLine(TStTextDataRecord(FRecords[i]).AsString);
+
+ FIsDirty := False;
+ finally
+ TS.Free;
+ end;
+end;
+
+procedure TStTextDataRecordSet.SetActive(const Value: Boolean);
+{ activate or close record set }
+begin
+ FActive := Value;
+ if not FActive then begin
+ Clear;
+ FSchema := nil;
+ end;
+end;
+
+procedure TStTextDataRecordSet.SetCurrentRecord(
+ const Value: TStTextDataRecord);
+begin
+ TStTextDataRecord(FRecords[FCurrentIndex]).Free;
+ FRecords.Insert(FCurrentIndex, Value);
+ FIsDirty := True;
+end;
+
+procedure TStTextDataRecordSet.SetRecord(Index: Integer;
+ const Value: TStTextDataRecord);
+begin
+ TStTextDataRecord(FRecords[Index]).Free;
+ FRecords.Insert(Index, Value);
+ FIsDirty := True;
+end;
+
+procedure TStTextDataRecordSet.SetSchema(const Value: TStTextDataSchema);
+{ assign new schema, only works on inactive record set }
+begin
+ if not FActive then begin
+ if Assigned(FSchema) then
+ FSchema.Free;
+ FSchema := Value;
+ end
+ else
+ raise EStException.CreateResTP(stscTxtDatRecordSetOpen, 0);
+end;
+
+
+
+end.