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

systools: Add windows-specific units to new package laz_systoolswin

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6148 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-01-17 23:58:23 +00:00
parent 133a3b98d7
commit 2f86a4b7f9
41 changed files with 11549 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

86
components/systools/examples/windows-only/general_log/exgenlog.lpi Normal file
View File

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

46
components/systools/examples/windows-only/general_log/exgenlog.lpr Normal file
View File

@ -0,0 +1,46 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program 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.

97
components/systools/examples/windows-only/general_log/exglog1.lfm Normal file
View File

@ -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

127
components/systools/examples/windows-only/general_log/exglog1.pas Normal file
View File

@ -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.

90
components/systools/examples/windows-only/nt_log/exnlog1.lfm Normal file
View File

@ -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

88
components/systools/examples/windows-only/nt_log/exnlog1.pas Normal file
View File

@ -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.

83
components/systools/examples/windows-only/nt_log/exntlog.lpi Normal file
View File

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

46
components/systools/examples/windows-only/nt_log/exntlog.lpr Normal file
View File

@ -0,0 +1,46 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program 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.

86
components/systools/examples/windows-only/sort/exsort.lpi Normal file
View File

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

46
components/systools/examples/windows-only/sort/exsort.lpr Normal file
View File

@ -0,0 +1,46 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program 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.

88
components/systools/examples/windows-only/sort/exsortu.lfm Normal file
View File

@ -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

163
components/systools/examples/windows-only/sort/exsortu.pas Normal file
View File

@ -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.

85
components/systools/examples/windows-only/spawn/exspawn.lpi Normal file
View File

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

46
components/systools/examples/windows-only/spawn/exspawn.lpr Normal file
View File

@ -0,0 +1,46 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program 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.

103
components/systools/examples/windows-only/spawn/exspawnu.lfm Normal file
View File

@ -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

114
components/systools/examples/windows-only/spawn/exspawnu.pas Normal file
View File

@ -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.

86
components/systools/examples/windows-only/text_sort/textsort.lpi Normal file
View File

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

46
components/systools/examples/windows-only/text_sort/textsort.lpr Normal file
View File

@ -0,0 +1,46 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program 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.

199
components/systools/examples/windows-only/text_sort/txtsortu.lfm Normal file
View File

@ -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

324
components/systools/examples/windows-only/text_sort/txtsortu.pas Normal file
View File

@ -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.

41
components/systools/examples/windows-only/version_info/exvinfou.lfm Normal file
View File

@ -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

105
components/systools/examples/windows-only/version_info/exvinfou.pas Normal file
View File

@ -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.

91
components/systools/examples/windows-only/version_info/exvrinfo.lpi Normal file
View File

@ -0,0 +1,91 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<Flags>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="exvrinfo"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<VersionInfo>
<UseVersionInfo Value="True"/>
<AutoIncrementBuild Value="True"/>
<MajorVersionNr Value="1"/>
<StringTable Comments="This is a comment" CompanyName="Turbo Power &amp; Lazarus" FileDescription="File version info viewer" InternalName="ExVrInfo" OriginalFilename="ExVrInfo.exe"/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_systoolswin"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="exvrinfo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="exvinfou.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExVInfoU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exvrinfo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

46
components/systools/examples/windows-only/version_info/exvrinfo.lpr Normal file
View File

@ -0,0 +1,46 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program 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.

2
components/systools/laz_systoolsdb.lpk
View File

@ -10,7 +10,7 @@
<SearchPaths> <SearchPaths>
<IncludeFiles Value="source\include;source\db"/> <IncludeFiles Value="source\include;source\db"/>
<OtherUnitFiles Value="source\db"/> <OtherUnitFiles Value="source\db"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\run-db"/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\run\db"/>
</SearchPaths> </SearchPaths>
</CompilerOptions> </CompilerOptions>
<Description Value="Lazarus port of Turbo Power SysTools database components - runtime package"/> <Description Value="Lazarus port of Turbo Power SysTools database components - runtime package"/>

4
components/systools/laz_systoolsdb_design.lpk
View File

