diff --git a/components/systools/examples/windows-only/general_log/exgenlog.lpi b/components/systools/examples/windows-only/general_log/exgenlog.lpi
new file mode 100644
index 000000000..6d890a74b
--- /dev/null
+++ b/components/systools/examples/windows-only/general_log/exgenlog.lpi
@@ -0,0 +1,86 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/windows-only/general_log/exgenlog.lpr b/components/systools/examples/windows-only/general_log/exgenlog.lpr
new file mode 100644
index 000000000..d2655676c
--- /dev/null
+++ b/components/systools/examples/windows-only/general_log/exgenlog.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 ExGenLog;
+
+uses
+ Interfaces,
+ Forms, lclversion,
+ exglog1 in 'exglog1.pas' {Form1};
+
+{$R *.res}
+
+begin
+ {$IF LCL_FULLVERSION >= 1080000}
+ Application.Scaled := True;
+ {$ENDIF}
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git a/components/systools/examples/windows-only/general_log/exglog1.lfm b/components/systools/examples/windows-only/general_log/exglog1.lfm
new file mode 100644
index 000000000..473e3401b
--- /dev/null
+++ b/components/systools/examples/windows-only/general_log/exglog1.lfm
@@ -0,0 +1,97 @@
+object Form1: TForm1
+ Left = 280
+ Height = 254
+ Top = 305
+ Width = 514
+ Caption = 'General Log Example'
+ ClientHeight = 254
+ ClientWidth = 514
+ Color = clBtnFace
+ Font.Color = clWindowText
+ OnCreate = FormCreate
+ LCLVersion = '1.9.0.0'
+ object Label1: TLabel
+ Left = 192
+ Height = 15
+ Top = 107
+ Width = 71
+ Caption = 'String to add:'
+ ParentColor = False
+ end
+ object RadioGroup1: TRadioGroup
+ Left = 193
+ Height = 57
+ Top = 22
+ Width = 289
+ AutoFill = True
+ Caption = 'Event Type'
+ ChildSizing.LeftRightSpacing = 6
+ ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+ ChildSizing.EnlargeVertical = crsHomogenousChildResize
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 4
+ ClientHeight = 37
+ ClientWidth = 285
+ Columns = 4
+ Items.Strings = (
+ 'Apple'
+ 'Orange'
+ 'Lemon'
+ 'Grape'
+ )
+ TabOrder = 0
+ end
+ object Button1: TButton
+ Left = 33
+ Height = 33
+ Top = 38
+ Width = 121
+ Caption = 'Add event to log'
+ OnClick = Button1Click
+ TabOrder = 1
+ end
+ object Button2: TButton
+ Left = 32
+ Height = 33
+ Top = 110
+ Width = 121
+ Caption = 'Add string to log'
+ OnClick = Button2Click
+ TabOrder = 2
+ end
+ object Edit1: TEdit
+ Left = 192
+ Height = 23
+ Top = 126
+ Width = 289
+ TabOrder = 3
+ end
+ object Button3: TButton
+ Left = 32
+ Height = 33
+ Top = 182
+ Width = 121
+ Caption = 'Dump log'
+ OnClick = Button3Click
+ TabOrder = 4
+ end
+ object CheckBox1: TCheckBox
+ Left = 192
+ Height = 19
+ Top = 192
+ Width = 82
+ Caption = 'Append log'
+ OnClick = CheckBox1Click
+ TabOrder = 5
+ end
+ object StGeneralLog1: TStGeneralLog
+ FileName = 'debug.log'
+ LogFileHeader = 'SysTools General Log'#10#13'============================================================================='#10#13#10#13
+ WriteMode = wmOverwrite
+ OnGetLogString = StGeneralLog1GetLogString
+ left = 400
+ top = 168
+ end
+end
diff --git a/components/systools/examples/windows-only/general_log/exglog1.pas b/components/systools/examples/windows-only/general_log/exglog1.pas
new file mode 100644
index 000000000..d2423fed4
--- /dev/null
+++ b/components/systools/examples/windows-only/general_log/exglog1.pas
@@ -0,0 +1,127 @@
+(* ***** 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 ExGLog1;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ StdCtrls, ExtCtrls, StBase, StGenLog;
+
+const
+ AppleEvent = 1;
+ OrangeEvent = 2;
+ LemonEvent = 3;
+ GrapeEvent = 4;
+ UnknownEvent = 5;
+
+type
+ TForm1 = class(TForm)
+ RadioGroup1: TRadioGroup;
+ Button1: TButton;
+ Button2: TButton;
+ Edit1: TEdit;
+ Label1: TLabel;
+ Button3: TButton;
+ CheckBox1: TCheckBox;
+ StGeneralLog1: TStGeneralLog;
+ procedure CheckBox1Click(Sender: TObject);
+ procedure Button3Click(Sender: TObject);
+ procedure Button2Click(Sender: TObject);
+ procedure Button1Click(Sender: TObject);
+ procedure StGeneralLog1GetLogString(Sender: TObject; const D1, D2, D3,
+ D4: Integer; var LogString: String);
+ procedure FormCreate(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$IFDEF FPC}
+ {$R *.lfm}
+{$ELSE}
+ {$R *.dfm}
+{$ENDIF}
+
+procedure TForm1.CheckBox1Click(Sender: TObject);
+begin
+ if CheckBox1.Checked then
+ StGeneralLog1.WriteMode := wmAppend
+ else
+ StGeneralLog1.WriteMode := wmOverwrite;
+end;
+
+procedure TForm1.Button3Click(Sender: TObject);
+begin
+ StGeneralLog1.DumpLog;
+end;
+
+procedure TForm1.Button2Click(Sender: TObject);
+begin
+ StGeneralLog1.WriteLogString(Edit1.Text);
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+ case RadioGroup1.ItemIndex of
+ 0 : StGeneralLog1.AddLogEntry(AppleEvent, 0, 0, 0);
+ 1 : StGeneralLog1.AddLogEntry(OrangeEvent, 0, 0, 0);
+ 2 : StGeneralLog1.AddLogEntry(LemonEvent, 0, 0, 0);
+ 3 : StGeneralLog1.AddLogEntry(GrapeEvent, 0, 0, 0);
+ else
+ StGeneralLog1.AddLogEntry(UnknownEvent, 0, 0, 0);
+ end;
+end;
+
+procedure TForm1.StGeneralLog1GetLogString(Sender: TObject; const D1, D2,
+ D3, D4: Integer; var LogString: String);
+begin
+ case D1 of
+ AppleEvent : LogString := 'AppleEvent';
+ OrangeEvent : LogString := 'OrangeEvent';
+ LemonEvent : LogString := 'LemonEvent';
+ GrapeEvent : LogString := 'GrapeEvent';
+ else
+ LogString := 'UnknownEvent';
+ end
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ StGeneralLog1.FileName := ExtractFilePath(Application.ExeName) + 'exgenlog.log';
+end;
+
+end.
diff --git a/components/systools/examples/windows-only/nt_log/exnlog1.lfm b/components/systools/examples/windows-only/nt_log/exnlog1.lfm
new file mode 100644
index 000000000..e70f6c587
--- /dev/null
+++ b/components/systools/examples/windows-only/nt_log/exnlog1.lfm
@@ -0,0 +1,90 @@
+object Form1: TForm1
+ Left = 205
+ Height = 310
+ Top = 155
+ Width = 421
+ Caption = 'NT Log Example'
+ ClientHeight = 310
+ ClientWidth = 421
+ Color = clBtnFace
+ Font.Color = clWindowText
+ LCLVersion = '1.9.0.0'
+ object Label1: TLabel
+ Left = 159
+ Height = 1
+ Top = 72
+ Width = 1
+ ParentColor = False
+ end
+ object Label2: TLabel
+ Left = 159
+ Height = 1
+ Top = 112
+ Width = 1
+ ParentColor = False
+ end
+ object Label3: TLabel
+ Left = 159
+ Height = 1
+ Top = 152
+ Width = 1
+ ParentColor = False
+ end
+ object Label4: TLabel
+ Left = 64
+ Height = 15
+ Top = 72
+ Width = 86
+ Caption = 'Number of logs:'
+ ParentColor = False
+ end
+ object Label5: TLabel
+ Left = 64
+ Height = 15
+ Top = 112
+ Width = 74
+ Caption = 'Record count:'
+ ParentColor = False
+ end
+ object Label6: TLabel
+ Left = 64
+ Height = 15
+ Top = 152
+ Width = 71
+ Caption = 'Records read:'
+ ParentColor = False
+ end
+ object Label7: TLabel
+ Left = 241
+ Height = 15
+ Top = 45
+ Width = 85
+ Caption = 'Logs on system:'
+ ParentColor = False
+ end
+ object Button1: TButton
+ AnchorSideLeft.Control = Owner
+ AnchorSideLeft.Side = asrCenter
+ Left = 165
+ Height = 25
+ Top = 256
+ Width = 91
+ AutoSize = True
+ Caption = 'Get Log Info'
+ OnClick = Button1Click
+ TabOrder = 0
+ end
+ object ListBox1: TListBox
+ Left = 240
+ Height = 129
+ Top = 64
+ Width = 161
+ ItemHeight = 0
+ TabOrder = 1
+ end
+ object EL: TStNTEventLog
+ LogName = 'Application'
+ left = 24
+ top = 24
+ end
+end
diff --git a/components/systools/examples/windows-only/nt_log/exnlog1.pas b/components/systools/examples/windows-only/nt_log/exnlog1.pas
new file mode 100644
index 000000000..2eaafa94a
--- /dev/null
+++ b/components/systools/examples/windows-only/nt_log/exnlog1.pas
@@ -0,0 +1,88 @@
+(* ***** 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 ExNLog1;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ StdCtrls, StBase, StNTLog;
+
+type
+ TForm1 = class(TForm)
+ Button1: TButton;
+ EL: TStNTEventLog;
+ Label1: TLabel;
+ Label2: TLabel;
+ Label3: TLabel;
+ ListBox1: TListBox;
+ Label4: TLabel;
+ Label5: TLabel;
+ Label6: TLabel;
+ Label7: TLabel;
+ procedure Button1Click(Sender: TObject);
+ private
+ { Private declarations }
+ procedure MyOnRead(Sender : TObject; const EventRec : TStNTEventLogRec; var Abort : Boolean);
+ public
+ { Public declarations }
+ end;
+
+var
+ Form1: TForm1;
+ ReadCount : DWORD = 0;
+
+implementation
+
+{$IFDEF FPC}
+ {$R *.lfm}
+{$ELSE}
+ {$R *.dfm}
+{$ENDIF}
+
+procedure TForm1.MyOnRead(Sender : TObject; const EventRec : TStNTEventLogRec; var Abort : Boolean);
+begin
+ Inc(ReadCount);
+end;
+
+procedure TForm1.Button1Click(Sender: TObject);
+var
+ I : Integer;
+begin
+ EL.OnReadRecord := MyOnRead;
+ Label1.Caption := IntToStr(EL.LogCount);
+ for I := 0 to EL.LogCount-1 do
+ Listbox1.Items.Add(EL.Logs[I]);
+ Label2.Caption := IntToStr(EL.RecordCount);
+ EL.ReadLog(True);
+ Label3.Caption := IntToStr(ReadCount);
+end;
+
+end.
diff --git a/components/systools/examples/windows-only/nt_log/exntlog.lpi b/components/systools/examples/windows-only/nt_log/exntlog.lpi
new file mode 100644
index 000000000..07cb778a0
--- /dev/null
+++ b/components/systools/examples/windows-only/nt_log/exntlog.lpi
@@ -0,0 +1,83 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/windows-only/nt_log/exntlog.lpr b/components/systools/examples/windows-only/nt_log/exntlog.lpr
new file mode 100644
index 000000000..319345884
--- /dev/null
+++ b/components/systools/examples/windows-only/nt_log/exntlog.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 ExNTLog;
+
+uses
+ Interfaces,
+ Forms, lclversion,
+ exnlog1 in 'exnlog1.pas' {Form1};
+
+{$R *.res}
+
+begin
+ {$IF LCL_FULLVERSION >= 1080000}
+ Application.Scaled := True;
+ {$ENDIF}
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git a/components/systools/examples/windows-only/sort/exsort.lpi b/components/systools/examples/windows-only/sort/exsort.lpi
new file mode 100644
index 000000000..7977bbc8b
--- /dev/null
+++ b/components/systools/examples/windows-only/sort/exsort.lpi
@@ -0,0 +1,86 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/windows-only/sort/exsort.lpr b/components/systools/examples/windows-only/sort/exsort.lpr
new file mode 100644
index 000000000..cd89aa050
--- /dev/null
+++ b/components/systools/examples/windows-only/sort/exsort.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 ExSort;
+
+uses
+ Interfaces,
+ Forms, lclversion,
+ exsortu in 'exsortu.pas' {TSTDlg};
+
+{$R *.res}
+
+begin
+ {$IF LCL_FULLVERSION >= 1080000}
+ Application.Scaled := True;
+ {$ENDIF}
+ Application.Initialize;
+ Application.CreateForm(TSTDlg, STDlg);
+ Application.Run;
+end.
diff --git a/components/systools/examples/windows-only/sort/exsortu.lfm b/components/systools/examples/windows-only/sort/exsortu.lfm
new file mode 100644
index 000000000..8784c9c79
--- /dev/null
+++ b/components/systools/examples/windows-only/sort/exsortu.lfm
@@ -0,0 +1,88 @@
+object STDlg: TSTDlg
+ Left = 250
+ Height = 273
+ Top = 156
+ Width = 428
+ Caption = 'StSorter Example'
+ ClientHeight = 273
+ ClientWidth = 428
+ Color = clBtnFace
+ Font.Color = clWindowText
+ OnActivate = FormActivate
+ ShowHint = True
+ LCLVersion = '1.9.0.0'
+ object Label1: TLabel
+ Left = 346
+ Height = 15
+ Top = 28
+ Width = 76
+ Caption = 'Items (1..5000)'
+ ParentColor = False
+ end
+ object LB1: TListBox
+ Left = 8
+ Height = 247
+ Hint = 'Unsorted List'
+ Top = 16
+ Width = 163
+ Font.Color = clBlack
+ Font.Height = -11
+ Font.Name = 'Courier New'
+ ItemHeight = 0
+ ParentFont = False
+ TabOrder = 4
+ TabStop = False
+ end
+ object LB2: TListBox
+ Left = 180
+ Height = 247
+ Hint = 'Sorted List'
+ Top = 16
+ Width = 157
+ Font.Color = clBlack
+ Font.Height = -11
+ Font.Name = 'Courier New'
+ ItemHeight = 0
+ ParentFont = False
+ TabOrder = 5
+ TabStop = False
+ end
+ object NewBtn: TButton
+ Left = 348
+ Height = 35
+ Hint = 'Create New List'
+ Top = 72
+ Width = 71
+ Caption = 'New List'
+ OnClick = NewBtnClick
+ TabOrder = 1
+ end
+ object SorterBtn: TButton
+ Left = 348
+ Height = 35
+ Hint = 'Sort List'
+ Top = 133
+ Width = 71
+ Caption = 'Sort'
+ OnClick = SorterBtnClick
+ TabOrder = 2
+ end
+ object Btn4: TButton
+ Left = 348
+ Height = 35
+ Hint = 'Exit program'
+ Top = 212
+ Width = 71
+ Caption = 'Exit'
+ OnClick = Btn4Click
+ TabOrder = 3
+ end
+ object Edit1: TEdit
+ Left = 348
+ Height = 23
+ Hint = '# items in list'
+ Top = 46
+ Width = 69
+ TabOrder = 0
+ end
+end
diff --git a/components/systools/examples/windows-only/sort/exsortu.pas b/components/systools/examples/windows-only/sort/exsortu.pas
new file mode 100644
index 000000000..6ada89d24
--- /dev/null
+++ b/components/systools/examples/windows-only/sort/exsortu.pas
@@ -0,0 +1,163 @@
+(* ***** 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 ExSortU;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
+
+ StConst, StBase, StSort;
+
+type
+ SortException = class(Exception);
+
+ TSTDlg = class(TForm)
+ LB1: TListBox;
+ LB2: TListBox;
+ NewBtn: TButton;
+ SorterBtn: TButton;
+ Btn4: TButton;
+ Edit1: TEdit;
+ Label1: TLabel;
+ procedure FormActivate(Sender: TObject);
+ procedure Btn4Click(Sender: TObject);
+ procedure SorterBtnClick(Sender: TObject);
+ procedure NewBtnClick(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ DidGet : Boolean;
+ MaxElems : Integer;
+ ISort : TStSorter;
+ procedure DoRandomStrings;
+ end;
+
+var
+ STDlg: TSTDlg;
+
+implementation
+
+{$IFDEF FPC}
+ {$R *.lfm}
+{$ELSE}
+ {$R *.dfm}
+{$ENDIF}
+
+type
+ S15 = string[15];
+
+
+function MyCompare(const E1, E2) : Integer; far;
+begin
+ Result := CompareText(S15(E1),S15(E2));
+end;
+
+procedure TSTDlg.FormActivate(Sender: TObject);
+var
+ OHTU : LongInt;
+begin
+ MaxElems := 1000;
+ Edit1.Text := IntToStr(MaxElems);
+ DoRandomStrings;
+ OHTU := OptimumHeapToUse(SizeOf(S15),MaxElems);
+ ISort := TStSorter.Create(OHTU,SizeOf(S15));
+ ISort.Compare := MyCompare;
+ DidGet := False;
+end;
+
+procedure TSTDlg.Btn4Click(Sender: TObject);
+begin
+ ISort.Free;
+ Close;
+end;
+
+procedure TSTDlg.DoRandomStrings;
+var
+ step, I : Integer;
+ AStr : S15;
+begin
+ LB1.Clear;
+ LB1.Perform(WM_SETREDRAW,0,0);
+ Randomize;
+ for step := 1 to MaxElems do
+ begin
+ AStr[0] := chr(15);
+ for I := 1 to 15 do
+ AStr[I] := Chr(Random(26) + Ord('A'));
+ LB1.Items.Add(AStr);
+ end;
+ LB1.Perform(WM_SETREDRAW,1,0);
+ LB1.Update;
+end;
+
+procedure TSTDlg.SorterBtnClick(Sender: TObject);
+var
+ I : integer;
+ S : S15;
+begin
+ if DidGet then
+ ISort.Reset;
+ Screen.Cursor := crHourGlass;
+ if LB1.Items.Count > 0 then
+ begin
+ for I := 0 to LB1.Items.Count-1 do
+ begin
+ S := LB1.Items[I];
+ ISort.Put(S);
+ end;
+ end;
+ LB2.Clear;
+ LB2.Perform(WM_SETREDRAW,0,0);
+ while (ISort.Get(S)) do
+ LB2.Items.Add(S);
+ LB2.Perform(WM_SETREDRAW,1,0);
+ LB2.Update;
+ DidGet := True;
+ Screen.Cursor := crDefault;
+end;
+
+procedure TSTDlg.NewBtnClick(Sender: TObject);
+var
+ Code : Integer;
+begin
+ Val(Edit1.Text,MaxElems,Code);
+ if (Code <> 0) OR (MaxElems = 0) OR (MaxElems > 5000) then
+ begin
+ ShowMessage('Invalid entry or value out of range (1..5000)');
+ Exit;
+ end;
+ LB2.Clear;
+ DoRandomStrings;
+end;
+
+
+end.
diff --git a/components/systools/examples/windows-only/spawn/exspawn.lpi b/components/systools/examples/windows-only/spawn/exspawn.lpi
new file mode 100644
index 000000000..644ce628e
--- /dev/null
+++ b/components/systools/examples/windows-only/spawn/exspawn.lpi
@@ -0,0 +1,85 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/windows-only/spawn/exspawn.lpr b/components/systools/examples/windows-only/spawn/exspawn.lpr
new file mode 100644
index 000000000..58bab9ac1
--- /dev/null
+++ b/components/systools/examples/windows-only/spawn/exspawn.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 EXSPAWN;
+
+uses
+ Interfaces,
+ Forms, lclversion,
+ exspawnu in 'exspawnu.pas' {Form1};
+
+{$R *.res}
+
+begin
+ {$IF LCL_FULLVERSION >= 1080000}
+ Application.Scaled := True;
+ {$ENDIF}
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git a/components/systools/examples/windows-only/spawn/exspawnu.lfm b/components/systools/examples/windows-only/spawn/exspawnu.lfm
new file mode 100644
index 000000000..3f7459203
--- /dev/null
+++ b/components/systools/examples/windows-only/spawn/exspawnu.lfm
@@ -0,0 +1,103 @@
+object Form1: TForm1
+ Left = 383
+ Height = 188
+ Top = 219
+ Width = 212
+ BorderStyle = bsDialog
+ Caption = 'EXSPAWN'
+ ClientHeight = 188
+ ClientWidth = 212
+ Color = clBtnFace
+ Font.Color = clWindowText
+ Position = poScreenCenter
+ LCLVersion = '1.9.0.0'
+ object btnSpawn: TButton
+ AnchorSideLeft.Control = Owner
+ AnchorSideLeft.Side = asrCenter
+ Left = 69
+ Height = 25
+ Top = 148
+ Width = 75
+ Caption = 'Spawn'
+ OnClick = btnSpawnClick
+ TabOrder = 0
+ end
+ object RG1: TRadioGroup
+ Left = 20
+ Height = 54
+ Top = 5
+ Width = 172
+ AutoFill = True
+ Caption = ' Spawn Action '
+ ChildSizing.LeftRightSpacing = 6
+ ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+ ChildSizing.EnlargeVertical = crsHomogenousChildResize
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 2
+ ClientHeight = 34
+ ClientWidth = 168
+ Columns = 2
+ ItemIndex = 0
+ Items.Strings = (
+ 'Open'
+ 'Print'
+ )
+ TabOrder = 1
+ end
+ object cbNotify: TCheckBox
+ Left = 22
+ Height = 19
+ Top = 120
+ Width = 53
+ Caption = 'Notify'
+ TabOrder = 2
+ end
+ object cbTimeout: TCheckBox
+ Left = 96
+ Height = 19
+ Top = 120
+ Width = 93
+ Caption = 'Timeout (15s)'
+ TabOrder = 3
+ end
+ object RG2: TRadioGroup
+ Left = 18
+ Height = 44
+ Top = 64
+ Width = 174
+ AutoFill = True
+ Caption = ' Window State '
+ ChildSizing.LeftRightSpacing = 6
+ ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
+ ChildSizing.EnlargeVertical = crsHomogenousChildResize
+ ChildSizing.ShrinkHorizontal = crsScaleChilds
+ ChildSizing.ShrinkVertical = crsScaleChilds
+ ChildSizing.Layout = cclLeftToRightThenTopToBottom
+ ChildSizing.ControlsPerLine = 2
+ ClientHeight = 24
+ ClientWidth = 170
+ Columns = 2
+ ItemIndex = 0
+ Items.Strings = (
+ 'Minimized'
+ 'Normal'
+ )
+ TabOrder = 4
+ end
+ object StSpawnApplication1: TStSpawnApplication
+ OnCompleted = StSpawnApplication1Completed
+ OnSpawnError = StSpawnApplication1SpawnError
+ OnTimeOut = StSpawnApplication1TimeOut
+ TimeOut = 15
+ left = 32
+ top = 136
+ end
+ object OpenDialog1: TOpenDialog
+ DefaultExt = '.TXT'
+ Filter = 'Text files (*.txt)|*.txt|All files (*.*)|*.*'
+ left = 152
+ top = 136
+ end
+end
diff --git a/components/systools/examples/windows-only/spawn/exspawnu.pas b/components/systools/examples/windows-only/spawn/exspawnu.pas
new file mode 100644
index 000000000..6894a7647
--- /dev/null
+++ b/components/systools/examples/windows-only/spawn/exspawnu.pas
@@ -0,0 +1,114 @@
+(* ***** 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 exspawnu;
+
+interface
+
+uses
+ Windows, SysUtils, Messages, Classes, Graphics, Controls,
+ Forms, Dialogs, StdCtrls, ShellAPI, ExtCtrls,
+
+ StBase, StSpawn;
+
+type
+ TForm1 = class(TForm)
+ StSpawnApplication1: TStSpawnApplication;
+ btnSpawn: TButton;
+ RG1: TRadioGroup;
+ OpenDialog1: TOpenDialog;
+ cbNotify: TCheckBox;
+ cbTimeout: TCheckBox;
+ RG2: TRadioGroup;
+ procedure btnSpawnClick(Sender: TObject);
+ procedure StSpawnApplication1Completed(Sender: TObject);
+ procedure StSpawnApplication1SpawnError(Sender: TObject; Error: Word);
+ procedure StSpawnApplication1TimeOut(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ procedure EnableControls(B : Boolean);
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$IFDEF FPC}
+ {$R *.lfm}
+{$ELSE}
+ {$R *.dfm}
+{$ENDIF}
+
+procedure TForm1.EnableControls(B : Boolean);
+begin
+ rg1.Enabled := B;
+ rg2.Enabled := B;
+ cbNotify.Enabled := B;
+ cbTimeOut.Enabled := B;
+ btnSpawn.Enabled := B;
+end;
+
+procedure TForm1.btnSpawnClick(Sender: TObject);
+begin
+ if OpenDialog1.Execute then begin
+ StSpawnApplication1.FileName := OpenDialog1.FileName;
+ StSpawnApplication1.SpawnCommand := TStSpawnCommand(rg1.ItemIndex);
+ StSpawnApplication1.NotifyWhenDone := cbNotify.Checked;
+ if (rg2.ItemIndex = 0) then
+ StSpawnApplication1.ShowState := ssMinimized
+ else
+ StSpawnApplication1.ShowState := ssNormal;
+ StSpawnApplication1.TimeOut := Ord(cbTimeout.Checked) * 15;
+ EnableControls(StSpawnApplication1.TimeOut = 0);
+ StSpawnApplication1.Execute;
+ end;
+end;
+
+procedure TForm1.StSpawnApplication1Completed(Sender: TObject);
+begin
+ EnableControls(True);
+ ShowMessage('Done');
+end;
+
+procedure TForm1.StSpawnApplication1SpawnError(Sender: TObject; Error: Word);
+begin
+ EnableControls(True);
+ ShowMessage(IntToStr(Error));
+end;
+
+procedure TForm1.StSpawnApplication1TimeOut(Sender: TObject);
+begin
+ EnableControls(True);
+ ShowMessage('TimeOut');
+end;
+
+end.
diff --git a/components/systools/examples/windows-only/text_sort/textsort.lpi b/components/systools/examples/windows-only/text_sort/textsort.lpi
new file mode 100644
index 000000000..ccb4aad29
--- /dev/null
+++ b/components/systools/examples/windows-only/text_sort/textsort.lpi
@@ -0,0 +1,86 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/windows-only/text_sort/textsort.lpr b/components/systools/examples/windows-only/text_sort/textsort.lpr
new file mode 100644
index 000000000..9c6377bb9
--- /dev/null
+++ b/components/systools/examples/windows-only/text_sort/textsort.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 Textsort;
+
+uses
+ Interfaces,
+ Forms, lclversion,
+ TxtSortU in 'TxtSortU.pas' {STDlg};
+
+{$R *.res}
+
+begin
+ {$IF LCL_FULLVERSION >= 1080000}
+ Application.Scaled := True;
+ {$ENDIF}
+ Application.Initialize;
+ Application.CreateForm(TSTDlg, STDlg);
+ Application.Run;
+end.
diff --git a/components/systools/examples/windows-only/text_sort/txtsortu.lfm b/components/systools/examples/windows-only/text_sort/txtsortu.lfm
new file mode 100644
index 000000000..d8e480d23
--- /dev/null
+++ b/components/systools/examples/windows-only/text_sort/txtsortu.lfm
@@ -0,0 +1,199 @@
+object STDlg: TSTDlg
+ Left = 354
+ Height = 274
+ Top = 324
+ Width = 329
+ ActiveControl = InFile
+ BorderStyle = bsDialog
+ Caption = 'TextSort'
+ ClientHeight = 274
+ ClientWidth = 329
+ Color = clBtnFace
+ Font.Color = clBlack
+ OnActivate = FormActivate
+ OnClose = FormClose
+ Position = poScreenCenter
+ LCLVersion = '1.9.0.0'
+ object GroupBox1: TGroupBox
+ Left = 6
+ Height = 87
+ Top = 12
+ Width = 231
+ Caption = 'File Names'
+ ClientHeight = 67
+ ClientWidth = 227
+ TabOrder = 0
+ object Label1: TLabel
+ Left = 8
+ Height = 15
+ Top = 11
+ Width = 28
+ Caption = 'Input'
+ ParentColor = False
+ end
+ object Label2: TLabel
+ Left = 8
+ Height = 15
+ Top = 39
+ Width = 38
+ Caption = 'Output'
+ ParentColor = False
+ end
+ object InputBtn: TSpeedButton
+ Left = 200
+ Height = 21
+ Top = 9
+ Width = 25
+ Caption = '...'
+ OnClick = InputBtnClick
+ end
+ object OutputBtn: TSpeedButton
+ Left = 200
+ Height = 21
+ Top = 37
+ Width = 25
+ Caption = '...'
+ OnClick = OutputBtnClick
+ end
+ object InFile: TEdit
+ Left = 60
+ Height = 23
+ Top = 8
+ Width = 135
+ TabOrder = 0
+ end
+ object OutFile: TEdit
+ Left = 60
+ Height = 23
+ Top = 36
+ Width = 135
+ TabOrder = 1
+ end
+ end
+ object GroupBox2: TGroupBox
+ Left = 6
+ Height = 82
+ Top = 110
+ Width = 107
+ Caption = 'Sort Options'
+ ClientHeight = 62
+ ClientWidth = 103
+ TabOrder = 1
+ object RevOrder: TCheckBox
+ Left = 12
+ Height = 19
+ Top = 4
+ Width = 93
+ Caption = 'Reverse Order'
+ TabOrder = 0
+ end
+ object IgnoreCase: TCheckBox
+ Left = 12
+ Height = 19
+ Top = 30
+ Width = 82
+ Caption = 'Ignore Case'
+ TabOrder = 1
+ end
+ end
+ object GroupBox3: TGroupBox
+ Left = 120
+ Height = 82
+ Top = 110
+ Width = 119
+ Caption = 'Sort Key'
+ ClientHeight = 62
+ ClientWidth = 115
+ TabOrder = 2
+ object Label3: TLabel
+ Left = 8
+ Height = 15
+ Top = 7
+ Width = 24
+ Caption = 'Start'
+ ParentColor = False
+ end
+ object Label4: TLabel
+ Left = 8
+ Height = 15
+ Top = 33
+ Width = 37
+ Caption = 'Length'
+ ParentColor = False
+ end
+ object StartPos: TEdit
+ Left = 64
+ Height = 23
+ Top = 4
+ Width = 41
+ TabOrder = 0
+ end
+ object KeyLen: TEdit
+ Left = 64
+ Height = 23
+ Top = 30
+ Width = 41
+ TabOrder = 1
+ end
+ end
+ object OkBtn: TBitBtn
+ Left = 252
+ Height = 33
+ Top = 18
+ Width = 67
+ Caption = '&OK'
+ NumGlyphs = 2
+ OnClick = OkBtnClick
+ TabOrder = 4
+ end
+ object CloseBtn: TBitBtn
+ Left = 252
+ Height = 33
+ Top = 231
+ Width = 67
+ Caption = '&Close'
+ NumGlyphs = 2
+ OnClick = CloseBtnClick
+ TabOrder = 6
+ end
+ object GroupBox4: TGroupBox
+ Left = 6
+ Height = 56
+ Top = 208
+ Width = 233
+ Caption = 'Sort Status'
+ ClientHeight = 36
+ ClientWidth = 229
+ TabOrder = 3
+ object Status: TLabel
+ Left = 16
+ Height = 15
+ Top = 8
+ Width = 19
+ Caption = 'Idle'
+ ParentColor = False
+ end
+ end
+ object AbortBtn: TBitBtn
+ Left = 252
+ Height = 33
+ Top = 66
+ Width = 67
+ Caption = '&Abort'
+ NumGlyphs = 2
+ OnClick = AbortBtnClick
+ TabOrder = 5
+ end
+ object OpenDialog1: TOpenDialog
+ DefaultExt = '.TXT'
+ Filter = 'Text files (*.txt)|*.txt|All files (*.*)|*.*'
+ left = 264
+ top = 120
+ end
+ object SaveDialog1: TSaveDialog
+ DefaultExt = '.TXT'
+ Filter = 'Text files (*.txt)|*.txt|All files (*.txt)|*.*'
+ left = 264
+ top = 176
+ end
+end
diff --git a/components/systools/examples/windows-only/text_sort/txtsortu.pas b/components/systools/examples/windows-only/text_sort/txtsortu.pas
new file mode 100644
index 000000000..96777ed96
--- /dev/null
+++ b/components/systools/examples/windows-only/text_sort/txtsortu.pas
@@ -0,0 +1,324 @@
+(* ***** 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 TxtSortU;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
+ StdCtrls, Buttons,
+
+ StConst, StBase, StColl, StSort;
+
+const
+ MaxStrLen = 1024;
+
+type
+ SortException = class(Exception);
+ LineBuf = array[0..MaxStrLen-1] of char;
+
+ TSTDlg = class(TForm)
+ GroupBox1: TGroupBox;
+ Label1: TLabel;
+ Label2: TLabel;
+ InFile: TEdit;
+ OutFile: TEdit;
+ GroupBox2: TGroupBox;
+ RevOrder: TCheckBox;
+ IgnoreCase: TCheckBox;
+ GroupBox3: TGroupBox;
+ Label3: TLabel;
+ Label4: TLabel;
+ StartPos: TEdit;
+ KeyLen: TEdit;
+ OkBtn: TBitBtn;
+ CloseBtn: TBitBtn;
+ GroupBox4: TGroupBox;
+ Status: TLabel;
+ AbortBtn: TBitBtn;
+ OpenDialog1: TOpenDialog;
+ SaveDialog1: TSaveDialog;
+ InputBtn: TSpeedButton;
+ OutputBtn: TSpeedButton;
+ procedure OkBtnClick(Sender: TObject);
+ procedure FormClose(Sender: TObject; var Action: TCloseAction);
+ procedure CloseBtnClick(Sender: TObject);
+ procedure FormActivate(Sender: TObject);
+ procedure AbortBtnClick(Sender: TObject);
+ procedure InputBtnClick(Sender: TObject);
+ procedure OutputBtnClick(Sender: TObject);
+ private
+ { Private declarations }
+ public
+ { Public declarations }
+ DoAbort,
+ InSort,
+ DoRev,
+ Ignore : Boolean;
+
+ SPos,
+ KeyL : Integer;
+
+ LC : LongInt;
+
+ InF,
+ OutF : TextFile;
+
+ MySort : TStSorter;
+
+ function ValidateEntryFields : Boolean;
+ procedure CleanUp;
+ end;
+
+
+var
+ STDlg: TSTDlg;
+
+implementation
+
+{$IFDEF FPC}
+ {$R *.lfm}
+{$ELSE}
+ {$R *.dfm}
+{$ENDIF}
+
+procedure DelNodeData(Data : pointer); far;
+ {-procedure to delete data pointer in each node}
+begin
+ Dispose(Data);
+end;
+
+
+function TFSorter(const S1, S2) : Integer; far;
+var
+ PX, PY : LineBuf;
+begin
+ if STDlg.DoRev then begin
+ StrCopy(PX, LineBuf(S2));
+ StrCopy(PY, LineBuf(S1));
+ end else begin
+ StrCopy(PX, LineBuf(S1));
+ StrCopy(PY, LineBuf(S2));
+ end;
+
+
+
+ if STDlg.Ignore then begin
+ if (StrLIComp(@PX[STDlg.SPos-1], @PY[STDlg.SPos-1], STDlg.KeyL) < 0) then
+ Result := -1
+ else
+ Result := 0;
+ end else begin
+ if (StrLComp(@PX[STDlg.SPos-1], @PY[STDlg.SPos-1], STDlg.KeyL) < 0) then
+ Result := -1
+ else
+ Result := 0;
+ end;
+end;
+
+procedure TSTDlg.FormClose(Sender: TObject; var Action: TCloseAction);
+begin
+ if MySort <> nil then
+ MySort.Free;
+end;
+
+procedure TSTDlg.CloseBtnClick(Sender: TObject);
+begin
+ if InSort then Exit;
+ Close;
+end;
+
+function TSTDlg.ValidateEntryFields : Boolean;
+var
+ Code : Integer;
+
+begin
+ Result := False;
+
+ if NOT FileExists(InFile.Text) then
+ begin
+ ShowMessage('Input file does not exist');
+ Exit;
+ end;
+
+ if FileExists(OutFile.Text) then
+ begin
+ if MessageDlg('Output file exists' + #13 + 'Continue?',
+ mtConfirmation,[mbYes,mbNo],0) = mrNo then
+ Exit;
+ end;
+
+ if (CompareText(InFile.Text,OutFile.Text) = 0) then
+ begin
+ ShowMessage('Input and Output file can not be the same');
+ Exit;
+ end;
+
+ val(StartPos.Text,SPos,Code);
+ if (Code <> 0) then
+ begin
+ ShowMessage('Invalid Start entry');
+ Exit;
+ end;
+ if (SPos < 1) OR (SPos >= MaxStrLen) then
+ begin
+ ShowMessage('Start out of range');
+ Exit;
+ end;
+
+ val(KeyLen.Text,KeyL,Code);
+ if (Code <> 0) then
+ begin
+ ShowMessage('Invalid Length entry');
+ Exit;
+ end;
+ if (KeyL < 1) OR (KeyL > MaxStrLen-SPos) then
+ begin
+ ShowMessage('Key Length out of range');
+ Exit;
+ end;
+
+ DoRev := RevOrder.Checked;
+ Ignore := IgnoreCase.Checked;
+
+ Result := True;
+end;
+
+
+procedure TSTDlg.CleanUp;
+begin
+ CloseFile(InF);
+ CloseFile(OutF);
+ InSort := False;
+ DoAbort := True;
+
+ MySort.Free;
+ MySort := nil;
+end;
+
+procedure TSTDlg.OkBtnClick(Sender: TObject);
+var
+ PS : LineBuf;
+begin
+ if NOT ValidateEntryFields then
+ Exit;
+
+ AssignFile(InF,InFile.Text);
+ Reset(InF);
+ AssignFile(OutF,OutFile.Text);
+ ReWrite(OutF);
+
+ if MySort <> nil then begin
+ MySort.Free;
+ MySort := nil;
+ end;
+
+ MySort := TStSorter.Create(500000, SizeOf(LineBuf));
+ MySort.Compare := TFSorter;
+
+ DoAbort := False;
+ InSort := True;
+ LC := 0;
+
+ while NOT EOF(InF) do begin
+ FillChar(PS, SizeOf(PS), #0);
+ Readln(InF, PS);
+ Inc(LC);
+ Status.Caption := 'Reading/Sorting line: ' + IntToStr(LC);
+ MySort.Put(PS);
+
+ if (LC mod 100) = 0 then begin
+ Application.ProcessMessages;
+ if DoAbort then begin
+ CleanUp;
+ Status.Caption := 'Sort Aborted';
+ Exit;
+ end;
+ end;
+ end;
+
+ Status.Caption := 'Processing';
+ Status.Update;
+ Application.ProcessMessages;
+
+ if NOT DoAbort then begin
+ LC := 0;
+ while MySort.Get(PS) do begin
+ Inc(LC);
+ Status.Caption := 'Writing line: ' + IntToStr(LC);
+ Writeln(OutF, PS);
+
+ if (LC mod 100) = 0 then begin
+ Application.ProcessMessages;
+ if DoAbort then begin
+ CleanUp;
+ Status.Caption := 'Sort Aborted';
+ Exit;
+ end;
+ end;
+ end;
+ end;
+
+ if NOT DoAbort then begin
+ CleanUp;
+ Status.Caption := 'Done';
+ end;
+end;
+
+
+procedure TSTDlg.FormActivate(Sender: TObject);
+begin
+ IgnoreCase.Checked := True;
+ RevOrder.Checked := False;
+ InFile.Text := '';
+ OutFile.Text := '';
+ StartPos.Text := '1';
+ KeyLen.Text := '20';
+ Status.Caption := 'Idle';
+end;
+
+procedure TSTDlg.AbortBtnClick(Sender: TObject);
+begin
+ DoAbort := True;
+end;
+
+procedure TSTDlg.InputBtnClick(Sender: TObject);
+begin
+ if OpenDialog1.Execute then
+ InFile.Text := OpenDialog1.FileName;
+end;
+
+procedure TSTDlg.OutputBtnClick(Sender: TObject);
+begin
+ if SaveDialog1.Execute then
+ OutFile.Text := SaveDialog1.FileName;
+end;
+
+end.
diff --git a/components/systools/examples/windows-only/version_info/exvinfou.lfm b/components/systools/examples/windows-only/version_info/exvinfou.lfm
new file mode 100644
index 000000000..d7955e131
--- /dev/null
+++ b/components/systools/examples/windows-only/version_info/exvinfou.lfm
@@ -0,0 +1,41 @@
+object Form1: TForm1
+ Left = 197
+ Height = 262
+ Top = 108
+ Width = 494
+ Caption = 'Version Info Example'
+ ClientHeight = 262
+ ClientWidth = 494
+ Color = clBtnFace
+ Font.Color = clWindowText
+ OnCreate = FormCreate
+ LCLVersion = '1.9.0.0'
+ object Button1: TButton
+ Left = 16
+ Height = 25
+ Top = 24
+ Width = 75
+ Caption = 'Open...'
+ OnClick = Button1Click
+ TabOrder = 0
+ end
+ object Memo1: TMemo
+ Left = 120
+ Height = 233
+ Top = 24
+ Width = 369
+ Lines.Strings = (
+ 'Use the "open" button to select a file that contains version '
+ 'information.'
+ )
+ TabOrder = 1
+ end
+ object OpenDialog1: TOpenDialog
+ left = 32
+ top = 64
+ end
+ object VerInfo: TStVersionInfo
+ left = 32
+ top = 136
+ end
+end
diff --git a/components/systools/examples/windows-only/version_info/exvinfou.pas b/components/systools/examples/windows-only/version_info/exvinfou.pas
new file mode 100644
index 000000000..52bdd4a79
--- /dev/null
+++ b/components/systools/examples/windows-only/version_info/exvinfou.pas
@@ -0,0 +1,105 @@
+(* ***** 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 ExVInfoU;
+
+interface
+
+uses
+ Windows, Messages,
+ SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
+ StVInfo, StBase;
+
+type
+ TForm1 = class(TForm)
+ Button1: TButton;
+ Memo1: TMemo;
+ OpenDialog1: TOpenDialog;
+ VerInfo: TStVersionInfo;
+ procedure Button1Click(Sender: TObject);
+ procedure FormCreate(Sender: TObject);
+ private
+ { Private declarations }
+ procedure ShowVersionInfo;
+ public
+ { Public declarations }
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$IFDEF FPC}
+ {$R *.lfm}
+{$ELSE}
+ {$R *.dfm}
+{$ENDIF}
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+ if OpenDialog1.Execute then begin
+ VerInfo.FileName := OpenDialog1.FileName;
+ ShowVersionInfo;
+ end;
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+ ShowVersionInfo;
+end;
+
+procedure TForm1.ShowVersionInfo;
+begin
+ with Memo1.Lines do begin
+ Memo1.Clear;
+ Add('Comments: ' + VerInfo.Comments);
+ Add('Company Name: ' + VerInfo.CompanyName);
+ Add('File Description: ' + VerInfo.FileDescription);
+ Add('File Version: ' + VerInfo.FileVersion);
+ Add('Internal Name: ' + VerInfo.InternalName);
+ Add('Legal Copyright: ' + VerInfo.LegalCopyright);
+ Add('Legal Trademark: ' + VerInfo.LegalTrademark);
+ Add('Original Filename: ' + VerInfo.OriginalFilename);
+ Add('Product Name: ' + VerInfo.ProductName);
+ Add('Product Version: ' + VerInfo.ProductVersion);
+ {$IFNDEF FPC}
+ if UpperCase(ExtractFileName(VerInfo.FileName))
+ = UpperCase('exvrinfo.exe') then begin
+ Add('Extra Info 1: ' + VerInfo.GetKeyValue('ExtraInfo1'));
+ Add('Extra Info 2: ' + VerInfo.GetKeyValue('ExtraInfo2'));
+ end;
+ {$ENDIF}
+ Add('Language: ' + VerInfo.LanguageName);
+ if VerInfo.FileDate <> 0 then
+ Add('File Date: ' + DateToStr(VerInfo.FileDate));
+ end;
+end;
+
+end.
diff --git a/components/systools/examples/windows-only/version_info/exvrinfo.lpi b/components/systools/examples/windows-only/version_info/exvrinfo.lpi
new file mode 100644
index 000000000..6a2e3058e
--- /dev/null
+++ b/components/systools/examples/windows-only/version_info/exvrinfo.lpi
@@ -0,0 +1,91 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/examples/windows-only/version_info/exvrinfo.lpr b/components/systools/examples/windows-only/version_info/exvrinfo.lpr
new file mode 100644
index 000000000..5ce133bf3
--- /dev/null
+++ b/components/systools/examples/windows-only/version_info/exvrinfo.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 exvrinfo;
+
+uses
+ Interfaces,
+ Forms, lclversion,
+ ExVInfoU in 'ExVInfoU.pas' {Form1};
+
+{$R *.res}
+
+begin
+ {$IF LCL_FULLVERSION >= 1080000}
+ Application.Scaled := True;
+ {$ENDIF}
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
diff --git a/components/systools/laz_systoolsdb.lpk b/components/systools/laz_systoolsdb.lpk
index 861a15faf..cbebd214c 100644
--- a/components/systools/laz_systoolsdb.lpk
+++ b/components/systools/laz_systoolsdb.lpk
@@ -10,7 +10,7 @@
-
+
diff --git a/components/systools/laz_systoolsdb_design.lpk b/components/systools/laz_systoolsdb_design.lpk
index efc2b0112..a5dc3fd18 100644
--- a/components/systools/laz_systoolsdb_design.lpk
+++ b/components/systools/laz_systoolsdb_design.lpk
@@ -9,9 +9,9 @@
-
+
-
+
diff --git a/components/systools/laz_systoolswin.lpk b/components/systools/laz_systoolswin.lpk
new file mode 100644
index 000000000..fa6765e11
--- /dev/null
+++ b/components/systools/laz_systoolswin.lpk
@@ -0,0 +1,75 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/laz_systoolswin.pas b/components/systools/laz_systoolswin.pas
new file mode 100644
index 000000000..0edb54d19
--- /dev/null
+++ b/components/systools/laz_systoolswin.pas
@@ -0,0 +1,16 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit laz_systoolswin;
+
+{$warn 5023 off : no warning about unused units}
+interface
+
+uses
+ StSystem, StText, StVInfo, StSort, StSpawn, StRegIni, StWmDCpy, StGenLog,
+ StNTLog;
+
+implementation
+
+end.
diff --git a/components/systools/laz_systoolswin_design.lpk b/components/systools/laz_systoolswin_design.lpk
new file mode 100644
index 000000000..c6d95179d
--- /dev/null
+++ b/components/systools/laz_systoolswin_design.lpk
@@ -0,0 +1,51 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/systools/laz_systoolswin_design.pas b/components/systools/laz_systoolswin_design.pas
new file mode 100644
index 000000000..6bacbf862
--- /dev/null
+++ b/components/systools/laz_systoolswin_design.pas
@@ -0,0 +1,22 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit laz_systoolswin_design;
+
+{$warn 5023 off : no warning about unused units}
+interface
+
+uses
+ StRegWin, LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+ RegisterUnit('StRegWin', @StRegWin.Register);
+end;
+
+initialization
+ RegisterPackage('laz_systoolswin_design', @Register);
+end.
diff --git a/components/systools/source/windows_only/design/stregwin.pas b/components/systools/source/windows_only/design/stregwin.pas
new file mode 100644
index 000000000..7dfdc91d5
--- /dev/null
+++ b/components/systools/source/windows_only/design/stregwin.pas
@@ -0,0 +1,135 @@
+(* ***** 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: StReg.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Component Registration Unit *}
+{*********************************************************}
+
+//{$I StDefine.inc}
+
+//{$R streg.r32}
+
+unit StRegWin;
+
+interface
+
+uses
+ Classes,
+{$IFDEF FPC}
+ PropEdits //, LazarusPackageIntf //, FieldsEditor, ComponentEditors
+{$ELSE}
+ {$IFDEF VERSION6}
+ DesignIntf,
+ DesignEditorsM
+ {$ELSE}
+ DsgnIntfM
+ {$ENDIF}
+{$ENDIF}
+ ;
+
+procedure Register;
+
+implementation
+
+uses
+ StPropEd,
+
+// StAbout0,
+
+ { components }
+ (*,
+ StNetCon,
+ StNetMsg,
+ StNetPfm,
+ *)
+ StSpawn,
+ StVInfo,
+ StWMDCpy,
+
+ {forces these units to be compiled when components are installed}
+ {vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv}
+ (*
+ StFirst,
+ StMime,
+ StNet,
+ StNetApi,
+ StNVCont,
+ StOStr,
+ *)
+ StRegIni,
+ StSort,
+ (*
+ StStrW,
+ StStrZ,
+ *)
+ StText,
+ { new units in ver 4: }
+ StSystem,
+ StNTLog,
+ { !!! StExpEng unit designed to handle problem with initialization }
+ { section in C++Builder; should NOT be included in Registration unit }
+ { nor in Run-time package !!! }
+ {StExpEng,}
+// StExpLog,
+ StGenLog;
+ {^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^}
+
+procedure Register;
+begin
+ (*
+ RegisterPropertyEditor(TypeInfo(string), TStComponent, 'Version',
+ TStVersionProperty);
+ RegisterPropertyEditor(TypeInfo(string), TStBaseEdit, 'Version',
+ TStVersionProperty);
+ RegisterPropertyEditor(TypeInfo(string), TStBarCode, 'Version',
+ TStVersionProperty);
+ RegisterPropertyEditor(TypeInfo(string), TStPNBarCode, 'Version',
+ TStVersionProperty);
+ *)
+ RegisterPropertyEditor(TypeInfo(string), TStVersionInfo, 'FileName',
+ TStFileNameProperty);
+ RegisterPropertyEditor(TypeInfo(string), TStSpawnApplication, 'FileName',
+ TStGenericFileNameProperty);
+
+ RegisterComponents('SysTools', [
+ {
+ TStNetConnection,
+ TStNetPerformance,
+ TStNetMessage,
+ }
+ TStVersionInfo,
+ TStWMDataCopy,
+ TStSpawnApplication,
+ TStGeneralLog,
+{.$IFNDEF BCB} {!!! problem with initialization section in BCB }
+// TStExceptionLog,
+{.$ENDIF}
+ TStNTEventLog
+ ]);
+end;
+
+end.
diff --git a/components/systools/source/windows_only/run/stexpeng.pas b/components/systools/source/windows_only/run/stexpeng.pas
new file mode 100644
index 000000000..48417b389
--- /dev/null
+++ b/components/systools/source/windows_only/run/stexpeng.pas
@@ -0,0 +1,361 @@
+(* ***** 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: StExpLog.pas 4.03 *}
+{*********************************************************}
+{* SysTools: Exception Logging *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StExpEng;
+
+interface
+
+uses
+ Windows, SysUtils, Classes, StBase, StExpLog;
+
+const
+ OnHookInstaller : procedure = nil;
+
+procedure DumpException;
+
+implementation
+
+uses
+ Forms;
+
+const
+ MaxStackSize = 48;
+
+type
+ TStExceptionHandler = class
+ private
+ OldOnException : TExceptionEvent;
+ protected
+ procedure OnException(Sender : TObject; E : Exception);
+ end;
+
+ TStExceptionTrace = record
+ Count : Integer;
+ Trace : array[0..pred(MaxStackSize)] of DWORD;
+ end;
+
+const
+ EH : TStExceptionHandler = nil;
+ WroteInfo : Boolean = False;
+ HandlerInstalled : Boolean = False;
+ cDelphiException = DWORD($0EEDFADE);
+ cCppException = DWORD($0EEFFACE); { used by BCB }
+
+var
+ RA2 : procedure (dwExceptionCode, dwExceptionFlags, nNumberOfArguments : DWORD;
+ const lpArguments : DWORD); stdcall;
+ BaseOfCode, TopOfCode : DWORD;
+
+{ Writes exception to log file }
+procedure WriteException(E : Exception);
+var
+ p1 : Integer;
+ RipFileName, S : string;
+ FS : TFileStream;
+ Buffer : array[0..255] of AnsiChar;
+begin
+ if Assigned(ExpLog) then
+ RipFileName := ExpLog.FileName;
+
+ if RipFileName = '' then begin
+ GetModuleFileName(HInstance, Buffer, SizeOf(Buffer));
+ RipFileName := ChangeFileExt(PChar(@Buffer),'.RIP');
+ end;
+
+ { Open file stream }
+ if FileExists(RipFileName) then begin
+ FS := TFileStream.Create(RipFileName, fmOpenReadWrite or fmShareDenyWrite);
+ FS.Seek(0, soFromEnd);
+ S := #13#10#13#10;
+ FS.Write(S[1], Length(S));
+ end else begin
+ FS := TFileStream.Create(RipFileName, fmCreate or fmShareDenyWrite);
+ end;
+
+ try
+ { Write info if necessary }
+ if not WroteInfo and Assigned(ExpLog) then begin
+ if (ExpLog.RipInfo <> '') then begin
+ S := ExpLog.RipInfo + #13#10#13#10;
+ FS.Write(S[1], Length(S));
+ end;
+ WroteInfo := True;
+ end;
+
+ { Write dump info from E.Message }
+ p1 := Pos(#0, E.Message);
+ S := Copy(E.Message, p1+1, MaxInt) + #13#10;
+ FS.Write(S[1], Length(S));
+
+ { Restore E.Message }
+ S := E.Message;
+ SetLength(S, P1-1);
+ E.Message := S;
+
+ finally
+ FS.Free;
+ end;
+end;
+
+{ Dumps Exception }
+procedure DumpException;
+var
+ PutInLog : Boolean;
+begin
+ PutInLog := True;
+ if Assigned(ExpLog) then
+ ExpLog.DoExceptionFilter(Exception(ExceptObject),PutInLog);
+ if PutInLog then
+ WriteException(Exception(ExceptObject));
+end;
+
+{ TStExceptionHandler }
+
+procedure TStExceptionHandler.OnException(Sender : TObject; E : Exception);
+begin
+ DumpException;
+ if Assigned(OldOnException) then
+ OldOnException(Sender, E)
+ else
+ Application.ShowException(Exception(ExceptObject));
+end;
+
+var
+ SaveGetExceptionObject : function(P : PExceptionRecord) : Exception;
+
+procedure HookInstaller;
+begin
+ EH := TStExceptionHandler.Create;
+ EH.OldOnException := Application.OnException;
+ Application.OnException := EH.OnException;
+end;
+
+procedure StackDump(E : Exception; Root : DWORD);
+var
+ P : PDWORD;
+ C, D, StackTop, N, Prev : DWORD;
+ Trace : TStExceptionTrace;
+ I : Integer;
+ Store : Boolean;
+ MsgPtr : PChar;
+ MsgLen : Integer;
+begin
+ if not HandlerInstalled then begin
+ if Assigned(OnHookInstaller) then
+ OnHookInstaller;
+ HandlerInstalled := True;
+ end;
+
+ if Root = 0 then
+ Trace.Count := 0
+ else begin
+ Trace.Count := 1;
+ Trace.Trace[0] := Root;
+ end;
+
+ asm
+ mov P,ebp
+ mov eax,fs:[4]
+ mov [StackTop],eax
+ end;
+
+ Prev := 0;
+ C := 0;
+
+ while DWORD(P) < DWORD(StackTop) do begin
+ D := P^;
+ N := 0;
+ if (D >= BaseOfCode) and (D < TopOfCode) then
+ if (PByte(D-5)^ = $E8)
+ or ((PByte(D-6)^ = $FF) and (((PByte(D-5)^ and $38) = $10)))
+ or ((PByte(D-4)^ = $FF) and (((PByte(D-3)^ and $38) = $10)))
+ or ((PByte(D-3)^ = $FF) and (((PByte(D-2)^ and $38) = $10)))
+ or ((PByte(D-2)^ = $FF) and (((PByte(D-1)^ and $38) = $10))) then
+ N := D-BaseOfCode;
+ if (N <> 0) and (N <> Prev) then begin
+ if (Root = 0) then
+ Store := C > 0
+ else
+ Store := C > 1;
+ if Store then
+ begin
+ Trace.Trace[Trace.Count] := N;
+ Inc(Trace.Count);
+ end;
+ Inc(C);
+ if C > MaxStackSize then Break;
+ Prev := N;
+ end;
+ Inc(P);
+ end;
+
+ if C > 0 then begin
+ MsgPtr := PChar(E.Message);
+ MsgLen := StrLen(MsgPtr);
+ if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then
+ E.Message := E.Message + '.';
+ E.Message := E.Message + #0 + Format('Fault : %s'#13#10'Date/time : %s %s'#13#10'Stack dump'#13#10+
+ '----------'#13#10,[E.Message,DateToStr(Now),TimeToStr(Now)]);
+ for i := 0 to pred(Trace.Count) do
+ E.Message := E.Message + Format('%8.8x'#13#10,[Trace.Trace[i]]);
+ end;
+end;
+
+procedure LRE(dwExceptionCode, dwExceptionFlags, nNumberOfArguments : DWORD;
+ const lpArguments : DWORD); stdcall;
+var
+ E : Exception;
+begin
+ if (dwExceptionCode = cDelphiException) or (dwExceptionCode = cCppException) then begin
+ asm
+ push ebx
+ mov ebx,lpArguments
+ mov eax,ss:[ebx+4]
+ mov E,eax
+ pop ebx
+ end;
+ if assigned(E) then
+ StackDump(E, 0);
+ end;
+ if Assigned(RA2) then
+ RA2(dwExceptionCode, dwExceptionFlags, nNumberOfArguments, lpArguments);
+end;
+
+function HookGetExceptionObject(P : PExceptionRecord) : Exception;
+begin
+ Result := SaveGetExceptionObject(P);
+ StackDump(Result, DWORD(P^.ExceptionAddress)-BaseOfCode);
+end;
+
+procedure InitializeEng;
+const
+ ImageNumberofDirectoryEntries = 16;
+ ImageDirectoryEntryImport = 1;
+
+type
+
+ PImageImportByName = ^TImageImportByName;
+ TImageImportByName = packed record
+ Hint : WORD;
+ Name : array[0..255] of char;
+ end;
+
+ PImageThunkData = ^TImageThunkData;
+ TImageThunkData = packed record
+ case Integer of
+ 1 : (Funct : ^DWORD);
+ 2 : (Ordinal : DWORD);
+ 3 : (AddressOfData : PImageImportByName);
+ end;
+
+ PImageImportDescriptor = ^TImageImportDescriptor;
+ TImageImportDescriptor = packed record
+ Characteristics : DWORD;
+ TimeDateStamp : DWORD;
+ ForwarderChain : DWORD;
+ Name : DWORD;
+ FirstThunk : PImageThunkData;
+ end;
+
+ PImageDosHeader = ^TImageDosHeader;
+ TImageDosHeader = packed record
+ e_magic : WORD;
+ e_cblp : WORD;
+ e_cp : WORD;
+ e_crlc : WORD;
+ e_cparhdr : WORD;
+ e_minalloc : WORD;
+ e_maxalloc : WORD;
+ e_ss : WORD;
+ e_sp : WORD;
+ e_csum : WORD;
+ e_ip : WORD;
+ e_cs : WORD;
+ e_lfarlc : WORD;
+ e_ovno : WORD;
+ e_res : array [0..3] of WORD;
+ e_oemid : WORD;
+ e_oeminfo : WORD;
+ e_res2 : array [0..9] of WORD;
+ e_lfanew : DWORD;
+ end;
+
+var
+ OriginalProc : Pointer;
+ NTHeader : PImageNTHeaders;
+ ImportDesc : PImageImportDescriptor;
+ Thunk : PImageThunkData;
+
+begin
+ RA2 := nil;
+ OriginalProc := GetProcAddress(GetModuleHandle('kernel32.dll'), 'RaiseException');
+
+ if OriginalProc <> nil then begin
+ NTHeader := PImageNTHeaders(DWORD(hInstance) + PImageDosHeader(hInstance).e_lfanew);
+ ImportDesc := PImageImportDescriptor(DWORD(hInstance) +
+ NTHeader.OptionalHeader.DataDirectory[ImageDirectoryEntryImport].VirtualAddress);
+
+ BaseOfCode := DWORD(hInstance) + NTHeader.OptionalHeader.BaseOfCode;
+ TopOfCode := BaseOfCode + NTHeader.OptionalHeader.SizeOfCode;
+
+ while ImportDesc.Name <> 0 do begin
+ if StriComp(PChar(DWORD(hInstance) + ImportDesc.Name), 'kernel32.dll') = 0 then begin
+ Thunk := PImageThunkData(DWORD(hInstance) + DWORD(ImportDesc.FirstThunk));
+ while Thunk.Funct <> nil do begin
+ if Thunk.Funct = OriginalProc then
+ Thunk.Funct := @LRE;
+ Inc(Thunk);
+ end;
+ end;
+ Inc(ImportDesc);
+ end;
+ RA2 := OriginalProc;
+ end;
+ SaveGetExceptionObject := ExceptObjProc;
+ ExceptObjProc := @HookGetExceptionObject;
+end;
+
+initialization
+ OnHookInstaller := HookInstaller;
+ {$WARNINGS OFF} { Yeah, we know DebugHook is platform specific }
+ if DebugHook = 0 then InitializeEng;
+ {$WARNINGS ON}
+
+finalization
+ EH.Free;
+
+end.
diff --git a/components/systools/source/windows_only/run/stgenlog.pas b/components/systools/source/windows_only/run/stgenlog.pas
new file mode 100644
index 000000000..f3a3dd180
--- /dev/null
+++ b/components/systools/source/windows_only/run/stgenlog.pas
@@ -0,0 +1,804 @@
+// 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: StGenLog.pas 4.04 *}
+{*********************************************************}
+{* SysTools: General Logging *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StGenLog;
+
+interface
+
+uses
+ Windows, SysUtils, Classes, StBase;
+
+const
+
+ StDefBufferSize = 65536; { Default buffer size }
+ StDefHighLevel = 0; { Default high level point }
+ StMaxLogSize = 16000000; { Max size of general log buffer }
+// StCRLF = #10#13; {!!.01}
+ StCRLF = #13#10; {!!.01}
+ StLogFileFooter = '';
+ StLogFileHeader = 'SysTools General Log' + StCRLF +
+ '=============================================================================' +
+ StCRLF + StCRLF;
+
+ { General log constants }
+ leEnabled = 1;
+ leDisabled = 2;
+
+ leString = DWORD($80000000);
+
+type
+
+ TStGetLogStringEvent = procedure(Sender : TObject; const D1, D2, D3, D4 : DWORD;
+ var LogString : AnsiString) of object;
+
+ TStWriteMode = (wmOverwrite, wmAppend);
+
+ { Record for log entries }
+ PStLogRec = ^TStLogRec;
+ TStLogRec = record
+ lrTime : DWORD;
+ lrData1 : DWORD;
+ lrData2 : DWORD;
+ lrData3 : DWORD;
+ lrData4 : DWORD;
+ end;
+
+ PStLogBuffer = ^TStLogBuffer;
+ TStLogBuffer = array[0..StMaxLogSize] of Byte;
+
+ StGenOptions = (goSuppressEnableMsg, goSuppressDisableMsg); {!!.01}
+ StGenOptionSet = set of StGenOptions; {!!.01}
+
+ TStGeneralLog = class(TStComponent)
+ private
+ { Property variables }
+ FBufferSize : DWORD;
+ FEnabled : Boolean;
+ FFileName : TFileName;
+ FHighLevel : Byte;
+ FLogFileFooter : string;
+ FLogFileHeader : string;
+ FLogOptions : StGenOptionSet; {!!.01}
+ FWriteMode : TStWriteMode;
+ { Event variables }
+ FOnHighLevel : TNotifyEvent;
+ FOnGetLogString : TStGetLogStringEvent;
+ { Private variables }
+ glBuffer : PStLogBuffer;
+ glBufferHead : DWORD;
+ glBufferTail : DWORD;
+ glHighLevelMark : DWORD;
+ glHighLevelTriggered : Boolean;
+ glLogCS : TRTLCriticalSection;
+ glTempBuffer : PByteArray;
+ glTempSize : DWORD;
+ glTimeBase : DWORD;
+ protected
+ { Property access methods }
+ procedure DoGetLogString(const D1, D2, D3, D4 : DWORD; var LogString : AnsiString); virtual;
+ function GetBufferEmpty : Boolean;
+ function GetBufferFree : DWORD;
+ function GetBufferSize : DWORD;
+ function GetEnabled : Boolean;
+ function GetFileName : TFileName;
+ function GetHighLevel : Byte;
+ function GetLogOptions : StGenOptionSet; {!!.01}
+ function GetWriteMode : TStWriteMode;
+ procedure SetBufferSize(const Value : DWORD);
+ procedure SetEnabled(const Value : Boolean); virtual;
+ procedure SetFileName(const Value : TFileName); virtual;
+ procedure SetHighLevel(const Value : Byte);
+ procedure SetLogOptions(const Value : StGenOptionSet); {!!.01}
+ procedure SetWriteMode(const Value : TStWriteMode);
+ { Internal methods }
+ procedure glCalcHighLevel;
+ procedure glCheckTempSize(SizeReq : DWORD);
+ procedure glHighLevelCheck;
+ procedure glLockLog;
+ function glPopLogEntry(var LogRec : TStLogRec) : Boolean;
+ function glTimeStamp(Mark : DWORD) : string;
+ procedure glUnlockLog;
+ public
+ { Public methods }
+ constructor Create(Owner : TComponent); override;
+ destructor Destroy; override;
+ procedure AddLogEntry(const D1, D2, D3, D4 : DWORD);
+ procedure ClearBuffer;
+ procedure DumpLog; virtual;
+ procedure WriteLogString(const LogString : AnsiString);
+ { Public properties }
+ property BufferEmpty : Boolean read GetBufferEmpty;
+ property BufferFree : DWORD read GetBufferFree;
+ published
+ { Published properties }
+ property BufferSize : DWORD
+ read GetBufferSize write SetBufferSize default StDefBufferSize;
+ property Enabled : Boolean read GetEnabled write SetEnabled default True;
+ property FileName : TFileName read GetFileName write SetFileName;
+ property HighLevel : Byte read GetHighLevel write SetHighLevel default StDefHighLevel;
+ property LogFileFooter : string read FLogFileFooter write FLogFileFooter;
+ property LogFileHeader : string read FLogFileHeader write FLogFileHeader;
+ property LogOptions : StGenOptionSet read GetLogOptions {!!.01}
+ write SetLogOptions default []; {!!.01}
+ property WriteMode : TStWriteMode read GetWriteMode write SetWriteMode;
+ { Event properties }
+ property OnHighLevel : TNotifyEvent read FOnHighLevel write FOnHighLevel;
+ property OnGetLogString : TStGetLogStringEvent
+ read FOnGetLogString write FOnGetLogString;
+ end;
+
+ function HexifyBlock(var Buffer; BufferSize : Integer) : AnsiString;
+
+implementation
+
+{ TStGeneralLog }
+
+{ Gives text representation of a block of data }
+function HexifyBlock(var Buffer; BufferSize : Integer) : AnsiString;
+type
+ TCastCharArray = array[0..Pred(High(LongInt))] of AnsiChar;
+const
+ { Starting string to work with - this is directly written to by index }
+ { below, so any positional changes here will also have to be made below. }
+ StockString = ' %6.6x: 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 : 0000000000000000' + StCRLF;
+ HexDigits : array[0..$F] of AnsiChar = '0123456789ABCDEF';
+var
+ I, J, K, Lines : Integer;
+ TempStr : AnsiString;
+ Hex1, Hex2 : array[0..23] of AnsiChar;
+ Ascii1, Ascii2 : array[0..7] of AnsiChar;
+begin
+ K := 0;
+ FillChar(Hex1, SizeOf(Hex1), #32);
+ FillChar(Hex2, SizeOf(Hex2), #32);
+
+ { Calculate number of lines required }
+ Lines := BufferSize div 16;
+ if (BufferSize mod 16) <> 0 then Inc(Lines);
+
+ { Process and append lines }
+ for I := 0 to Lines-1 do begin
+
+ { Load string, add index marker }
+ TempStr := Format(StockString, [I*16]);
+
+ { Format data for first word }
+ for J := 0 to 7 do begin
+ if J+K >= BufferSize then begin
+ Ascii1[J] := ' ';
+ Hex1[J*3] := ' ';
+ Hex1[J*3+1] := ' ';
+ end else begin
+ Ascii1[J] := TCastCharArray(Buffer)[J+K];
+ Hex1[J*3] := HexDigits[Byte(Ascii1[J]) shr 4];
+ Hex1[J*3+1] := HexDigits[Byte(Ascii1[J]) and $F];
+
+ { Clamp Ascii to printable range }
+ if (Ascii1[J] < #32) or (Ascii1[J] > #126) then Ascii1[J] := '.';
+ end;
+ end;
+ Inc(K,8);
+
+ { Format data for second word }
+ for J := 0 to 7 do begin
+ if J+K >= BufferSize then begin
+ Ascii2[J] := ' ';
+ Hex2[J*3] := ' ';
+ Hex2[J*3+1] := ' ';
+ end else begin
+ Ascii2[J] := TCastCharArray(Buffer)[J+K];
+ Hex2[J*3] := HexDigits[Byte(Ascii2[J]) shr 4];
+ Hex2[J*3+1] := HexDigits[Byte(Ascii2[J]) and $F];
+ { Clamp Ascii to printable range }
+ if (Ascii2[J] < #32) or (Ascii2[J] > #126) then Ascii2[J] := '.';
+ end;
+ end;
+ Inc(K,8);
+
+ { Move data to existing temp string }
+ Move(Hex1[0], TempStr[11], SizeOf(Hex1));
+ Move(Hex2[0], TempStr[36], SizeOf(Hex2));
+
+ Move(Ascii1[0], TempStr[62], SizeOf(Ascii1));
+ Move(Ascii2[0], TempStr[70], SizeOf(Ascii2));
+
+ { Append temp string to result }
+ Result := Result + TempStr;
+ end;
+end;
+
+constructor TStGeneralLog.Create(Owner : TComponent);
+begin
+ inherited Create(Owner);
+ InitializeCriticalSection(glLogCS);
+ BufferSize := StDefBufferSize;
+ FEnabled := True;
+ FFileName := 'debug.log';
+ FLogFileFooter := StLogFileFooter;
+ FLogFileHeader := StLogFileHeader;
+ HighLevel := StDefHighLevel;
+ glHighLevelTriggered := False;
+ glTimeBase := GetTickCount;
+end;
+
+destructor TStGeneralLog.Destroy;
+begin
+ FreeMem(glBuffer);
+ FreeMem(glTempBuffer);
+ DeleteCriticalSection(glLogCS);
+ inherited Destroy;
+end;
+
+procedure TStGeneralLog.glLockLog;
+begin
+ if IsMultiThread then
+ EnterCriticalSection(glLogCS);
+end;
+
+procedure TStGeneralLog.glUnlockLog;
+begin
+ if IsMultiThread then
+ LeaveCriticalSection(glLogCS);
+end;
+
+{ AddLogEntry notes: }
+{ }
+{ D1 = $FFFFFFFF is reserved for internal events }
+{ }
+{ D1, D2, D3, D4 are "info" fields to be used in the OnGetLogString }
+{ handler to identify the logged event and what type of data would be }
+{ appropriate for the corresponding log entry. }
+{ }
+{ While you're free to come up with your own logging scheme, it was }
+{ envisioned that D1 would identify the logged event in the broadest }
+{ terms, and the event classification would be narrowed further and }
+{ further with D2 --> D4. }
+{ }
+{ Special case: If the high bit of D2 is set, D3 becomes a pointer }
+{ to data, and D4 is the size of the data. Make *sure* the high bit }
+{ isn't set unless you are using this special situation. }
+{ }
+{ If you just have a simple case for logging that probably won't get }
+{ used that often, consider adding entries with the WriteDebugString }
+{ method. }
+procedure TStGeneralLog.AddLogEntry(const D1, D2, D3, D4 : DWORD);
+var
+ LogEntry : TStLogRec;
+ EntryPtr : PStLogRec;
+ SizeReq, TimeMrk, ChunkSize : DWORD;
+ HasData : Boolean;
+begin
+ glLockLog;
+ try
+ { Bail if we're not logging }
+ if not Enabled then Exit;
+
+ TimeMrk := GetTickCount;
+
+ { Determine size needed }
+ SizeReq := SizeOf(TStLogRec);
+ if (D2 and $80000000) = $80000000 then begin
+ HasData := True;
+ Inc(SizeReq, D4);
+ end else begin
+ HasData := False;
+ end;
+
+ { Bail if SizeReq is bigger than the whole buffer }
+ if SizeReq > FBufferSize then Exit;
+
+ { Make more room in buffer if necessary }
+ while (SizeReq > BufferFree) and glPopLogEntry(LogEntry) do ;
+
+ { Do we need to wrap this entry? }
+ if (glBufferTail + SizeReq) <= FBufferSize then begin
+
+ { Wrap not required, write directly to glBuffer }
+ EntryPtr := @glBuffer[glBufferTail];
+ EntryPtr.lrTime := TimeMrk;
+ EntryPtr.lrData1 := D1;
+ EntryPtr.lrData2 := D2;
+ EntryPtr.lrData3 := D3;
+ EntryPtr.lrData4 := D4;
+
+ { Write add'l data if necessary }
+ if HasData then begin
+ Move(Pointer(D3)^, glBuffer[glBufferTail + SizeOf(TStLogRec)], D4);
+ end;
+ Inc(glBufferTail, SizeReq);
+
+ { Fix tail if necessary }
+ if glBufferTail = FBufferSize then
+ glBufferTail := 0;
+
+ end else begin
+
+ { Wrap required, use temp buffer }
+ glCheckTempSize(SizeReq);
+
+ EntryPtr := @glTempBuffer[0];
+ EntryPtr.lrTime := TimeMrk;
+ EntryPtr.lrData1 := D1;
+ EntryPtr.lrData2 := D2;
+ EntryPtr.lrData3 := D3;
+ EntryPtr.lrData4 := D4;
+
+ { Write add'l data if necessary }
+ if HasData then begin
+ Move(Pointer(D3)^, glTempBuffer[SizeOf(TStLogRec)], D4);
+ end;
+
+ { Move first half }
+ ChunkSize := FBufferSize - glBufferTail;
+ Move(glTempBuffer[0], glBuffer[glBufferTail], ChunkSize);
+
+ { Move second half }
+ Move(glTempBuffer[ChunkSize], glBuffer[0], SizeReq - ChunkSize);
+
+ { Set tail }
+ glBufferTail := SizeReq - ChunkSize;
+ end;
+ glHighLevelCheck;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Clears all data from buffer (does not write data to disk) }
+procedure TStGeneralLog.ClearBuffer;
+begin
+ glLockLog;
+ try
+ glBufferHead := 0;
+ glBufferTail := 0;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Let user fill in the data for the LogString }
+procedure TStGeneralLog.DoGetLogString(const D1, D2, D3, D4 : DWORD; var LogString : AnsiString);
+begin
+ if Assigned(FOnGetLogString) then
+ FOnGetLogString(Self, D1, D2, D3, D4, LogString);
+end;
+
+{ Calculate the BufferFree level, in bytes, to trip the high level alarm }
+procedure TStGeneralLog.glCalcHighLevel;
+begin
+ glLockLog;
+ try
+ glHighLevelMark := FBufferSize - Round(FBufferSize * FHighLevel / 100);
+ glHighLevelCheck;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Verifies the size of the temp buffer }
+procedure TStGeneralLog.glCheckTempSize(SizeReq : DWORD);
+begin
+ if (SizeReq > glTempSize) then begin
+ ReallocMem(glTempBuffer, SizeReq);
+ glTempSize := SizeReq;
+ end;
+end;
+
+{ Test for high level condition, fire event if necessary }
+procedure TStGeneralLog.glHighLevelCheck;
+begin
+ glLockLog;
+ try
+ if FHighLevel = 0 then Exit;
+ if BufferFree < glHighLevelMark then begin
+ if Assigned(FOnHighLevel) and not glHighLevelTriggered then begin
+ FOnHighLevel(Self);
+ glHighLevelTriggered := True;
+ end;
+ end else begin
+ glHighLevelTriggered := False;
+ end;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Pop log record from log, return False if no record to return }
+function TStGeneralLog.glPopLogEntry(var LogRec : TStLogRec) : Boolean;
+type
+ BytesArray = array[0..SizeOf(TStLogRec)-1] of Byte;
+var
+ Bytes : BytesArray absolute LogRec;
+ ChunkSize : DWORD;
+begin
+ glLockLog;
+ try
+ { Check for empty buffer }
+ if (glBufferHead = glBufferTail) then begin
+ Result := False;
+ Exit;
+ end else begin
+ Result := True;
+ end;
+
+ { Check to see if log record wraps }
+ if (glBufferHead + SizeOf(TStLogRec)) <= FBufferSize then begin
+
+ { No wrap, copy directly over }
+ Move(glBuffer[glBufferHead], LogRec, SizeOf(LogRec));
+ Inc(glBufferHead, SizeOf(LogRec));
+
+ { Fix head if needed }
+ if (glBufferHead = FBufferSize) then glBufferHead := 0;
+ end else begin
+
+ { Need to deal with wrap -- copy first half }
+ ChunkSize := (FBufferSize - glBufferHead);
+ Move(glBuffer[glBufferHead], Bytes[0], ChunkSize);
+
+ { Copy second half }
+ Move(glBuffer[0], Bytes[ChunkSize], (SizeOf(LogRec) - ChunkSize));
+ glBufferHead := SizeOf(LogRec) - ChunkSize;
+ end;
+
+ { Do we have data? If so, deal with it }
+ if (LogRec.lrData2 and $80000000) = $80000000 then begin
+
+ { Check to see if log data wraps }
+ if (glBufferHead + LogRec.lrData4) <= FBufferSize then begin
+
+ { No wrap -- point D2 to buffer }
+ LogRec.lrData3 := DWORD(@glBuffer[glBufferHead]);
+ Inc(glBufferHead, LogRec.lrData4);
+ end else begin
+
+ { Wrap -- copy first half to temp buffer }
+ glCheckTempSize(LogRec.lrData4);
+ ChunkSize := (FBufferSize - glBufferHead);
+ Move(glBuffer[glBufferHead], glTempBuffer[0], ChunkSize);
+
+ { Copy second half }
+ Move(glBuffer[0], glTempBuffer[ChunkSize], (LogRec.lrData4 - ChunkSize));
+ LogRec.lrData3 := DWORD(@glTempBuffer[0]);
+ glBufferHead := LogRec.lrData4 - ChunkSize;
+ end;
+ end
+
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Return time stamp string }
+function TStGeneralLog.glTimeStamp(Mark : DWORD) : string;
+begin
+ Result := Format('%07.7d : ', [Mark - glTimeBase]);
+ Insert('.', Result, 5);
+end;
+
+{ Dumps log file to disk }
+procedure TStGeneralLog.DumpLog;
+var
+ LR : TStLogRec;
+ FS : TFileStream;
+ S, T : AnsiString;
+begin
+ glLockLog;
+
+ try
+ { Open file stream }
+ if FileExists(FileName) and (WriteMode = wmAppend) then begin
+ FS := TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyWrite);
+ FS.Seek(0, soFromEnd);
+ end else begin
+ FS := TFileStream.Create(FileName, fmCreate or fmShareDenyWrite);
+ end;
+
+ try
+ { Do file header if appropriate }
+ if (FS.Size = 0) then begin
+ S := FLogFileHeader;
+ FS.Write(S[1], Length(S));
+
+ { Write trailing CRLF } {!!.02}
+ FS.Write(StCRLF[1], Length(StCRLF)); {!!.02}
+ end;
+
+ { Cycle through all data }
+ while glPopLogEntry(LR) do begin
+ if LR.lrData1 <> $FFFFFFFF then begin
+
+ { It belongs to somone else, let them process it }
+ DoGetLogString(LR.lrData1, LR.lrData2, LR.lrData3, LR.lrData4, S);
+ end else begin
+
+ { Something we're supposed to know about, deal with it }
+ case LR.lrData2 of
+
+ { Logging enabled }
+ leEnabled : S := '**** Logging Enabled' + StCRLF;
+
+ { Logging disabled }
+ leDisabled : S := '**** Logging Disabled' + StCRLF;
+
+ { WriteLogString entry }
+ leString :
+ begin
+ if LR.lrData4 > 0 then begin {!!.02}
+ SetLength(S, LR.lrData4);
+ Move(PByteArray(LR.lrData3)[0], S[1], LR.lrData4);
+ end else begin {!!.02}
+ S := ''; { empty string } {!!.02}
+ end; {!!.02}
+ end;
+
+ else
+ S := Format('!! Unknown log entry : [%8.8x][%8.8x][%8.8x][%8.8x]' + StCRLF,
+ [LR.lrData1, LR.lrData2, LR.lrData3, LR.lrData4]);
+
+ end;
+ end;
+
+ { Write time stamp }
+ T := glTimeStamp(LR.lrTime);
+ FS.Write(T[1], Length(T));
+
+ { Write log string }
+ if Length(S) > 0 then {!!.02}
+ FS.Write(S[1], Length(S));
+
+ { Write trailing CRLF }
+ FS.Write(StCRLF[1], Length(StCRLF));
+ end;
+
+ { Do file header if appropriate }
+ if (FLogFileFooter <> '') then begin
+ S := FLogFileFooter;
+ FS.Write(S[1], Length(S));
+
+ { Write trailing CRLF } {!!.02}
+ FS.Write(StCRLF[1], Length(StCRLF)); {!!.02}
+ end;
+
+ glHighLevelTriggered := False;
+
+ finally
+ FS.Free;
+ end;
+
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Determines whether something is in the buffer }
+function TStGeneralLog.GetBufferEmpty : Boolean;
+begin
+ glLockLog;
+ try
+ Result := (glBufferHead = glBufferTail);
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Calculates free space in the buffer }
+function TStGeneralLog.GetBufferFree : DWORD;
+begin
+ glLockLog;
+ try
+ if (glBufferHead <= glBufferTail) then
+ { One less than actual, since we always leave one byte free }
+ Result := Pred(FBufferSize - (glBufferTail - glBufferHead))
+ else
+ Result := Pred(glBufferHead - glBufferTail);
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Retrieves buffer size }
+function TStGeneralLog.GetBufferSize : DWORD;
+begin
+ glLockLog;
+ try
+ Result := FBufferSize;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Get Enabled property }
+function TStGeneralLog.GetEnabled : Boolean;
+begin
+ glLockLog;
+ try
+ Result := FEnabled;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Get FileName property }
+function TStGeneralLog.GetFileName : TFileName;
+begin
+ glLockLog;
+ try
+ Result := FFileName;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Retrieves high level setpoint }
+function TStGeneralLog.GetHighLevel : Byte;
+begin
+ glLockLog;
+ try
+ Result := FHighLevel;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{!!.01 - added}
+{ Retrieves log options }
+function TStGeneralLog.GetLogOptions : StGenOptionSet;
+begin
+ glLockLog;
+ try
+ Result := FLogOptions;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Retrieves write mode }
+function TStGeneralLog.GetWriteMode : TStWriteMode;
+begin
+ glLockLog;
+ try
+ Result := FWriteMode;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Sets the size of the logging buffer }
+procedure TStGeneralLog.SetBufferSize(const Value : DWORD);
+begin
+ glLockLog;
+ try
+ if Value <> FBufferSize then begin
+ FBufferSize := Value;
+ ReallocMem(glBuffer, Value);
+ ClearBuffer;
+ glCalcHighLevel;
+ end;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Enables (or disables) logging }
+procedure TStGeneralLog.SetEnabled(const Value : Boolean);
+begin
+ glLockLog;
+ try
+ if (Value = True) then begin
+
+ { Allocate buffer if not already done }
+ if (glBuffer = nil) then begin
+ GetMem(glBuffer, FBufferSize);
+ end;
+
+ { Init temp buffer if not already done }
+ if (glTempBuffer = nil) then begin
+ glTempSize := 1024;
+ GetMem(glTempBuffer, glTempSize);
+ end;
+ end else if not (goSuppressDisableMsg in LogOptions) then begin {!!.01}
+ AddLogEntry($FFFFFFFF, leDisabled, 0, 0);
+ end;
+
+ FEnabled := Value;
+
+ finally
+ glUnlockLog;
+ end;
+
+ if (Value = True) and not (goSuppressEnableMsg in LogOptions) then {!!.01}
+ AddLogEntry($FFFFFFFF, leEnabled, 0, 0);
+end;
+
+{ Set FileName property }
+procedure TStGeneralLog.SetFileName(const Value : TFileName);
+begin
+ glLockLog;
+ try
+ FFileName := Value;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Set HighLevel property }
+procedure TStGeneralLog.SetHighLevel(const Value : Byte);
+begin
+ glLockLog;
+ try
+ if (FHighLevel <> Value) and (Value <= 100) then begin
+ FHighLevel := Value;
+ glCalcHighLevel;
+ end;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{!!.01 - added}
+{ Set LogOptions property }
+procedure TStGeneralLog.SetLogOptions(const Value : StGenOptionSet);
+begin
+ glLockLog;
+ try
+ FLogOptions := Value;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Set WriteMode property }
+procedure TStGeneralLog.SetWriteMode(const Value : TStWriteMode);
+begin
+ glLockLog;
+ try
+ FWriteMode := Value;
+ finally
+ glUnlockLog;
+ end;
+end;
+
+{ Write log string to log buffer }
+procedure TStGeneralLog.WriteLogString(const LogString : AnsiString);
+begin
+ AddLogEntry($FFFFFFFF, leString, DWORD(LogString), Length(LogString));
+end;
+
+end.
diff --git a/components/systools/source/windows_only/run/stntlog.pas b/components/systools/source/windows_only/run/stntlog.pas
new file mode 100644
index 000000000..8465ea67a
--- /dev/null
+++ b/components/systools/source/windows_only/run/stntlog.pas
@@ -0,0 +1,436 @@
+// 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: StNTLog.pas 4.04 *}
+{*********************************************************}
+{* SysTools: NT Event Logging *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StNTLog;
+
+interface
+
+uses
+ Windows, SysUtils, Classes, Registry, StBase;
+
+type
+
+ TStNTEventType = (etSuccess, etError, etWarning, etInfo,
+ etAuditSuccess, etAuditFailure);
+
+ PStNTEventLogRec = ^TStNTEventLogRec;
+ TStNTEventLogRec = record
+ case Integer of
+ 0 : (Length : DWORD; { Length of full record }
+ Reserved : DWORD; { Used by the service }
+ RecordNumber : DWORD; { Absolute record number }
+ TimeGenerated : DWORD; { Seconds since 1-1-1970 }
+ TimeWritten : DWORD; { Seconds since 1-1-1970 }
+ EventID : DWORD;
+ EventType : WORD;
+ NumStrings : WORD;
+ EventCategory : WORD;
+ ReservedFlags : WORD; { For use with paired events (auditing) }
+ ClosingRecordNumber : DWORD; { For use with paired events (auditing) }
+ StringOffset : DWORD; { Offset from beginning of record }
+ UserSidLength : DWORD;
+ UserSidOffset : DWORD;
+ DataLength : DWORD;
+ DataOffset : DWORD); { Offset from beginning of record }
+
+ 1 : (VarData : array [0..65535] of Byte);
+
+ //
+ // Variable data may contain:
+ //
+ // WCHAR SourceName[]
+ // WCHAR Computername[]
+ // SID UserSid
+ // WCHAR Strings[]
+ // BYTE Data[]
+ // CHAR Pad[]
+ // DWORD Length;
+ //
+ // Data is contained -after- the static data, the VarData field is set
+ // to the beginning of the record merely to make the offsets match up.
+ end;
+
+ TStReadRecordEvent = procedure(Sender : TObject; const EventRec : TStNTEventLogRec;
+ var Abort : Boolean) of object;
+
+ TStNTEventLog = class(TStComponent)
+ private
+ { Internal use variables }
+ elLogHandle : THandle;
+ elLogList : TStringList;
+ { Property variables }
+ FComputerName : string;
+ FEnabled : Boolean;
+ FEventSource : string;
+ FLogName : string;
+ FOnReadRecord : TStReadRecordEvent;
+ protected
+ { Internal Methods }
+ procedure elAddEntry(const EventType : TStNTEventType; EventCategory, EventID : DWORD;
+ const Strings : TStrings; DataPtr : pointer; DataSize : DWORD);
+ procedure elCloseLog;
+ procedure elOpenLog;
+ { Property Methods }
+ function GetLogCount : DWORD;
+ function GetLogs(Index : Integer) : string;
+ function GetRecordCount : DWORD;
+ procedure SetComputerName(const Value : string);
+ procedure SetLogName(const Value : string);
+ public
+ { Public Methods }
+ constructor Create(AOwner : TComponent); override;
+ destructor Destroy; override;
+ procedure AddEntry(const EventType : TStNTEventType; EventCategory, EventID : DWORD);
+ procedure AddEntryEx(const EventType : TStNTEventType; EventCategory, EventID : DWORD;
+ const Strings : TStrings; DataPtr : pointer; DataSize : DWORD);
+ procedure ClearLog(const BackupName : TFileName);
+ procedure CreateBackup(const BackupName : TFileName);
+ procedure ReadLog(const Reverse : Boolean);
+ procedure RefreshLogList;
+ { Public Properties }
+ property LogCount : DWORD read GetLogCount;
+ property Logs[Index : Integer] : string read GetLogs;
+ property RecordCount : DWORD read GetRecordCount;
+ published
+ { Published Properties }
+ property ComputerName : string read FComputerName write SetComputerName;
+ property Enabled : Boolean read FEnabled write FEnabled default True;
+ property EventSource : string read FEventSource write FEventSource;
+ property LogName : string read FLogName write SetLogName;
+ property OnReadRecord : TStReadRecordEvent read FOnReadRecord write FOnReadRecord;
+ end;
+
+implementation
+
+const
+ { Defines for the READ flags for Eventlogging }
+
+ EVENTLOG_SEQUENTIAL_READ = $0001;
+ EVENTLOG_SEEK_READ = $0002;
+ EVENTLOG_FORWARDS_READ = $0004;
+ EVENTLOG_BACKWARDS_READ = $0008;
+
+ { The types of events that can be logged. }
+
+ EVENTLOG_SUCCESS = $0000;
+ EVENTLOG_ERROR_TYPE = $0001;
+ EVENTLOG_WARNING_TYPE = $0002;
+ EVENTLOG_INFORMATION_TYPE = $0004;
+ EVENTLOG_AUDIT_SUCCESS = $0008;
+ EVENTLOG_AUDIT_FAILURE = $0010;
+
+ { Defines for the WRITE flags used by Auditing for paired events }
+ { These are not implemented in Product 1 }
+
+ EVENTLOG_START_PAIRED_EVENT = $0001;
+ EVENTLOG_END_PAIRED_EVENT = $0002;
+ EVENTLOG_END_ALL_PAIRED_EVENTS = $0004;
+ EVENTLOG_PAIRED_EVENT_ACTIVE = $0008;
+ EVENTLOG_PAIRED_EVENT_INACTIVE = $0010;
+
+ StEventLogKey = '\SYSTEM\CurrentControlSet\Services\EventLog';
+
+
+{ Create instance of event log component }
+constructor TStNTEventLog.Create(AOwner : TComponent);
+begin
+ inherited Create(AOwner);
+
+ { initialization }
+ elLogHandle := 0;
+ elLogList := TStringList.Create;
+ FEnabled := True;
+ FLogName := 'Application';
+
+ { initialize log list }
+ RefreshLogList;
+end;
+
+{ Destroy instance of event log component }
+destructor TStNTEventLog.Destroy;
+begin
+ if elLogHandle <> 0 then elCloseLog;
+ elLogList.Free;
+ inherited;
+end;
+
+{ Add entry to the event log }
+procedure TStNTEventLog.AddEntry(const EventType : TStNTEventType;
+ EventCategory, EventID : DWORD);
+begin
+ elAddEntry(EventType, EventCategory, EventID, nil, nil, 0);
+end;
+
+{ Add entry to the event log - more options }
+procedure TStNTEventLog.AddEntryEx(const EventType : TStNTEventType;
+ EventCategory, EventID : DWORD; const Strings : TStrings;
+ DataPtr : pointer; DataSize : DWORD);
+begin
+ elAddEntry(EventType, EventCategory, EventID, Strings, DataPtr, DataSize);
+end;
+
+{ Clear the event log }
+procedure TStNTEventLog.ClearLog(const BackupName : TFileName);
+begin
+ elOpenLog;
+ try
+ ClearEventLog(elLogHandle, PChar(BackupName));
+ finally
+ elCloseLog;
+ end;
+end;
+
+{ Back up the event log }
+procedure TStNTEventLog.CreateBackup(const BackupName : TFileName);
+begin
+ elOpenLog;
+ try
+ BackupEventLog(elLogHandle, PChar(BackupName));
+ finally
+ elCloseLog;
+ end;
+end;
+
+{ Adds an entry to the event log }
+procedure TStNTEventLog.elAddEntry(const EventType : TStNTEventType;
+ EventCategory, EventID : DWORD; const Strings : TStrings; DataPtr : pointer; DataSize : DWORD);
+const
+ StrArraySize = 1024;
+var
+ TempType, StrCount : DWORD;
+ StrArray : array[0..StrArraySize-1] of PChar;
+ StrArrayPtr : pointer;
+ I : Integer;
+begin
+ StrArrayPtr := nil;
+
+ case EventType of
+ etSuccess : TempType := EVENTLOG_SUCCESS;
+ etError : TempType := EVENTLOG_ERROR_TYPE;
+ etWarning : TempType := EVENTLOG_WARNING_TYPE;
+ etInfo : TempType := EVENTLOG_INFORMATION_TYPE;
+ etAuditSuccess : TempType := EVENTLOG_AUDIT_SUCCESS;
+ etAuditFailure : TempType := EVENTLOG_AUDIT_FAILURE;
+ else
+ TempType := 0;
+ end;
+
+ elOpenLog;
+ try
+ { Fill string array }
+ if Assigned(Strings) then begin
+ FillChar(StrArray, SizeOf(StrArray), #0);
+ StrCount := Strings.Count;
+ Assert(StrCount <= StrArraySize);
+ for I := 0 to StrCount-1 do begin
+ StrArray[I] := StrAlloc(Length(Strings[I]));
+ StrPCopy(StrArray[I], Strings[I]);
+ end;
+ StrArrayPtr := @StrArray;
+ end else begin
+ StrCount := 0;
+ end;
+ ReportEvent(elLogHandle, TempType, EventCategory,
+ EventID, nil, StrCount, DataSize, StrArrayPtr, DataPtr);
+ finally
+ { Release string array memory }
+ for I := 0 to StrArraySize-1 do begin
+ if StrArray[I] = nil then Break;
+ StrDispose(StrArray[I]);
+ end;
+ elCloseLog;
+ end;
+end;
+
+{ Close event log }
+procedure TStNTEventLog.elCloseLog;
+begin
+ if elLogHandle <> 0 then begin
+ CloseEventLog(elLogHandle);
+ elLogHandle := 0;
+ end;
+end;
+
+{ Open event log }
+procedure TStNTEventLog.elOpenLog;
+begin
+ if elLogHandle = 0 then
+ elLogHandle := OpenEventLog(PChar(FComputerName), PChar(FLogName));
+end;
+
+{ Get number on logs available on system }
+function TStNTEventLog.GetLogCount : DWORD;
+begin
+ Result := elLogList.Count;
+end;
+
+{ Get name of logs }
+function TStNTEventLog.GetLogs(Index : Integer) : string;
+begin
+ Result := elLogList[Index];
+end;
+
+{ Get number of log entries in event log }
+function TStNTEventLog.GetRecordCount : DWORD;
+begin
+ elOpenLog;
+ try
+ {$IFDEF FPC}
+ GetNumberOfEventLogRecords(elLogHandle, @Result);
+ {$ELSE}
+ GetNumberOfEventLogRecords(elLogHandle, Result);
+ {$ENDIF}
+ finally
+ elCloseLog;
+ end;
+end;
+
+{ Reads log until complete or aborted }
+procedure TStNTEventLog.ReadLog(const Reverse : Boolean);
+var
+ ReadDir, BytesRead, BytesNeeded, LastErr : DWORD;
+ RetVal, Aborted : Boolean;
+ TempBuffer : array[0..2047] of Byte;
+ TempPointer : Pointer;
+ TempRecPtr : PStNTEventLogRec; { used as an alias, don't actually allocate }
+ FakeBuf : Byte;
+begin
+ Aborted := False;
+ TempPointer := nil;
+
+ { Set direction }
+ if Reverse then
+ ReadDir := EVENTLOG_SEQUENTIAL_READ or EVENTLOG_BACKWARDS_READ
+ else
+ ReadDir := EVENTLOG_SEQUENTIAL_READ or EVENTLOG_FORWARDS_READ;
+
+ elOpenLog;
+ try
+ repeat
+ { Fake read to determine required buffer size }
+ RetVal := ReadEventLog(elLogHandle, ReadDir, 0, @FakeBuf,
+ SizeOf(FakeBuf), BytesRead, BytesNeeded);
+
+ if not RetVal then begin
+ LastErr := GetLastError;
+ if (LastErr = ERROR_INSUFFICIENT_BUFFER) then begin
+
+ { We can use local buffer, which is faster }
+ if (BytesNeeded <= SizeOf(TempBuffer)) then begin
+ if not (ReadEventLog(elLogHandle, ReadDir, 0, @TempBuffer,
+ BytesNeeded, BytesRead, BytesNeeded)) then
+ {$WARNINGS OFF} { Yeah, we know RaiseLastWin32Error is deprecated }
+ RaiseLastWin32Error;
+ {$WARNINGS ON}
+
+ TempRecPtr := @TempBuffer
+
+ { Local buffer too small, need to allocate a buffer on the heap }
+ end else begin
+ if TempPointer = nil then
+ GetMem(TempPointer, BytesNeeded)
+ else
+ ReallocMem(TempPointer, BytesNeeded);
+
+ if not (ReadEventLog(elLogHandle, ReadDir, 0, TempPointer,
+ BytesNeeded, BytesRead, BytesNeeded)) then
+ {$WARNINGS OFF} { Yeah, we know RaiseLastWin32Error is deprecated }
+ RaiseLastWin32Error;
+ {$WARNINGS ON}
+
+ TempRecPtr := TempPointer;
+
+ end;
+
+ { At this point, we should have the data -- fire the event }
+ if Assigned(FOnReadRecord) then
+ FOnReadRecord(Self, TempRecPtr^, Aborted);
+
+ end else begin
+ Aborted := True;
+
+ { Handle unexpected error }
+ {$WARNINGS OFF} { Yeah, we know RaiseLastWin32Error is deprecated }
+ if (LastErr <> ERROR_HANDLE_EOF) then
+ RaiseLastWin32Error;
+ {$WARNINGS ON}
+ end;
+ end;
+ until Aborted;
+
+ finally
+ elCloseLog;
+
+ if TempPointer = nil then
+ FreeMem(TempPointer);
+ end;
+end;
+
+{ Refreshes log list }
+procedure TStNTEventLog.RefreshLogList;
+var
+ Reg : TRegistry;
+begin
+ elLogList.Clear;
+ Reg := TRegistry.Create;
+ try
+ Reg.RootKey := HKEY_LOCAL_MACHINE;
+ if Reg.OpenKey(StEventLogKey, False) then begin
+ Reg.GetKeyNames(elLogList);
+ Reg.CloseKey;
+ end;
+ finally
+ Reg.Free;
+ end;
+end;
+
+{ Set log name }
+procedure TStNTEventLog.SetLogName(const Value : string);
+begin
+ FLogName := Value
+end;
+
+{ Set computer name }
+procedure TStNTEventLog.SetComputerName(const Value : string);
+begin
+ FComputerName := Value;
+ RefreshLogList;
+end;
+
+end.
diff --git a/components/systools/source/windows_only/run/stregini.pas b/components/systools/source/windows_only/run/stregini.pas
new file mode 100644
index 000000000..169efc62e
--- /dev/null
+++ b/components/systools/source/windows_only/run/stregini.pas
@@ -0,0 +1,2824 @@
+// 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: StRegIni.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Registry and INI file access *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StRegIni;
+
+interface
+
+uses
+ Windows,
+ Graphics, Classes, SysUtils,
+ STStrL, StDate, STConst, STBase;
+
+type
+{.Z+}
+ TRegIniType = (riIniType, riRegType);
+ TRegIniMode = (riSet, riGet);
+ TWinVerType = (riWin31,riWin32s,riWin95,riWinNT);
+{.Z-}
+
+ TQueryKeyInfo = record
+ QIKey : HKey; {Value of key being queried}
+ QIClassName : string; {Class Name associated with key}
+ QINumSubKeys: DWORD; {Number of Subkeys under queried key}
+ QIMaxSKNLen : DWORD; {Length of longest subkey name}
+ QIMaxCNLen : DWORD; {Length of longest class name found}
+ QINumValues : DWORD; {Number of values found in queried key ONLY, i.e., values in subkeys not included}
+ QIMaxVNLen : DWORD; {Length of longest value name}
+ QIMaxDataLen: DWORD; {Largest size (in bytes) of values in queried key}
+ QISDescLen : DWORD; {Length of Security Descriptor}
+ QIFileTime : TFileTime; {Time/date file/key was last modified}
+ end;
+
+const
+ {$IFDEF FPC}
+ REG_WHOLE_HIVE_VOLATILE = ($00000001); { Restore whole hive volatile }
+ {$ENDIF}
+{.Z+}
+ RI_INVALID_VALUE = -1;
+ RIVOLATILE = REG_WHOLE_HIVE_VOLATILE;
+ ShortBufSize = 255;
+ MaxBufSize = 8192;
+ MaxByteArraySize = 127;
+{.Z-}
+
+ RIMachine = 'MACHINE';
+ RIUsers = 'USERS';
+ RIRoot = 'ROOT';
+ RICUser = 'C_USERS';
+
+
+type
+ TStRegIni = class(TObject)
+{.Z+}
+ protected {private}
+ riMode : TRegIniMode;
+
+ riWinVer : TWinVerType;
+ riType : TRegIniType;
+ riHoldPrimary,
+ riPrimaryKey : HKey;
+ riRemoteKey : HKey;
+
+ riCurSubKey,
+ riTrueString,
+ riFalseString : PChar;
+
+{$IFDEF ThreadSafe}
+ riThreadSafe : TRTLCriticalSection;
+{$ENDIF}
+
+ function GetAttributes : TSecurityAttributes;
+ {-get security attributes record or value}
+ procedure SetAttributes(Value : TSecurityAttributes);
+ {-get security attributes record or value}
+
+ function GetCurSubKey : string;
+ {-get current subkey/section}
+ procedure SetCurSubKey(Value : string);
+ {-set current subkey/section}
+
+ function GetIsIniFile : Boolean;
+ {-get whether current instance in IniFile or no}
+
+ procedure ParseIniFile(SList : TStrings);
+ {-adds section names in an INI file to a string list}
+
+ protected
+ FCurSubKey : string;
+ FriSecAttr : TSecurityAttributes;
+ FIsIniFile : Boolean;
+
+ riRootName : PChar;
+
+ BmpText,
+ BmpBinary : TBitMap;
+
+ {protected procedures to manage open/closing}
+ function OpenRegKey : HKey;
+ {-opens/creates key or ini file}
+ procedure CloseRegKey(const Key : HKey);
+ {-closes open key or ini file}
+
+ procedure EnterCS;
+ {- call EnterCriticalSection procedure}
+ procedure LeaveCS;
+ {- call LeaveCriticalSection procedure}
+
+ function WriteIniData(const ValueName : string; Data : string) : Boolean;
+ {-write data to an Ini file}
+
+ function ReadIniData(const ValueName : string; var Value : string;
+ Default : string) : Integer;
+ {-read data from an Ini file}
+
+ function WriteRegData(Key : HKey; const ValueName : string; Data : Pointer;
+ DType : DWORD; Size : Integer) : LongInt;
+ {-write data to the registry}
+
+ function ReadRegData(Key : HKey; const ValueName : string; Data : Pointer;
+ Size : LongInt; DType : DWORD) : LongInt;
+ {-read data from the registry}
+
+{.Z-}
+ public
+ constructor Create(RootName : String; IsIniFile : Boolean); virtual;
+ destructor Destroy; override;
+
+ procedure SetPrimary(Value : string);
+ {-change INI filename or primary key of registry}
+ function GetPrimary : string;
+ {-return current INI filename or primary key of registry}
+
+ function GetDataInfo(Key : HKey; const ValueName : string;
+ var Size : LongInt; var DType : DWORD) : LongInt;
+ {-get size and type of data for entry in registry}
+
+ function BytesToString(Value : PByte; Size : Cardinal) : AnsiString;
+ {-converts byte array to string with no spaces}
+ function StringToBytes(const IString : AnsiString; var Value; Size : Cardinal) : Boolean;
+ {-converts string (by groups of 2 char) to byte values}
+
+
+ function GetFullKeyPath : string;
+
+ procedure WriteBoolean(const ValueName : string; Value : Boolean);
+ {-set boolean data in the ini file or registry}
+ function ReadBoolean(const ValueName : string; Default : Boolean) : Boolean;
+ {-get boolean data in the ini file or registry}
+ procedure WriteInteger(const ValueName : string; Value : DWORD);
+ {-set integer data in the ini file or registry}
+ function ReadInteger(const ValueName : string; Default : DWORD) : DWORD;
+ {-get integer data in the ini file or registry}
+ procedure WriteString(const ValueName : string; const Value : string);
+ {-set string data in the ini file or registry}
+ function ReadString(const ValueName : string; const Default : string) : string;
+ {-get string data in the ini file or registry}
+ procedure WriteBinaryData(const ValueName : string; const Value; Size : Integer);
+ {-set byte array in the ini file or registry}
+ procedure ReadBinaryData(const ValueName : string; const Default; var Value; var Size : Integer);
+ {-get byte array from the ini file or registry}
+ procedure WriteFloat(const ValueName : string; const Value : Double);
+ {-set float value in the ini file or registry}
+ function ReadFloat(const ValueName : string; const Default : TStFloat) : TStFloat;
+ {-get float from the ini file or registry}
+ procedure WriteDate(const ValueName : string; const Value : TStDate);
+ {-set date value in the ini file or registry}
+ function ReadDate(const ValueName : string; const Default : TStDate) : TStDate;
+ {-get date value from the ini file or registry}
+ procedure WriteDateTime(const ValueName : string; const Value : TDateTime);
+ {-set datetime value in the ini file or registry}
+ function ReadDateTime(const ValueName : string; const Default : TDateTime) : TDateTime;
+ {-get datetime value from the ini file or registry}
+ procedure WriteTime(const ValueName : string; const Value : TStTime);
+ {-set time value in the ini file or registry}
+ function ReadTime(const ValueName : string; const Default : TStTime) : TStTime;
+ {-get time value from the ini file or registry}
+
+
+ procedure CreateKey(const KeyName : string);
+ {-creates Section in INI file or Key in Registry}
+ procedure GetSubKeys(SK : TStrings);
+ {-lists sections in INI file or subkeys of SubKey in Registry}
+ procedure GetValues(SKV : TStrings);
+ {-lists values in INI section or in Registry SubKey}
+ procedure DeleteKey(const KeyName : string; DeleteSubKeys : Boolean);
+ {-Deletes section in INI file or key in Registry file}
+ procedure DeleteValue(const ValueName : string);
+ {-Deletes a value from an INI section or Registry key}
+ procedure QueryKey(var KeyInfo : TQueryKeyInfo);
+ {-lists information about an INI section or Registry SubKey}
+ function KeyExists(KeyName : string) : Boolean;
+ {-checks if exists in INI file/Registry}
+ function IsKeyEmpty(Primary, SubKey : string) : Boolean;
+ {-checks if key has values and/or subkeys}
+
+ procedure SaveKey(const SubKey : string; FileName : string);
+ {-saves an INI Section with values or Registry Subkey with all values and
+ subkeys to specified file}
+ procedure LoadKey(const SubKey, FileName : string);
+ {-loads an INI file section or Registry key with all subkeys/values}
+ procedure UnLoadKey(const SubKey : string);
+ {-same as DeleteKey for INI file; removes key/subkeys loaded with LoadKey}
+ procedure ReplaceKey(const SubKey, InputFile, SaveFile : string);
+ {-replaces an INI file section or Registry key/subkeys
+ from InputFile, saves old data in SaveFile}
+ procedure RestoreKey(const SubKey, KeyFile : string; Options : DWORD);
+ {-restores an INI section or Registry key/subkeys from KeyFile}
+
+ procedure RegOpenRemoteKey(CompName : string);
+ {-connects to Registry on another computer on network}
+ procedure RegCloseRemoteKey;
+ {-closes connection made with RegConnectRegistry}
+
+ property Attributes : TSecurityAttributes
+ read GetAttributes
+ write SetAttributes;
+
+ property CurSubKey : string
+ read GetCurSubKey
+ write SetCurSubKey;
+
+ property IsIniFile : Boolean
+ read GetIsIniFile;
+ procedure RegGetKeySecurity(const SubKey : string; var SD : TSecurityDescriptor);
+ {-gets KeySecurity information on WinNT machines}
+ procedure RegSetKeySecurity(const SubKey : string; SD : TSecurityDescriptor);
+ {-sets KeySecurity information on WinNT machines}
+ end;
+
+
+implementation
+
+procedure RaiseRegIniError(Code : LongInt);
+var
+ E : ESTRegIniError;
+begin
+ E := ESTRegIniError.CreateResTP(Code, 0);
+ E.ErrorCode := Code;
+ raise E;
+end;
+
+{==========================================================================}
+
+procedure RaiseRegIniErrorFmt(Code : LongInt; A : array of const);
+var
+ E : ESTRegIniError;
+begin
+ E := ESTRegIniError.CreateResFmtTP(Code, A, 0);
+ E.ErrorCode := Code;
+ raise E;
+end;
+
+{==========================================================================}
+
+constructor TStRegIni.Create(RootName : String; IsIniFile : Boolean);
+var
+ S : string;
+ OSI : TOSVERSIONINFO;
+begin
+{$IFDEF ThreadSafe}
+ Windows.InitializeCriticalSection(riThreadSafe);
+{$ENDIF}
+
+ {check if a primary key or ini file is specified}
+ if (Length(RootName) = 0) then
+ RaiseRegIniError(stscNoFileKey);
+ RootName := ANSIUpperCase(RootName);
+
+ {get False string from resource}
+ S := SysToolsStr(stscFalseString);
+ riFalseString := StrAlloc(Length(S)); // GetMem(riFalseString,Length(S)+1);
+ StrPCopy(riFalseString,S);
+
+ {get True string from resource}
+ S := SysToolsStr(stscTrueString);
+ riTrueString := StrAlloc(Length(S)); // GetMem(riTrueString,Length(S)+1);
+ StrPCopy(riTrueString,S);
+
+ riCurSubKey := StrAlloc(1); // GetMem(riCurSubKey,1);
+ riCurSubKey[0] := #0;
+
+ BmpText := TBitMap.Create;
+ BmpBinary := TBitMap.Create;
+
+ BmpText.Handle := LoadBitmap(HInstance, 'STBMPTEXT');
+ BmpBinary.Handle := LoadBitmap(HInstance, 'STBMPBINARY');
+
+ {setup ini file/primary key via riRootName}
+ if (IsIniFile) then begin
+ riType := riIniType;
+ riRootName := StrAlloc(Length(RootName)); // GetMem(riRootName,Length(RootName)+1);
+ StrPCopy(riRootName,RootName);
+ end else begin
+ riType := riRegType;
+
+ riPrimaryKey := 0;
+ riHoldPrimary := 0;
+ if (RootName = RIMachine) then
+ riPrimaryKey := HKEY_LOCAL_MACHINE
+ else if (RootName = RIUsers) then
+ riPrimaryKey := HKEY_USERS
+ else if (RootName = RIRoot) then
+ riPrimaryKey := HKEY_CLASSES_ROOT
+ else if (RootName = RICUser) then
+ riPrimaryKey := HKEY_CURRENT_USER
+ else
+ riPrimaryKey := HKEY_CURRENT_USER;
+
+ OSI.dwOSVersionInfoSize := SizeOf(OSI);
+ if (GetVersionEX(OSI)) then begin
+ case OSI.dwPlatformID of
+ VER_PLATFORM_WIN32S : RaiseRegIniError(stscNoWin32S);
+ VER_PLATFORM_WIN32_WINDOWS : riWinVer := riWin95;
+ VER_PLATFORM_WIN32_NT : riWinVer := riWinNT;
+ end;
+ end;
+
+ if (FriSecAttr.nLength <> sizeOf(TSecurityAttributes)) then begin
+ FriSecAttr.nLength := sizeof(TSecurityAttributes);
+ FriSecAttr.lpSecurityDescriptor := nil;
+ FriSecAttr.bInheritHandle := TRUE;
+ end;
+
+ end;
+end;
+
+{==========================================================================}
+
+destructor TStRegIni.Destroy;
+begin
+ {no need to check for local key since none are kept open}
+ {longer than needed for a specific method}
+ if (riRemoteKey <> 0) then
+ RegCloseRemoteKey;
+
+ if (riRootName <> nil) then
+ FreeMem(riRootName,StrLen(riRootName)+1);
+ if (riFalseString <> nil) then
+ FreeMem(riFalseString,StrLen(riFalseString)+1);
+ if (riTrueString <> nil) then
+ FreeMem(riTrueString,StrLen(riTrueString)+1);
+ if (riCurSubKey <> nil) then
+ FreeMem(riCurSubKey,StrLen(riCurSubKey)+1);
+
+ BmpText.Free;
+ BmpBinary.Free;
+
+{$IFDEF ThreadSafe}
+ Windows.DeleteCriticalSection(riThreadSafe);
+{$ENDIF}
+ inherited Destroy;
+end;
+
+{==========================================================================}
+
+
+procedure TStRegIni.SetPrimary(Value : string);
+ {-change working Ini file or top level key in registry}
+begin
+ if riType = riIniType then begin
+ if CompareText(Value,StrPas(riRootName)) = 0 then Exit;
+
+ if (riRootName <> nil) then
+ StrDispose(riRootName); // FreeMem(riRootName,StrLen(riRootName)+1);
+ riRootName := StrAlloc(Length(Value)); //GetMem(riRootName,Length(Value)+1);
+ StrPCopy(riRootName,Value);
+ end else begin
+ if (riRemoteKey <> 0) then
+ RegCloseRemoteKey;
+
+ if (Value = RIMachine) then
+ riPrimaryKey := HKEY_LOCAL_MACHINE
+ else if (Value = RIUsers) then
+ riPrimaryKey := HKEY_USERS
+ else if (Value = RIRoot) then
+ riPrimaryKey := HKEY_CLASSES_ROOT
+ else if (Value = RICUser) then
+ riPrimaryKey := HKEY_CURRENT_USER
+ else
+ riPrimaryKey := HKEY_CURRENT_USER;
+ end;
+end;
+
+{==========================================================================}
+
+function TStRegIni.GetPrimary : string;
+ {-return working Ini file or top level registry key}
+begin
+ if (riType = riIniType) then
+ Result := StrPas(riRootName)
+ else begin
+ case riPrimaryKey of
+ HKEY_LOCAL_MACHINE : Result := RIMachine;
+ HKEY_USERS : Result := RIUsers;
+ HKEY_CLASSES_ROOT : Result := RIRoot;
+ HKEY_CURRENT_USER : Result := RICUser;
+ else
+ Result := 'Invalid primary key'
+ end;
+ end;
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.EnterCS;
+begin
+{$IFDEF ThreadSafe}
+ EnterCriticalSection(riThreadSafe);
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.LeaveCS;
+begin
+{$IFDEF ThreadSafe}
+ LeaveCriticalSection(riThreadSafe);
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.GetIsIniFile : Boolean;
+ {-get whether instance is IniFile or no}
+begin
+ Result := riType = riIniType;
+end;
+
+{==========================================================================}
+
+function TStRegIni.GetAttributes : TSecurityAttributes;
+ {-Get current security attributes (NT Only) }
+begin
+ with Result do begin
+ nLength := sizeof(TSecurityAttributes);
+ lpSecurityDescriptor := FriSecAttr.lpSecurityDescriptor;
+ bInheritHandle := FriSecAttr.bInheritHandle;
+ end;
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.SetAttributes(Value : TSecurityAttributes);
+ {-set security attributes (NT only) }
+begin
+ FriSecAttr.nLength := sizeof(TSecurityAttributes);
+ FriSecAttr.lpSecurityDescriptor := Value.lpSecurityDescriptor;
+ FriSecAttr.bInheritHandle := Value.bInheritHandle;
+end;
+
+{==========================================================================}
+
+function TStRegIni.GetCurSubKey : string;
+ {-retrn name of working Ini file section or registry subkey}
+begin
+ Result := FCurSubKey;
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.SetCurSubKey(Value : string);
+ {-set name of working Ini file section or registry subkey}
+begin
+ if (riCurSubKey <> nil) then
+ StrDispose(riCurSubKey); // FreeMem(riCurSubKey,StrLen(riCurSubKey)+1);
+ FCurSubKey := Value;
+ riCurSubKey := StrAlloc(Length(Value)); // GetMem(riCurSubKey,Length(Value)+1);
+ StrPCopy(riCurSubKey,Value);
+end;
+
+{==========================================================================}
+
+function TStRegIni.OpenRegKey : HKey;
+ {-open a registry key}
+var
+ Disposition : DWORD;
+ ECode : LongInt;
+begin
+ Disposition := 0;
+ if (riMode = riSet) then begin
+ {Keys are created with all key access privilages and as non-volatile}
+ ECode := RegCreateKeyEx(riPrimaryKey, riCurSubKey,0,nil,
+ REG_OPTION_NON_VOLATILE,KEY_ALL_ACCESS,@FriSecAttr,
+ Result,@Disposition);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscCreateKeyFail, [ECode]);
+ end else begin
+ {Read operations limit key access to read only}
+ ECode := RegOpenKeyEx(riPrimaryKey,riCurSubKey, 0, KEY_READ,Result);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscOpenKeyFail, [ECode]);
+ end;
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.CloseRegKey(const Key : HKey);
+ {-close registry key}
+begin
+ RegCloseKey(Key);
+end;
+
+{==========================================================================}
+
+function TStRegIni.WriteIniData(const ValueName : string;
+ Data : String) : Boolean;
+ {-write data to the Ini file in the working section}
+var
+ PData,
+ PValueName : PChar;
+ VNLen,
+ DLen : integer;
+begin
+ if (ValueName = '') then
+ RaiseRegIniError(stscNoValueNameSpecified);
+
+ PData := nil;
+ PValueName := nil;
+ VNLen := Length(ValueName) + 1;
+ DLen := Length(Data) + 1;
+
+ try
+ PValueName := StrAlloc(VNLen); // GetMem(PValueName, VNLen);
+ PData := StrAlloc(DLen); // GetMem(PData, DLen);
+
+ strPCopy(PValueName, ValueName);
+ strPCopy(PData, Data);
+
+ Result := WritePrivateProfileString(riCurSubKey, PValueName,
+ PData, riRootName)
+ finally
+ if PValueName <> nil then
+ StrDispose(PValueName); // FreeMem(PValueName, VNLen);
+ if PData <> nil then
+ StrDispose(PData); // FreeMem(PData, DLen);
+ end;
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadIniData(const ValueName : string; var Value : String;
+ Default : String) : Integer;
+ {-read a value from the working section of the Ini file}
+var
+ PValue : array[0..1024] of char;
+ PVName,
+ PDefault : PChar;
+begin
+ PDefault := nil;
+ PVName := nil;
+
+ try
+ PVName := StrAlloc(Length(ValueName)); // GetMem(PVName,Length(ValueName)+1);
+ PDefault := StrAlloc(Length(Default)); // GetMem(PDefault,Length(Default)+1);
+
+ StrPCopy(PVName,ValueName);
+ StrPCopy(PDefault,Default);
+
+ GetPrivateProfileString(riCurSubKey,PVName,PDefault,
+ PValue,Length(PValue)-1,riRootName);
+
+ Value := StrPas(PValue);
+ Result := Length(Value);
+ finally
+ if PVName <> nil then
+ StrDispose(PVName); // FreeMem(PVName,strlen(PVName)+1);
+ if PDefault <> nil then
+ StrDispose(PDefault); // FreeMem(PDefault,strlen(PDefault)+1);
+ end;
+end;
+
+{==========================================================================}
+
+function TStRegIni.WriteRegData(Key : HKey; const ValueName : string; Data : Pointer;
+ DType : DWORD; Size : Integer) : LongInt;
+ {-write a value into the registry}
+begin
+ Result := RegSetValueEx(Key, PChar(ValueName), 0, DType, Data, Size);
+end;
+
+{==========================================================================}
+
+function TStRegIni.GetDataInfo(Key : HKey; const ValueName : string;
+ var Size : LongInt; var DType : DWORD) : LongInt;
+ {-get the size and type of a specific value in the registry}
+var
+ PVName : PChar;
+ Opened : Boolean;
+ TS : string;
+begin
+ Opened := False;
+ riMode := riGet;
+ if (riType = riIniType) then begin
+ TS := ReadString(ValueName,'');
+ Size := Length(TS);
+ DType := REG_SZ;
+ Result := ERROR_SUCCESS;
+ Exit;
+ end;
+
+ PVName := StrAlloc(Length(ValueName)); //GetMem(PVName,Length(ValueName)+1);
+ try
+ StrPCopy(PVName,ValueName);
+ if Key = 0 then begin
+ Key := OpenRegKey;
+ Opened := True;
+ end;
+ Result := RegQueryValueEx(Key,PVName,nil,@DType,nil,LPDWORD(@Size));
+ finally
+ StrDispose(PVName); // FreeMem(PVName,strlen(PVName)+1);
+ end;
+ if Opened then
+ RegCloseKey(Key);
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadRegData(Key : HKey; const ValueName : string; Data : Pointer;
+ Size : LongInt; DType : DWORD) : LongInt;
+ {-read a value from the registry}
+var
+ PVName : PChar;
+begin
+ PVName := StrAlloc(Length(ValueName)); // GetMem(PVName,(Length(ValueName)+1) * SizeOf(Char));
+ try
+ StrPCopy(PVName,ValueName);
+ DType := REG_NONE;
+ Result := RegQueryValueEx(Key, PVName, nil,@DType,PByte(Data),LPDWORD(@Size));
+ finally
+ StrDispose(PVName); // FreeMem(PVName,strlen(PVName)+1);
+ end;
+end;
+
+{==========================================================================}
+
+function TStRegIni.GetFullKeyPath : string;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ Result := StrPas(riRootName) + '\' + StrPas(riCurSubKey);
+ end else begin
+ case riPrimaryKey of
+
+ HKEY_LOCAL_MACHINE : Result := 'HKEY_LOCAL_MACHINE\';
+ HKEY_USERS : Result := 'HKEY_USERS\';
+ HKEY_CLASSES_ROOT : Result := 'HKEY_CLASSES_ROOT\';
+ HKEY_CURRENT_USER : Result := 'HKEY_CURRENT_USER\';
+ end;
+ Result := Result + StrPas(riCurSubKey);
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.WriteBoolean(const ValueName : string; Value : Boolean);
+ {-write Boolean value to the Ini file or registry}
+var
+ ECode : LongInt;
+ IValue : DWORD;
+ Key : HKey;
+ wResult : Boolean;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ if (Value) then
+ wResult := WriteIniData(ValueName, StrPas(riTrueString))
+ else
+ wResult := WriteIniData(ValueName, StrPas(riFalseString));
+ if (NOT wResult) then
+ RaiseRegIniError(stscIniWriteFail);
+ end else begin
+ Key := OpenRegKey;
+ try
+ IValue := Ord(Value);
+ ECode := WriteRegData(Key,ValueName,@IValue,REG_DWORD,SizeOf(DWORD));
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscRegWriteFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadBoolean(const ValueName : string; Default : Boolean) : Boolean;
+ {-read a Boolean value from the Ini file or registry}
+var
+ Value : string;
+ IVal : Double;
+ Key : HKey;
+ ECode,
+
+ ValSize : LongInt;
+ ValType : DWORD;
+ LResult : Pointer;
+ Code : Integer;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ if Default then
+ ReadIniData(ValueName,Value,StrPas(riTrueString))
+ else
+ ReadIniData(ValueName,Value,StrPas(riFalseString));
+
+ if (CompareText(Value,StrPas(riFalseString)) = 0) then
+ Result := False
+ else begin
+ if (CompareText(Value,StrPas(riTrueString)) = 0) then
+ Result := True
+ else begin
+ Val(Value,IVal,Code);
+ if (Code = 0) then
+ Result := IVal <> 0
+ else
+ Result := Default;
+ end;
+ end;
+
+ end else begin
+ try
+ Key := OpenRegKey;
+ except
+ Result := Default;
+ Exit;
+ end;
+ try
+ {get info on requested value}
+ ECode := GetDataInfo(Key,ValueName,ValSize,ValType);
+ if (ECode <> ERROR_SUCCESS) then begin
+ Result := Default;
+ Exit;
+ end;
+
+ {Size does not include null terminator for strings}
+ if (ValType = REG_SZ) OR (ValType = REG_EXPAND_SZ) then
+ begin
+ Inc(ValSize);
+ {$IFDEF UNICODE}
+ ValSize := ValSize * 2;
+ {$ENDIF}
+ end;
+ GetMem(LResult,ValSize);
+ try
+ ECode := ReadRegData(Key,ValueName,LResult,ValSize,ValType);
+ if (ECode <> ERROR_SUCCESS) then
+ Result := Default
+ else begin
+ {convert data, if possible, to Boolean}
+ case (ValType) of
+ REG_SZ,
+ REG_EXPAND_SZ : Result := StrIComp(PChar(LResult),riFalseString) <> 0;
+ REG_BINARY,
+ REG_DWORD : Result := (LongInt(LResult^) <> 0);
+ else
+ Result := Default;
+ end;
+ end;
+ finally
+ FreeMem(LResult,ValSize);
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.WriteInteger(const ValueName : string; Value : DWORD);
+ {-write an integer to the Ini file or the registry}
+var
+ ECode : LongInt;
+ Key : HKey;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ if (NOT WriteIniData(ValueName,IntToStr(Value))) then
+ RaiseRegIniError(stscIniWriteFail);
+ end else begin
+ Key := OpenRegKey;
+ try
+ ECode := WriteRegData(Key,ValueName,@Value,REG_DWORD,SizeOf(DWORD));
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscRegWriteFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadInteger(const ValueName : string; Default : DWORD) : DWORD;
+ {-read an integer from the Ini file or registry}
+var
+ Value : string;
+
+ ECode,
+ Key : HKey;
+ Len : LongInt;
+ ValSize : LongInt;
+ ValType : DWORD;
+
+ LResult : Pointer;
+ Code : Integer;
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ Len := ReadIniData(ValueName,Value,IntToStr(Default));
+ if (Len > 0) then begin
+ Val(Value,Result,Code);
+ if (Code <> 0) then
+ Result := Default;
+ end else
+ Result := Default;
+ end else begin
+ try
+ Key := OpenRegKey;
+ except
+ Result := Default;
+ Exit;
+ end;
+ try
+ {get info on requested value}
+ ECode := GetDataInfo(Key,ValueName,ValSize,ValType);
+ if (ECode <> ERROR_SUCCESS) then begin
+ Result := Default;
+ Exit;
+ end;
+
+ {Size does not include null terminator for strings}
+ if (ValType = REG_SZ) OR (ValType = REG_EXPAND_SZ) then
+ begin
+ Inc(ValSize);
+ {$IFDEF UNICODE}
+ ValSize := ValSize * 2;
+ {$ENDIF}
+ end;
+ GetMem(LResult,ValSize);
+ try
+ ECode := ReadRegData(Key,ValueName,LResult,ValSize,ValType);
+ if (ECode <> ERROR_SUCCESS) then
+ Result := Default
+ else begin
+ {convert data, if possible, to an integer value}
+ case (ValType) of
+ REG_SZ,
+ REG_EXPAND_SZ : begin
+ Value := StrPas(PChar(LResult));
+ Val(Value,Result,Code);
+ if (Code <> 0) then
+ Result := Default;
+ end;
+ REG_BINARY,
+ REG_DWORD : Result := DWORD(LResult^);
+ else
+ Result := Default;
+ end;
+ end;
+ finally
+ FreeMem(LResult,ValSize);
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.BytesToString(Value : PByte; Size : Cardinal) : AnsiString;
+ {-convert byte array to string, no spaces or hex enunciators, e.g., '$'}
+var
+ I,
+ Index : Cardinal;
+ S : String[3];
+
+begin
+ SetLength(Result,2*Size);
+
+ for I := 1 to Size do begin
+ Index := I*2;
+ S := HexBL(Byte(PAnsiChar(Value)[I-1]));
+ Result[(Index)-1] := S[1];
+ Result[Index] := S[2];
+ end;
+end;
+
+{==========================================================================}
+
+function TStRegIni.StringToBytes(const IString : AnsiString; var Value; Size : Cardinal) : Boolean;
+ {-convert string (by groups of 2 char) to byte values}
+var
+ Code,
+ Index,
+ I : Integer;
+ Q : array[1..MaxByteArraySize] of byte;
+ S : array[1..3] of AnsiChar;
+begin
+ if ((Length(IString) div 2) <> LongInt(Size)) then begin
+ Result := False;
+ Exit;
+ end;
+
+ Result := True;
+ for I := 1 to Size do begin
+ Index := (2*(I-1))+1;
+ S[1] := '$';
+ S[2] := IString[Index];
+ S[3] := IString[Index+1];
+ Val(S,Q[I],Code);
+ if (Code <> 0) then begin
+ Result := False;
+ Exit;
+ end;
+ end;
+ Move(Q, Value, Size);
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.WriteBinaryData(const ValueName : string; const Value; Size : Integer);
+ {-write binary data of any form to Ini file or registry}
+var
+ SValue : string;
+ ECode : LongInt;
+ Key : HKey;
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ if (Size > MaxByteArraySize) then
+ RaiseRegIniError(stscByteArrayTooLarge);
+ SValue := BytesToString(PByte(@Value),Size);
+ if (NOT WriteIniData(ValueName,SValue)) then
+ RaiseRegIniError(stscIniWriteFail);
+ end else begin
+ Key := OpenRegKey;
+ try
+ ECode := WriteRegData(Key,ValueName,@Value,REG_BINARY,Size);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscRegWriteFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.ReadBinaryData(const ValueName : string; const Default;
+ var Value; var Size : Integer);
+ {-read binary data of any form from Ini file or regsitry}
+var
+ ECode : LongInt;
+ Key : HKey;
+ Len : Cardinal;
+
+ ValSize : LongInt;
+ ValType : DWORD;
+
+ DefVals,
+ Values : String;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ DefVals := BytesToString(PByte(@Default), Size);
+ Len := ReadIniData(ValueName, Values, DefVals);
+ if (Len mod 2 = 0) then begin
+ {covert string, if possible, to series of bytes}
+ if not (StringToBytes(Values, PByte(Value), Size)) then
+ Move(Default, PByte(Value), Size);
+ end else
+ Move(Default, PByte(Value), Size);
+ end else begin
+ try
+ Key := OpenRegKey;
+ except
+ Move(Default, Value, Size);
+ Exit;
+ end;
+ try
+ {get info on requested value}
+ ECode := GetDataInfo(Key, ValueName, ValSize, ValType);
+ if (ECode <> ERROR_SUCCESS) then begin
+ Move(Default, Value, Size);
+ Exit;
+ end;
+
+ if (ValSize <> Size) then
+ RaiseRegIniErrorFmt(stscBufferDataSizesDif, [Size,ValSize])
+ else
+ Size := ValSize;
+
+ if (ValType <> REG_BINARY) then
+ Move(Default, Value, Size)
+ else begin
+ ECode := ReadRegData(Key, ValueName, PByte(@Value), ValSize, ValType);
+ if (ECode <> ERROR_SUCCESS) then
+ Move(Default, Value, Size)
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.WriteString(const ValueName : string; const Value : string);
+ {-write a string to the Ini file or registry}
+var
+ ECode : LongInt;
+ Key : HKey;
+ PValue : PChar;
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ if NOT WriteIniData(ValueName, Value) then
+ RaiseRegIniError(stscIniWriteFail);
+ end else begin
+ PValue := StrAlloc(Length(Value)); // GetMem(PValue, Length(Value)+1);
+ try
+ StrPCopy(PValue, Value);
+ Key := OpenRegKey;
+ try
+ {same call for 16/32 since we're using a PChar}
+ ECode := WriteRegData(Key,ValueName, PValue,REG_SZ, (strlen(PValue)+1) * SizeOf(Char));
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscRegWriteFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ finally
+ StrDispose(PValue); // FreeMem(PValue,strlen(PValue)+1);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadString(const ValueName : string; const Default : string) : string;
+ {-read a string from an Ini file or the registry}
+var
+ ECode : LongInt;
+ Len : LongInt;
+ ValSize : LongInt;
+ Key : HKey;
+ ValType : DWORD;
+ TmpVal : DWORD;
+ LResult : Pointer;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ Len := ReadIniData(ValueName,Result,Default);
+ if (Len < 1) then
+ Result := Default;
+ end else begin
+ try
+ Key := OpenRegKey;
+ except
+ Result := Default;
+ Exit;
+ end;
+ try
+ {get info on requested value}
+ ECode := GetDataInfo(Key,ValueName,ValSize,ValType);
+ if (ECode <> ERROR_SUCCESS) then begin
+ Result := Default;
+ Exit;
+ end;
+
+ if (ValType = REG_SZ) OR (ValType = REG_EXPAND_SZ)then
+ begin
+ Inc(ValSize);
+ {$IFDEF UNICODE}
+ ValSize := ValSize * 2;
+ {$ENDIF}
+ end;
+ GetMem(LResult,ValSize);
+ try
+ ECode := ReadRegData(Key,ValueName,LResult,ValSize,ValType);
+ if (ECode <> ERROR_SUCCESS) AND (ECode <> ERROR_MORE_DATA) then
+ Result := Default
+ else begin
+ {convert data, if possible, to string}
+ case (ValType) of
+ REG_SZ,
+ REG_EXPAND_SZ : Result := StrPas(PChar(LResult));
+ REG_BINARY : begin
+ if (ValSize > MaxByteArraySize) then
+ RaiseRegIniError(stscByteArrayTooLarge);
+ Result := BytesToString(PByte(@LResult),ValSize);
+ end;
+ REG_DWORD : begin
+ TmpVal := DWORD(LResult^);
+ Str(TmpVal,Result);
+ end;
+ else
+ Result := Default;
+ end;
+ end;
+ finally
+ FreeMem(LResult,ValSize);
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.WriteFloat(const ValueName : string; const Value : Double);
+ {-write floating point number to Ini file or registry}
+var
+ ECode : LongInt;
+ Key : HKey;
+ SValue : string;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ Str(Value, SValue);
+ while (SValue[1] = ' ') do
+ System.Delete(SValue, 1, 1);
+ if (riType = riIniType) then begin
+ if (NOT WriteIniData(ValueName, SValue)) then
+ RaiseRegIniError(stscIniWriteFail);
+ end else begin
+ Key := OpenRegKey;
+ try
+ ECode := WriteRegData(Key,ValueName,@Value,REG_BINARY,SizeOf(Double));
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscRegWriteFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadFloat(const ValueName : string; const Default : TStFloat) : TStFloat;
+ {-read floating point value from Ini file or registry}
+var
+ SDefault,
+ Value : string;
+
+ ECode,
+ Key : HKey;
+ Len : LongInt;
+ ValSize : LongInt;
+ ValType : DWORD;
+
+ LResult : Pointer;
+ Code : integer;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ Str(Default,SDefault);
+ Len := ReadIniData(ValueName,Value,SDefault);
+ if (Len > 0) then begin
+ Val(Value,Result,Code);
+ if (Code <> 0) then
+ Result := Default;
+ end else
+ Result := Default;
+ end else begin
+ try
+ Key := OpenRegKey;
+ except
+ Result := Default;
+ Exit;
+ end;
+ try
+ ECode := GetDataInfo(Key,ValueName,ValSize,ValType);
+
+ if (ECode <> ERROR_SUCCESS) then begin
+ Result := Default;
+ Exit;
+ end;
+
+ {Size does not include null terminator for strings}
+ if (ValType = REG_SZ) OR (ValType = REG_EXPAND_SZ) then
+ begin
+ Inc(ValSize);
+ {$IFDEF UNICODE}
+ ValSize := ValSize * 2;
+ {$ENDIF}
+ end;
+
+ GetMem(LResult,ValSize);
+ try
+ ECode := ReadRegData(Key,ValueName,LResult,ValSize,ValType);
+ if (ECode <> ERROR_SUCCESS) then
+ Result := Default
+ else begin
+ {convert data, if possible, to floating point number}
+ case (ValType) of
+ REG_SZ,
+ REG_EXPAND_SZ : begin
+ Value := StrPas(PChar(LResult));
+ Val(Value,Result,Code);
+ if (Code <> 0) then
+ Result := Default;
+ end;
+ REG_BINARY,
+ REG_DWORD : Result := Double(LResult^);
+ else
+ Result := Default;
+ end;
+ end;
+ finally
+ FreeMem(LResult,ValSize);
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.WriteDateTime(const ValueName : string; const Value : TDateTime);
+ {-write a Delphi DateTime to Ini file or registry}
+var
+ ECode : LongInt;
+ Key : HKey;
+ SValue : string;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ Str(Value,SValue);
+ if (riType = riIniType) then begin
+ if (NOT WriteIniData(ValueName,SValue)) then
+ RaiseRegIniError(stscIniWriteFail);
+ end else begin
+ Key := OpenRegKey;
+ try
+ ECode := WriteRegData(Key,ValueName,@Value,REG_BINARY,SizeOf(TDateTime));
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscRegWriteFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadDateTime(const ValueName : string; const Default : TDateTime) : TDateTime;
+ {-read a Delphi DateTime from the Ini file or registry}
+var
+ SDefault,
+ Value : string;
+
+ ECode,
+ Key : HKey;
+ Len : LongInt;
+ ValSize : LongInt;
+ ValType : DWORD;
+
+ LResult : Pointer;
+ Code : integer;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ Str(Default,SDefault);
+ Len := ReadIniData(ValueName,Value,SDefault);
+ if (Len > 0) then begin
+ Val(Value,Result,Code);
+ if (Code <> 0) then
+ Result := Default;
+ end else
+ Result := Default;
+ end else begin
+ try
+ Key := OpenRegKey;
+ except
+ Result := Default;
+ Exit;
+ end;
+ try
+ ECode := GetDataInfo(Key,ValueName,ValSize,ValType);
+
+ if (ECode <> ERROR_SUCCESS) then begin
+ Result := Default;
+ Exit;
+ end;
+
+ {Size does not include null terminator for strings}
+ if (ValType = REG_SZ) OR (ValType = REG_EXPAND_SZ) then
+ begin
+ Inc(ValSize);
+ {$IFDEF UNICODE}
+ ValSize := ValSize * 2;
+ {$ENDIF}
+ end;
+ GetMem(LResult,ValSize);
+ try
+ ECode := ReadRegData(Key,ValueName,LResult,ValSize,ValType);
+ if (ECode <> ERROR_SUCCESS) then
+ Result := Default
+ else begin
+ {covert data, if possible, to DateTime value}
+ case (ValType) of
+ REG_SZ,
+ REG_EXPAND_SZ : begin
+ Value := StrPas(PAnsiChar(LResult));
+ Val(Value,Result,Code);
+ if (Code <> 0) then
+ Result := Default;
+ end;
+ REG_BINARY,
+ REG_DWORD : Result := TDateTime(LResult^);
+ else
+ Result := Default;
+ end;
+ end;
+ finally
+ FreeMem(LResult,ValSize);
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.WriteDate(const ValueName : string; const Value : TStDate);
+ {-write a SysTools Date to Ini file or registry}
+begin
+ WriteInteger(ValueName,DWORD(Value));
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadDate(const ValueName : string; const Default : TStDate) : TStDate;
+ {-read a SysTools Date from Ini file or registry}
+begin
+ Result := TStDate(ReadInteger(ValueName,DWORD(Default)));
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.WriteTime(const ValueName : string; const Value : TStTime);
+ {-write SysTools Time to Ini file or registry}
+begin
+ WriteInteger(ValueName,DWORD(Value));
+end;
+
+{==========================================================================}
+
+function TStRegIni.ReadTime(const ValueName : string; const Default : TStTime) : TStTime;
+ {-read SysTools Time from Ini file or registry}
+begin
+ Result := TStTime(ReadInteger(ValueName,DWORD(Default)));
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.CreateKey(const KeyName : string);
+ {-create a new section in Ini file or subkey in registry}
+const
+ TempValueName = '$ABC123098FED';
+var
+ Disposition : DWORD;
+ ECode : LongInt;
+ newKey : HKey;
+ PCSKey,
+ PSKey : PChar;
+ HoldKey : HKey;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (Length(KeyName) = 0) then
+ RaiseRegIniError(stscNoKeyName);
+
+ if (riType = riIniType) then begin
+ PSKey := StrAlloc(Length(KeyName)); // GetMem(PSKey,Length(KeyName)+1);
+ try
+ StrPCopy(PSKey,KeyName);
+ {Create Section with temporary value}
+ if (NOT WritePrivateProfileString(PSKey,TempValueName,' ',riRootName)) then
+ RaiseRegIniError(stscCreateKeyFail);
+ {Delete temporary value but leave section intact}
+ if (NOT WritePrivateProfileString(PSKey,TempValueName,nil,riRootName)) then
+ RaiseRegIniError(stscIniWriteFail);
+ finally
+ StrDispose(PSKey); // FreeMem(PSKey,Length(KeyName)+1);
+ end;
+ end else begin
+ HoldKey := 0;
+ PCSKey := StrAlloc(Length(KeyName) + StrLen(riCurSubKey) + 2); // GetMem(PCSKey, Length(KeyName)+1 + LongInt(strlen(riCurSubkey))+2);
+ PSKey := StrAlloc(Length(KeyName)); // GetMem(PSKey, Length(KeyName)+1);
+ try
+ PCSKey[0] := #0;
+ StrPCopy(PSKey,KeyName);
+ if riCurSubKey[0] <> #0 then
+ strcat(Strcopy(PCSKey, riCurSubKey), '\');
+ strcat(PCSKey, PSKey);
+ if (riRemoteKey <> 0) then begin
+ HoldKey := riPrimaryKey;
+ riPrimaryKey := riRemoteKey;
+ end;
+ Disposition := 0;
+ {creates a new key or opens an existing key}
+ ECode := RegCreateKeyEx(riPrimaryKey,PCSKey,0,nil,
+ REG_OPTION_NON_VOLATILE,KEY_ALL_ACCESS,@FriSecAttr,
+ newKey,@Disposition);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscCreateKeyFail,[ECode]);
+
+ {don't leave a key open longer than it's needed}
+ RegCloseKey(newKey);
+ finally
+ if (HoldKey <> 0) then
+ riPrimaryKey := HoldKey;
+ StrDispose(PSKey); // FreeMem(PSKey,Length(KeyName)+1);
+ StrDispose(PCSKey); // FreeMem(PCSKey, Length(KeyName)+1 + LongInt(strlen(riCurSubkey))+2);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.ParseIniFile(SList : TStrings);
+{-procedure to read through an INI text file}
+var
+ F : TextFile;
+ L : string;
+begin
+ AssignFile(F, riRootName);
+ Reset(F);
+ try
+ Readln(F,L);
+ while NOT EOF(F) do begin
+ if (L[1] = '[') AND (L[Length(L)] = ']') then begin
+ Delete(L, Length(L), 1);
+ Delete(L, 1, 1);
+ SList.Add(L);
+ end;
+ Readln(F,L);
+ end;
+ finally
+ CloseFile(F);
+ end;
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.GetSubKeys(SK : TStrings);
+ {-get list of section names (or values) from Ini file or subkeys in registry}
+ {For Ini files only: if riCurSubKey = '', list is of section names}
+ { if riCurSubKey <> '', list is of value names in section}
+var
+ ValueName : PChar;
+
+ Sections,
+ valuePos,
+ NumSubKeys,
+ LongSKName,
+ LongVName,
+ NumVals,
+ MaxSize,
+ VSize : DWORD;
+ Buffer : array[0..MaxBufSize] of Char;
+ S : string;
+ ECode : LongInt;
+ Key : HKey;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ SK.Clear;
+
+ if (riType = riIniType) then begin
+ Buffer[0] := #0;
+ if (riCurSubKey[0] = #0) then begin
+ {Get section names in ini file}
+ Sections := GetPrivateProfileSectionNames(Buffer,MaxBufSize,riRootName);
+ end else
+ {get value names in specified section}
+ Sections := GetPrivateProfileString(riCurSubKey,nil,#0,
+ Buffer,MaxBufSize,riRootName);
+
+ {parse Section Names from Buffer string}
+ if (Sections > 0) then begin
+ valuePos := 0;
+ repeat
+ S := StrPas(Buffer+valuePos);
+ if (Length(S) > 0) then begin
+ SK.Add(S);
+ Inc(valuePos,StrEnd(Buffer+valuePos)-(Buffer+valuePos)+1);
+ end else
+ break;
+ until Length(S) = 0;
+ end;
+ end else begin
+ Key := OpenRegKey;
+ try
+ ECode := RegQueryInfoKey(Key,nil,nil,nil,@NumSubKeys,
+ @LongSKName,nil,@NumVals,@LongVName,@MaxSize,nil,nil);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscQueryKeyFail,[ECode]);
+ Inc(LongSKName);
+ valuePos := 0;
+ ValueName := StrAlloc(LongSKName); // GetMem(ValueName,LongSKName);
+ try
+ while valuePos < NumSubKeys do begin
+ ValueName[0] := #0;
+ VSize := LongSKName;
+ ECode := RegEnumKeyEx(Key,valuePos,ValueName,VSize,
+ nil,nil,nil,nil);
+ if (ECode <> ERROR_SUCCESS) AND
+ (ECode <> ERROR_MORE_DATA) then
+ RaiseRegIniErrorFmt(stscEnumKeyFail,[ECode]);
+ SK.Add(StrPas(ValueName));
+ Inc(valuePos);
+ end;
+ finally
+ StrDispose(ValueName); // FreeMem(ValueName,LongSKName);
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.GetValues(SKV : TStrings);
+ {-return value names and string representation of data in}
+ {Ini file section or registry subkey}
+var
+ ValueName : PChar;
+
+ valuePos,
+ NumSubKeys,
+ LongSKName,
+ LongVName,
+ NumVals,
+ MaxSize,
+ VSize,
+ DSize : DWORD;
+
+ S, TS : string;
+ KeyList : TStringList;
+ ECode : LongInt;
+ Key : HKey;
+
+ ValType : DWORD;
+ LResult : Pointer;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ SKV.Clear;
+
+ if (riType = riIniType) then begin
+ KeyList := TStringList.Create;
+ try
+ {get list of value names in section}
+ GetSubKeys(KeyList);
+ if (KeyList.Count > 0) then begin
+ for valuePos := 0 to KeyList.Count-1 do begin
+ S := KeyList[valuePos] + '='
+ + ReadString(KeyList[valuePos],'');
+ SKV.AddObject(S,BmpText);
+ end;
+ end;
+ finally
+ KeyList.Free;
+ end;
+ end else begin
+ Key := OpenRegKey;
+ try
+ {get data on specified keys}
+ ECode := RegQueryInfoKey(Key,nil,nil,nil,
+ @NumSubKeys,@LongSKName,nil,@NumVals,
+ @LongVName,@MaxSize,nil,nil);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscQueryKeyFail,[ECode]);
+ Inc(MaxSize);
+ Inc(LongVName);
+ GetMem(LResult,MaxSize);
+ try
+ valuePos := 0;
+ ValueName := StrAlloc(LongVName); // GetMem(ValueName,LongVName);
+ try
+ {step through values in subkey and get data from each}
+ while valuePos < NumVals do begin
+ ValueName[0] := #0;
+ VSize := LongVName;
+ DSize := MaxSize;
+ ECode := RegEnumValue(Key,valuePos,ValueName,
+ VSize,nil,@ValType,LResult,@DSize);
+ if (ECode <> ERROR_SUCCESS) AND
+ (ECode <> ERROR_MORE_DATA) then
+ RaiseRegIniErrorFmt(stscEnumValueFail,[ECode]);
+ if (Length(ValueName) > 0) then
+ S := StrPas(ValueName) + '='
+ else
+ S := 'Default=';
+ case ValType of
+ {convert data to string representation}
+ REG_SZ,
+ REG_EXPAND_SZ : begin
+ TS := StrPas(PChar(LResult));
+ S := S + TS;
+ SKV.AddObject(S,BmpText);
+ end;
+
+ REG_DWORD,
+ REG_BINARY : begin
+ if ValType = REG_DWORD then
+ Str(LongInt(LResult^),TS)
+ else
+ TS := BytesToString(PByte(LResult),DSize);
+ S := S + TS;
+ SKV.AddObject(S,BmpBinary);
+ end;
+ end;
+ Inc(valuePos);
+ end;
+ finally
+ StrDispose(ValueName); // FreeMem(ValueName,LongVName);
+ end;
+ finally
+ FreeMem(LResult,MaxSize);
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.DeleteKey(const KeyName : string; DeleteSubKeys : Boolean);
+ {-delete a section from Ini file or subkey from registry}
+ {if DeleteSubKeys = True : specified section (key) and values (subkeys),}
+ { if any, are deleted }
+ { = False : specified section (key) can not be deleted }
+ { if there are any values (subkeys) }
+var
+ PSKey : PChar;
+ NumSubKeys,
+ NumValues : DWORD;
+ Key : HKey;
+ ECode : LongInt;
+ TS,
+ HldKey : String;
+ ASL : TStringList;
+
+
+ procedure ClearKey(StartKey : HKey);
+ var
+ SL : TStringList;
+ NK : HKey;
+ NSK,
+ NV : DWORD;
+ J : LongInt;
+ TS,
+ HK : String;
+ PSK : array[0..255] of char;
+ begin
+ ECode := RegQueryInfoKey(StartKey, nil, nil, nil, @NSK,
+ nil, nil, @NV, nil, nil, nil, nil);
+ if (NV > 0) then begin
+ SL := TStringList.Create;
+ try
+ GetValues(SL);
+ for J := 0 to SL.Count-1 do begin
+ TS := SL.Names[J];
+ if (AnsiCompareText('Default', TS) <> 0) then
+ DeleteValue(TS);
+ end;
+ finally
+ SL.Free;
+ end;
+ end;
+
+ if NSK > 0 then begin
+ SL := TStringList.Create;
+ try
+ GetSubKeys(SL);
+ for J := 0 to SL.Count-1 do begin
+ HK := GetCurSubKey;
+ SetCurSubKey(HK + '\' + SL[J]);
+ NK := OpenRegKey;
+ ClearKey(NK);
+ RegCloseKey(NK);
+ SetCurSubKey(HK);
+ StrPCopy(PSK, SL[J]);
+ RegDeleteKey(StartKey, PSK);
+ end;
+ finally
+ SL.Free;
+ end;
+ end;
+ end;
+
+begin
+ riMode := riSet;
+ {$IFDEF ThreadSafe}
+ EnterCS;
+ try
+ {$ENDIF}
+ PSKey := StrAlloc(Length(KeyName)); // GetMem(PSKey,Length(KeyName)+1);
+ try
+ StrPCopy(PSKey,KeyName);
+ if (riType = riIniType) then begin
+ ASL := TStringList.Create;
+ try
+ {check for values in section}
+ HldKey := GetCurSubkey;
+ SetCurSubKey(KeyName);
+ GetSubKeys(ASL);
+ SetCurSubKey(HldKey);
+ NumSubKeys := ASL.Count;
+
+ {remove section KeyName from INI file}
+ if (NumSubKeys > 0) AND (NOT DeleteSubKeys) then
+ RaiseRegIniErrorFmt(stscKeyHasSubKeys,[NumSubKeys]);
+ if (NOT WritePrivateProfileString(PSKey,nil,nil,riRootName)) then
+ RaiseRegIniError(stscIniDeleteFail);
+ finally
+ ASL.Free;
+ end;
+ end else begin
+ HldKey := GetCurSubkey;
+ TS := HldKey + '\' + KeyName;
+ if TS[1] = '\' then
+ Delete(TS, 1, 1);
+ SetCurSubKey(TS);
+ Key := OpenRegKey;
+ try
+ {check for subkeys under key to be deleted}
+ ECode := RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys,
+ nil, nil, @NumValues, nil, nil, nil, nil);
+
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscQueryKeyFail,[ECode]);
+
+ if (NumSubKeys > 0) OR (NumValues > 0) then begin
+ if (NOT DeleteSubKeys) then
+ RaiseRegIniErrorFmt(stscKeyHasSubKeys,[NumSubKeys])
+ else
+ if (riWinVer = riWinNT) then
+ ClearKey(Key);
+ end;
+ finally
+ RegCloseKey(Key);
+ SetCurSubKey(HldKey);
+ end;
+
+ Key := OpenRegKey;
+ try
+ ECode := RegDeleteKey(Key, PSKey);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscDeleteKeyFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ RegCloseKey(Key);
+ end;
+ end;
+ finally
+ StrDispose(PSKey); // FreeMem(PSKey,Length(KeyName)+1);
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.DeleteValue(const ValueName : string);
+ {-delete value from Ini file section or registry subkey}
+var
+ PVName : PChar;
+ ECode : LongInt;
+ Key : HKey;
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ PVName := StrAlloc(Length(valueName)); // GetMem(PVName,Length(valueName)+1);
+ try
+ StrPCopy(PVName,valueName);
+ if (riType = riIniType) then begin
+ if (NOT WritePrivateProfileString(riCurSubKey,PVName,nil,riRootName)) then
+ RaiseRegIniError(stscIniDelValueFail);
+ end else begin
+ Key := OpenRegKey;
+ try
+ ECode := RegDeleteValue(Key,PVName);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscRegDelValueFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+ finally
+ StrDispose(PVName); // FreeMem(PVName,Length(valueName)+1);
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.QueryKey(var KeyInfo : TQueryKeyInfo);
+ {-get informatino about Ini file seciton or registry subkey}
+const
+ BufSize = 2048;
+var
+ PVName,
+ PCName : PChar;
+
+ P,
+ step : integer;
+
+ CNSize : DWORD;
+ Key : HKey;
+ ECode : LongInt;
+ SL : TStringList;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ {data for the specified section in the INI file}
+ SL := TStringList.Create;
+ try
+ FillChar(KeyInfo,sizeof(KeyInfo),#0);
+ {get value names/values}
+ GetValues(SL);
+ with KeyInfo do begin
+ QIMaxVNLen := 0;
+ QIMaxDataLen := 0;
+ QINumValues := SL.Count;
+ if (SL.Count > 0) then begin
+ for step := 0 to SL.Count-1 do begin
+ {find maximum length of value names and values}
+ P := pos('=',SL[step])-1;
+ if (P > LongInt(QIMaxVNLen)) then
+ QIMaxVNLen := P;
+
+ P := Length(SL[step]) - P;
+ if (P > LongInt(QIMaxDataLen)) then
+ QIMaxDataLen := P;
+ end;
+ end;
+ end;
+ finally
+ SL.Free;
+ end;
+ end else begin
+ PVName := nil;
+ PCName := nil;
+ try
+ PVName := StrAlloc(BufSize); // GetMem(PVName,BufSize);
+ PCName := StrAlloc(BufSize); //GetMem(PCName,BufSize);
+
+ Key := OpenRegKey;
+ try
+ PCName[0] := #0;
+ CNSize := BufSize;
+ with KeyInfo do begin
+ ECode := RegQueryInfoKey(Key,PCName,@CNSize,
+ nil,@QINumSubKeys,@QIMaxSKNLen,
+ @QIMaxCNLen, @QINumValues,
+ @QIMaxVNLen, @QIMaxDataLen,
+ @QISDescLen, @QIFileTime);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscQueryKeyFail,[ECode]);
+ QIKey := Key;
+ QIClassName := StrPas(PCName);
+ end;
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ finally
+ if (PVName <> nil) then
+ StrDispose(PVName); // FreeMem(PVName,BufSize);
+ if (PCName <> nil) then
+ StrDispose(PCName); // FreeMem(PCName,BufSize);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.KeyExists(KeyName : string) : Boolean;
+ {-checks if exists in INI file/Registry}
+var
+ KN : PChar;
+ PV : array[0..9] of char;
+ HK : HKey;
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ KN := StrAlloc(Length(KeyName)); // GetMem(KN, Length(KeyName)+1);
+ try
+ StrPCopy(KN, KeyName);
+ if (riType = riIniType) then begin
+ GetPrivateProfileString(KN, nil, '$KDNE1234', PV, 10, riRootName);
+ Result := StrIComp(PV, '$KDNE1234') <> 0;
+ end else begin
+ Result := RegOpenKeyEx(riPrimaryKey,KN,0,KEY_READ,HK) = ERROR_SUCCESS;
+ if Result then
+ RegCloseKey(HK);
+ end;
+ finally
+ StrDispose(KN); // FreeMem(KN, Length(KeyName)+1);
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+function TStRegIni.IsKeyEmpty(Primary, SubKey : string) : Boolean;
+var
+ FindPos : Integer;
+ Key : HKey;
+ NumSubKeys,
+ NumValues : DWORD;
+ ECode : LongInt;
+ HPrime,
+ HSubKy : String;
+ ASL : TStringList;
+
+begin
+ riMode := riGet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ HPrime := GetPrimary;
+ HSubKy := CurSubKey;
+
+ SetPrimary(Primary);
+ CurSubKey := SubKey;
+ Result := True;
+
+ if (riType = riIniType) then begin
+ {check for values in section}
+ ASL := TStringList.Create;
+ try
+ ParseIniFile(ASL);
+ if not (ASL.Find( '[' + SubKey + ']', FindPos)) then
+ Result := False;
+ finally
+ ASL.Free;
+ end;
+ end else begin
+ try
+ Key := OpenRegKey;
+ try
+ ECode := RegQueryInfoKey(Key, nil, nil, nil, @NumSubKeys,
+ nil, nil, @NumValues, nil, nil, nil, nil);
+ if (ECode <> ERROR_SUCCESS) or
+ (NumSubKeys > 0) or (NumValues > 0) then
+ Result := False;
+ except
+ Result := False;
+ end;
+ RegCloseKey(Key);
+ finally
+ SetPrimary(HPrime);
+ SetCurSubKey(HSubKy);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.SaveKey(const SubKey : string; FileName : string);
+ {-save contents of registry key to a file}
+var
+ SKey : string;
+ I,
+ DotPos : Cardinal;
+ TSL : TStringList;
+ F : TextFile;
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (SubKey <> FCurSubKey) then begin
+ SKey := FCurSubKey;
+ SetCurSubKey(SubKey);
+ end;
+
+ if (riType = riIniType) then begin
+ if (FileExists(FileName)) then
+ RaiseRegIniError(stscOutputFileExists);
+ TSL := TStringList.Create;
+ try
+ {get valuenames and values from specified section}
+ GetValues(TSL);
+ if (TSL.Count < 1) then
+ RaiseRegIniError(stscKeyIsEmptyNotExists);
+ AssignFile(F,FileName);
+ ReWrite(F);
+ try
+ writeln(F,'[' + SubKey + ']');
+ for I := 0 to TSL.Count-1 do
+ writeln(F,TSL[I]);
+ finally
+ CloseFile(F);
+ end;
+ finally
+ TSL.Free;
+ end;
+ end else begin
+ if (FileExists(FileName)) then
+ RaiseRegIniError(stscOutputFileExists);
+ if (HasExtensionL(FileName,DotPos)) then
+ RaiseRegIniError(stscFileHasExtension);
+(* TODO: this was only executed if $H+ why?
+ GetMem(PFName,Length(FileName)+1);
+ try
+ StrPCopy(PFName,FileName);
+ Key := OpenRegKey;
+ try
+ if (riWinVer = riWinNT) then begin
+ OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES OR TOKEN_QUERY, hToken);
+ LookupPrivilegeValue(nil,'SeBackupPrivilege',luid);
+ tp.PrivilegeCount := 1;
+ tp.Privileges[0].Luid := luid;
+ tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, FALSE, tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ end;
+
+ ECode := RegSaveKey(Key,PFName,@FriSecAttr);
+
+ if (riWinVer = riWinNT) then
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscSaveKeyFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ finally
+ FreeMem(PFName,Length(FileName)+1);
+ end;
+*)
+ end;
+
+ if (SKey <> '') then
+ SetCurSubKey(SKey);
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.LoadKey(const SubKey, FileName : string);
+ {-load a registry key from a file created with SaveKey}
+const
+ BufSize = 2048;
+var
+ I,
+ DotPos : Cardinal;
+
+ F : TextFile;
+ TSL : TStringList;
+ S,
+ SKey : string;
+ ECode : LongInt;
+ P : LongInt;
+
+ hToken : THandle;
+ ptp,
+ tp : TTokenPrivileges;
+ luid : TLargeInteger;
+ retval : DWORD;
+
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+{$ENDIF}
+ riMode := riSet;
+ try
+ if (riType = riIniType) then begin
+ if (NOT FileExists(FileName)) then
+ RaiseRegIniError(stscCantFindInputFile);
+
+ {read contents of file into a string list}
+ TSL := TStringList.Create;
+ try
+ AssignFile(F,FileName);
+ try
+ ReSet(F);
+ while NOT EOF(F) do begin
+ Readln(F,S);
+ TSL.Add(S);
+ end;
+ finally
+ CloseFile(F);
+ end;
+
+ if (TSL.Count < 1) then
+ RaiseRegIniError(stscKeyIsEmptyNotExists);
+
+ {if section exists - delete it and all values}
+ DeleteKey(SubKey,True);
+
+ {write contents of string list to ini file}
+ for I := 1 to TSL.Count-1 do begin
+ S := TSL[I];
+ P := pos('=',S);
+ Delete(S,P,Length(S)-P+1);
+ WritePrivateProfileString(PChar(SubKey),PChar(S), PChar(TSL.Values[S]),riRootName);
+ end;
+ finally
+ TSL.Free;
+ end;
+ end else begin
+ if (NOT FileExists(FileName)) then
+ RaiseRegIniError(stscCantFindInputFile);
+ if (HasExtensionL(FileName,DotPos)) then
+ RaiseRegIniError(stscFileHasExtension);
+
+ {save current subkey if saving another}
+ if (SubKey <> FCurSubKey) then begin
+ SKey := FCurSubKey;
+ SetCurSubKey(SubKey);
+ end;
+
+ {get security token for NT}
+ if (riWinVer = riWinNT) then begin
+ OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES OR TOKEN_QUERY, hToken);
+ LookupPrivilegeValue(nil,'SeRestorePrivilege',luid);
+ tp.PrivilegeCount := 1;
+ tp.Privileges[0].Luid := luid;
+ tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, FALSE, tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ end;
+
+ {can load only at top of registry}
+ if (riPrimaryKey = HKEY_LOCAL_MACHINE) OR
+ (riPrimaryKey = HKEY_USERS) then begin
+ ECode := RegLoadKey(riPrimaryKey,PChar(SubKey),PChar(FileName));
+ if (riWinVer = riWinNT) then
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscLoadKeyFail,[ECode]);
+ end else begin
+ if (riRemoteKey <> 0) then begin
+ ECode := RegLoadKey(riRemoteKey,PChar(SubKey),PChar(FileName));
+ if (riWinVer = riWinNT) then
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscLoadKeyFail,[ECode]);
+ end else
+ RaiseRegIniError(stscInvalidPKey);
+ end;
+
+ {restore current subkey if necessary}
+ if (SKey <> '') then
+ SetCurSubKey(SKey);
+ end;
+ finally
+{$IFDEF ThreadSafe}
+ LeaveCS;
+{$ENDIF}
+ end;
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.UnLoadKey(const SubKey : string);
+ {-remove a section from Ini file or subkey from registry}
+ {Registry only: SubKey must have been loaded with LoadKey}
+var
+ PSKey : PChar;
+ ECode : LongInt;
+ HoldKey : HKey;
+
+ hToken : THandle;
+ ptp,
+ tp : TTokenPrivileges;
+ luid : TLargeInteger;
+ retval : DWORD;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then
+ DeleteKey(SubKey,TRUE)
+ else
+ begin
+ HoldKey := 0;
+
+ {store primary key if working on remote computer}
+ if (riRemoteKey <> 0) then begin
+ HoldKey := riPrimaryKey;
+ riPrimaryKey := riRemoteKey;
+ end;
+ try
+ if (riWinVer = riWinNT) then begin
+ OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES OR TOKEN_QUERY, hToken);
+ LookupPrivilegeValue(nil,'SeRestorePrivilege',luid);
+ tp.PrivilegeCount := 1;
+ tp.Privileges[0].Luid := luid;
+ tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, FALSE, tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ end;
+
+ ECode := RegUnLoadKey(riPrimaryKey,PChar(SubKey));
+
+ if (riWinVer = riWinNT) then
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscUnloadKeyFail,[ECode]);
+ finally
+ {restore primary key if function used on remote computer}
+ if (riRemoteKey <> 0) then
+ riPrimaryKey := HoldKey;
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.RestoreKey(const SubKey, KeyFile : string; Options : DWORD);
+ {-restore a section of Ini file or subkey of registry}
+ {Registry only: key being loaded must have been stored using SaveKey}
+var
+ ECode : LongInt;
+ Key : HKey;
+ hToken : THandle;
+ ptp,
+ tp : TTokenPrivileges;
+ luid : TLargeInteger;
+ retval : DWORD;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then
+ LoadKey(SubKey, KeyFile)
+ else begin
+ if (riWinVer <> riWinNT) then
+ RaiseRegIniError(stscNotWinNTPlatform);
+
+ Key := OpenRegKey;
+ try
+ if (Options = REG_WHOLE_HIVE_VOLATILE) AND
+ (Key <> HKEY_USERS) AND
+ (Key <> HKEY_LOCAL_MACHINE) then
+ RaiseRegIniError(stscBadOptionsKeyCombo);
+
+ {get process token for WinNT}
+ if (riWinVer = riWinNT) then begin
+ OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES OR TOKEN_QUERY, hToken);
+ LookupPrivilegeValue(nil,'SeRestorePrivilege',luid);
+ tp.PrivilegeCount := 1;
+ tp.Privileges[0].Luid := luid;
+ tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, FALSE, tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ end;
+
+ ECode := RegRestoreKey(Key,PChar(KeyFile),Options);
+
+ if (riWinVer = riWinNT) then
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscRestoreKeyFail,[ECode]);
+ finally
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.ReplaceKey(const SubKey, InputFile, SaveFile : string);
+ {-replace existing section or registry subkey}
+ {Registry only: key being loaded must have been stored with SaveKey}
+ { "new" key does not take affect unti re-boot}
+var
+ DotPos : Cardinal;
+ ECode : LongInt;
+ hToken : THandle;
+ ptp,
+ tp : TTokenPrivileges;
+ luid : TLargeInteger;
+ retval : DWORD;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then begin
+ if (FileExists(SaveFile)) then
+ RaiseRegIniError(stscOutputFileExists);
+ SaveKey(SubKey,SaveFile);
+ LoadKey(SubKey,InputFile);
+ end else begin
+ if (FileExists(SaveFile)) then
+ RaiseRegIniError(stscOutputFileExists);
+ if (HasExtensionL(SaveFile,DotPos)) OR
+ (HasExtensionL(InputFile,DotPos)) then
+ RaiseRegIniError(stscFileHasExtension);
+
+ if (riWinVer = riWinNT) then begin
+ OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES OR TOKEN_QUERY,
+ {$IFNDEF VERSION3}
+ @hToken);
+ {$ELSE}
+ hToken);
+ {$ENDIF}
+ LookupPrivilegeValue(nil,'SeRestorePrivilege',luid);
+ tp.PrivilegeCount := 1;
+ tp.Privileges[0].Luid := luid;
+ tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, FALSE, tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ end;
+
+ if (riRemoteKey <> 0) then begin
+ ECode := RegReplaceKey(riRemoteKey,PChar(SubKey),PChar(InputFile),PChar(SaveFile));
+
+ if (riWinVer = riWinNT) then
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscReplaceKeyFail,[ECode]);
+ end else begin
+ ECode := RegReplaceKey(riPrimaryKey,PChar(SubKey),PChar(InputFile),PChar(SaveFile));
+ if (riWinVer = riWinNT) then
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscReplaceKeyFail,[ECode]);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.RegOpenRemoteKey(CompName : string);
+ {-open a registry subkey on a remote computer}
+var
+ ECode : LongInt;
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then
+ RaiseRegIniError(stscNoIniFileSupport)
+ else begin
+ if (riRemoteKey <> 0) then
+ RaiseRegIniError(stscRemoteKeyIsOpen);
+
+ if (riPrimaryKey <> HKEY_LOCAL_MACHINE) AND
+ (riPrimaryKey <> HKEY_USERS) then
+ RaiseRegIniError(stscInvalidPKey);
+
+ ECode := Windows.RegConnectRegistry(PChar(CompName),riPrimaryKey,riRemoteKey);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscConnectRemoteKeyFail,[ECode]);
+
+ {store current primary key while remote key is open}
+ if (riPrimaryKey <> riRemoteKey) then
+ riHoldPrimary := riPrimaryKey;
+ riPrimaryKey := riRemoteKey;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.RegCloseRemoteKey;
+ {-close a registry key on a remote computer}
+var
+ ECode : LongInt;
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then
+ RaiseRegIniError(stscNoIniFileSupport)
+ else begin
+ if (riRemoteKey <> 0) then begin
+ ECode := RegCloseKey(riRemoteKey);
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscCloseRemoteKeyFail,[ECode]);
+ riRemoteKey := 0;
+
+ {reset primary key if opening remote key changed it}
+ if riHoldPrimary <> 0 then begin
+ riPrimaryKey := riHoldPrimary;
+ riHoldPrimary := 0;
+ end;
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.RegGetKeySecurity(const SubKey : string; var SD : TSecurityDescriptor);
+ {-get security attributes for key (WinNT only) }
+ //SZ: todo Subkey never used
+var
+ Key : HKey;
+ ECode : LongInt;
+ SDSize : DWORD;
+ SI : SECURITY_INFORMATION;
+ QI : TQueryKeyInfo;
+
+ hToken : THandle;
+ ptp,
+ tp : TTokenPrivileges;
+ luid : TLargeInteger;
+ retval : DWORD;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then
+ RaiseRegIniError(stscNoIniFileSupport)
+ else begin
+ if (riWinVer <> riWinNT) then
+ RaiseRegIniError(stscNotWinNTPlatform);
+
+ QueryKey(QI);
+
+ Key := OpenRegKey;
+ try
+ SDSize := QI.QISDescLen;
+ SI := OWNER_SECURITY_INFORMATION or
+ GROUP_SECURITY_INFORMATION or
+ DACL_SECURITY_INFORMATION or
+ SACL_SECURITY_INFORMATION;
+
+ OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES OR TOKEN_QUERY, hToken);
+ LookupPrivilegeValue(nil,'SeSecurityPrivilege',luid);
+ tp.PrivilegeCount := 1;
+ tp.Privileges[0].Luid := luid;
+ tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, FALSE, tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+ ECode := Windows.RegGetKeySecurity(Key,SI,@SD,SDSize);
+
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscGetSecurityFail,[ECode]);
+ finally
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+{==========================================================================}
+
+procedure TStRegIni.RegSetKeySecurity(const SubKey : string; SD : TSecurityDescriptor);
+ {-set security attributes for a registry key (WinNT only) }
+var
+ Key : HKey;
+ ECode : LongInt;
+ SI : SECURITY_INFORMATION;
+
+ hToken : THandle;
+ ptp,
+ tp : TTokenPrivileges;
+ luid : TLargeInteger;
+ retval : DWORD;
+
+begin
+ riMode := riSet;
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if (riType = riIniType) then
+ RaiseRegIniError(stscNoIniFileSupport)
+ else begin
+ if (riWinVer <> riWinNT) then
+ RaiseRegIniError(stscNotWinNTPlatform);
+
+ Key := OpenRegKey;
+ try
+ SI := OWNER_SECURITY_INFORMATION or
+ GROUP_SECURITY_INFORMATION or
+ DACL_SECURITY_INFORMATION or
+ SACL_SECURITY_INFORMATION;
+
+ OpenProcessToken(GetCurrentProcess(),
+ TOKEN_ADJUST_PRIVILEGES OR TOKEN_QUERY, hToken);
+ LookupPrivilegeValue(nil,'SeSecurityName',luid);
+ tp.PrivilegeCount := 1;
+ tp.Privileges[0].Luid := luid;
+ tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, FALSE, tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+
+ ECode := Windows.RegSetKeySecurity(Key,SI,@SD);
+
+ AdjustTokenPrivileges(hToken,TRUE,tp,
+ sizeOf(TTokenPrivileges),ptp,retval);
+
+ if (ECode <> ERROR_SUCCESS) then
+ RaiseRegIniErrorFmt(stscSetSecurityFail,[ECode]);
+ finally
+ if (riRemoteKey = 0) then
+ CloseRegKey(Key);
+ end;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+end.
diff --git a/components/systools/source/windows_only/run/stsort.pas b/components/systools/source/windows_only/run/stsort.pas
new file mode 100644
index 000000000..4f8781eee
--- /dev/null
+++ b/components/systools/source/windows_only/run/stsort.pas
@@ -0,0 +1,1107 @@
+// 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: StSort.pas 4.04 *}
+{*********************************************************}
+{* SysTools: General purpose sorting class using *}
+{* merge sort algorithm *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+{Notes:
+ The sequence to sort data is this:
+
+ Sorter := TStSorter.Create(MaxHeap, RecLen);
+ Sorter.Compare := ACompareFunction;
+ repeat
+ ... obtain ADataRecord from somewhere ...
+ Sorter.Put(ADataRecord);
+ until NoMoreData;
+ while Sorter.Get(ADataRecord) do
+ ... do something with ADataRecord ...
+ Sorter.Free;
+
+ While Put is called, the sorter buffers as many records as it can fit in
+ MaxHeap. When that space is filled, it sorts the buffer and stores that
+ buffer to a temporary merge file. When Get is called, the sorter sorts the
+ last remaining buffer and starts either returning the records from the
+ buffer (if all records fit into memory) or merging the files and returning
+ the records from there.
+
+ The Compare function can be used as a place to display status and to abort
+ the sort. It is not possible to accurately predict the total number of
+ times Compare will be called, but it is called very frequently throughout
+ the sort. To abort a sort from the Compare function, just raise an
+ exception there.
+
+ The Reset method can be called to sort another set of data of the same
+ record length. Once Get has been called, Put cannot be called again unless
+ Reset is called first.
+
+ There is no default Compare function. One must be assigned after creating
+ a TStSorter and before calling Put. Otherwise an exception is raised the
+ first time a Compare function is needed.
+
+ If Create cannot allocate MaxHeap bytes for a work buffer, it
+ repeatedly divides MaxHeap by two until it can successfully allocate that
+ much space. After finding a block it can allocate, it does not attempt to
+ allocate larger blocks that might still fit.
+
+ Unlike MSORTP, STSORT always swaps full records. It does not use pointer
+ swapping for large records. If this is desirable, the application should
+ pass pointers to previously allocated records into the TStSorter class.
+
+ The OptimumHeapToUse, MinimumHeapToUse, and MergeInfo functions can be used
+ to optimize the buffer size before starting a sort.
+
+ By default, temporary merge files are saved in the current directory with
+ names of the form SORnnnnn.TMP, where nnnnn is a sequential file number.
+ You can supply a different merge name function via the MergeName property
+ to put the files in a different location or use a different form for the
+ names.
+
+ The sorter is thread-aware and uses critical sections to protect the Put,
+ Get, and Reset methods. Be sure that one thread does not call Put after
+ another thread has already called Get.
+}
+
+unit StSort;
+
+interface
+
+uses
+ Windows,
+ SysUtils, STConst, STBase;
+
+const
+{.Z+}
+ MinRecsPerRun = 4; {Minimum number of records in run buffer}
+ MergeOrder = 5; {Input files used at a time during merge, >=2, <=10}
+ MedianThreshold = 16; {Threshold for using median-of-three quicksort}
+{.Z-}
+
+type
+ TMergeNameFunc = function (MergeNum : Integer) : string;
+
+ TMergeInfo = record {Record returned by MergeInfo}
+ SortStatus : Integer; {Predicted status of sort, assuming disk ok}
+ MergeFiles : Integer; {Total number of merge files created}
+ MergeHandles : Integer; {Maximum file handles used}
+ MergePhases : Integer; {Number of merge phases}
+ MaxDiskSpace : LongInt; {Maximum peak disk space used}
+ HeapUsed : LongInt; {Heap space actually used}
+ end;
+
+ {.Z+}
+ TMergeIntArray = array[1..MergeOrder] of Integer;
+ TMergeLongArray = array[1..MergeOrder] of LongInt;
+ TMergePtrArray = array[1..MergeOrder] of Pointer;
+ {.Z-}
+
+ TStSorter = class(TObject)
+ {.Z+}
+ protected
+ {property instance variables}
+ FCount : LongInt; {Number of records put to sort}
+ FRecLen : Cardinal; {Size of each record}
+ FCompare : TUntypedCompareFunc; {Compare function}
+ FMergeName : TMergeNameFunc; {Merge file naming function}
+
+ {private instance variables}
+ sorRunCapacity : LongInt; {Capacity (in records) of run buffer}
+ sorRunCount : LongInt; {Current number of records in run buffer}
+ sorGetIndex : LongInt; {Last run element passed back to user}
+ sorPivotPtr : Pointer; {Pointer to pivot record}
+ sorSwapPtr : Pointer; {Pointer to swap record}
+ sorState : Integer; {0 = empty, 1 = adding, 2 = getting}
+ sorMergeFileCount : Integer; {Number of merge files created}
+ sorMergeFileMerged : Integer; {Index of last merge file merged}
+ sorMergeOpenCount : Integer; {Count of open merge files}
+ sorMergeBufSize : LongInt; {Usable bytes in merge buffer}
+ sorMergeFileNumber : TMergeIntArray; {File number of each open merge file}
+ sorMergeFiles : TMergeIntArray; {File handles for merge files}
+ sorMergeBytesLoaded: TMergeLongArray;{Count of bytes in each merge buffer}
+ sorMergeBytesUsed : TMergeLongArray; {Bytes used in each merge buffer}
+ sorMergeBases : TMergePtrArray; {Base index for each merge buffer}
+ sorMergePtrs : TMergePtrArray; {Current head elements in each merge buffer}
+ sorOutFile : Integer; {Output file handle}
+ sorOutPtr : Pointer; {Pointer for output buffer}
+ sorOutBytesUsed : LongInt; {Number of bytes in output buffer}
+ {$IFDEF ThreadSafe}
+ sorThreadSafe : TRTLCriticalSection;{Windows critical section record}
+ {$ENDIF}
+ sorBuffer : Pointer; {Pointer to global buffer}
+
+ {protected undocumented methods}
+ procedure sorAllocBuffer(MaxHeap : LongInt);
+ procedure sorCreateNewMergeFile(var Handle : Integer);
+ procedure sorDeleteMergeFiles;
+ function sorElementPtr(Index : LongInt) : Pointer;
+ procedure sorFlushOutBuffer;
+ procedure sorFreeBuffer;
+ procedure sorGetMergeElementPtr(M : Integer);
+ function sorGetNextElementIndex : Integer;
+ procedure sorMergeFileGroup;
+ procedure sorMoveElement(Src, Dest : Pointer);
+ procedure sorOpenMergeFiles;
+ procedure sorPrimaryMerge;
+ procedure sorRunSort(L, R : LongInt);
+ procedure sorStoreElement(Src : Pointer);
+ procedure sorStoreNewMergeFile;
+ procedure sorSwapElements(L, R : LongInt);
+ procedure sorSetCompare(Comp : TUntypedCompareFunc);
+
+ {protected documented methods}
+ procedure EnterCS;
+ {-Enter critical section for this instance}
+ procedure LeaveCS;
+ {-Leave critical section}
+ {.Z-}
+
+ public
+ constructor Create(MaxHeap : LongInt; RecLen : Cardinal); virtual;
+ {-Initialize a sorter}
+ destructor Destroy; override;
+ {-Destroy a sorter}
+
+ procedure Put(const X);
+ {-Add an element to the sort system}
+ function Get(var X) : Boolean;
+ {-Return next sorted element from the sort system}
+
+ procedure Reset;
+ {-Reset sorter before starting another sort}
+
+ property Count : LongInt
+ {-Return the number of elements in the sorter}
+ read FCount;
+
+ property Compare : TUntypedCompareFunc
+ {-Set or read the element comparison function}
+ read FCompare
+ write sorSetCompare;
+
+ property MergeName : TMergeNameFunc
+ {-Set or read the merge filename function}
+ read FMergeName
+ write FMergeName;
+
+ property RecLen : Cardinal
+ {-Return the size of each record}
+ read FRecLen;
+ end;
+
+function OptimumHeapToUse(RecLen : Cardinal; NumRecs : LongInt) : LongInt;
+ {-Returns the optimum amount of heap space to sort NumRecs records
+ of RecLen bytes each. Less heap space causes merging; more heap
+ space is partially unused.}
+
+function MinimumHeapToUse(RecLen : Cardinal) : LongInt;
+ {-Returns the absolute minimum heap that allows MergeSort to succeed}
+
+function MergeInfo(MaxHeap : LongInt; RecLen : Cardinal;
+ NumRecs : LongInt) : TMergeInfo;
+ {-Predicts status and resource usage of a merge sort}
+
+function DefaultMergeName(MergeNum : Integer) : string;
+ {-Default function used for returning merge file names}
+
+procedure ArraySort(var A; RecLen, NumRecs : Cardinal;
+ Compare : TUntypedCompareFunc);
+ {-Sort a normal Delphi array (A) in place}
+
+{$IFDEF FPC}
+var
+ HeapAllocFlags: Word platform = 2; { Heap allocation flags, gmem_Moveable }
+{$ENDIF}
+
+{======================================================================}
+
+implementation
+
+const
+ ecOutOfMemory = 8;
+
+procedure RaiseError(Code : longint);
+var
+ E : ESTSortError;
+begin
+ if Code = ecOutOfMemory then
+ OutOfMemoryError
+ else begin
+ E := ESTSortError.CreateResTP(Code, 0);
+ E.ErrorCode := Code;
+ raise E;
+ end;
+end;
+
+function DefaultMergeName(MergeNum : Integer) : string;
+begin
+ Result := 'SOR'+IntToStr(MergeNum)+'.TMP';
+end;
+
+function MergeInfo(MaxHeap : LongInt; RecLen : Cardinal;
+ NumRecs : LongInt) : TMergeInfo;
+type
+ MergeFileSizeArray = array[1..(StMaxBlockSize div SizeOf(LongInt))] of LongInt;
+var
+ MFileMerged, MOpenCount, MFileCount : Integer;
+ SizeBufSize, DiskSpace, OutputSpace, PeakDiskSpace : LongInt;
+ AllocRecs, RunCapacity, RecordsLeft, RecordsInFile : LongInt;
+ MFileSizeP : ^MergeFileSizeArray;
+begin
+ {Set defaults for the result}
+ FillChar(Result, SizeOf(TMergeInfo), 0);
+
+ {Validate input parameters}
+ if (RecLen = 0) or (MaxHeap <= 0) or (NumRecs <= 0) then begin
+ Result.SortStatus := stscBadSize;
+ Exit;
+ end;
+
+ AllocRecs := MaxHeap div LongInt(RecLen);
+ if AllocRecs < MergeOrder+1 then begin
+ Result.SortStatus := stscBadSize;
+ Exit;
+ end;
+
+ RunCapacity := AllocRecs-2;
+ if RunCapacity < MinRecsPerRun then begin
+ Result.SortStatus := stscBadSize;
+ Exit;
+ end;
+
+ {Compute amount of memory used}
+ Result.HeapUsed := AllocRecs*LongInt(RecLen);
+
+ if RunCapacity >= NumRecs then
+ {All the records fit into memory}
+ Exit;
+
+ {Compute initial number of merge files and disk space}
+ MFileCount := NumRecs div (AllocRecs-2);
+ if NumRecs mod (AllocRecs-2) <> 0 then
+ inc(MFileCount);
+ {if MFileCount > MaxInt then begin }
+ { Result.SortStatus := stscTooManyFiles;}
+ { Exit; }
+ {end; }
+ DiskSpace := NumRecs*LongInt(RecLen);
+
+ {At least one merge phase required}
+ Result.MergePhases := 1;
+
+ if MFileCount <= MergeOrder then begin
+ {Only one merge phase, direct to user}
+ Result.MergeFiles := MFileCount;
+ Result.MergeHandles := MFileCount;
+ Result.MaxDiskSpace := DiskSpace;
+ Exit;
+ end;
+
+ {Compute total number of merge files and merge phases}
+ MFileMerged := 0;
+ while MFileCount-MFileMerged > MergeOrder do begin
+ inc(Result.MergePhases);
+ MOpenCount := 0;
+ while (MOpenCount < MergeOrder) and (MFileMerged < MFileCount) do begin
+ inc(MOpenCount);
+ inc(MFileMerged);
+ end;
+ inc(MFileCount);
+ end;
+
+ {Store the information we already know}
+ Result.MergeFiles := MFileCount;
+ Result.MergeHandles := MergeOrder+1; {MergeOrder input files, 1 output file}
+
+ {Determine whether the disk space analysis can proceed}
+ Result.MaxDiskSpace := -1;
+ if MFileCount > (StMaxBlockSize div SizeOf(LongInt)) then
+ Exit;
+ SizeBufSize := MFileCount*SizeOf(LongInt);
+ try
+ GetMem(MFileSizeP, SizeBufSize);
+ except
+ Exit;
+ end;
+
+ {Compute size of initial merge files}
+ RecordsLeft := NumRecs;
+ MFileCount := 0;
+ while RecordsLeft > 0 do begin
+ inc(MFileCount);
+ if RecordsLeft >= RunCapacity then
+ RecordsInFile := RunCapacity
+ else
+ RecordsInFile := RecordsLeft;
+ MFileSizeP^[MFileCount] := RecordsInFile*LongInt(RecLen);
+ dec(RecordsLeft, RecordsInFile);
+ end;
+
+ {Carry sizes forward to get disk space used}
+ PeakDiskSpace := DiskSpace;
+ MFileMerged := 0;
+ while MFileCount-MFileMerged > MergeOrder do begin
+ MOpenCount := 0;
+ OutputSpace := 0;
+ while (MOpenCount < MergeOrder) and (MFileMerged < MFileCount) do begin
+ inc(MOpenCount);
+ inc(MFileMerged);
+ inc(OutputSpace, MFileSizeP^[MFileMerged]);
+ end;
+ inc(MFileCount);
+ {Save size of output file}
+ MFileSizeP^[MFileCount] := OutputSpace;
+ {Output file and input files coexist temporarily}
+ inc(DiskSpace, OutputSpace);
+ {Store new peak disk space}
+ if DiskSpace > PeakDiskSpace then
+ PeakDiskSpace := DiskSpace;
+ {Account for deleting input files}
+ dec(DiskSpace, OutputSpace);
+ end;
+ Result.MaxDiskSpace := PeakDiskSpace;
+
+ FreeMem(MFileSizeP, SizeBufSize);
+end;
+
+function MinimumHeapToUse(RecLen : Cardinal) : LongInt;
+var
+ HeapToUse : LongInt;
+begin
+ HeapToUse := (MergeOrder+1)*RecLen;
+ Result := (MinRecsPerRun+2)*RecLen;
+ if Result < HeapToUse then
+ Result := HeapToUse;
+end;
+
+function OptimumHeapToUse(RecLen : Cardinal; NumRecs : LongInt) : LongInt;
+begin
+ if (NumRecs < MergeOrder+1) then
+ NumRecs := MergeOrder+1;
+ Result := LongInt(RecLen)*(NumRecs+2);
+end;
+
+{----------------------------------------------------------------------}
+
+constructor TStSorter.Create(MaxHeap : LongInt; RecLen : Cardinal);
+begin
+ if (RecLen = 0) or (MaxHeap <= 0) then
+ RaiseError(stscBadSize);
+
+ FMergeName := DefaultMergeName;
+ FRecLen := RecLen;
+
+ {Allocate a sort work buffer using at most MaxHeap bytes}
+ sorAllocBuffer(MaxHeap);
+
+{$IFDEF ThreadSafe}
+ Windows.InitializeCriticalSection(sorThreadSafe);
+{$ENDIF}
+end;
+
+destructor TStSorter.Destroy;
+begin
+{$IFDEF ThreadSafe}
+ Windows.DeleteCriticalSection(sorThreadSafe);
+{$ENDIF}
+ sorDeleteMergeFiles;
+ sorFreeBuffer;
+end;
+
+procedure TStSorter.EnterCS;
+begin
+{$IFDEF ThreadSafe}
+ EnterCriticalSection(sorThreadSafe);
+{$ENDIF}
+end;
+
+function TStSorter.Get(var X) : Boolean;
+var
+ NextIndex : Integer;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ Result := False;
+
+ if sorState <> 2 then begin
+ {First call to Get}
+ if sorRunCount > 0 then begin
+ {Still have elements to sort}
+ sorRunSort(0, sorRunCount-1);
+ if sorMergeFileCount > 0 then begin
+ {Already have other merge files}
+ sorStoreNewMergeFile;
+ sorPrimaryMerge;
+ sorOpenMergeFiles;
+ end else
+ {No merging necessary}
+ sorGetIndex := 0;
+ end else if FCount = 0 then
+ {No elements were sorted}
+ Exit;
+
+ sorState := 2;
+ end;
+
+ if sorMergeFileCount > 0 then begin
+ {Get next record from merge files}
+ NextIndex := sorGetNextElementIndex;
+ if NextIndex <> 0 then begin
+ {Return the element}
+ sorMoveElement(sorMergePtrs[NextIndex], @X);
+ {Get pointer to next element in the stream just used}
+ sorGetMergeElementPtr(NextIndex);
+ Result := True;
+ end;
+ end else if sorGetIndex < sorRunCount then begin
+ {Get next record from run buffer}
+ sorMoveElement(sorElementPtr(sorGetIndex), @X);
+ inc(sorGetIndex);
+ Result := True;
+ end;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStSorter.LeaveCS;
+begin
+{$IFDEF ThreadSafe}
+ LeaveCriticalSection(sorThreadSafe);
+{$ENDIF}
+end;
+
+procedure TStSorter.Reset;
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ sorDeleteMergeFiles;
+ FCount := 0;
+ sorState := 0;
+ sorRunCount := 0;
+ sorMergeFileCount := 0;
+ sorMergeFileMerged := 0;
+ sorMergeOpenCount := 0;
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStSorter.Put(const X);
+begin
+{$IFDEF ThreadSafe}
+ EnterCS;
+ try
+{$ENDIF}
+ if sorState = 2 then
+ {Can't Put after calling Get}
+ RaiseError(stscBadState);
+
+ sorState := 1;
+
+ if sorRunCount >= sorRunCapacity then begin
+ {Run buffer full; sort buffer and store to disk}
+ sorRunSort(0, sorRunCount-1);
+ sorStoreNewMergeFile;
+ sorRunCount := 0;
+ end;
+
+ {Store new element into run buffer}
+ sorMoveElement(@X, sorElementPtr(sorRunCount));
+ inc(sorRunCount);
+ inc(FCount);
+{$IFDEF ThreadSafe}
+ finally
+ LeaveCS;
+ end;
+{$ENDIF}
+end;
+
+procedure TStSorter.sorAllocBuffer(MaxHeap : LongInt);
+ {-Allocate a work buffer of records in at most MaxHeap bytes}
+var
+ Status : Integer;
+ AllocRecs : LongInt;
+begin
+ Status := stscBadSize;
+ repeat
+ AllocRecs := MaxHeap div LongInt(FRecLen);
+ if AllocRecs < MergeOrder+1 then
+ RaiseError(Status);
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ sorBuffer := GlobalAllocPtr(HeapAllocFlags, AllocRecs*LongInt(FRecLen));
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+ if sorBuffer = nil then begin
+ Status := ecOutOfMemory;
+ MaxHeap := MaxHeap div 2;
+ end else
+ break;
+ until False;
+
+ sorMergeBufSize := LongInt(FRecLen)*(AllocRecs div (MergeOrder+1));
+
+ sorRunCapacity := AllocRecs-2;
+ if sorRunCapacity < MinRecsPerRun then
+ RaiseError(Status);
+
+ sorPivotPtr := sorElementPtr(AllocRecs-1);
+ sorSwapPtr := sorElementPtr(AllocRecs-2);
+end;
+
+procedure TStSorter.sorCreateNewMergeFile(var Handle : Integer);
+ {-Create another merge file and return its handle}
+begin
+ if sorMergeFileCount = MaxInt then
+ {Too many merge files}
+ RaiseError(stscTooManyFiles);
+
+ {Create new merge file}
+ inc(sorMergeFileCount);
+ Handle := FileCreate(FMergeName(sorMergeFileCount));
+ if Handle < 0 then begin
+ dec(sorMergeFileCount);
+ RaiseError(stscFileCreate);
+ end;
+end;
+
+procedure TStSorter.sorDeleteMergeFiles;
+ {-Delete open and already-closed merge files}
+var
+ I : Integer;
+begin
+ for I := 1 to sorMergeOpenCount do begin
+ FileClose(sorMergeFiles[I]);
+ SysUtils.DeleteFile(FMergeName(sorMergeFileNumber[I]));
+ end;
+
+ for I := sorMergeFileMerged+1 to sorMergeFileCount do
+ SysUtils.DeleteFile(FMergeName(I));
+end;
+
+function TStSorter.sorElementPtr(Index : LongInt) : Pointer;
+ {-Return a pointer to the given element in the sort buffer}
+begin
+ Result := PAnsiChar(sorBuffer)+Index*LongInt(FRecLen);
+end;
+
+procedure TStSorter.sorFlushOutBuffer;
+ {-Write the merge output buffer to disk}
+var
+ BytesWritten : LongInt;
+begin
+ if sorOutBytesUsed <> 0 then begin
+ BytesWritten := FileWrite(sorOutFile, sorOutPtr^, sorOutBytesUsed);
+ if BytesWritten <> sorOutBytesUsed then
+ RaiseError(stscFileWrite);
+ end;
+end;
+
+procedure TStSorter.sorFreeBuffer;
+begin
+ GlobalFreePtr(sorBuffer);
+end;
+
+procedure TStSorter.sorGetMergeElementPtr(M : Integer);
+ {-Update head pointer in input buffer of specified open merge file}
+var
+ BytesRead : LongInt;
+begin
+ if sorMergeBytesUsed[M] >= sorMergeBytesLoaded[M] then begin
+ {Try to load new data into buffer}
+ BytesRead := FileRead(sorMergeFiles[M], sorMergeBases[M]^, sorMergeBufSize);
+ if BytesRead < 0 then
+ {Error reading file}
+ RaiseError(stscFileRead);
+ if BytesRead < LongInt(FRecLen) then begin
+ {End of file. Close and delete it}
+ FileClose(sorMergeFiles[M]);
+ SysUtils.DeleteFile(FMergeName(sorMergeFileNumber[M]));
+ {Remove file from merge list}
+ if M <> sorMergeOpenCount then begin
+ sorMergeFileNumber[M] := sorMergeFileNumber[sorMergeOpenCount];
+ sorMergeFiles[M] := sorMergeFiles[sorMergeOpenCount];
+ sorMergePtrs[M] := sorMergePtrs[sorMergeOpenCount];
+ sorMergeBytesLoaded[M] := sorMergeBytesLoaded[sorMergeOpenCount];
+ sorMergeBytesUsed[M] := sorMergeBytesUsed[sorMergeOpenCount];
+ sorMergeBases[M] := sorMergeBases[sorMergeOpenCount];
+ end;
+ dec(sorMergeOpenCount);
+ Exit;
+ end;
+ sorMergeBytesLoaded[M] := BytesRead;
+ sorMergeBytesUsed[M] := 0;
+ end;
+
+ sorMergePtrs[M] := PAnsiChar(sorMergeBases[M])+sorMergeBytesUsed[M];
+ inc(sorMergeBytesUsed[M], FRecLen);
+end;
+
+function TStSorter.sorGetNextElementIndex : Integer;
+ {-Return index into open merge file of next smallest element}
+var
+ M : Integer;
+ MinElPtr : Pointer;
+begin
+ if sorMergeOpenCount = 0 then begin
+ {All merge streams are empty}
+ Result := 0;
+ Exit;
+ end;
+
+ {Assume first element is the least}
+ MinElPtr := sorMergePtrs[1];
+ Result := 1;
+
+ {Scan the other elements}
+ for M := 2 to sorMergeOpenCount do
+ if FCompare(sorMergePtrs[M]^, MinElPtr^) < 0 then begin
+ Result := M;
+ MinElPtr := sorMergePtrs[M];
+ end;
+end;
+
+procedure TStSorter.sorMergeFileGroup;
+ {-Merge a group of input files into one output file}
+var
+ NextIndex : Integer;
+begin
+ sorOutBytesUsed := 0;
+ repeat
+ {Find index of minimum element}
+ NextIndex := sorGetNextElementIndex;
+ if NextIndex = 0 then
+ break
+ else begin
+ {Copy element to output}
+ sorStoreElement(sorMergePtrs[NextIndex]);
+ {Get the next element from its merge stream}
+ sorGetMergeElementPtr(NextIndex);
+ end;
+ until False;
+
+ {Flush and close the output file}
+ sorFlushOutBuffer;
+ FileClose(sorOutFile);
+end;
+
+procedure TStSorter.sorMoveElement(Src, Dest : Pointer); assembler;
+ {-Copy one record to another location, non-overlapping}
+register;
+asm
+ {eax = Self, edx = Src, ecx = Dest}
+ push esi
+ mov esi,Src
+ mov edx,edi
+ mov edi,Dest
+ mov ecx,TStSorter([eax]).FRecLen
+ mov eax,ecx
+ shr ecx,2
+ rep movsd
+ mov ecx,eax
+ and ecx,3
+ rep movsb
+ mov edi,edx
+ pop esi
+end;
+
+procedure TStSorter.sorOpenMergeFiles;
+ {-Open a group of up to MergeOrder input files}
+begin
+ sorMergeOpenCount := 0;
+ while (sorMergeOpenCount < MergeOrder) and
+ (sorMergeFileMerged < sorMergeFileCount) do begin
+ inc(sorMergeOpenCount);
+ {Open associated merge file}
+ inc(sorMergeFileMerged);
+ sorMergeFiles[sorMergeOpenCount] :=
+ FileOpen(FMergeName(sorMergeFileMerged), fmOpenRead);
+ if sorMergeFiles[sorMergeOpenCount] < 0 then begin
+ dec(sorMergeFileMerged);
+ dec(sorMergeOpenCount);
+ RaiseError(stscFileOpen);
+ end;
+ {File number of merge file}
+ sorMergeFileNumber[sorMergeOpenCount] := sorMergeFileMerged;
+ {Selector for merge file}
+ sorMergePtrs[sorMergeOpenCount] := PAnsiChar(sorBuffer)+
+ (sorMergeOpenCount-1)*sorMergeBufSize;
+ {Number of bytes currently in merge buffer}
+ sorMergeBytesLoaded[sorMergeOpenCount] := 0;
+ {Number of bytes used in merge buffer}
+ sorMergeBytesUsed[sorMergeOpenCount] := 0;
+ {Save the merge pointer}
+ sorMergeBases[sorMergeOpenCount] := sorMergePtrs[sorMergeOpenCount];
+ {Get the first element}
+ sorGetMergeElementPtr(sorMergeOpenCount);
+ end;
+end;
+
+procedure TStSorter.sorPrimaryMerge;
+ {-Merge until there are no more than MergeOrder merge files left}
+begin
+ sorOutPtr := PAnsiChar(sorBuffer)+MergeOrder*sorMergeBufSize;
+ while sorMergeFileCount-sorMergeFileMerged > MergeOrder do begin
+ {Open next group of MergeOrder files}
+ sorOpenMergeFiles;
+ {Create new output file}
+ sorCreateNewMergeFile(sorOutFile);
+ {Merge these files into the output}
+ sorMergeFileGroup;
+ end;
+end;
+
+procedure TStSorter.sorRunSort(L, R : LongInt);
+ {-Sort one run buffer full of records in memory using non-recursive QuickSort}
+const
+ StackSize = 32;
+type
+ Stack = array[0..StackSize-1] of LongInt;
+var
+ Pl : LongInt; {Left edge within partition}
+ Pr : LongInt; {Right edge within partition}
+ Pm : LongInt; {Mid-point of partition}
+ PartitionLen : LongInt; {Size of current partition}
+ StackP : Integer; {Stack pointer}
+ Lstack : Stack; {Pending partitions, left edge}
+ Rstack : Stack; {Pending partitions, right edge}
+begin
+ {Make sure there's a compare function}
+ if @FCompare = nil then
+ RaiseError(stscNoCompare);
+
+ {Initialize the stack}
+ StackP := 0;
+ Lstack[0] := L;
+ Rstack[0] := R;
+
+ {Repeatedly take top partition from stack}
+ repeat
+
+ {Pop the stack}
+ L := Lstack[StackP];
+ R := Rstack[StackP];
+ Dec(StackP);
+
+ {Sort current partition}
+ repeat
+ Pl := L;
+ Pr := R;
+ PartitionLen := Pr-Pl+1;
+
+ {$IFDEF MidPoint}
+ Pm := Pl+(PartitionLen shr 1);
+ {$ENDIF}
+
+ {$IFDEF Random}
+ Pm := Pl+Random(PartitionLen);
+ {$ENDIF}
+
+ {$IFDEF Median}
+ Pm := Pl+(PartitionLen shr 1);
+ if PartitionLen >= MedianThreshold then begin
+ {Sort elements Pl, Pm, Pr}
+ if FCompare(sorElementPtr(Pm)^, sorElementPtr(Pl)^) < 0 then
+ sorSwapElements(Pm, Pl);
+ if FCompare(sorElementPtr(Pr)^, sorElementPtr(Pl)^) < 0 then
+ sorSwapElements(Pr, Pl);
+ if FCompare(sorElementPtr(Pr)^, sorElementPtr(Pm)^) < 0 then
+ sorSwapElements(Pr, Pm);
+
+ {Exchange Pm with Pr-1 but use Pm's value as the pivot}
+ sorSwapElements(Pm, Pr-1);
+ Pm := Pr-1;
+
+ {Reduce range of swapping}
+ inc(Pl);
+ dec(Pr, 2);
+ end;
+ {$ENDIF}
+
+ {Save the pivot element}
+ sorMoveElement(sorElementPtr(Pm), sorPivotPtr);
+
+ {Swap items in sort order around the pivot}
+ repeat
+ while FCompare(sorElementPtr(Pl)^, sorPivotPtr^) < 0 do
+ Inc(Pl);
+ while FCompare(sorPivotPtr^, sorElementPtr(Pr)^) < 0 do
+ Dec(Pr);
+
+ if Pl = Pr then begin
+ {Reached the pivot}
+ Inc(Pl);
+ Dec(Pr);
+ end else if Pl < Pr then begin
+ {Swap elements around the pivot}
+ sorSwapElements(Pl, Pr);
+ Inc(Pl);
+ Dec(Pr);
+ end;
+ until Pl > Pr;
+
+ {Decide which partition to sort next}
+ if (Pr-L) < (R-Pl) then begin
+ {Left partition is bigger}
+ if Pl < R then begin
+ {Stack the request for sorting right partition}
+ Inc(StackP);
+ Lstack[StackP] := Pl;
+ Rstack[StackP] := R;
+ end;
+ {Continue sorting left partition}
+ R := Pr;
+ end else begin
+ {Right partition is bigger}
+ if L < Pr then begin
+ {Stack the request for sorting left partition}
+ Inc(StackP);
+ Lstack[StackP] := L;
+ Rstack[StackP] := Pr;
+ end;
+ {Continue sorting right partition}
+ L := Pl;
+ end;
+ until L >= R;
+ until StackP < 0;
+end;
+
+procedure TStSorter.sorSetCompare(Comp : TUntypedCompareFunc);
+ {-Set the compare function, with error checking}
+begin
+ if ((FCount <> 0) or (@Comp = nil)) and (@Comp <> @FCompare) then
+ RaiseError(stscBadCompare);
+ FCompare := Comp;
+end;
+
+procedure TStSorter.sorStoreElement(Src : Pointer);
+ {-Store element in the merge output buffer}
+begin
+ if sorOutBytesUsed >= sorMergeBufSize then begin
+ sorFlushOutBuffer;
+ sorOutBytesUsed := 0;
+ end;
+ sorMoveElement(Src, PAnsiChar(sorOutPtr)+sorOutBytesUsed);
+ inc(sorOutBytesUsed, FRecLen);
+end;
+
+procedure TStSorter.sorStoreNewMergeFile;
+ {-Create new merge file, write run buffer to it, close file}
+var
+ BytesToWrite, BytesWritten : Integer;
+begin
+ sorCreateNewMergeFile(sorOutFile);
+ try
+ BytesToWrite := sorRunCount*LongInt(FRecLen);
+ BytesWritten := FileWrite(sorOutFile, sorBuffer^, BytesToWrite);
+ if BytesWritten <> BytesToWrite then
+ RaiseError(stscFileWrite);
+ finally
+ {Close merge file}
+ FileClose(sorOutFile);
+ end;
+end;
+
+procedure TStSorter.sorSwapElements(L, R : LongInt);
+ {-Swap elements with indexes L and R}
+var
+ LPtr : Pointer;
+ RPtr : Pointer;
+begin
+ LPtr := sorElementPtr(L);
+ RPtr := sorElementPtr(R);
+ sorMoveElement(LPtr, sorSwapPtr);
+ sorMoveElement(RPtr, LPtr);
+ sorMoveElement(sorSwapPtr, RPtr);
+end;
+
+procedure ArraySort(var A; RecLen, NumRecs : Cardinal;
+ Compare : TUntypedCompareFunc);
+const
+ StackSize = 32;
+type
+ Stack = array[0..StackSize-1] of LongInt;
+var
+ Pl, Pr, Pm, L, R : LongInt;
+ ArraySize, PartitionLen : LongInt;
+ PivotPtr : Pointer;
+ SwapPtr : Pointer;
+ StackP : Integer;
+ Lstack, Rstack : Stack;
+
+ function ElementPtr(Index : Cardinal) : Pointer;
+ begin
+ Result := PAnsiChar(@A)+Index*RecLen;
+ end;
+
+ procedure SwapElements(L, R : LongInt);
+ var
+ LPtr : Pointer;
+ RPtr : Pointer;
+ begin
+ LPtr := ElementPtr(L);
+ RPtr := ElementPtr(R);
+ Move(LPtr^, SwapPtr^, RecLen);
+ Move(RPtr^, LPtr^, RecLen);
+ Move(SwapPtr^, RPtr^, RecLen);
+ end;
+
+begin
+ {Make sure there's a compare function}
+ if @Compare = nil then
+ RaiseError(stscNoCompare);
+
+ {Make sure the array size is reasonable}
+ ArraySize := LongInt(RecLen)*LongInt(NumRecs);
+ if (ArraySize = 0) {or (ArraySize > MaxBlockSize)} then
+ RaiseError(stscBadSize);
+
+ {Get pivot and swap elements}
+ GetMem(PivotPtr, RecLen);
+ try
+ GetMem(SwapPtr, RecLen);
+ try
+ {Initialize the stack}
+ StackP := 0;
+ Lstack[0] := 0;
+ Rstack[0] := NumRecs-1;
+
+ {Repeatedly take top partition from stack}
+ repeat
+
+ {Pop the stack}
+ L := Lstack[StackP];
+ R := Rstack[StackP];
+ Dec(StackP);
+
+ {Sort current partition}
+ repeat
+ Pl := L;
+ Pr := R;
+ PartitionLen := Pr-Pl+1;
+
+ {$IFDEF MidPoint}
+ Pm := Pl+(PartitionLen shr 1);
+ {$ENDIF}
+
+ {$IFDEF Random}
+ Pm := Pl+Random(PartitionLen);
+ {$ENDIF}
+
+ {$IFDEF Median}
+ Pm := Pl+(PartitionLen shr 1);
+ if PartitionLen >= MedianThreshold then begin
+ {Sort elements Pl, Pm, Pr}
+ if Compare(ElementPtr(Pm)^, ElementPtr(Pl)^) < 0 then
+ SwapElements(Pm, Pl);
+ if Compare(ElementPtr(Pr)^, ElementPtr(Pl)^) < 0 then
+ SwapElements(Pr, Pl);
+ if Compare(ElementPtr(Pr)^, ElementPtr(Pm)^) < 0 then
+ SwapElements(Pr, Pm);
+
+ {Exchange Pm with Pr-1 but use Pm's value as the pivot}
+ SwapElements(Pm, Pr-1);
+ Pm := Pr-1;
+
+ {Reduce range of swapping}
+ inc(Pl);
+ dec(Pr, 2);
+ end;
+ {$ENDIF}
+
+ {Save the pivot element}
+ Move(ElementPtr(Pm)^, PivotPtr^, RecLen);
+
+ {Swap items in sort order around the pivot}
+ repeat
+ while Compare(ElementPtr(Pl)^, PivotPtr^) < 0 do
+ Inc(Pl);
+ while Compare(PivotPtr^, ElementPtr(Pr)^) < 0 do
+ Dec(Pr);
+
+ if Pl = Pr then begin
+ {Reached the pivot}
+ Inc(Pl);
+ Dec(Pr);
+ end else if Pl < Pr then begin
+ {Swap elements around the pivot}
+ SwapElements(Pl, Pr);
+ Inc(Pl);
+ Dec(Pr);
+ end;
+ until Pl > Pr;
+
+ {Decide which partition to sort next}
+ if (Pr-L) < (R-Pl) then begin
+ {Left partition is bigger}
+ if Pl < R then begin
+ {Stack the request for sorting right partition}
+ Inc(StackP);
+ Lstack[StackP] := Pl;
+ Rstack[StackP] := R;
+ end;
+ {Continue sorting left partition}
+ R := Pr;
+ end else begin
+ {Right partition is bigger}
+ if L < Pr then begin
+ {Stack the request for sorting left partition}
+ Inc(StackP);
+ Lstack[StackP] := L;
+ Rstack[StackP] := Pr;
+ end;
+ {Continue sorting right partition}
+ L := Pl;
+ end;
+ until L >= R;
+ until StackP < 0;
+
+ finally
+ FreeMem(SwapPtr, RecLen);
+ end;
+ finally
+ FreeMem(PivotPtr, RecLen);
+ end;
+end;
+
+
+end.
diff --git a/components/systools/source/windows_only/run/stspawn.pas b/components/systools/source/windows_only/run/stspawn.pas
new file mode 100644
index 000000000..eb8742019
--- /dev/null
+++ b/components/systools/source/windows_only/run/stspawn.pas
@@ -0,0 +1,421 @@
+// 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: StSpawn.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Component to spawn another application *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StSpawn;
+
+interface
+
+uses
+ SysUtils, Windows, ExtCtrls, Messages, Classes, ShellAPI,
+
+ StBase, StConst;
+
+type
+
+ TStWaitThread = class(TThread)
+ protected
+ FTimeOut : Longint;
+ procedure Execute; override;
+ public
+ CancelWaitEvent : THandle;
+ WaitResult : DWORD;
+ WaitFors : PWOHandleArray; {!!.01}
+
+ constructor Create(aInst, CancelIt : THandle; ATimeOut : Longint);
+ destructor Destroy; override; {!!.01}
+ end;
+
+ TStSpawnCommand = (scOpen, scPrint, scOther);
+ TStShowState = (ssMinimized, ssMaximized, ssNormal, ssMinNotActive);
+
+ TStSpawnErrorEvent = procedure (Sender : TObject; Error : Word) of object;
+ TStSpawnCompletedEvent = procedure (Sender : TObject) of object;
+ TStSpawnTimeOutEvent = procedure (Sender : TObject) of object;
+
+ TStSpawnApplication = class(TStComponent)
+ protected {private}
+ { Private declarations }
+
+ FAllowChange : Boolean;
+ FCancelEvent : THandle;
+ FDefaultDir : String;
+ FFileName : String;
+ FInstance : THandle;
+ FNotifyWhenDone : Boolean;
+ FOnCompleted : TStSpawnCompletedEvent;
+ FOnSpawnError : TStSpawnErrorEvent;
+ FOnSpawnTimeOut : TStSpawnTimeOutEvent;
+ FRunParameters : String;
+ FShowState : TStShowState;
+ FSpawnCommand : TStSpawnCommand;
+ FTimer : TTimer;
+ FTimeOut : Longint;
+ FWaitResult : DWORD;
+ FWaitThread : TStWaitThread;
+ FSpawnCommandStr : String;
+
+ protected
+ { Protected declarations }
+
+ CountDownValue : Longint;
+ procedure DoOnThreadEnd(Sender : TObject);
+ procedure SetDefaultDir(const Value : String); {!!.02}
+ procedure SetFileName(const Value : String); {!!.02}
+ procedure SetOnCompleted(Value : TStSpawnCompletedEvent);
+ procedure SetOnSpawnError(Value : TStSpawnErrorEvent);
+ procedure SetNotifyWhenDone(Value : Boolean);
+ procedure SetRunParameters(const Value : String); {!!.02}
+ procedure SetShowState(Value : TStShowState);
+ procedure SetSpawnCommand(Value : TStSpawnCommand);
+ procedure SetSpawnTimeOut(Value : TStSpawnTimeOutEvent);
+ procedure SetTimeOut(Value : Longint);
+ public
+ { Public declarations }
+
+ constructor Create(AOwner : TComponent); override;
+ destructor Destroy; override;
+
+ procedure CancelWait;
+ function Execute : THandle;
+ published
+ { Published declarations }
+
+ property DefaultDir : String
+ read FDefaultDir write SetDefaultDir;
+
+ property FileName : String
+ read FFileName write SetFileName;
+
+ property NotifyWhenDone : Boolean
+ read FNotifyWhenDone write SetNotifyWhenDone default True;
+
+ property OnCompleted : TStSpawnCompletedEvent
+ read FOnCompleted write SetOnCompleted;
+
+ property OnSpawnError : TStSpawnErrorEvent
+ read FOnSpawnError write SetOnSpawnError;
+
+ property OnTimeOut : TStSpawnTimeOutEvent
+ read FOnSpawnTimeOut write SetSpawnTimeOut;
+
+ property RunParameters : String
+ read FRunParameters write SetRunParameters;
+
+ property ShowState : TStShowState
+ read FShowState write SetShowState default ssNormal;
+
+ property SpawnCommand : TStSpawnCommand
+ read FSpawnCommand write SetSpawnCommand default scOpen;
+
+ property TimeOut : Longint
+ read FTimeOut write SetTimeOut default 0;
+
+ property SpawnCommandStr : String
+ read FSpawnCommandStr write FSpawnCommandStr;
+
+ end;
+
+implementation
+
+{-----------------------------------------------------------------------------}
+{ WIN32 WAIT THREAD }
+{-----------------------------------------------------------------------------}
+
+const {!!.01}
+ WAIT_HANDLE_COUNT = 2; {!!.01}
+
+constructor TStWaitThread.Create(aInst, CancelIt : THandle; ATimeOut : Longint);
+begin
+ GetMem(WaitFors, WAIT_HANDLE_COUNT * SizeOf(THandle)); {!!.01}
+ WaitFors^[0] := aInst; {!!.01}
+ WaitFors^[1] := CancelIt; {!!.01}
+ FTimeOut := ATimeOut * 1000;
+ CancelWaitEvent := CancelIt;
+
+ inherited Create(True);
+end;
+
+{!!.01 - Added}
+destructor TStWaitThread.Destroy;
+begin
+ FreeMem(WaitFors, WAIT_HANDLE_COUNT * SizeOf(THandle));
+ inherited Destroy;
+end;
+{!!.01 - End Added}
+
+procedure TStWaitThread.Execute;
+begin
+ if (FTimeOut > 0) then
+ WaitResult := WaitForMultipleObjects(WAIT_HANDLE_COUNT, WaitFors, {!!.01}
+ False, FTimeOut) {!!.01}
+ else
+ WaitResult := WaitForMultipleObjects(WAIT_HANDLE_COUNT, WaitFors, {!!.01}
+ False, INFINITE); {!!.01}
+end;
+
+
+
+{-----------------------------------------------------------------------------}
+{ TStSpawnApplication }
+{-----------------------------------------------------------------------------}
+
+constructor TStSpawnApplication.Create(AOwner : TComponent);
+begin
+ inherited Create(AOwner);
+
+ FAllowChange := True;
+ FDefaultDir := '';
+ FFileName := '';
+ FNotifyWhenDone := True;
+ FShowState := ssNormal;
+ FSpawnCommand := scOpen;
+ FSpawnCommandStr := '';
+ FTimer := nil;
+ FTimeOut := 0;
+
+end;
+
+destructor TStSpawnApplication.Destroy;
+begin
+ FTimer.Free;
+ FTimer := nil;
+
+ inherited Destroy;
+end;
+
+
+procedure TStSpawnApplication.CancelWait;
+begin
+ if (FCancelEvent <> 0) then
+ SetEvent(FWaitThread.CancelWaitEvent);
+end;
+
+
+procedure TStSpawnApplication.DoOnThreadEnd(Sender : TObject);
+begin
+ FWaitResult := FWaitThread.WaitResult;
+
+ case FWaitResult of
+ WAIT_FAILED :
+ begin
+ if (Assigned(FOnSpawnError)) then
+ FOnSpawnError(Self, GetLastError);
+ end;
+
+ WAIT_TIMEOUT :
+ begin
+ if Assigned(FOnSpawnTimeOut) then
+ FOnSpawnTimeOut(Self);
+ end;
+
+ WAIT_OBJECT_0,
+ WAIT_OBJECT_0 + 1 :
+ begin
+ if (FNotifyWhenDone) and (Assigned(FOnCompleted)) then
+ FOnCompleted(Self);
+ end;
+ end;
+
+ if (FCancelEvent <> 0) then begin
+ SetEvent(FCancelEvent);
+ CloseHandle(FCancelEvent);
+ FCancelEvent := 0;
+ end;
+end;
+
+
+function TStSpawnApplication.Execute : THandle;
+var
+ Cmd : String;
+ HowShow : integer;
+ Res : Bool;
+ Startup : TShellExecuteInfo;
+
+begin
+ if (FileName = '') and (RunParameters > '') then
+ RaiseStError(EStSpawnError, stscInsufficientData);
+
+ case FSpawnCommand of
+ scOpen : Cmd := 'open';
+ scPrint: Cmd := 'print';
+ scOther: Cmd := FSpawnCommandStr;
+ end;
+
+ case FShowState of
+ ssNormal : HowShow := SW_NORMAL;
+ ssMinimized : HowShow := SW_MINIMIZE;
+ ssMaximized : HowShow := SW_SHOWMAXIMIZED;
+ ssMinNotActive : HowShow := SW_SHOWMINNOACTIVE;
+ else
+ HowShow := SW_NORMAL;
+ end;
+ FInstance := 0;
+
+ with Startup do begin
+ cbSize := SizeOf(Startup);
+ fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_NO_UI;
+ Wnd := 0;
+ lpVerb := Pointer(Cmd);
+ if (FFileName > '') then
+ lpFile := PChar(FFileName)
+ else
+ lpFile := nil;
+ if (FRunParameters > '') then
+ lpParameters := PChar(FRunParameters)
+ else
+ lpParameters := nil;
+ if (FDefaultDir > '') then
+ lpDirectory := PChar(FDefaultDir)
+ else
+ lpDirectory := nil;
+ nShow := HowShow;
+ hInstApp := 0;
+ end;
+
+ {$IFDEF FPC}
+ Res := ShellExecuteExA(@Startup);
+ {$ELSE}
+ Res := ShellExecuteEx(@Startup);
+ {$ENDIF}
+ FInstance := Startup.hProcess;
+
+ if (not Res) then begin
+ Result := 0;
+ if (Assigned(FOnSpawnError)) then begin
+ FOnSpawnError(Self, GetLastError);
+ end;
+ end else
+ Result := FInstance;
+
+ if (NotifyWhenDone) then begin
+ FTimer := nil;
+ FCancelEvent := CreateEvent(nil, False, False, PChar(FloatToStr(Now)));
+
+ FWaitThread := TStWaitThread.Create(FInstance, FCancelEvent, FTimeOut);
+ FWaitThread.OnTerminate := DoOnThreadEnd;
+ FWaitThread.FreeOnTerminate := True;
+ FWaitThread.Resume;
+ end;
+end;
+
+procedure TStSpawnApplication.SetDefaultDir(const Value : String); {!!.02}
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then begin
+ if (Value <> FDefaultDir) then
+ FDefaultDir := Value;
+ end;
+end;
+
+
+procedure TStSpawnApplication.SetFileName(const Value : String); {!!.02}
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then begin
+ if (Value <> FileName) then
+ FFileName := Value;
+ end;
+end;
+
+
+procedure TStSpawnApplication.SetNotifyWhenDone(Value : Boolean);
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then begin
+ if (Value <> FNotifyWhenDone) then
+ FNotifyWhenDone := Value;
+ end;
+end;
+
+
+procedure TStSpawnApplication.SetRunParameters(const Value : String); {!!.02}
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then begin
+ if (Value <> FRunParameters) then
+ FRunParameters := Value;
+ end;
+end;
+
+
+procedure TStSpawnApplication.SetOnCompleted(Value : TStSpawnCompletedEvent);
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then
+ FOnCompleted := Value;
+end;
+
+
+procedure TStSpawnApplication.SetOnSpawnError(Value : TStSpawnErrorEvent);
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then
+ FOnSpawnError := Value;
+end;
+
+
+procedure TStSpawnApplication.SetShowState(Value : TStShowState);
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then begin
+ if (Value <> FShowState) then
+ FShowState := Value;
+ end;
+end;
+
+
+procedure TStSpawnApplication.SetSpawnCommand(Value : TStSpawnCommand);
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then begin
+ if (Value <> FSpawnCommand) then
+ FSpawnCommand := Value;
+ end;
+end;
+
+
+procedure TStSpawnApplication.SetSpawnTimeOut(Value : TStSpawnTimeOutEvent);
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then
+ FOnSpawnTimeOut := Value;
+end;
+
+
+procedure TStSpawnApplication.SetTimeOut(Value : Longint);
+begin
+ if (FAllowChange) or (csDesigning in ComponentState) then begin
+ if (Value <> FTimeOut) and (Value >= 0) then
+ FTimeOut := Value;
+ end;
+end;
+
+
+end.
diff --git a/components/systools/source/windows_only/run/stsystem.pas b/components/systools/source/windows_only/run/stsystem.pas
new file mode 100644
index 000000000..10c96efce
--- /dev/null
+++ b/components/systools/source/windows_only/run/stsystem.pas
@@ -0,0 +1,1851 @@
+// 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: StSystem.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Assorted system level routines *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StSystem;
+
+interface
+
+uses
+ Windows, SysUtils, Classes,
+{$IFDEF FPC}
+ FileUtil,
+{$ELSE}
+ {$IFDEF Version6} {$WARN UNIT_PLATFORM OFF} {$ENDIF}
+ FileCtrl,
+ {$IFDEF Version6} {$WARN UNIT_PLATFORM ON} {$ENDIF}
+{$ENDIF}
+ StConst, StBase, StUtils, StDate, StStrL;
+
+{$IFNDEF VERSION6}
+const
+ PathDelim = '\';
+ DriveDelim = ':';
+ PathSep = ';';
+{$ENDIF VERSION6}
+const
+ StPathDelim = PathDelim; { Delphi/Linux constant }
+ StPathSep = PathSep; { Delphi/Linux constant }
+ StDriveDelim = DriveDelim;
+ StDosPathDelim = '\';
+ StUnixPathDelim = '/';
+ StDosPathSep = ';';
+ StUnixPathSep = ':';
+ StDosAnyFile = '*.*';
+ StUnixAnyFile = '*';
+ StAnyFile = {$IFDEF LINUX} StUnixAnyFile; {$ELSE} StDosAnyFile; {$ENDIF}
+ StThisDir = '.';
+ StParentDir = '..';
+
+
+type
+ DiskClass = ( Floppy360, Floppy720, Floppy12, Floppy144, OtherFloppy,
+ HardDisk, RamDisk, UnknownDisk, InvalidDrive, RemoteDrive, CDRomDisk );
+ {This enumerated type defines the nine classes of disks that can be
+ identified by GetDiskClass, as well as several types used as error
+ indications}
+
+ PMediaIDType = ^MediaIDType;
+ MediaIDType = packed record
+ {This type describes the information that DOS 4.0 or higher writes
+ in the boot sector of a disk when it is formatted}
+ InfoLevel : Word; {Reserved for future use}
+ SerialNumber : LongInt; {Disk serial number}
+ VolumeLabel : array[0..10] of Char; {Disk volume label}
+ FileSystemID : array[0..7] of Char; {String for internal use by the OS}
+ end;
+
+ TIncludeItemFunc = function (const SR : TSearchRec;
+ ForInclusion : Boolean; var Abort : Boolean) : Boolean;
+ {Function type for the routine passed to EnumerateFiles and
+ EnumerateDirectories. It will be called in two ways: to request
+ confirmation to include the entity described in SR into the
+ string list (ForInclusion = true); or to ask whether to recurse
+ into a particular subdirectory (ForInclusion = false).}
+
+{**** Routine Declarations ****}
+
+
+{CopyFile}
+function CopyFile(const SrcPath, DestPath : String) : Cardinal;
+{-Copy a file.}
+
+{CreateTempFile}
+function CreateTempFile(const aFolder : String;
+ const aPrefix : String) : String;
+{-Creates a temporary file.}
+
+{DeleteVolumeLabel}
+function DeleteVolumeLabel(Drive : Char) : Cardinal;
+{-Deletes an existing volume label on Drive. Returns 0 for success,
+ or OS error code.}
+
+{EnumerateDirectories}
+procedure EnumerateDirectories(const StartDir : String; FL : TStrings; {!!.02}
+ SubDirs : Boolean;
+ IncludeItem : TIncludeItemFunc);
+{-Retrieves the complete path name of directories on requested file
+ system path.}
+
+{EnumerateFiles}
+procedure EnumerateFiles(const StartDir : String; FL : TStrings; {!!.02}
+ SubDirs : Boolean;
+ IncludeItem : TIncludeItemFunc);
+{-Retrieves the complete path name of files in a requested file system path.}
+
+{FileHandlesLeft}
+function FileHandlesLeft(MaxHandles : Cardinal) : Cardinal;
+{-Return the number of available file handles.}
+
+{FileMatchesMask}
+function FileMatchesMask(const FileName, FileMask : String ) : Boolean;
+{-see if FileName matches FileMask}
+
+{FileTimeToStDateTime}
+function FileTimeToStDateTime(FileTime : LongInt) : TStDateTimeRec;
+{-Converts a DOS date-time value to TStDate and TStTime values.}
+
+{FindNthSlash}
+function FindNthSlash( const Path : String; n : Integer ) : Integer;
+{ return the position of the character just before the nth slash }
+
+{FlushOsBuffers}
+function FlushOsBuffers(Handle : Integer) : Boolean;
+{-Flush the OS buffers for the specified file handle.}
+
+{GetCurrentUser}
+function GetCurrentUser : String;
+{-Obtains current logged in username}
+
+{GetDiskClass}
+function GetDiskClass(Drive : Char) : DiskClass;
+{-Return the disk class for the specified drive.}
+
+{GetDiskInfo}
+function GetDiskInfo(Drive : Char; var ClustersAvailable, TotalClusters,
+ BytesPerSector, SectorsPerCluster : Cardinal) : Boolean;
+{-Return technical information about the specified drive.}
+
+{GetDiskSpace}
+{$IFDEF CBuilder}
+function GetDiskSpace(Drive : Char;
+ var UserSpaceAvail : Double; {space available to user}
+ var TotalSpaceAvail : Double; {total space available}
+ var DiskSize : Double) : Boolean;{disk size}
+{-Return space information about the drive.}
+{$ELSE}
+function GetDiskSpace(Drive : Char;
+ var UserSpaceAvail : Comp; {space available to user}
+ var TotalSpaceAvail : Comp; {total space available}
+ var DiskSize : Comp) : Boolean;{disk size}
+{-Return space information about the drive.}
+{$ENDIF}
+
+{GetFileCreateDate}
+function GetFileCreateDate(const FileName : String) :
+ TDateTime;
+{-Obtains file system time of file creation.}
+
+{GetFileLastAccess}
+function GetFileLastAccess(const FileName : String) :
+ TDateTime;
+{-Obtains file system time of last file access.}
+
+{GetFileLastModify}
+function GetFileLastModify(const FileName : String) :
+ TDateTime;
+{-Obtains file system time of last file modification.}
+
+{GetHomeFolder}
+function GetHomeFolder(aForceSlash : Boolean) : String;
+{-Obtains the "Home Folder" for the current user}
+
+{$IFNDEF CBuilder}
+{GetLongPath}
+function GetLongPath(const APath : String) : String;
+{-Returns the long filename version of a provided path.}
+{$ENDIF}
+
+{GetMachineName}
+function GetMachineName : String;
+{-Returns the "Machine Name" for the current computer }
+
+{GetMediaID}
+function GetMediaID(Drive : Char; var MediaIDRec : MediaIDType) : Cardinal;
+{-Get the media information (Volume Label, Serial Number) for the specified drive}
+
+{GetParentFolder}
+function GetParentFolder(const APath : String; aForceSlash : Boolean) : String;
+{-return the parent directory for the provided directory }
+
+{GetShortPath}
+function GetShortPath(const APath : String) : String;
+{-Returns the short filename version of a provided path.}
+
+{GetSystemFolder}
+function GetSystemFolder(aForceSlash : Boolean) : String;
+{-Returns the path to the Windows "System" folder".}
+
+{GetTempFolder}
+function GetTempFolder(aForceSlash : boolean) : String;
+{-Returns the path to the system temporary folder.}
+
+{GetWindowsFolder}
+function GetWindowsFolder(aForceSlash : boolean) : String;
+{-Returns the path to the main "Windows" folder.}
+
+{GetWorkingFolder}
+function GetWorkingFolder(aForceSlash : boolean) : String;
+{-Returns the current working directory.}
+
+{GlobalDateTimeToLocal}
+function GlobalDateTimeToLocal(const UTC: TStDateTimeRec; MinOffset: Integer): TStDateTimeRec; {!!.02}
+{-adjusts a global date/time (UTC) to the local date/time}
+
+{IsDirectory}
+function IsDirectory(const DirName : String) : Boolean;
+{-Return True if DirName is a directory.}
+
+{IsDirectoryEmpty}
+function IsDirectoryEmpty(const S : String) : Integer;
+{-checks if there are any entries in the directory}
+
+{IsDriveReady}
+function IsDriveReady(Drive : Char) : Boolean;
+{-determine if requested drive is accessible }
+
+{IsFile}
+function IsFile(const FileName : String) : Boolean;
+{-Determines if the provided path specifies a file.}
+
+{IsFileArchive}
+function IsFileArchive(const S : String) : Integer;
+{-checks if file's archive attribute is set}
+
+{IsFileHidden}
+function IsFileHidden(const S : String) : Integer;
+{-checks if file's hidden attribute is set}
+
+{IsFileReadOnly}
+function IsFileReadOnly(const S : String) : Integer;
+{-checks if file's readonly attribute is set}
+
+{IsFileSystem}
+function IsFileSystem(const S : String) : Integer;
+{-checks if file's system attribute is set}
+
+{LocalDateTimeToGlobal}
+function LocalDateTimeToGlobal(const DT1: TStDateTimeRec; MinOffset: Integer): TStDateTimeRec; {!!.02}
+{-adjusts a local date/time to the global (UTC) date/time}
+
+{ReadVolumeLabel}
+function ReadVolumeLabel(var VolName : String; Drive : Char) : Cardinal;
+{-Get the volume label for the specified drive.}
+
+{SameFile}
+function SameFile(const FilePath1, FilePath2 : String; var ErrorCode : Integer) : Boolean;
+{-Return True if FilePath1 and FilePath2 refer to the same physical file.}
+
+{SetMediaID} {!!!! does not work on NT/2000 !!!!}
+function SetMediaID(Drive : Char; var MediaIDRec : MediaIDType) : Cardinal;
+{-Set the media ID record for the specified drive.}
+
+{SplitPath}
+procedure SplitPath(const APath : String; Parts : TStrings);
+{-Splits the provided path into its component sub-paths}
+
+{StDateTimeToFileTime}
+function StDateTimeToFileTime(const FileTime : TStDateTimeRec) : LongInt; {!!.02}
+{-Converts an TStDate and TStTime to a DOS date-time value.}
+
+{StDateTimeToUnixTime}
+function StDateTimeToUnixTime(const DT1 : TStDateTimeRec) : Longint; {!!.02}
+{-converts a TStDateTimeRec to a time in Unix base (1970)}
+
+{UnixTimeToStDateTime}
+function UnixTimeToStDateTime(UnixTime : Longint) : TStDateTimeRec;
+{-converts a time in Unix base (1970) to a TStDateTimeRec}
+
+{ValidDrive}
+function ValidDrive(Drive : Char) : Boolean;
+{-Determine if the drive is a valid drive.}
+
+{WriteVolumeLabel}
+function WriteVolumeLabel(const VolName : String; Drive : Char) : Cardinal;
+{-Sets the volume label for the specified drive.}
+
+(*
+{$EXTERNALSYM GetLongPathNameA}
+function GetLongPathNameA(lpszShortPath: PAnsiChar; lpszLongPath: PAnsiChar;
+ cchBuffer: DWORD): DWORD; stdcall;
+{$EXTERNALSYM GetLongPathNameW}
+function GetLongPathNameW(lpszShortPath: PWideChar; lpszLongPath: PWideChar;
+ cchBuffer: DWORD): DWORD; stdcall;
+{$EXTERNALSYM GetLongPathName}
+function GetLongPathName(lpszShortPath: PChar; lpszLongPath: PChar;
+ cchBuffer: DWORD): DWORD; stdcall;
+*)
+
+implementation
+
+const
+ FILE_ANY_ACCESS = 0;
+ METHOD_BUFFERED = 0;
+ IOCTL_DISK_BASE = $00000007;
+ VWIN32_DIOC_DOS_IOCTL = 1;
+ IOCTL_DISK_GET_MEDIA_TYPES = ((IOCTL_DISK_BASE shl 16) or
+ (FILE_ANY_ACCESS shl 14) or ($0300 shl 2) or METHOD_BUFFERED);
+
+procedure StChDir(const S: String); {!!.02}
+{ wrapper for Delphi ChDir to handle a bug in D6}
+{$IFDEF VER140}
+var
+ Rslt : Integer;
+{$ENDIF}
+begin
+{$IFNDEF VER140}
+ Chdir(S);
+{$ELSE}
+{$I-}
+ Chdir(S);
+ if IOResult <> 0 then begin
+ Rslt := GetLastError;
+ SetInOutRes(Rslt);
+ end;
+{$I+}
+{$ENDIF}
+end;
+
+{CopyFile}
+function CopyFile(const SrcPath, DestPath : String) : Cardinal;
+ {-Copy the file specified by SrcPath into DestPath. DestPath must specify
+ a complete filename, it may not be the name of a directory without the
+ file portion. This a low level routine, and the input pathnames are not
+ checked for validity.}
+const
+ BufferSize = 4 * 1024;
+
+var
+ BytesRead, BytesWritten : LongInt;
+ FileDate : LongInt;
+ Src, Dest, Mode, SaveFAttr : Integer;
+ Buffer : Pointer;
+
+begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ Src := 0;
+ Dest := 0;
+ Buffer := nil;
+ Result := 1;
+ try
+ GetMem(Buffer, BufferSize);
+ Mode := FileMode and $F0;
+ SaveFAttr := FileGetAttr(SrcPath);
+ if SaveFAttr < 0 then begin
+ Result := 1;
+ Exit;
+ end;
+ Src := FileOpen(SrcPath, Mode);
+ if Src < 0 then begin
+ Result := 1; {unable to access SrcPath}
+ Exit;
+ end;
+ Dest := FileCreate(DestPath);
+ if Dest < 0 then begin
+ Result := 2; {unable to open DestPath}
+ Exit;
+ end;
+ repeat
+ BytesRead := FileRead(Src, Buffer^, BufferSize);
+ if (BytesRead = -1) then begin
+ Result := 3; {error reading from Src}
+ Exit;
+ end;
+ BytesWritten := FileWrite(Dest, Buffer^, BytesRead);
+ if (BytesWritten = -1) or
+ (BytesWritten <> BytesRead) then begin
+ Result := 4; {error writing to Dest}
+ Exit;
+ end;
+ until BytesRead < BufferSize;
+ FileDate := FileGetDate(Src);
+ if FileDate = -1 then begin
+ Result := 5; {error getting SrcPath's Date/Time}
+ Exit;
+ end;
+ FileSetDate(Dest, FileDate);
+ FileSetAttr(DestPath, SaveFAttr);
+ Result := 0;
+ finally
+ if Assigned(Buffer) then
+ FreeMem(Buffer, BufferSize);
+ if Src > 0 then FileClose(Src);
+ if Dest > 0 then begin
+ FileClose(Dest);
+ if Result <> 0 then SysUtils.DeleteFile(DestPath);
+ end;
+ end;
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+end;
+
+{CreateTempFile}
+function CreateTempFile(const aFolder : String;
+ const aPrefix : String) : String;
+{-Creates a temporary file.}
+var
+ TempFileNameZ : array [0..MAX_PATH] of Char;
+ TempDir : String;
+begin
+ TempDir := aFolder;
+ if not DirectoryExists(TempDir) then
+ TempDir := GetTempFolder(True);
+ if not DirectoryExists(TempDir) then
+ TempDir := GetWorkingFolder(True);
+
+ if (GetTempFileName(PChar(TempDir), PChar(aPrefix), 0,
+ TempFileNameZ) = 0)
+ then
+{$IFDEF Version6}
+ RaiseLastOSError;
+{$ELSE}
+ RaiseLastWin32Error;
+{$ENDIF}
+ Result := TempFileNameZ;
+end;
+
+
+{DeleteVolumeLabel}
+function DeleteVolumeLabel(Drive : Char) : Cardinal;
+{-Deletes an existing volume label on Drive. Returns 0 for success,
+ or OS error code.}
+var
+ Root : array[0..3] of Char;
+begin
+ StrCopy(Root, '%:\');
+ Root[0] := Drive;
+ if Windows.SetVolumeLabel(Root, '') then
+ Result := 0
+ else Result := GetLastError;
+end;
+
+{EnumerateDirectories}
+procedure EnumerateDirectories(const StartDir : String; FL : TStrings; {!!.02}
+ SubDirs : Boolean;
+ IncludeItem : TIncludeItemFunc);
+{-Retrieves the complete path name of directories on requested file
+ system path.}
+var
+ Abort : Boolean;
+ procedure SearchBranch;
+ var
+ SR : TSearchRec;
+ Error : SmallInt;
+ Dir : String;
+ begin
+ Error := FindFirst(StDosAnyFile, faDirectory, SR);
+ if Error = 0 then begin
+ GetDir(0, Dir);
+ if Dir[Length(Dir)] <> StDosPathDelim then
+ Dir := Dir + StDosPathDelim;
+ Abort := False;
+ while (Error = 0) and not Abort do begin
+ try
+ if (@IncludeItem = nil) or (IncludeItem(SR, true, Abort)) then begin
+ if (SR.Attr and faDirectory = faDirectory) and
+ (SR.Name <> StThisDir) and (SR.Name <> StParentDir) then
+ FL.Add(Dir + SR.Name);
+ end;
+ except
+ on EOutOfMemory do
+ raise EOutOfMemory.Create(stscSysStringListFull);
+ end;
+ Error := FindNext(SR);
+ end;
+ FindClose(SR);
+ end;
+
+ if not Abort and SubDirs then begin
+ Error := FindFirst(StDosAnyFile, faDirectory, SR);
+ if Error = 0 then begin
+ Abort := False;
+ while (Error = 0) and not Abort do begin
+ if ((SR.Attr and faDirectory = faDirectory) and
+ (SR.Name <> StThisDir) and (SR.Name <> StParentDir)) then begin
+ if (@IncludeItem = nil) or (IncludeItem(SR, false, Abort)) then begin
+ StChDir(SR.Name);
+ SearchBranch;
+ StChDir(StParentDir);
+ end;
+ end;
+ Error := FindNext(SR);
+ end;
+ FindClose(SR);
+
+ end;
+ end;
+ end;
+
+var
+ OrgDir : String;
+
+begin
+ if IsDirectory(StartDir) then
+ begin
+ GetDir(0, OrgDir);
+ try
+ StChDir(StartDir);
+ SearchBranch;
+ finally
+ StChDir(OrgDir);
+ end;
+ end else
+ raise Exception.Create(stscSysBadStartDir);
+end;
+
+{EnumerateFiles}
+procedure EnumerateFiles(const StartDir : String; {!!.02}
+ FL : TStrings;
+ SubDirs : Boolean;
+ IncludeItem : TIncludeItemFunc);
+{-Retrieves the complete path name of files in a requested file system path.}
+var
+ Abort : Boolean;
+
+ procedure SearchBranch;
+ var
+ SR : TSearchRec;
+ Error : SmallInt;
+ Dir : String;
+ begin
+ Error := FindFirst(StDosAnyFile, faAnyFile, SR);
+ if Error = 0 then begin
+ GetDir(0, Dir);
+ if Dir[Length(Dir)] <> StDosPathDelim then
+ Dir := Dir + StDosPathDelim;
+
+ Abort := False;
+ while (Error = 0) and not Abort do begin
+ try
+ if (@IncludeItem = nil) or (IncludeItem(SR, true, Abort)) then
+ FL.Add(Dir + SR.Name);
+ except
+ on EOutOfMemory do
+ begin
+ raise EOutOfMemory.Create(stscSysStringListFull);
+ end;
+ end;
+ Error := FindNext(SR);
+ end;
+ FindClose(SR);
+ end;
+
+
+ if not Abort and SubDirs then begin
+ Error := FindFirst(StDosAnyFile, faAnyFile, SR);
+ if Error = 0 then begin
+ Abort := False;
+ while (Error = 0) and not Abort do begin
+ if ((SR.Attr and faDirectory = faDirectory) and
+ (SR.Name <> StThisDir) and (SR.Name <> StParentDir)) then begin
+ if (@IncludeItem = nil) or (IncludeItem(SR, false, Abort)) then begin
+ StChDir(SR.Name);
+ SearchBranch;
+ StChDir(StParentDir);
+ end;
+ end;
+ Error := FindNext(SR);
+ end;
+ FindClose(SR);
+ end;
+ end;
+ end;
+
+var
+ OrgDir : String;
+
+begin
+ if IsDirectory(StartDir) then
+ begin
+ GetDir(0, OrgDir);
+ try
+ StChDir(StartDir);
+ SearchBranch;
+ finally
+ StChDir(OrgDir);
+ end;
+ end else
+ raise Exception.Create(stscSysBadStartDir);
+end;
+
+
+{FileHandlesLeft}
+{.$HINTS OFF}
+function FileHandlesLeft(MaxHandles : Cardinal) : Cardinal;
+ {-Returns the number of available file handles. In 32-bit, this can be a
+ large number. Use MaxHandles to limit the number of handles counted.
+ The maximum is limited by HandleLimit - you can increase HandleLimit if
+ you wish. A temp file is required because Win95 seems to have some
+ limit on the number of times you can open NUL.}
+const
+ HandleLimit = 1024;
+type
+ PHandleArray = ^THandleArray;
+ THandleArray = array[0..Pred(HandleLimit)] of Integer;
+var
+ Handles : PHandleArray;
+ MaxH, I : Integer;
+ TempPath, TempFile : PChar;
+begin
+ Result := 0;
+ MaxH := MinLong(HandleLimit, MaxHandles);
+ TempFile := nil;
+ TempPath := nil;
+ Handles := nil;
+ try
+ TempFile := StrAlloc(MAX_PATH+1); {!!.01}
+ TempPath := StrAlloc(MAX_PATH+1); {!!.01}
+ GetMem(Handles, MaxH * SizeOf(Integer));
+ GetTempPath(MAX_PATH, TempPath); {!!.01}
+ GetTempFileName(TempPath, 'ST', 0, TempFile);
+ for I := 0 to Pred(MaxH) do begin
+ Handles^[I] := CreateFile(TempFile, 0, FILE_SHARE_READ, nil,
+ OPEN_EXISTING, FILE_FLAG_DELETE_ON_CLOSE, 0);
+ if Handles^[I] <> LongInt(INVALID_HANDLE_VALUE) then
+ Inc(Result) else Break;
+ end;
+ for I := 0 to Pred(Result) do
+ FileClose(Handles^[I]);
+ finally
+ if Assigned(Handles) then
+ FreeMem(Handles, MaxH * SizeOf(Integer));
+ StrDispose(TempFile);
+ StrDispose(TempPath);
+ end;
+end;
+{.$HINTS ON}
+
+{ -------------------------------------------------------------------------- }
+function StPatternMatch(const Source : string; iSrc : Integer; {!!.02}
+ const Pattern : string; iPat : Integer ) : Boolean; {!!.02}
+{ recursive routine to see if the source string matches
+ the pattern. Both ? and * wildcard characters are allowed.
+ Compares Source from iSrc to Length(Source) to
+ Pattern from iPat to Length(Pattern)}
+var
+ Matched : Boolean;
+ k : Integer;
+begin
+{$R-}
+ if Length( Source ) = 0 then begin
+ Result := Length( Pattern ) = 0;
+ Exit;
+ end;
+
+ if iPat = 1 then begin
+ if ( CompareStr( Pattern, StDosAnyFile) = 0 ) or
+ ( CompareStr( Pattern, StUnixAnyFile ) = 0 ) then begin
+ Result := True;
+ Exit;
+ end;
+ end;
+
+ if Length( Pattern ) = 0 then begin
+ Result := (Length( Source ) - iSrc + 1 = 0);
+ Exit;
+ end;
+
+ while True do begin
+ if ( Length( Source ) < iSrc ) and
+ ( Length( Pattern ) < iPat ) then begin
+ Result := True;
+ Exit;
+ end;
+
+ if Length( Pattern ) < iPat then begin
+ Result := False;
+ Exit;
+ end;
+
+ if (iPat <= Length(Pattern)) and (Pattern[iPat] = '*') then begin
+ k := iPat;
+ if ( Length( Pattern ) < iPat + 1 ) then begin
+ Result := True;
+ Exit;
+ end;
+
+ while True do begin
+ Matched := StPatternMatch( Source, k, Pattern, iPat + 1 );
+ if Matched or ( Length( Source ) < k ) then begin
+ Result := Matched;
+ Exit;
+ end;
+ inc( k );
+ end;
+ end
+ else begin
+ if ((Pattern[iPat] = '?') and
+ ( Length( Source ) <> iSrc - 1 ) ) or
+ ( Pattern[iPat] = Source[iSrc] ) then begin
+ inc( iPat );
+ inc( iSrc );
+ end
+ else begin
+ Result := False;
+ Exit;
+ end;
+ end;
+ end;
+{$R+}
+end;
+
+{FileMatchesMask}
+function FileMatchesMask(const FileName, FileMask : String ) : Boolean;
+{-see if FileName matches FileMask}
+var
+ DirMatch : Boolean;
+ MaskDir : String;
+ LFN, LFM : String;
+begin
+ LFN := UpperCase( FileName );
+ LFM := UpperCase( FileMask );
+ MaskDir := ExtractFilePath( LFN );
+ if MaskDir = '' then
+ DirMatch := True
+ else
+ DirMatch := StPatternMatch( ExtractFilePath( LFN ), 1, MaskDir, 1 );
+
+ Result := DirMatch and StPatternMatch( ExtractFileName( LFN ), 1,
+ ExtractFileName( LFM ), 1 );
+end;
+
+{FileTimeToStDateTime}
+function FileTimeToStDateTime(FileTime : LongInt) : TStDateTimeRec;
+{-Converts a DOS date-time value to TStDate and TStTime values.}
+
+var
+ DDT : TDateTime;
+begin
+ DDT := FileDateToDateTime(FileTime);
+ Result.D := DateTimeToStDate(DDT);
+ Result.T := DateTimeToStTime(DDT);
+end;
+
+{FindNthSlash}
+function FindNthSlash(const Path : String; n : Integer) : Integer;
+{ return the position of the character just before the nth slash }
+var
+ i : Integer;
+ Len : Integer;
+ iSlash : Integer;
+begin
+ Len := Length( Path );
+ Result := Len;
+ iSlash := 0;
+ i := 1;
+ while i <= Len do begin
+ if Path[i] = StPathDelim then begin
+ inc( iSlash );
+ if iSlash = n then begin
+ Result := pred( i );
+ break;
+ end;
+ end;
+ inc( i );
+ end;
+end;
+
+{FlushOsBuffers}
+{-Flush the OS buffers for the specified file handle.}
+function FlushOsBuffers(Handle : Integer) : Boolean;
+ {-Flush the OS's buffers for the specified file}
+begin
+ Result := FlushFileBuffers(Handle);
+ if not Result then
+{$IFDEF Version6}
+ RaiseLastOSError;
+{$ELSE}
+ RaiseLastWin32Error;
+{$ENDIF}
+end;
+
+{GetCurrentUser}
+function GetCurrentUser : String;
+{-Obtains current logged in username}
+var
+ Size : DWORD;
+ UserNameZ : array [0..511] of Char;
+begin
+ Size := Length(UserNameZ);
+ if not GetUserName(UserNameZ, Size) then
+{$IFDEF Version6}
+ RaiseLastOSError;
+{$ELSE}
+ RaiseLastWin32Error;
+{$ENDIF}
+// SetString(Result, UserNameZ, Size); {!!.02}
+ SetString(Result, UserNameZ, StrLen(UserNameZ)); {!!.02}
+end;
+
+{GetDiskClass}
+function GetDiskClass(Drive : Char) : DiskClass;
+{-Return the disk class for the specified drive.}
+type
+ TMediaType =
+ ( Unknown, { Format is unknown }
+ F5_1Pt2_512, { 5.25", 1.2MB, 512 bytes/sector }
+ F3_1Pt44_512, { 3.5", 1.44MB, 512 bytes/sector }
+ F3_2Pt88_512, { 3.5", 2.88MB, 512 bytes/sector }
+ F3_20Pt8_512, { 3.5", 20.8MB, 512 bytes/sector }
+ F3_720_512, { 3.5", 720KB, 512 bytes/sector }
+ F5_360_512, { 5.25", 360KB, 512 bytes/sector }
+ F5_320_512, { 5.25", 320KB, 512 bytes/sector }
+ F5_320_1024, { 5.25", 320KB, 1024 bytes/sector }
+ F5_180_512, { 5.25", 180KB, 512 bytes/sector }
+ F5_160_512, { 5.25", 160KB, 512 bytes/sector }
+ RemovableMedia, { Removable media other than floppy }
+ FixedMedia ); { Fixed hard disk media }
+
+ PDiskGeometry = ^TDiskGeometry;
+ TDiskGeometry = record
+ Cylinders1 : DWORD;
+ Cylinders2 : Integer;
+ MediaType : TMediaType;
+ TracksPerCylinder : DWORD;
+ SectorsPerTrack : DWORD;
+ BytesPerSector : DWORD;
+ end;
+
+var
+ Root : array[0..3] of Char;
+ Root2 : array[0..6] of Char;
+ ReturnedByteCount,
+ SectorsPerCluster,
+ BytesPerSector,
+ NumberOfFreeClusters,
+ TotalNumberOfClusters : DWORD;
+ SupportedGeometry : array[1..20] of TDiskGeometry;
+ HDevice : THandle;
+ I : Integer;
+ VerInfo : TOSVersionInfo;
+ Found : Boolean;
+begin
+ FillChar(VerInfo, SizeOf(TOSVersionInfo), #0);
+ VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
+
+ Result := InvalidDrive;
+ Found := False;
+ StrCopy(Root, '%:\');
+ Root[0] := Drive;
+ case GetDriveType(Root) of
+ 0 : Result := UnknownDisk;
+ 1 : Result := InvalidDrive;
+ DRIVE_REMOVABLE :
+ begin
+ GetVersionEx(VerInfo);
+ if VerInfo.dwPlatformID = VER_PLATFORM_WIN32_NT then begin
+ StrCopy(Root2, '\\.\%:');
+ Root2[4] := Drive;
+ HDevice := CreateFile(Root2, 0, FILE_SHARE_READ,
+ nil, OPEN_ALWAYS, 0, 0);
+ if HDevice = INVALID_HANDLE_VALUE then Exit;
+ if not DeviceIoControl(HDevice, IOCTL_DISK_GET_MEDIA_TYPES, nil, 0,
+ @SupportedGeometry, SizeOf(SupportedGeometry), ReturnedByteCount, nil)
+ then Exit;
+ for I := 1 to (ReturnedByteCount div SizeOf(TDiskGeometry)) do begin
+ case SupportedGeometry[I].MediaType of
+ F5_1Pt2_512 : begin
+ Result := Floppy12;
+ Exit;
+ end;
+ F3_1Pt44_512 : begin
+ Result := Floppy144;
+ Exit;
+ end;
+ F3_720_512 : begin
+ Result := Floppy720;
+ Found := True;
+ end;
+ F5_360_512 : begin
+ Result := Floppy360;
+ Found := True;
+ end;
+ end;
+ end;
+ if Found then Exit;
+ Result := OtherFloppy;
+ end else begin
+ GetDiskFreeSpace(Root, SectorsPerCluster, BytesPerSector,
+ NumberOfFreeClusters, TotalNumberOfClusters);
+ case TotalNumberOfClusters of
+ 354 : Result := Floppy360;
+ 713,
+ 1422 : Result := Floppy720;
+ 2371 : Result := Floppy12;
+ 2847 : Result := Floppy144;
+ else Result := OtherFloppy;
+ end;
+ end;
+ end;
+ DRIVE_FIXED : Result := HardDisk;
+ DRIVE_REMOTE : Result := RemoteDrive;
+ DRIVE_CDROM : Result := CDRomDisk;
+ DRIVE_RAMDISK : Result := RamDisk;
+ end;
+end;
+
+{GetDiskInfo}
+function GetDiskInfo(Drive : Char; var ClustersAvailable, TotalClusters,
+ BytesPerSector, SectorsPerCluster : Cardinal) : Boolean;
+{-Return technical information about the specified drive.}
+var
+ Root : String;
+begin
+ if Drive <> ' ' then begin
+ Root := Char(System.Upcase(Drive)) + ':\';
+ Result := GetDiskFreeSpace(PChar(Root), DWORD(SectorsPerCluster),
+ DWORD(BytesPerSector), DWORD(ClustersAvailable), DWORD(TotalClusters));
+ end else
+ Result := GetDiskFreeSpace(nil, DWORD(SectorsPerCluster),
+ DWORD(BytesPerSector), DWORD(ClustersAvailable), DWORD(TotalClusters));
+end;
+
+
+{GetDiskSpace}
+{$IFDEF CBuilder}
+function GetDiskSpace(Drive : Char;
+ var UserSpaceAvail : Double; {space available to user}
+ var TotalSpaceAvail : Double; {total space available}
+ var DiskSize : Double) : Boolean;{disk size}
+{-Return space information about the drive.}
+type
+ TGetDiskFreeSpace = function (Drive : PChar;
+ var UserFreeBytes : Comp;
+ var TotalBytes : Comp;
+ var TotalFreeBytes : Comp) : Bool; stdcall;
+ LH = packed record L,H : word; end;
+var
+ UserFree, Total, Size : Comp;
+ VerInfo : TOSVersionInfo;
+ LibHandle : THandle;
+ GDFS : TGetDiskFreeSpace;
+ Root : String;
+begin
+ Result := False;
+ {get the version info}
+ FillChar(VerInfo, SizeOf(TOSVersionInfo), #0);
+ VerInfo.dwOSVersionInfoSize := SizeOf(VerInfo);
+ if GetVersionEx(VerInfo) then begin
+ with VerInfo do begin
+ if ((dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) and
+ (LH(dwBuildNumber).L <> 1000)) or
+ ((dwPlatformId = VER_PLATFORM_WIN32_NT) and
+ (dwMajorVersion >= 4)) then begin
+ LibHandle := LoadLibrary('KERNEL32.DLL');
+ try
+ if (LibHandle <> 0) then begin
+ @GDFS := GetProcAddress(LibHandle, 'GetDiskFreeSpaceEx'+{$IFDEF UNICODE}'W'{$ELSE}'A'{$ENDIF});
+ if Assigned(GDFS) then begin
+ Root := Char(Upcase(Drive)) + ':\';
+ if GDFS(PChar(Root), UserFree, Size, Total) then begin
+ UserSpaceAvail := UserFree;
+ DiskSize := Size;
+ TotalSpaceAvail := Total;
+ Result := true;
+ end;
+ end;
+ end;
+
+ finally
+ FreeLibrary(LibHandle);
+ end;
+ end;
+ end;
+ end;
+end;
+{$ELSE}
+function GetDiskSpace(Drive : Char;
+ var UserSpaceAvail : Comp; {space available to user}
+ var TotalSpaceAvail : Comp; {total space available}
+ var DiskSize : Comp) : Boolean;{disk size}
+{-Return space information about the drive.}
+type
+ TGetDiskFreeSpace = function (Drive : PChar;
+ var UserFreeBytes : Comp;
+ var TotalBytes : Comp;
+ var TotalFreeBytes : Comp) : Bool; stdcall;
+ LH = packed record L,H : word; end;
+var
+ CA, TC, BPS, SPC : Cardinal;
+ VerInfo : TOSVersionInfo;
+ LibHandle : THandle;
+ GDFS : TGetDiskFreeSpace;
+ Root : String;
+begin
+ Result := false;
+ {get the version info}
+ FillChar(VerInfo, SizeOf(TOSVersionInfo), #0);
+ VerInfo.dwOSVersionInfoSize := SizeOf(VerInfo);
+ if GetVersionEx(VerInfo) then begin
+ with VerInfo do begin
+ if ((dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) and
+ (LH(dwBuildNumber).L <> 1000)) or
+ ((dwPlatformId = VER_PLATFORM_WIN32_NT) and
+ (dwMajorVersion >= 4)) then begin
+ LibHandle := LoadLibrary('KERNEL32.DLL');
+ try
+ if (LibHandle <> 0) then begin
+ @GDFS := GetProcAddress(LibHandle, 'GetDiskFreeSpaceEx'+{$IFDEF UNICODE}'W'{$ELSE}'A'{$ENDIF});
+ if Assigned(GDFS) then begin
+ Root := Char(System.Upcase(Drive)) + ':\';
+ if GDFS(PChar(Root), UserSpaceAvail, DiskSize, TotalSpaceAvail) then
+ Result := true;
+ end;
+ end;
+
+ finally
+ FreeLibrary(LibHandle);
+ end;
+ end;
+ end;
+ end;
+
+ if not Result then begin
+ if GetDiskInfo(Drive, CA, TC, BPS, SPC) then begin
+ Result := true;
+ DiskSize := BPS;
+ DiskSize := DiskSize * SPC * TC;
+ TotalSpaceAvail := BPS;
+ TotalSpaceAvail := TotalSpaceAvail * SPC * CA;
+ UserSpaceAvail := TotalSpaceAvail;
+ end;
+ end;
+end;
+{$ENDIF}
+
+function GetFileCreateDate(const FileName : String) :
+ TDateTime;
+{-Obtains file system time of file creation.}
+{!!.01 - Rewritten}
+var
+ Rslt : Integer;
+ SR : TSearchRec;
+ FTime : Integer;
+begin
+ Result := 0.0;
+ Rslt := FindFirst(FileName, faAnyFile, SR);
+ if Rslt = 0 then begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ FileTimeToDosDateTime(SR.FindData.ftCreationTime,
+ LongRec(FTime).Hi, LongRec(FTime).Lo);
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+ Result := FileDateToDateTime(FTime);
+ FindClose(SR);
+ end;
+{!!.01 - End Rewritten}
+end;
+
+{GetFileLastAccess}
+function GetFileLastAccess(const FileName : String) :
+ TDateTime;
+ {-Obtains file system time of last file access.}
+{!!.01 - Rewritten}
+var
+ Rslt : Integer;
+ SR : TSearchRec;
+ FTime : Integer;
+begin
+ Result := 0.0;
+ Rslt := FindFirst(FileName, faAnyFile, SR);
+ if Rslt = 0 then begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ FileTimeToDosDateTime(SR.FindData.ftLastAccessTime,
+ LongRec(FTime).Hi, LongRec(FTime).Lo);
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+ Result := FileDateToDateTime(FTime);
+ FindClose(SR);
+ end;
+{!!.01 - End Rewritten}
+end;
+
+{GetFileLastModify}
+function GetFileLastModify(const FileName : String) :
+ TDateTime;
+ {-Obtains file system time of last file modification.}
+{!!.01 - Rewritten}
+var
+ Rslt : Integer;
+ SR : TSearchRec;
+ FTime : Integer;
+begin
+ Result := 0.0;
+ Rslt := FindFirst(FileName, faAnyFile, SR);
+ if Rslt = 0 then begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ FileTimeToDosDateTime(SR.FindData.ftLastWriteTime,
+ LongRec(FTime).Hi, LongRec(FTime).Lo);
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+ Result := FileDateToDateTime(FTime);
+ FindClose(SR);
+ end;
+{!!.01 - End Rewritten}
+end;
+
+{GetHomeFolder}
+function GetHomeFolder(aForceSlash : boolean) : String;
+{-Obtains the "Home Folder" for the current user}
+var
+ Size : integer;
+ Path : String;
+ Buffer : PChar;
+begin
+ Size := Windows.GetEnvironmentVariable('HOMEDRIVE', nil, 0);
+ GetMem(Buffer, Size * SizeOf(Char));
+ try
+ SetString(Result, Buffer, Windows.GetEnvironmentVariable('HOMEDRIVE',
+ Buffer, Size));
+ finally
+ FreeMem(Buffer);
+ end;
+
+ Size := Windows.GetEnvironmentVariable('HOMEPATH', nil, 0);
+ GetMem(Buffer, Size * SizeOf(Char));
+ try
+ SetString(Path, Buffer, Windows.GetEnvironmentVariable('HOMEPATH',
+ Buffer, Size));
+ finally
+ FreeMem(Buffer);
+ end;
+
+ if Path = '' then
+ Path := GetWorkingFolder(aForceSlash);
+
+ if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
+ Path := Path + StDosPathDelim;
+ if (Path[1] <> StDosPathDelim) then
+ Result := Result + StDosPathDelim + Path
+ else
+ Result := Result + Path;
+end;
+
+function GetLongPathName(lpszShortPath: PChar; lpszLongPath: PChar;
+ cchBuffer: DWORD): DWORD;
+var
+ PathBuf : PChar;
+ Len, i : Integer;
+ FD : TWIN32FindData;
+ FH : THandle;
+ ResBuf : String;
+begin
+ if not Assigned(lpszShortPath) then begin
+ SetLastError(ERROR_INVALID_PARAMETER);
+ Result := 0;
+ Exit;
+ end;
+
+ { Check whether the input path is valid. }
+ if (GetFileAttributes(lpszShortPath) = $FFFFFFFF) then begin
+ Result := 0;
+ Exit;
+ end;
+
+ Len := StrLen(lpszShortPath);
+ PathBuf := StrAlloc(Len + 1);
+ try
+ StrCopy(PathBuf, lpszShortPath);
+ ResBuf := '';
+
+ i := 0;
+ { Check for Drive Letter }
+ if (IsCharAlpha(PathBuf[0])) and (PathBuf[1] = DriveDelim) and (Len > 3) then begin
+ repeat
+ ResBuf := ResBuf + PathBuf[i];
+ Inc(i);
+ until PathBuf[i] = StPathDelim;
+ ResBuf := ResBuf + StPathDelim;
+ end;
+
+ { Check for UNC Path }
+ if (PathBuf[0] = StPathDelim) and (PathBuf[1] = StPathDelim) then begin
+ { extract machine name }
+ ResBuf := '\\';
+ i := 2;
+ repeat
+ ResBuf := ResBuf + PathBuf[i];
+ Inc(i);
+ until PathBuf[i] = StPathDelim;
+ ResBuf := ResBuf + StPathDelim;
+ Inc(i);
+
+ { extract share name }
+ repeat
+ ResBuf := ResBuf + PathBuf[i];
+ Inc(i);
+ until PathBuf[i] = StPathDelim;
+ ResBuf := ResBuf + StPathDelim;
+ Inc(i);
+ end;
+
+ { move past current delimiter } {!!.01}
+ Inc(i); {!!.01}
+
+ { find next occurrence of path delimiter }
+ while i < Len do begin
+ if (PathBuf[i] = StPathDelim) then begin
+ PathBuf[i] := #0;
+ FH := FindFirstFile(PathBuf, FD);
+ if FH <> INVALID_HANDLE_VALUE then begin
+ ResBuf := ResBuf + StrPas(FD.cFileName) + StPathDelim;
+ Windows.FindClose(FH);
+ end;
+ PathBuf[i] := StPathDelim;
+
+ end;
+ Inc(i);
+ end;
+
+ { one mo' time for the entire string: }
+ FH := FindFirstFile(PathBuf, FD);
+ if FH <> INVALID_HANDLE_VALUE then begin
+ ResBuf := ResBuf + StrPas(FD.cFileName);
+ Windows.FindClose(FH);
+ end;
+
+ Result := Length(ResBuf);
+
+ if Assigned(lpszLongPath) and (cchBuffer >= DWord(Length(ResBuf))) then begin
+ StrPCopy(lpszLongPath, ResBuf);
+ end;
+ finally
+ StrDispose(PathBuf);
+ end;
+end;
+
+{GetLongPath}
+function GetLongPath(const APath : String) : String;
+{-Returns the long filename version of a provided path.}
+var
+ Size : integer;
+ Buffer : PChar;
+begin
+ Buffer := nil;
+ Size := GetLongPathName(PChar(APath), Buffer, 0);
+ Buffer := StrAlloc(Size);
+ try
+ SetString(Result, Buffer, GetLongPathName(PChar(APath), Buffer, Size));
+ finally
+ if Assigned(Buffer) then
+ StrDispose(Buffer);
+ end;
+end;
+
+{GetMachineName}
+function GetMachineName : String;
+{-Returns the "Machine Name" for the current computer }
+var
+ Size : DWORD;
+ MachineNameZ : array [0..MAX_COMPUTERNAME_LENGTH] of Char;
+begin
+ Size := Length(MachineNameZ);
+ if not GetComputerName(MachineNameZ, Size) then
+{$IFDEF Version6}
+ RaiseLastOSError;
+{$ELSE}
+ RaiseLastWin32Error;
+{$ENDIF}
+// SetString(Result, MachineNameZ, Size); {!!.02}
+ SetString(Result, MachineNameZ, StrLen(MachineNameZ)); {!!.02}
+end;
+
+{GetMediaID}
+function GetMediaID(Drive : Char; var MediaIDRec : MediaIDType) : Cardinal;
+{-Get the media information (Volume Label, Serial Number) for the specified drive}
+var
+ VolBuf, FSNameBuf : PChar;
+ VolSiz, FSNSiz : Integer;
+ Root : String;
+ SN, ML, Flags : DWORD;
+begin
+ VolSiz := Length(MediaIDRec.VolumeLabel){ + 1}; //SZ: why +1??
+ FSNSiz := Length(MediaIDRec.FileSystemID){ + 1};
+
+ Root := Char(System.Upcase(Drive)) + ':\';
+
+ VolBuf := nil;
+ FSNameBuf := nil;
+
+ try
+ VolBuf := StrAlloc(VolSiz);
+ FSNameBuf := StrAlloc(FSNSiz);
+ Result := 0;
+ if GetVolumeInformation(PChar(Root), VolBuf, VolSiz, @SN, ML, Flags, FSNameBuf, FSNSiz) then begin
+ StrCopy(MediaIDRec.FileSystemID, FSNameBuf);
+ StrCopy(MediaIDRec.VolumeLabel, VolBuf);
+ MediaIDRec.SerialNumber := SN;
+
+ end else
+ Result := GetLastError;
+ finally
+ if Assigned(VolBuf) then
+ StrDispose(VolBuf);
+ if Assigned(FSNameBuf) then
+ StrDispose(FSNameBuf);
+ end;
+end;
+
+{!!.02 -- Added }
+function StAddBackSlash(const DirName : string) : string;
+{ Add a default slash to a directory name }
+const
+ DelimSet : set of AnsiChar = [StPathDelim, ':', #0];
+begin
+ Result := DirName;
+ if Length(DirName) = 0 then
+ Exit;
+ {$IFDEF UNICODE}
+ if not CharInSet(DirName[Length(DirName)], DelimSet) then
+ Result := DirName + StPathDelim;
+ {$ELSE}
+ if not (DirName[Length(DirName)] in DelimSet) then
+ Result := DirName + StPathDelim;
+ {$ENDIF}
+end;
+{!!.02 -- End Added }
+
+{GetParentFolder}
+function GetParentFolder(const APath : String; aForceSlash : Boolean) : String;
+{-return the parent directory for the provided directory }
+begin
+ Result := ExpandFileName(StAddBackSlash(APath) + StParentDir); {!!.02}
+ if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
+ Result := Result + StDosPathDelim;
+end;
+
+{GetShortPath}
+function GetShortPath(const APath : String) : String;
+{-Returns the short filename version of a provided path.}
+var
+ Size : integer;
+ Buffer : PChar;
+begin
+ Buffer := nil;
+ Size := GetShortPathName(PChar(APath), Buffer, 0);
+ Buffer := StrAlloc(Size);
+ try
+ SetString(Result, Buffer, GetShortPathName(PChar(APath), Buffer, Size));
+ finally
+ if Assigned(Buffer) then
+ StrDispose(Buffer);
+ end;
+end;
+
+{GetSystemFolder}
+function GetSystemFolder(aForceSlash : boolean) : String;
+{-Returns the path to the Windows "System" folder".}
+var
+ Size : integer;
+ Buffer : PChar;
+begin
+ Size := GetSystemDirectory(nil, 0);
+ Buffer := StrAlloc(Size);
+ try
+ SetString(Result, Buffer, GetSystemDirectory(Buffer, Size));
+ finally
+ StrDispose(Buffer);
+ end;
+ if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
+ Result := Result + StDosPathDelim;
+end;
+
+{GetTempFolder}
+function GetTempFolder(aForceSlash : boolean) : String;
+{-Returns the path to the system temporary folder.}
+var
+ Size : integer;
+ Buffer : PChar;
+begin
+ Size := GetTempPath(0, nil);
+ Buffer := StrAlloc(Size);
+ try
+ SetString(Result, Buffer, GetTempPath(Size, Buffer));
+ finally
+ StrDispose(Buffer);
+ end;
+ if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
+ Result := Result + StDosPathDelim;
+end;
+
+{GetWindowsFolder}
+function GetWindowsFolder(aForceSlash : boolean) : String;
+{-Returns the path to the main "Windows" folder.}
+var
+ Size : integer;
+ Buffer : PChar;
+begin
+ Size := GetWindowsDirectory(nil, 0);
+ Buffer := StrAlloc(Size);
+ try
+ SetString(Result, Buffer, GetWindowsDirectory(Buffer, Size));
+ finally
+ StrDispose(Buffer);
+ end;
+ if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
+ Result := Result + StDosPathDelim;
+end;
+
+{GetWorkingFolder}
+function GetWorkingFolder(aForceSlash : boolean) : String;
+{-Returns the current working directory.}
+begin
+ Result := ExpandFileName(StThisDir);
+ if aForceSlash and (Result[length(Result)] <> StDosPathDelim) then
+ Result := Result + StDosPathDelim;
+end;
+
+{GlobalDateTimeToLocal}
+function GlobalDateTimeToLocal(const UTC: TStDateTimeRec; MinOffset: Integer): TStDateTimeRec; {!!.02}
+{-adjusts a global date/time (UTC) to the local date/time}
+{$IFNDEF VERSION4}
+const
+ TIME_ZONE_ID_INVALID = DWORD($FFFFFFFF);
+ TIME_ZONE_ID_UNKNOWN = 0;
+ TIME_ZONE_ID_STANDARD = 1;
+ TIME_ZONE_ID_DAYLIGHT = 2;
+{$ENDIF}
+var
+ Minutes : LongInt;
+ TZ : TTimeZoneInformation;
+begin
+ Minutes := (UTC.D * MinutesInDay) + (UTC.T div 60);
+ case GetTimeZoneInformation(TZ) of
+ TIME_ZONE_ID_UNKNOWN :
+ Minutes := Minutes - TZ.Bias;
+ TIME_ZONE_ID_INVALID :
+ Minutes := Minutes - MinOffset;
+ TIME_ZONE_ID_STANDARD:
+ Minutes := Minutes - (TZ.Bias + TZ.StandardBias);
+ TIME_ZONE_ID_DAYLIGHT:
+ Minutes := Minutes - (TZ.Bias + TZ.DaylightBias);
+ end;
+
+ Result.D := (Minutes div MinutesInDay);
+ Result.T := ((Minutes mod MinutesInDay) * SecondsInMinute) + (UTC.T mod SecondsInMinute);
+end;
+
+{IsDirectory}
+function IsDirectory(const DirName : String) : Boolean;
+{-Return true if DirName is a directory}
+var
+ Attrs : DWORD; {!!.01}
+begin
+ Result := False;
+ Attrs := GetFileAttributes(PChar(DirName));
+ if Attrs <> DWORD(-1) then {!!.01}
+ Result := (FILE_ATTRIBUTE_DIRECTORY and Attrs <> 0);
+end;
+
+{IsDirectoryEmpty}
+function IsDirectoryEmpty(const S : String) : Integer;
+{-checks if there are any entries in the directory}
+var
+ SR : TSearchRec;
+ R : Integer;
+ DS : String;
+begin
+ Result := 1;
+ if IsDirectory(S) then begin
+ DS := AddBackSlashL(S);
+ R := Abs(FindFirst(DS + StDosAnyFile, faAnyFile, SR));
+ if R <> 18 then begin
+ if (R = 0) then
+ repeat
+ if (SR.Attr and faDirectory = faDirectory) then begin
+ if (SR.Name <> StThisDir) and (SR.Name <> StParentDir) then begin
+ Result := 0;
+ break;
+ end;
+ end else begin
+ Result := 0;
+ break;
+ end;
+ R := Abs(FindNext(SR));
+ until R = 18;
+ end;
+ FindClose(SR);
+ end else
+ Result := -1;
+end;
+
+{IsDriveReady}
+function IsDriveReady(Drive : Char) : Boolean;
+{-determine if requested drive is accessible }
+var
+ Root : String;
+ VolName : PChar;
+ Flags, MaxLength : DWORD;
+ NameSize : Integer;
+begin
+ Result := False;
+ NameSize := 0;
+ Root := System.Upcase(Drive) + ':\' ;
+ VolName := StrAlloc(MAX_PATH);
+
+ try
+ if GetVolumeInformation(PChar(Root), VolName, MAX_PATH,
+ nil, MaxLength, Flags, nil, NameSize) then
+ Result := True;
+ finally
+ if Assigned(VolName) then
+ StrDispose(VolName);
+ end;
+end;
+
+{IsFile}
+function IsFile(const FileName : String) : Boolean;
+{-Determines if the provided path specifies a file.}
+var
+ Attrs : DWORD; {!!.02}
+begin
+ Result := False;
+ Attrs := GetFileAttributes(PChar(FileName));
+ if Attrs <> DWORD(-1) then {!!.02}
+ Result := (Attrs and FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY;
+end;
+
+{IsFileArchive}
+function IsFileArchive(const S : String) : Integer;
+ {-checks if file's archive attribute is set}
+begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ if FileExists(S) then
+ Result := Integer((FileGetAttr(S) and faArchive) = faArchive)
+ else
+ Result := -1;
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+end;
+
+{IsFileHidden}
+function IsFileHidden(const S : String) : Integer;
+ {-checks if file's hidden attribute is set}
+begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ if FileExists(S) then
+ Result := Integer((FileGetAttr(S) and faHidden) = faHidden)
+ else
+ Result := -1;
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+end;
+
+{IsFileReadOnly}
+function IsFileReadOnly(const S : String) : Integer;
+ {-checks if file's readonly attribute is set}
+begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ if FileExists(S) then
+ Result := Integer((FileGetAttr(S) and faReadOnly) = faReadOnly)
+ else
+ Result := -1;
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+end;
+
+{IsFileSystem}
+function IsFileSystem(const S : String) : Integer;
+ {-checks if file's system attribute is set}
+begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ if FileExists(S) then
+ Result := Integer((FileGetAttr(S) and faSysFile) = faSysFile)
+ else
+ Result := -1;
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+end;
+
+{LocalDateTimeToGlobal}
+function LocalDateTimeToGlobal(const DT1: TStDateTimeRec; MinOffset: Integer): TStDateTimeRec; {!!.02}
+{-adjusts a local date/time to the global (UTC) date/time}
+{$IFNDEF VERSION4}
+const
+ TIME_ZONE_ID_INVALID = DWORD($FFFFFFFF);
+ TIME_ZONE_ID_UNKNOWN = 0;
+ TIME_ZONE_ID_STANDARD = 1;
+ TIME_ZONE_ID_DAYLIGHT = 2;
+{$ENDIF}
+var
+ Minutes : LongInt;
+ TZ : TTimeZoneInformation;
+begin
+ Minutes := (DT1.D * MinutesInDay) + (DT1.T div 60);
+ case GetTimeZoneInformation(TZ) of
+ TIME_ZONE_ID_UNKNOWN : { Time Zone transition dates not used }
+ Minutes := Minutes + TZ.Bias;
+ TIME_ZONE_ID_INVALID :
+ Minutes := Minutes + MinOffset;
+ TIME_ZONE_ID_STANDARD:
+ Minutes := Minutes + (TZ.Bias + TZ.StandardBias);
+ TIME_ZONE_ID_DAYLIGHT:
+ Minutes := Minutes + (TZ.Bias + TZ.DaylightBias);
+ end;
+
+ Result.D := (Minutes div MinutesInDay);
+ Result.T := ((Minutes mod MinutesInDay) * SecondsInMinute) + (DT1.T mod SecondsInMinute);
+end;
+
+{ReadVolumeLabel}
+function ReadVolumeLabel(var VolName : String; Drive : Char) : Cardinal;
+{-Get the volume label for the specified drive.}
+var
+ Root : String;
+ Flags, MaxLength : DWORD;
+ NameSize : Integer;
+begin
+ NameSize := 0;
+ Root := Drive + ':\';
+ if Length(VolName) < 12 then
+ SetLength(VolName, 12);
+ if GetVolumeInformation(PChar(Root), PChar(VolName), Length(VolName),
+ nil, MaxLength, Flags, nil, NameSize)
+ then begin
+ SetLength(VolName, StrLen(PChar(VolName)));
+ Result := 0;
+ end
+ else begin
+ VolName := '';
+ Result := GetLastError;
+ end;
+end;
+
+{SameFile}
+function SameFile(const FilePath1, FilePath2 : String;
+ var ErrorCode : Integer) : Boolean;
+ {-Return true if FilePath1 and FilePath2 refer to the same physical file.
+ Error codes:
+ 0 - Success (no error)
+ 1 - Invalid FilePath1
+ 2 - Invalid FilePath2
+ 3 - Error on FileSetAttr/FileGetAttr }
+var
+ Attr1, Attr2, NewAttr : Integer;
+
+
+ function DirectoryExists(const Name : String): Boolean;
+ var
+ Code : DWORD; {!!.02}
+ Buf : array[0..MAX_PATH] of Char; {!!.01}
+ begin
+ StrPLCopy(Buf, Name, Length(Buf)-1);
+ Code := GetFileAttributes(Buf);
+ Result := (Code <> DWORD(-1)) and {!!.02}
+ (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); {!!.02}
+ end;
+
+begin
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM OFF} {$ENDIF}
+ Result := False;
+ ErrorCode := 0;
+ Attr1 := FileGetAttr(FilePath1);
+ if Attr1 < 0 then begin
+ ErrorCode := 1;
+ Exit;
+ end;
+ Attr2 := FileGetAttr(FilePath2);
+ if Attr2 < 0 then begin
+ {leave ErrorCode at 0 if file not found but path is valid}
+ if not DirectoryExists(ExtractFilePath(FilePath2)) then
+ ErrorCode := 2;
+ Exit;
+ end;
+ if Attr1 <> Attr2 then
+ Exit;
+ if ((Attr1 and faArchive) = 0) then
+ NewAttr := Attr1 or faArchive
+ else
+ NewAttr := Attr1 and (not faArchive);
+ if FileSetAttr(FilePath1, NewAttr) <> 0 then begin
+ ErrorCode := 3;
+ Exit;
+ end;
+ Attr2 := FileGetAttr(FilePath2);
+ if Attr2 < 0 then
+ ErrorCode := 3;
+
+ Result := (Attr2 = NewAttr) or (Attr2 = $80);
+ { If the attribute is set to $00, Win32 automatically sets it to $80. }
+
+ if FileSetAttr(FilePath1, Attr1) <> 0 then
+ ErrorCode := 3;
+{$IFDEF Version6} {$WARN SYMBOL_PLATFORM ON} {$ENDIF}
+end;
+
+{SetMediaID} {!!!! Does not work on NT/2000 !!!!}
+function SetMediaID(Drive : Char; var MediaIDRec : MediaIDType) : Cardinal;
+{-Set the media ID record for the specified drive.}
+type
+ DevIOCtlRegisters = record
+ reg_EBX : LongInt;
+ reg_EDX : LongInt;
+ reg_ECX : LongInt;
+ reg_EAX : LongInt;
+ reg_EDI : LongInt;
+ reg_ESI : LongInt;
+ reg_Flags : LongInt;
+ end;
+var
+ PMid : PMediaIDType;
+ Regs : DevIOCtlRegisters;
+ CB : DWord;
+ HDevice : THandle;
+ SA : TSecurityAttributes;
+begin
+ PMid := @MediaIDRec;
+ with SA do begin
+ nLength := SizeOf(SA);
+ lpSecurityDescriptor := nil;
+ bInheritHandle := True;
+ end;
+ with Regs do begin
+ reg_EAX := $440D;
+ reg_EBX := Ord(System.UpCase(Drive)) - (Ord('A') - 1);
+ reg_ECX := $0846;
+ reg_EDX := LongInt(PMid);
+ end;
+ HDevice := CreateFile('\\.\vwin32', GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,
+ Pointer(@SA), OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
+ if HDevice <> INVALID_HANDLE_VALUE then begin
+ if DeviceIOControl(HDevice, VWIN32_DIOC_DOS_IOCTL, Pointer(@Regs), SizeOf(Regs),
+ Pointer(@Regs), SizeOf(Regs), CB, nil)
+ then
+ Result := 0
+ else
+ Result := GetLastError;
+ CloseHandle(HDevice);
+ end else
+ Result := GetLastError;
+end;
+
+{SplitPath}
+procedure SplitPath(const APath : String; Parts : TStrings);
+{-Splits the provided path into its component sub-paths}
+var
+ i : Integer;
+ iStart : Integer;
+ iStartSlash : Integer;
+ Path, SubPath : String;
+begin
+ Path := APath;
+ if Path = '' then Exit;
+ if not Assigned(Parts) then Exit;
+
+ if Path[ Length( Path ) ] = StPathDelim then
+ Delete( Path, Length( APath ), 1 );
+ iStart := 1;
+ iStartSlash := 1;
+ repeat
+ {find the Slash at iStartSlash}
+ i := FindNthSlash( Path, iStartSlash );
+ {get the subpath}
+ SubPath := Copy( Path, iStart, i - iStart + 1 );
+ iStart := i + 2;
+ inc( iStartSlash );
+ Parts.Add( SubPath );
+ until ( i = Length( Path ) );
+end;
+
+{StDateTimeToFileTime}
+function StDateTimeToFileTime(const FileTime : TStDateTimeRec) : LongInt; {!!.02}
+{-Converts an TStDate and TStTime to a DOS date-time value.}
+var
+ DDT : TDateTime;
+begin
+ DDT := Int(StDateToDateTime(FileTime.D)) + Frac(StTimeToDateTime(FileTime.T));
+ Result := DateTimeToFileDate(DDT);
+end;
+
+{StDateTimeToUnixTime}
+function StDateTimeToUnixTime(const DT1 : TStDateTimeRec) : Longint; {!!.02}
+{-converts a TStDateTimeRec to a time in Unix base (1970)}
+begin
+ Result := ((DT1.D - Date1970) * SecondsInDay) + DT1.T;
+end;
+
+{UnixTimeToStDateTime}
+function UnixTimeToStDateTime(UnixTime : Longint) : TStDateTimeRec;
+{-converts a time in Unix base (1970) to a TStDateTimeRec}
+begin
+ Result.D := Date1970 + (UnixTime div SecondsInDay);
+ Result.T := UnixTime mod SecondsInDay;
+end;
+
+{ValidDrive}
+function ValidDrive(Drive : Char) : Boolean;
+{-Determine if the drive is a valid drive.}
+var
+ DriveBits : LongInt;
+ DriveLtr : Char;
+begin
+ DriveLtr := System.UpCase(Drive);
+ DriveBits := GetLogicalDrives shr (Ord(DriveLtr)-Ord('A'));
+ Result := LongFlagIsSet(DriveBits, $00000001);
+end;
+
+{WriteVolumeLabel}
+function WriteVolumeLabel(const VolName : String; Drive : Char) : Cardinal;
+{-Sets the volume label for the specified drive.}
+var
+ Temp : String;
+ Vol : array[0..11] of Char;
+ Root : array[0..3] of Char;
+begin
+ Temp := VolName;
+ StrCopy(Root, '%:\');
+ Root[0] := Drive;
+ if Length(Temp) > 11 then
+ SetLength(Temp, 11);
+ StrPCopy(Vol, Temp);
+ if Windows.SetVolumeLabel(Root, Vol) then
+ Result := 0
+ else Result := GetLastError;
+end;
+
+
+end.
+
+
+
+
+
+
+
diff --git a/components/systools/source/windows_only/run/sttext.pas b/components/systools/source/windows_only/run/sttext.pas
new file mode 100644
index 000000000..394d6c92d
--- /dev/null
+++ b/components/systools/source/windows_only/run/sttext.pas
@@ -0,0 +1,175 @@
+// 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: StText.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Routines for manipulating Delphi Text files *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StText;
+
+interface
+
+uses
+ Windows,
+ SysUtils, STConst, StBase, StSystem;
+
+function TextSeek(var F : TextFile; Target : LongInt) : Boolean;
+ {-Seek to the specified position in a text file opened for input}
+
+function TextFileSize(var F : TextFile) : LongInt;
+ {-Return the size of a text file}
+
+function TextPos(var F : TextFile) : LongInt;
+ {-Return the current position of the logical file pointer (that is,
+ the position of the physical file pointer, adjusted to account for
+ buffering)}
+
+function TextFlush(var F : TextFile) : Boolean;
+ {-Flush the buffer(s) for a text file}
+
+implementation
+
+function TextSeek(var F : TextFile; Target : LongInt) : Boolean;
+ {-Do a Seek for a text file opened for input. Returns False in case of I/O
+ error.}
+var
+ Pos : LongInt;
+begin
+ with TTextRec(F) do begin
+ {assume failure}
+ Result := False;
+ {check for file opened for input}
+ if Mode <> fmInput then Exit;
+ Pos := FileSeek(Handle, 0, FILE_CURRENT);
+ if Pos = -1 then Exit;
+ Dec(Pos, BufEnd);
+ {see if the Target is within the buffer}
+ Pos := Target-Pos;
+ if (Pos >= 0) and (Pos < LongInt(BufEnd)) then
+ {it is--just move the buffer pointer}
+ BufPos := Pos
+ else begin
+ if FileSeek(Handle, Target, FILE_BEGIN) = -1 then Exit;
+ {tell Delphi its buffer is empty}
+ BufEnd := 0;
+ BufPos := 0;
+ end;
+ end;
+ {if we get to here we succeeded}
+ Result := True;
+end;
+
+function TextFileSize(var F : TextFile) : LongInt;
+ {-Return the size of text file F. Returns -1 in case of I/O error.}
+var
+ Old : LongInt;
+ Res : LongInt;
+begin
+ Result := -1;
+ with TTextRec(F) do begin
+ {check for open file}
+ if Mode = fmClosed then Exit;
+ {get/save current pos of the file pointer}
+ Old := FileSeek(Handle, 0, FILE_CURRENT);
+ if Old = -1 then Exit;
+ {have OS move to end-of-file}
+ Res := FileSeek(Handle, 0, FILE_END);
+ if Res = -1 then Exit;
+ {reset the old position of the file pointer}
+ if FileSeek(Handle, Old, FILE_BEGIN) = - 1 then Exit;
+ end;
+ Result := Res;
+end;
+
+function TextPos(var F : TextFile) : LongInt;
+ {-Return the current position of the logical file pointer (that is,
+ the position of the physical file pointer, adjusted to account for
+ buffering). Returns -1 in case of I/O error.}
+var
+ Position : LongInt;
+begin
+ Result := -1;
+ with TTextRec(F) do begin
+ {check for open file}
+ if Mode = fmClosed then Exit;
+ Position := FileSeek(Handle, 0, FILE_CURRENT);
+ if Position = -1 then Exit;
+ end;
+ with TTextRec(F) do
+ if Mode = fmOutput then {writing}
+ Inc(Position, BufPos)
+ else if BufEnd <> 0 then {reading}
+ Dec(Position, BufEnd-BufPos);
+ {return the calculated position}
+ Result := Position;
+end;
+
+function TextFlush(var F : TextFile) : Boolean;
+ {-Flush the buffer(s) for a text file. Returns False in case of I/O error.}
+var
+ Position : LongInt;
+ Code : Integer;
+begin
+ Result := False;
+ with TTextRec(F) do begin
+ {check for open file}
+ if Mode = fmClosed then Exit;
+ {see if file is opened for reading or writing}
+ if Mode = fmInput then begin
+ {get current position of the logical file pointer}
+ Position := TextPos(F);
+ {exit in case of I/O error}
+ if Position = -1 then Exit;
+ if FileSeek(Handle, Position, FILE_BEGIN) = - 1 then Exit;
+ end
+ else begin
+ {write the current contents of the buffer, if any}
+ if BufPos <> 0 then begin
+ Code := FileWrite(Handle, BufPtr^, BufPos);
+ if Code = -1 {<> 0} then Exit;
+ end;
+ {flush OS's buffers}
+ if not FlushOsBuffers(Handle) then Exit;
+ end;
+ {tell Delphi its buffer is empty}
+ BufEnd := 0;
+ BufPos := 0;
+ end;
+ {if we get to here we succeeded}
+ Result := True;
+end;
+
+
+end.
diff --git a/components/systools/source/windows_only/run/stvinfo.pas b/components/systools/source/windows_only/run/stvinfo.pas
new file mode 100644
index 000000000..55125eca1
--- /dev/null
+++ b/components/systools/source/windows_only/run/stvinfo.pas
@@ -0,0 +1,787 @@
+// 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: StVInfo.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Version Information Extraction Component *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+{$I+} {I/O Checking On}
+
+unit StVInfo;
+
+interface
+
+uses
+ Windows, SysUtils, Classes,
+ StBase, StConst;
+
+{!!.02 - added }
+const
+ STVERMAJOR = 0;
+ STVERMINOR = 1;
+ STVERBUILD = 2;
+ STVERRELEASE = 3;
+{!!.02 - added end }
+
+type
+ PVerTranslation = ^TVerTranslation;
+ TVerTranslation = record
+ Language : Word;
+ CharSet : Word;
+ end;
+
+ TStCustomVersionInfo = class(TStComponent)
+ protected {private}
+{$Z+}
+ FComments : string;
+ FCompanyName : string;
+ FFileDescription : string;
+ FFileDate : TDateTime;
+ FFileFlags : DWORD; {!!.02}
+ FFileFlagsMask : DWORD; {!!.02}
+ FFileMajorVersion : DWORD; {!!.02}
+ FFileMinorVersion : DWORD; {!!.02}
+ FFileName : string;
+ FFileOS : DWORD; {!!.02}
+ FFileType : DWORD; {!!.02}
+ FFileSubtype : DWORD; {!!.02}
+ FFileVersion : string;
+ FFileVersionFloat : Double;
+ FInternalName : string;
+ FLanguageCount : LongInt;
+ FLanguageName : string;
+ FLegalCopyright : string;
+ FLegalTrademark : string;
+ FOriginalFilename : string;
+ FProductMajorVersion : DWORD; {!!.02}
+ FProductMinorVersion : DWORD; {!!.02}
+ FProductName : string;
+ FProductVersion : string;
+ FProductVersionFloat : Double;
+ FTranslationValue : LongInt;
+ VInfoLoaded : Boolean;
+
+ function GetComments : string;
+ function GetCompanyName : string;
+ function GetFileDate: TDateTime;
+ function GetFileDescription : string;
+ function GetFileFlags: DWORD; {!!.02}
+ function GetFileFlagsMask: DWORD; {!!.02}
+ function GetFileMajorVersion: DWORD; {!!.02}
+ function GetFileMinorVersion: DWORD; {!!.02}
+ function GetFileOS: DWORD; {!!.02}
+ function GetFileSubtype: DWORD; {!!.02}
+ function GetFileType: DWORD; {!!.02}
+ function GetFileVersion : string;
+ function GetFileVersionFloat : Double;
+ function GetInternalName : string;
+ function GetLanguageCount: LongInt;
+ function GetLanguageName: string;
+ function GetLegalCopyright : string;
+ function GetLegalTrademark : string;
+ function GetOriginalFilename : string;
+ function GetProductMajorVersion: DWORD; {!!.02}
+ function GetProductMinorVersion: DWORD; {!!.02}
+ function GetProductName : string;
+ function GetProductVersion : string;
+ function GetProductVersionFloat : Double;
+ function GetTranslationValue: LongInt;
+ procedure SetFileName(const Value : string);
+
+ function LoadVersionInfo(const Key : string) : string;
+ procedure Loaded; override;
+
+{!!.02 - added }
+ function GetFileVerSubPart(Index : Integer) : Word;
+ function GetProdVerSubPart(Index : Integer) : Word;
+{!!.02 - added end }
+
+ protected
+
+{$Z-}
+ {properties}
+ property Comments : string
+ read GetComments;
+
+ property CompanyName : string
+ read GetCompanyName;
+
+ property FileDate : TDateTime
+ read GetFileDate;
+
+ property FileDescription : string
+ read GetFileDescription;
+
+ property FileFlags : DWORD {!!.02}
+ read GetFileFlags;
+
+ property FileFlagsMask : DWORD {!!.02}
+ read GetFileFlagsMask;
+
+ property FileMajorVersion : DWORD {!!.02}
+ read GetFileMajorVersion;
+
+ property FileMinorVersion : DWORD {!!.02}
+ read GetFileMinorVersion;
+
+ property FileName : string
+ read FFileName write SetFileName;
+
+ property FileOS : DWORD {!!.02}
+ read GetFileOS;
+
+ property FileType : DWORD {!!.02}
+ read GetFileType;
+
+ property FileSubtype : DWORD {!!.02}
+ read GetFileSubtype;
+
+ property FileVersion : string
+ read GetFileVersion;
+
+ property FileVersionFloat : Double
+ read GetFileVersionFloat;
+
+ property InternalName : string
+ read GetInternalName;
+
+ property LanguageCount : LongInt
+ read GetLanguageCount;
+
+ property LanguageName : string
+ read GetLanguageName;
+
+ property LegalCopyright : string
+ read GetLegalCopyright;
+
+ property LegalTrademark : string
+ read GetLegalTrademark;
+
+ property OriginalFilename : string
+ read GetOriginalFilename;
+
+ property ProductName : string
+ read GetProductName;
+
+ property ProductMajorVersion : DWORD {!!.02}
+ read GetProductMajorVersion;
+
+ property ProductMinorVersion : DWORD {!!.02}
+ read GetProductMinorVersion;
+
+ property ProductVersion : string
+ read GetProductVersion;
+
+ property ProductVersionFloat : Double
+ read GetProductVersionFloat;
+
+ property TranslationValue : LongInt
+ read GetTranslationValue;
+
+{!!.02 - added }
+ property FileVerMajor : Word
+ index STVERMAJOR read GetFileVerSubPart;
+ property FileVerMinor : Word
+ index STVERMINOR read GetFileVerSubPart;
+ property FileVerBuild : Word
+ index STVERBUILD read GetFileVerSubPart;
+ property FileVerRelease : Word
+ index STVERRELEASE read GetFileVerSubPart;
+ property ProductVerMajor : Word
+ index STVERMAJOR read GetProdVerSubPart;
+ property ProductVerMinor : Word
+ index STVERMINOR read GetProdVerSubPart;
+ property ProductVerBuild : Word
+ index STVERBUILD read GetProdVerSubPart;
+ property ProductVerRelease : Word
+ index STVERRELEASE read GetProdVerSubPart;
+{!!.02 - added end }
+
+
+ public
+ { Public declarations }
+{$Z+}
+ constructor Create(AOwner : TComponent);
+ override;
+ destructor Destroy;
+ override;
+{$Z-}
+ function GetKeyValue(const Key : string) : string;
+
+ published
+ { Published declarations }
+ end;
+
+ TStVersionInfo = class(TStCustomVersionInfo)
+ public
+ {properties}
+ property Comments;
+ property CompanyName;
+ property FileDescription;
+ property FileDate;
+ property FileFlags;
+ property FileFlagsMask;
+ property FileMajorVersion;
+ property FileMinorVersion;
+ property FileOS;
+ property FileType;
+ property FileSubtype;
+ property FileVersion;
+ property FileVersionFloat;
+ property InternalName;
+ property LanguageCount;
+ property LanguageName;
+ property LegalCopyright;
+ property LegalTrademark;
+ property OriginalFilename;
+ property ProductMajorVersion;
+ property ProductMinorVersion;
+ property ProductName;
+ property ProductVersion;
+ property ProductVersionFloat;
+ property TranslationValue;
+
+{!!.02 - added }
+ property FileVerMajor;
+ property FileVerMinor;
+ property FileVerBuild;
+ property FileVerRelease;
+ property ProductVerMajor;
+ property ProductVerMinor;
+ property ProductVerBuild;
+ property ProductVerRelease;
+{!!.02 - added end }
+
+
+ published
+ {properties}
+ property FileName;
+ end;
+
+implementation
+
+constructor TStCustomVersionInfo.Create(AOwner : TComponent);
+begin
+ inherited Create(AOwner);
+ VInfoLoaded := False;
+ SetFileName('');
+end;
+
+destructor TStCustomVersionInfo.Destroy;
+begin
+ inherited Destroy;
+end;
+
+function TStCustomVersionInfo.LoadVersionInfo(const Key : string) : string;
+var
+ Handle : DWORD;
+ Res : Boolean;
+ Size : Integer;
+ Error : LongInt;
+ Data : Pointer;
+ Buffer : Pointer;
+ ErrCode : Integer;
+ {$IFDEF VERSION4}
+ Bytes : Cardinal;
+ {$ELSE}
+ Bytes : Integer;
+ {$ENDIF}
+ TempStr : array [0..259] of Char;
+ LangBuff: array [0..259] of Char;
+ BaseStr : string;
+ InfoStr : string;
+ Trans : PVerTranslation;
+ TrSize : Integer;
+ FixedInfo : TVSFixedFileInfo;
+ FT : TFileTime; {!!.02}
+ ST : TSystemTime; {!!.02}
+
+ function MakeFloat(S : string) : Double;
+ var
+ Buff : array [0..5] of Char;
+ I : Integer;
+ Count : Integer;
+ begin
+ Count := 0;
+ FillChar(Buff, SizeOf(Buff), 0);
+ Buff[0] := '0';
+ { The file version string might be specified like }
+ { 4.72.3105.0. Parse it down to just one decimal }
+ { place and create the floating point version #. }
+ for I := 1 to Pred(Length(S)) do begin
+ if S[I] = '.' then begin
+ { Found the first period. Replace it with the DecimalSeparator }
+ { constant so that StrToFloat works properly. }
+ S[I] := {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator;
+ Inc(Count);
+ if (Count = 2) and (I <= Length(Buff)) then begin
+ Move(S[1], Buff, (I - 1) * SizeOf(Char));
+ Break;
+ end;
+ end;
+ end;
+ Result := StrToFloat(Buff);
+ end;
+
+begin
+ TrSize := 0;
+ Size := GetFileVersionInfoSize(StrPCopy(TempStr, FFileName), Handle);
+ if Size = 0 then begin
+ { GetFileVersionInfoSize might fail because the }
+ { file is a 16-bit file or because the file does not }
+ { contain version info. }
+ Error := GetLastError;
+ if Error = ERROR_RESOURCE_TYPE_NOT_FOUND then
+ RaiseStError(EStVersionInfoError, stscNoVerInfo);
+ if Error = 0 then
+ RaiseStError(EStVersionInfoError, stscVerInfoFail);
+ end;
+
+ { Allocate some memory and get version info block. }
+ GetMem(Data, Size);
+ Res := GetFileVersionInfo(TempStr, Handle, Size, Data);
+ Trans := nil;
+ try
+ if not Res then
+ { Error. Raise an exception. }
+ RaiseStError(EStVersionInfoError, stscVerInfoFail);
+
+ { Get the translation value. We need it to get the version info. }
+ Res := VerQueryValue(Data, '\VarFileInfo\Translation', Buffer, Bytes);
+ if not Res then
+ RaiseStError(EStVersionInfoError, stscVerInfoFail);
+ TrSize := Bytes;
+ GetMem(Trans, TrSize);
+ Move(Buffer^, Trans^, TrSize);
+ FTranslationValue := LongInt(Trans^);
+ FLanguageCount := Bytes div SizeOf(TVerTranslation);
+ VerLanguageName(Trans^.Language, LangBuff, Length(LangBuff));
+ FLanguageName := StrPas(LangBuff);
+ VInfoLoaded := True;
+
+ { Build a base string including the translation value. }
+ BaseStr := Format('StringFileInfo\%.4x%.4x\', [Trans^.Language, Trans^.CharSet]);
+
+ { User-defined string. Get the string and exit. }
+ if Key <> '' then begin
+ InfoStr := BaseStr + Key;
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+
+ if Res then begin
+ Result := StrPas(PChar(Buffer));
+// Exit; {!!.02}
+ end else begin
+ Result := '';
+ RaiseStError(EStVersionInfoError, stscBadVerInfoKey);
+ end;
+ end {!!.02}
+ else begin {!!.02}
+
+ { Get the fixed version info. }
+ Bytes := SizeOf(FixedInfo);
+ FillChar(FixedInfo, Bytes, 0);
+ { '\' is used to get the root block. }
+ Res := VerQueryValue(Data, '\', Buffer, Bytes);
+ if not Res then
+ RaiseStError(EStVersionInfoError, stscVerInfoFail);
+
+ Move(Buffer^, FixedInfo, Bytes);
+ with FixedInfo do begin
+ FFileMajorVersion := dwFileVersionMS;
+ FFileMinorVersion := dwFileVersionLS;
+ FProductMajorVersion := dwProductVersionMS;
+ FProductMinorVersion := dwProductVersionLS;
+ FFileFlagsMask := dwFileFlagsMask;
+ FFileFlags := dwFileFlags;
+
+{!!.02 - rewritten }
+ { Note: Most files don't set the binary date. }
+// FFileDate := MakeLong(dwFileDateMS, dwFileDateLS);
+ FT.dwHighDateTime := dwFileDateMS;
+ FT.dwLowDateTime := dwFileDateLS;
+ FileTimeToSystemTime(FT, ST);
+ FFileDate := SystemTimeToDateTime(ST);
+{!!.02 - rewritten end}
+
+ FFileOS := dwFileOS;
+ FFileType := dwFileType;
+ FFileSubtype := dwFileSubtype;
+ end;
+
+ { Comments }
+ InfoStr := BaseStr + 'Comments';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then
+ FComments := StrPas(PChar(Buffer))
+ else
+ FComments := '';
+
+ { CompanyName }
+ InfoStr := BaseStr + 'CompanyName';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then
+ FCompanyName := StrPas(PChar(Buffer))
+ else
+ FCompanyName := '';
+
+ { FileDescription }
+ InfoStr := BaseStr + 'FileDescription';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then
+ FFileDescription := StrPas(PChar(Buffer))
+ else
+ FFileDescription := '';
+
+ { FileVersion }
+ InfoStr := BaseStr + 'FileVersion';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then begin
+ FFileVersion := StrPas(PChar(Buffer));
+ { First try to convert the version number to a float as-is. }
+ Val(FFileVersion, FFileVersionFloat, ErrCode);
+ if ErrCode <> 0 then
+ { Failed. Create the float with the local MakeFloat function. }
+ try
+ FFileVersionFloat := MakeFloat(FFileVersion);
+ except
+ FFileVersionFloat := 0;
+ end;
+ end else begin
+ FFileVersion := '';
+ FFileVersionFloat := 0;
+ end;
+
+ { InternalName }
+ InfoStr := BaseStr + 'InternalName';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then
+ FInternalName := StrPas(PChar(Buffer))
+ else
+ FInternalName := '';
+
+ { LegalCopyright }
+ InfoStr := BaseStr + 'LegalCopyright';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then
+ FLegalCopyright := StrPas(PChar(Buffer))
+ else
+ FLegalCopyright := '';
+
+ { LegalTrademarks }
+ InfoStr := BaseStr + 'LegalTrademarks';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then
+ FLegalTrademark := StrPas(PChar(Buffer))
+ else
+ FLegalTrademark := '';
+
+ { OriginalFilename }
+ InfoStr := BaseStr + 'OriginalFilename';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then
+ FOriginalFilename := StrPas(PChar(Buffer))
+ else
+ FOriginalFilename := '';
+
+ { ProductName }
+ InfoStr := BaseStr + 'ProductName';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then
+ FProductName := StrPas(PChar(Buffer))
+ else
+ FProductName := '';
+
+ { ProductVersion }
+ InfoStr := BaseStr + 'ProductVersion';
+ Res := VerQueryValue(Data, StrPCopy(TempStr, InfoStr), Buffer, Bytes);
+ if Res and (Bytes <> 0) then begin
+ FProductVersion := StrPas(PChar(Buffer));
+ { First try to convert the product number to a float as-is. }
+ Val(FProductVersion, FProductVersionFloat, ErrCode);
+ if ErrCode <> 0 then
+ { Failed. Create the float with the local MakeFloat function. }
+ try
+ FProductVersionFloat := MakeFloat(FProductVersion);
+ except
+ FProductVersionFloat := 0;
+ end;
+ end else begin
+ FProductVersion := '';
+ FProductVersionFloat := 0;
+ end;
+
+ end; {!!.02}
+
+ finally
+ FreeMem(Data, Size);
+ FreeMem(Trans, TrSize);
+ end;
+end;
+
+function TStCustomVersionInfo.GetComments : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FComments;
+end;
+
+function TStCustomVersionInfo.GetCompanyName : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FCompanyName;
+end;
+
+function TStCustomVersionInfo.GetFileDescription : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileDescription;
+end;
+
+function TStCustomVersionInfo.GetFileVersion : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileVersion;
+end;
+
+function TStCustomVersionInfo.GetInternalName : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FInternalName;
+end;
+
+function TStCustomVersionInfo.GetLegalCopyright : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FLegalCopyright;
+end;
+
+function TStCustomVersionInfo.GetLegalTrademark : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FLegalTrademark;
+end;
+
+function TStCustomVersionInfo.GetOriginalFilename : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FOriginalFilename;
+end;
+
+function TStCustomVersionInfo.GetProductName : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FProductName;
+end;
+
+function TStCustomVersionInfo.GetProductVersion : string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FProductVersion;
+end;
+
+function TStCustomVersionInfo.GetProductVersionFloat : Double;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FProductVersionFloat;
+end;
+
+function TStCustomVersionInfo.GetFileVersionFloat : Double;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileVersionFloat;
+end;
+
+procedure TStCustomVersionInfo.SetFileName(const Value : string);
+var
+ Buff : array [0..255] of Char;
+begin
+ if (Value <> '') and not (csDesigning in ComponentState) then
+ if not FileExists(Value) then
+ RaiseStError(EStVersionInfoError, stscFileOpen);
+ if FFileName <> Value then
+ VInfoLoaded := False;
+ FFileName := Value;
+ { If FileName is an emtpy string then load the }
+ { version info for the current process. }
+ if (FFileName = '') and not (csDesigning in ComponentState) then
+ if GetModuleFileName(0, Buff, Length(Buff)) = 0 then
+ FFileName := ''
+ else
+ FFileName := StrPas(Buff);
+end;
+
+function TStCustomVersionInfo.GetFileDate: TDateTime;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileDate;
+end;
+
+function TStCustomVersionInfo.GetFileFlags: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileFlags;
+end;
+
+function TStCustomVersionInfo.GetFileFlagsMask: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileFlagsMask;
+end;
+
+function TStCustomVersionInfo.GetFileOS: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileOS;
+end;
+
+function TStCustomVersionInfo.GetFileSubtype: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileSubtype;
+end;
+
+function TStCustomVersionInfo.GetFileType: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileType;
+end;
+
+function TStCustomVersionInfo.GetFileMajorVersion: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileMajorVersion;
+end;
+
+function TStCustomVersionInfo.GetFileMinorVersion: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FFileMinorVersion;
+end;
+
+function TStCustomVersionInfo.GetProductMajorVersion: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FProductMajorVersion;
+end;
+
+function TStCustomVersionInfo.GetProductMinorVersion: DWORD; {!!.02}
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FProductMinorVersion;
+end;
+
+function TStCustomVersionInfo.GetLanguageCount: LongInt;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FLanguageCount;
+end;
+
+function TStCustomVersionInfo.GetLanguageName: string;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FLanguageName;
+end;
+
+function TStCustomVersionInfo.GetTranslationValue: LongInt;
+begin
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ Result := FTranslationValue;
+end;
+
+function TStCustomVersionInfo.GetKeyValue(const Key: string): string;
+begin
+ Result := LoadVersionInfo(Key);
+end;
+
+procedure TStCustomVersionInfo.Loaded;
+begin
+ inherited Loaded;
+ if FFileName = '' then
+ SetFileName('');
+end;
+
+{!!.02 - added }
+function TStCustomVersionInfo.GetFileVerSubPart(Index: Integer): Word;
+begin
+ Result := 0;
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ case Index of
+ STVERMAJOR: Result := HIWORD(FFileMajorVersion);
+ STVERMINOR: Result := LOWORD(FFileMajorVersion);
+ STVERBUILD: Result := HIWORD(FFileMinorVersion);
+ STVERRELEASE: Result := LOWORD(FFileMinorVersion);
+ end; { case }
+end;
+
+function TStCustomVersionInfo.GetProdVerSubPart(Index: Integer): Word;
+begin
+ Result := 0;
+ if not VInfoLoaded then
+ LoadVersionInfo('');
+ case Index of
+ STVERMAJOR: Result := HIWORD(FProductMajorVersion);
+ STVERMINOR: Result := LOWORD(FProductMajorVersion);
+ STVERBUILD: Result := HIWORD(FProductMinorVersion);
+ STVERRELEASE: Result := LOWORD(FProductMinorVersion);
+ end; { case }
+end;
+{!!.02 - added end }
+
+end.
diff --git a/components/systools/source/windows_only/run/stwmdcpy.pas b/components/systools/source/windows_only/run/stwmdcpy.pas
new file mode 100644
index 000000000..c7c91c253
--- /dev/null
+++ b/components/systools/source/windows_only/run/stwmdcpy.pas
@@ -0,0 +1,149 @@
+// 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: StWmDCpy.pas 4.04 *}
+{*********************************************************}
+{* SysTools: Class for handling WM_COPYDATA exchanges *}
+{*********************************************************}
+
+{$IFDEF FPC}
+ {$mode DELPHI}
+{$ENDIF}
+
+{$I StDefine.inc}
+
+unit StWmDCpy;
+
+interface
+
+uses
+ Windows,
+ SysUtils,
+ Messages,
+ Classes,
+ Forms,
+ Controls,
+ Dialogs,
+
+ StBase;
+
+type
+ TStOnDataReceivedEvent = procedure(Sender : TObject;
+ CopyData : TCopyDataStruct) of object;
+
+ TStWMDataCopy = class(TStComponent)
+ protected {private}
+ { Private declarations }
+ NewWndProc : TFarProc;
+ PrevWndProc : TFarProc;
+ FOnDataReceived : TStOnDataReceivedEvent;
+
+ procedure AppWndProc(var Msg : TMessage);
+ procedure HookForm(Value : Boolean);
+ protected
+ { Protected declarations }
+
+ public
+ { Public declarations }
+
+ constructor Create(AOwner : TComponent); override;
+ destructor Destroy; override;
+ published
+ { Published declarations }
+
+ property OnDataReceived : TStOnDataReceivedEvent
+ read FOnDataReceived
+ write FOnDataReceived;
+ end;
+
+
+implementation
+
+
+constructor TStWMDataCopy.Create(AOwner : TComponent);
+begin
+ inherited Create(AOwner);
+
+ if not (csDesigning in ComponentState) then begin
+{$IFDEF Version6} {$WARN SYMBOL_DEPRECATED OFF} {$ENDIF}
+ NewWndProc := MakeObjectInstance(AppWndProc);
+{$IFDEF Version6} {$WARN SYMBOL_DEPRECATED ON} {$ENDIF}
+ HookForm(True);
+ end;
+end;
+
+destructor TStWMDataCopy.Destroy;
+begin
+ if Assigned(NewWndProc) then begin
+ HookForm(False);
+{$IFDEF Version6} {$WARN SYMBOL_DEPRECATED OFF} {$ENDIF}
+ FreeObjectInstance(NewWndProc);
+{$IFDEF Version6} {$WARN SYMBOL_DEPRECATED ON} {$ENDIF}
+ end;
+
+ inherited Destroy;
+end;
+
+procedure TStWMDataCopy.HookForm(Value : Boolean);
+begin
+ if (not (csDesigning in ComponentState))
+ and not (csDestroying in ComponentState) then begin
+ if Assigned(PrevWndProc) then
+ Exit;
+ if Value then begin
+ PrevWndProc:= Pointer(
+ SetWindowLong(TForm(Owner).Handle, GWL_WNDPROC, LongInt(NewWndProc)))
+ end else if Assigned(PrevWndProc) then begin
+ SetWindowLong(TForm(Owner).Handle, GWL_WNDPROC, LongInt(PrevWndProc));
+ PrevWndProc := nil;
+ end;
+ end;
+end;
+
+procedure TStWMDataCopy.AppWndProc(var Msg : TMessage);
+var
+ CDS : TCopyDataStruct;
+begin
+ with Msg do begin
+ if (Msg = WM_COPYDATA) then begin
+ CDS := PCopyDataStruct(Pointer(lParam))^;
+ if (CDS.dwData = WMCOPYID) then begin
+ if (Assigned(FOnDataReceived)) then
+ FOnDataReceived(Self, CDS);
+ end else
+ if Assigned(PrevWndProc) then
+ Result :=
+ CallWindowProc(PrevWndProc, TForm(Owner).Handle, Msg, wParam, lParam);
+ end else
+ if Assigned(PrevWndProc) then
+ Result :=
+ CallWindowProc(PrevWndProc, TForm(Owner).Handle, Msg, wParam, lParam);
+ end;
+end;
+
+end.