@ -9,9 +9,9 @@
<Version Value="11"/> <Version Value="11"/>
<PathDelim Value="\"/> <PathDelim Value="\"/>
<SearchPaths> <SearchPaths>
<IncludeFiles Value="source\design"/> <IncludeFiles Value="source\include"/>
<OtherUnitFiles Value="source\design"/> <OtherUnitFiles Value="source\design"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\design\db"/>
</SearchPaths> </SearchPaths>
</CompilerOptions> </CompilerOptions>
<Description Value="Lazarus port of TurboPower SysTools database components - designtime package"/> <Description Value="Lazarus port of TurboPower SysTools database components - designtime package"/>

75
components/systools/laz_systoolswin.lpk Normal file
View File

@ -0,0 +1,75 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="laz_systoolswin"/>
<Author Value="TurboPower Software"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="source\include"/>
<OtherUnitFiles Value="source\windows_only\run"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\run\win"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Lazarus port of TurboPower SysTools, Windows-only units - runtime package"/>
<License Value="MPL 1.1"/>
<Version Major="4" Release="4"/>
<Files Count="9">
<Item1>
<Filename Value="source\windows_only\run\stsystem.pas"/>
<UnitName Value="StSystem"/>
</Item1>
<Item2>
<Filename Value="source\windows_only\run\sttext.pas"/>
<UnitName Value="StText"/>
</Item2>
<Item3>
<Filename Value="source\windows_only\run\stvinfo.pas"/>
<UnitName Value="StVInfo"/>
</Item3>
<Item4>
<Filename Value="source\windows_only\run\stsort.pas"/>
<UnitName Value="StSort"/>
</Item4>
<Item5>
<Filename Value="source\windows_only\run\stspawn.pas"/>
<UnitName Value="StSpawn"/>
</Item5>
<Item6>
<Filename Value="source\windows_only\run\stregini.pas"/>
<UnitName Value="StRegIni"/>
</Item6>
<Item7>
<Filename Value="source\windows_only\run\stwmdcpy.pas"/>
<UnitName Value="StWmDCpy"/>
</Item7>
<Item8>
<Filename Value="source\windows_only\run\stgenlog.pas"/>
<UnitName Value="StGenLog"/>
</Item8>
<Item9>
<Filename Value="source\windows_only\run\stntlog.pas"/>
<UnitName Value="StNTLog"/>
</Item9>
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

16
components/systools/laz_systoolswin.pas Normal file
View File

@ -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.

51
components/systools/laz_systoolswin_design.lpk Normal file
View File

@ -0,0 +1,51 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="laz_systoolswin_design"/>
<Type Value="DesignTime"/>
<Author Value="TurboPower Software"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="source\include"/>
<OtherUnitFiles Value="source\windows_only\design"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\design\win"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Lazarus port of TurboPower SysTools: Windows-only units, designtime-package"/>
<License Value="MPL 1.1"/>
<Version Major="4" Release="4"/>
<Files Count="1">
<Item1>
<Filename Value="source\windows_only\design\stregwin.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="StRegWin"/>
</Item1>
</Files>
<RequiredPkgs Count="5">
<Item1>
<PackageName Value="laz_systools_design"/>
</Item1>
<Item2>
<PackageName Value="IDEIntf"/>
</Item2>
<Item3>
<PackageName Value="laz_systoolswin"/>
</Item3>
<Item4>
<PackageName Value="LCL"/>
</Item4>
<Item5>
<PackageName Value="FCL"/>
</Item5>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

22
components/systools/laz_systoolswin_design.pas Normal file
View File

@ -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.

135
components/systools/source/windows_only/design/stregwin.pas Normal file
View File

@ -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.

361
components/systools/source/windows_only/run/stexpeng.pas Normal file
View File

@ -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.

804
components/systools/source/windows_only/run/stgenlog.pas Normal file
View File

@ -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.

436
components/systools/source/windows_only/run/stntlog.pas Normal file
View File

@ -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.

2824
components/systools/source/windows_only/run/stregini.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1107
components/systools/source/windows_only/run/stsort.pas Normal file
View File

File diff suppressed because it is too large Load Diff

421
components/systools/source/windows_only/run/stspawn.pas Normal file
View File

@ -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.

1851
components/systools/source/windows_only/run/stsystem.pas Normal file
View File

File diff suppressed because it is too large Load Diff

175
components/systools/source/windows_only/run/sttext.pas Normal file
View File

@ -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.

787
components/systools/source/windows_only/run/stvinfo.pas Normal file
View File

@ -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.

149
components/systools/source/windows_only/run/stwmdcpy.pas Normal file
View File

@ -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.