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

jvcllaz: Add TJvProfiler.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6859 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2019-04-22 22:51:58 +00:00
parent 1dc7fd8705
commit a908ae901c
11 changed files with 1132 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
components/jvcllaz/design/JvCmp/images/images.txt
View File

@ -1,3 +1,4 @@
tjvstrholder.bmp
tjvmultistringholder.bmp
tjvspellchecker.bmp
tjvprofiler.bmp

BIN
components/jvcllaz/design/JvCmp/images/tjvprofiler.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.6 KiB

4
components/jvcllaz/design/JvCmp/jvcmpreg.pas
View File

@ -17,12 +17,12 @@ uses
Classes, PropEdits, ComponentEditors,
JvDsgnConsts,
JvStringHolder, JvSpellChecker,
JvStrHolderEditor;
JvStrHolderEditor, JvProfilerForm;
procedure Register;
begin
RegisterComponents(RsPaletteJvcl, [
TJvStrHolder, TJvMultiStringHolder,
TJvStrHolder, TJvMultiStringHolder, TJvProfiler,
TJvSpellChecker
]);
RegisterComponentEditor(TJvStrHolder, TJvStrHolderEditor);

189
components/jvcllaz/examples/JvProfiler32/Profiler32MainFormU.lfm Normal file
View File

@ -0,0 +1,189 @@
object Profiler32MainForm: TProfiler32MainForm
Left = 343
Height = 357
Top = 157
Width = 466
Caption = 'Profiler 32 test program'
ClientHeight = 357
ClientWidth = 466
Color = clBtnFace
Constraints.MinHeight = 200
Constraints.MinWidth = 380
DefaultMonitor = dmDesktop
Font.Color = clWindowText
KeyPreview = True
OnClose = FormClose
OnCreate = FormCreate
OnKeyDown = FormKeyDown
Position = poScreenCenter
LCLVersion = '2.1.0.0'
Scaled = False
object ListBox1: TListBox
Left = 6
Height = 303
Top = 38
Width = 454
Align = alClient
BorderSpacing.Left = 6
BorderSpacing.Right = 6
BorderStyle = bsNone
Items.Strings = (
'ASSOC'
'AT'
'ATTRIB'
'BREAK'
'CACLS'
'CALL'
'CD'
'CHCP'
'CHDIR'
'CHKDSK'
'CLS'
'CMD'
'COLOR'
'COMP'
'COMPACT'
'CONVERT'
'COPY'
'DATE'
'DEL'
'DIR'
'DISKCOMP'
'DISKCOPY'
'DOSKEY'
'ECHO'
'ENDLOCAL'
'ERASE'
'EXIT'
'FC'
'FIND'
'FINDSTR'
'FOR'
'FORMAT'
'FTYPE'
'GOTO'
'GRAFTABL'
'HELP'
'IF'
'KEYB'
'LABEL'
'MD'
'MKDIR'
'MODE'
'MORE'
'MOVE'
'PATH'
'PAUSE'
'POPD'
'PRINT'
'PROMPT'
'PUSHD'
'RD'
'RECOVER'
'REM'
'REN'
'RENAME'
'REPLACE'
'RESTORE'
'RMDIR'
'SET'
'SETLOCAL'
'SHIFT'
'SORT'
'START'
'SUBST'
'TIME'
'TITLE'
'TREE'
'TYPE'
'VER'
'VERIFY'
'VOL'
'XCOPY'
)
ItemHeight = 15
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Height = 38
Top = 0
Width = 466
Align = alTop
AutoSize = True
BevelOuter = bvNone
ClientHeight = 38
ClientWidth = 466
TabOrder = 1
object Label1: TLabel
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 6
Height = 15
Top = 12
Width = 72
BorderSpacing.Around = 6
Caption = 'Create report:'
ParentColor = False
end
object UseIdBtn: TButton
AnchorSideLeft.Control = Label1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 108
Height = 25
Top = 7
Width = 75
BorderSpacing.Left = 24
BorderSpacing.Around = 6
Caption = 'Use &ID'
OnClick = UseIdBtnClick
TabOrder = 0
end
object UseNameBtn: TButton
AnchorSideLeft.Control = UseIdBtn
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 197
Height = 25
Top = 7
Width = 75
BorderSpacing.Left = 8
BorderSpacing.Around = 6
Caption = 'Use &name'
OnClick = UseNameBtnClick
TabOrder = 1
end
object ResultBtn: TButton
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Panel1
AnchorSideRight.Side = asrBottom
Left = 385
Height = 25
Top = 7
Width = 75
Anchors = [akTop, akRight]
BorderSpacing.Left = 80
BorderSpacing.Around = 6
Caption = '&Result'
OnClick = ResultBtnClick
TabOrder = 2
end
end
object Progress: TProgressBar
Left = 0
Height = 16
Top = 341
Width = 466
Align = alBottom
TabOrder = 2
end
object P: TJvProfiler
left = 376
top = 56
end
end

171
components/jvcllaz/examples/JvProfiler32/Profiler32MainFormU.pas Normal file
View File

@ -0,0 +1,171 @@
{-----------------------------------------------------------------------------
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/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvLookOut.PAS, released on 2002-05-26.
The Initial Developer of the Original Code is Peter Th�rnqvist [peter3 att users dott sourceforge dott net]
Portions created by Peter Th�rnqvist are Copyright (C) 2002 Peter Th�rnqvist.
All Rights Reserved.
Contributor(s):
Last Modified: 2002-05-26
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
-----------------------------------------------------------------------------}
unit Profiler32MainFormU;
{$mode objfpc}{$H+}
interface
uses
//Windows, Messages,
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, ComCtrls, //JvComponent,
JvProfilerForm;
type
TProfiler32MainForm = class(TForm)
ListBox1: TListBox;
Panel1: TPanel;
UseIdBtn: TButton;
UseNameBtn: TButton;
ResultBtn: TButton;
Label1: TLabel;
Progress: TProgressBar;
P: TJvProfiler;
procedure FormCreate(Sender: TObject);
procedure ResultBtnClick(Sender: TObject);
procedure UseNameBtnClick(Sender: TObject);
procedure UseIdBtnClick(Sender: TObject);
procedure FormClose(Sender: TObject; var AAction: TCloseAction);
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
private
FTerminated:boolean;
end;
var
Profiler32MainForm: TProfiler32MainForm;
implementation
{$R *.lfm}
const
DefCaption = 'JvProfiler 32 Test program';
procedure TProfiler32MainForm.FormCreate(Sender: TObject);
begin
P.Names := ListBox1.Items;
P.Sorted := true;
P.Enabled := true;
FTerminated := false;
end;
procedure TProfiler32MainForm.ResultBtnClick(Sender: TObject);
begin
P.ShowReport;
end;
procedure TProfiler32MainForm.UseNameBtnClick(Sender: TObject);
var i,j,k:integer;
begin
Randomize;
{ just randomize to get some results }
Screen.Cursor := crHourGlass;
UseIdBtn.Enabled := false;
UseNameBtn.Enabled := false;
ResultBtn.Enabled := false;
P.Start;
try
k := Random(133);
Progress.Max := k;
for j := 0 to k do
begin
Progress.Position := j;
Caption := Format('%s - to do: %d',[DefCaption,k - j]);
i := Random(ListBox1.Items.Count);
{ use integer ID (Names[i] ID = i) }
P.EnterID(i);
Sleep(random(333)); // wp: replaces next line
// SleepEx(random(333),false);
P.ExitID(i);
Application.ProcessMessages;
if FTerminated then
Break;
end;
finally
Screen.Cursor := crDefault;
UseIdBtn.Enabled := true;
UseNameBtn.Enabled := true;
ResultBtn.Enabled := true;
end;
P.Stop;
Beep;
Progress.Position := 0;
end;
procedure TProfiler32MainForm.UseIdBtnClick(Sender: TObject);
var i,j,k:integer;
begin
Randomize;
P.Start;
{ make distributed randomize to get some results }
Screen.Cursor := crHourGlass;
UseIdBtn.Enabled := false;
UseNameBtn.Enabled := false;
ResultBtn.Enabled := false;
try
k := Random(100);
Progress.Max := k;
for j := 0 to k do
begin
Progress.Position := j;
Caption := Format('%s - to do: %d',[DefCaption,k - j]);
i := Random(ListBox1.Items.Count);
{ use string ID instead }
P.EnterName(P.Names[i]);
Sleep(10 * j); // wp: replaces next line
//SleepEx(10 * j,false);
P.ExitName(P.Names[i]);
Application.ProcessMessages;
if FTerminated then
Break;
end;
finally
Screen.Cursor := crDefault;
UseIdBtn.Enabled := true;
UseNameBtn.Enabled := true;
ResultBtn.Enabled := true;
end;
P.Stop;
Beep;
Progress.Position := 0;
end;
procedure TProfiler32MainForm.FormClose(Sender: TObject; var AAction: TCloseAction);
begin
Fterminated := true;
P.Enabled := false;
P.Stop;
end;
procedure TProfiler32MainForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = 27 then FTerminated := true;
end;
end.

81
components/jvcllaz/examples/JvProfiler32/ProfilerDemo.lpi Normal file
View File

@ -0,0 +1,81 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<Title Value="ProfilerDemo"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="JvCmpR"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units>
<Unit>
<Filename Value="ProfilerDemo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="Profiler32MainFormU.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Profiler32MainForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="ProfilerDemo"/>
</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>

15
components/jvcllaz/examples/JvProfiler32/ProfilerDemo.lpr Normal file
View File

@ -0,0 +1,15 @@
program ProfilerDemo;
uses
Interfaces,
Forms,
Profiler32MainFormU in 'Profiler32MainFormU.pas' {Profiler32MainForm};
{$R *.res}
begin
Application.Scaled:=True;
Application.Initialize;
Application.CreateForm(TProfiler32MainForm, Profiler32MainForm);
Application.Run;
end.

6
components/jvcllaz/packages/JvCmpR.lpk
View File

@ -18,7 +18,7 @@
- StringHolder (easier access to TStrings at designtime)."/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="4"/>
<Files Count="4">
<Files Count="5">
<Item1>
<Filename Value="..\run\JvCmp\JvSpellChecker.pas"/>
<UnitName Value="JvSpellChecker"/>
@ -35,6 +35,10 @@
<Filename Value="..\run\JvCmp\jvstringholder.pas"/>
<UnitName Value="JvStringHolder"/>
</Item4>
<Item5>
<Filename Value="..\run\JvCmp\jvprofilerform.pas"/>
<UnitName Value="JvProfilerForm"/>
</Item5>
</Files>
<RequiredPkgs Count="2">
<Item1>

BIN
components/jvcllaz/resource/jvcmpreg.res
View File

Binary file not shown.

143
components/jvcllaz/run/JvCmp/jvprofilerform.lfm Normal file
View File

@ -0,0 +1,143 @@
object ProfReport: TProfReport
Left = 470
Height = 305
Top = 178
Width = 550
ActiveControl = lvReport
BorderIcons = [biSystemMenu]
Caption = 'Profiler Report'
ClientHeight = 305
ClientWidth = 550
Color = clBtnFace
Font.Color = clBlack
Icon.Data = {
FE0200000000010001002020040000000000E802000016000000280000002000
0000400000000100040000000000000200000000000000000000000000000000
0000000000000000800000800000008080008000000080008000808000008080
8000C0C0C0000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
FF00000007777777777777777777777777000000777777777777777777777777
77700030000000000000000000000007777703BBBBBBBBBBBBBBBBBBBBBBBB80
77773BBBBBBBBBBBBBBBBBBBBBBBBBB807773BBBBBBBBBBBBBBBBBBBBBBBBBBB
07773BBBBBBBBBBBB8008BBBBBBBBBBB07703BBBBBBBBBBBB0000BBBBBBBBBB8
077003BBBBBBBBBBB0000BBBBBBBBBB0770003BBBBBBBBBBB8008BBBBBBBBB80
7700003BBBBBBBBBBBBBBBBBBBBBBB077000003BBBBBBBBBBB0BBBBBBBBBB807
70000003BBBBBBBBB808BBBBBBBBB07700000003BBBBBBBBB303BBBBBBBB8077
000000003BBBBBBBB000BBBBBBBB0770000000003BBBBBBB80008BBBBBB80770
0000000003BBBBBB30003BBBBBB077000000000003BBBBBB00000BBBBB807700
00000000003BBBBB00000BBBBB07700000000000003BBBBB00000BBBB8077000
000000000003BBBB00000BBBB0770000000000000003BBBB00000BBB80770000
0000000000003BBB80008BBB077000000000000000003BBBBBBBBBB807700000
00000000000003BBBBBBBBB07700000000000000000003BBBBBBBB8077000000
000000000000003BBBBBBB0770000000000000000000003BBBBBB80770000000
0000000000000003BBBBB077000000000000000000000003BBBB807000000000
00000000000000003BB800000000000000000000000000000333000000000000
0000F8000003F0000001C0000000800000000000000000000000000000010000
00018000000380000003C0000007C0000007E000000FE000000FF000001FF000
001FF800003FF800003FFC00007FFC00007FFE0000FFFE0000FFFF0001FFFF00
01FFFF8003FFFF8003FFFFC007FFFFC007FFFFE00FFFFFE01FFFFFF07FFFFFF8
FFFF
}
OnShow = FormShow
Position = poScreenCenter
ShowHint = True
LCLVersion = '2.1.0.0'
object Panel1: TPanel
Left = 0
Height = 37
Top = 268
Width = 550
Align = alBottom
AutoSize = True
BevelOuter = bvNone
ClientHeight = 37
ClientWidth = 550
TabOrder = 0
object SaveBtn: TButton
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 6
Height = 25
Hint = 'Save report to a file (compatible with Excel)'
Top = 6
Width = 75
BorderSpacing.Around = 6
Caption = '&Save...'
OnClick = SaveBtnClick
TabOrder = 0
end
object TrimBtn: TButton
AnchorSideLeft.Control = SaveBtn
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 87
Height = 25
Hint = 'Remove unused calls from the list'
Top = 6
Width = 75
BorderSpacing.Around = 6
Caption = '&Trim'
OnClick = TrimBtnClick
TabOrder = 1
end
object OKBtn: TButton
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
AnchorSideRight.Control = Panel1
AnchorSideRight.Side = asrBottom
Left = 469
Height = 25
Hint = 'Close report window'
Top = 6
Width = 75
Anchors = [akTop, akRight]
BorderSpacing.Around = 6
Cancel = True
Caption = '&Close'
Default = True
ModalResult = 1
OnClick = OKBtnClick
TabOrder = 2
end
end
object lvReport: TListView
Left = 0
Height = 268
Hint = 'Click the top column to sort the items'
Top = 0
Width = 550
Align = alClient
BorderStyle = bsNone
Columns = <
item
Caption = 'Function / Procedure '
Width = 160
end
item
Alignment = taRightJustify
Caption = 'Total time (ms)'
Width = 100
end
item
Alignment = taRightJustify
Caption = 'Calls'
end
item
Alignment = taRightJustify
Caption = 'Average time (ms)'
Width = 120
end
item
Alignment = taRightJustify
Caption = 'Percent (%)'
Width = 90
end>
GridLines = True
MultiSelect = True
RowSelect = True
TabOrder = 1
ViewStyle = vsReport
OnColumnClick = lvReportColumnClick
end
end

525
components/jvcllaz/run/JvCmp/jvprofilerform.pas Normal file
View File

@ -0,0 +1,525 @@
{-----------------------------------------------------------------------------
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/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvProfilerForm.PAS, released on 2002-05-26.
The Initial Developer of the Original Code is Certified Software Corp. [certsoft att quest-net dott com]
Portions created by Peter Th�rnqvist are Copyright (C) 1996 Certified Software Corp.
All Rights Reserved.
Contributor(s): Peter Th�rnqvist [peter3 at sourceforge dot net]
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
Use QueryPerformanceCounter / Frequency instead of GetTickCount (the high resolution timer)
-----------------------------------------------------------------------------}
// $Id$
unit JvProfilerForm;
{$mode objfpc}{$H+}
interface
uses
Classes, Dialogs, ComCtrls, StdCtrls, Controls, ExtCtrls, Forms;
const
MaxProfEntries = 1024; { maximum number of "blocks" to profile }
MaxStackSize = 1024; { maximum nesting of blocks at any one time }
var
OddClick: Boolean = True;
type
TJvProfileInfo = array [0..MaxProfEntries - 1] of record
InOutTime: Longint;
TimeSpent: Longint;
Calls: Longint;
StringID: string;
end;
TProcStack = array [1..MaxStackSize] of record
CallerID: Integer;
EntryTime: Longint;
end;
TProfReport = class(TForm)
Panel1: TPanel;
SaveBtn: TButton;
lvReport: TListView;
OKBtn: TButton;
TrimBtn: TButton;
procedure FormShow(Sender: TObject);
procedure lvReportColumnClick(Sender: TObject; Column: TListColumn);
procedure SaveBtnClick(Sender: TObject);
procedure OKBtnClick(Sender: TObject);
procedure TrimBtnClick(Sender: TObject);
public
StartTime: Integer;
EndTime: Integer;
LastProc: Integer;
ProfileInfo: TJvProfileInfo;
end;
TJvProfiler = class(TComponent)
private
FProfileInfo: TJvProfileInfo;
FNames: TStringList;
FStack: TProcStack;
FStartTime: Longint;
FEndTime: Longint;
FLastProc: Integer;
FStackSize: Integer;
FEnabled: Boolean;
FStarted: Boolean;
FSorted: Boolean;
FOnStart: TNotifyEvent;
FOnStop: TNotifyEvent;
function GetNames: TStrings;
procedure SetNames(Value: TStrings);
procedure SetEnabled(Value: Boolean);
procedure SetSorted(Value: Boolean);
protected
procedure DoStart; virtual;
procedure DoStop; virtual;
procedure Initialize; virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Start;
procedure EnterID(ID: Integer);
procedure EnterName(const AName: string);
procedure ExitName(const AName: string);
procedure ExitID(ID: Integer);
procedure Stop;
procedure ShowReport;
published
property Enabled: Boolean read FEnabled write SetEnabled default False;
property Names: TStrings read GetNames write SetNames;
property Sorted: Boolean read FSorted write SetSorted default False;
property OnStart: TNotifyEvent read FOnStart write FOnStart;
property OnStop: TNotifyEvent read FOnStop write FOnStop;
end;
implementation
uses
{$IFDEF LINUX}
baseunix, unix, linux, users,
{$ELSE}
Windows,
{$ENDIF}
SysUtils, LazUTF8,
JvConsts, JvTypes, JvResources;
{$R *.lfm}
const
EmptyLine = '0.00';
DefHeader2 =
'Profiler 32 - (C) 1996 Certified Software Corp, portions Copyright (C) 1997 by Peter Th�rnqvist; all rights reserved.';
type
PProfType = ^TProfType;
TProfType = record
InOutTime: Integer;
TimeSpent: Integer;
Calls: Integer;
StringID: string;
end;
PStackType = ^TStackType;
TStackType = record
CallerID: Integer;
EntryTime: Integer;
end;
function GetUserName: String;
// http://forum.lazarus.freepascal.org/index.php/topic,23171.msg138057.html#msg138057
{$IFDEF WINDOWS}
const
MaxLen = 256;
var
Len: DWORD;
WS: WideString;
Res: windows.BOOL;
{$ENDIF}
begin
Result := '';
{$IFDEF UNIX}
{$IF (DEFINED(LINUX)) OR (DEFINED(FREEBSD))}
Result := SysToUtf8(users.GetUserName(fpgetuid)); //GetUsername in unit Users, fpgetuid in unit BaseUnix
{$ELSE Linux/BSD}
Result := GetEnvironmentVariableUtf8('USER');
{$ENDIF UNIX}
{$ELSE}
{$IFDEF WINDOWS}
Len := MaxLen;
{$IFnDEF WINCE}
if Win32MajorVersion <= 4 then begin
SetLength(Result,MaxLen);
Res := Windows.GetUserName(@Result[1], Len);
//writeln('GetUserNameA = ',Res);
if Res then begin
SetLength(Result,Len-1);
Result := WinCPToUtf8(Result);
end else
SetLength(Result,0);
end
else
{$ENDIF NOT WINCE}
begin
SetLength(WS, MaxLen-1);
Res := Windows.GetUserNameW(@WS[1], Len);
//writeln('GetUserNameW = ',Res);
if Res then begin
SetLength(WS, Len - 1);
Result := Utf16ToUtf8(WS);
end else
SetLength(Result,0);
end;
{$ENDIF WINDOWS}
{$ENDIF UNIX}
end;
function GetComputerName : string;
{$IFDEF WINDOWS}
var
len : cardinal;
begin
len := MAX_COMPUTERNAME_LENGTH + 1;
SetLength(result, len);
if Windows.GetComputerName(PChar(result), len) then begin
SetLength(Result, len);
Result := WinCPToUTF8(Result);
end
else
RaiseLastWin32Error;
end;
{$ELSE}
begin
Result := GetHostName;
end;
{$ENDIF}
//=== { TJvProfiler } ========================================================
constructor TJvProfiler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FNames := TStringList.Create;
end;
destructor TJvProfiler.Destroy;
begin
Stop;
FNames.Free;
inherited Destroy;
end;
procedure TJvProfiler.Initialize;
var
I: Integer;
begin
FEnabled := False;
FStarted := False;
FStartTime := 0;
FEndTime := 0;
FStackSize := 0;
FLastProc := -1;
{ build ID list }
for I := 0 to FNames.Count - 1 do
begin
if Length(Trim(FNames[I])) < 1 then
Continue; { skip empty ID's }
if FLastProc > MaxProfEntries then
raise EJVCLException.CreateResFmt(@RsEMaxNumberOfIDsExceededd, [MaxProfEntries - 1]);
Inc(FLastProc);
with FProfileInfo[FLastProc] do
begin
TimeSpent := 0;
Calls := 0;
StringID := FNames[I];
end;
end;
end;
procedure TJvProfiler.EnterID(ID: Integer);
var
Snap: Integer;
begin
if FEnabled then
begin
Snap := GetTickCount;
if FStackSize > MaxStackSize then
raise EJVCLException.CreateResFmt(@RsEMaxStackSizeExceededd, [MaxStackSize]);
Inc(FStackSize);
with FStack[FStackSize] do
begin
EntryTime := Snap;
CallerID := ID
end;
with FProfileInfo[ID] do
begin
Inc(Calls);
InOutTime := Snap;
end;
end;
end;
procedure TJvProfiler.EnterName(const AName: string);
begin
EnterID(FNames.IndexOf(AName));
end;
procedure TJvProfiler.ExitName(const AName: string);
begin
ExitID(FNames.IndexOf(AName));
end;
procedure TJvProfiler.ExitID(ID: Integer);
var
Snap, Elapsed: Integer;
begin
if Enabled then
begin
Snap := GetTickCount;
with FProfileInfo[ID] do
begin
Elapsed := Snap - InOutTime;
TimeSpent := TimeSpent + Elapsed;
end;
if FStackSize > 0 then
Dec(FStackSize);
if FStackSize > 0 then
with FProfileInfo[FStack[FStackSize].CallerID] do
TimeSpent := TimeSpent - Elapsed;
end;
end;
procedure TJvProfiler.DoStart;
begin
if Assigned(FOnStart) then
FOnStart(Self);
end;
procedure TJvProfiler.DoStop;
begin
if Assigned(FOnStop) then
FOnStop(Self);
end;
procedure TJvProfiler.Start;
begin
if FEnabled and not FStarted then
begin
// Initialize;
DoStart;
FStartTime := GetTickCount;
FStarted := True;
end;
end;
procedure TJvProfiler.Stop;
begin
if FEnabled and FStarted then
begin
FEndTime := GetTickCount;
DoStop;
FStarted := False;
end;
end;
function TJvProfiler.GetNames: TStrings;
begin
Result := FNames;
end;
procedure TJvProfiler.SetNames(Value: TStrings);
begin
FNames.Assign(Value);
Initialize;
end;
procedure TJvProfiler.SetEnabled(Value: Boolean);
begin
if FEnabled <> Value then
FEnabled := Value;
end;
procedure TJvProfiler.SetSorted(Value: Boolean);
begin
if FSorted <> Value then
begin
FSorted := Value;
FNames.Sorted := FSorted;
Initialize;
end;
end;
procedure TJvProfiler.ShowReport;
begin
if FEnabled then
begin
if FStarted then
Stop;
with TProfReport.Create(nil) do
begin
EndTime := FEndTime;
StartTime := FStartTime;
LastProc := FLastProc;
ProfileInfo := FProfileInfo;
ShowModal;
Free;
end;
end;
end;
//=== { TProfReport } ========================================================
procedure TProfReport.FormShow(Sender: TObject);
const
NumberFormat = '%4.2f';
var
ThisProc: Integer;
TotalSum: Integer;
LItem: TListItem;
begin
OddClick := True;
TotalSum := (EndTime - StartTime);
if TotalSum = 0 then
Exit;
lvReport.Items.BeginUpdate;
lvReport.Items.Clear;
for ThisProc := 0 to LastProc do
with ProfileInfo[ThisProc] do
begin
LItem := lvReport.Items.Add;
LItem.Caption := StringID; { function ID }
if Calls <> 0 then
begin
LItem.SubItems.Add(Format(NumberFormat, [TimeSpent * 1.0])); { Total time spent here }
LItem.SubItems.Add(IntToStr(Calls)); { Total number of calls }
LItem.SubItems.Add(Format(NumberFormat, [TimeSpent / Calls])); { average time }
LItem.SubItems.Add(Format(NumberFormat, [TimeSpent / TotalSum * 100.0])); { percentage }
end
else
begin
LItem.SubItems.Add(EmptyLine);
LItem.SubItems.Add('0');
LItem.SubItems.Add(EmptyLine);
LItem.SubItems.Add(EmptyLine);
end;
end;
Caption := Format(RsTotalElapsedTimedms, [RsDefCaption, TotalSum]);
lvReport.Items.EndUpdate;
end;
function IsFloat(S: string): Boolean;
var
x: Double;
begin
Result := TryStrToFloat(S, x);
end;
function DefSort(lParam1, lParam2: TListItem; lParamSort: Integer): Integer; stdcall;
var
l1, l2: Extended;
begin
if lParamSort = 0 then
Result := AnsiCompareText(lParam1.Caption, lParam2.Caption)
else
begin
if not IsFloat(lParam1.SubItems[lParamSort - 1]) then
l1 := -1.0
else
l1 := StrToFloat(lParam1.SubItems[lParamSort - 1]);
if not IsFloat(lParam2.SubItems[lParamSort - 1]) then
l2 := -1.0
else
l2 := StrToFloat(lParam2.SubItems[lParamSort - 1]);
Result := Round((l1 * 1000) - (l2 * 1000));
end;
if OddClick then
Result := -Result;
end;
procedure TProfReport.lvReportColumnClick(Sender: TObject; Column: TListColumn);
begin
// lvReport.Items.BeginUpdate;
lvReport.CustomSort(TLVCompare(@DefSort), Column.Index);
OddClick := not OddClick;
// lvReport.Items.EndUpdate;
end;
procedure TProfReport.SaveBtnClick(Sender: TObject);
var
OutList: TStringList;
S: string;
I, J: Integer;
begin
with TSaveDialog.Create(nil) do
begin
Filter := RsTextFormatsasctxtinfdocAllFiles;
if Execute then
begin
OutList := TStringList.Create;
OutList.Add(Format(RsDefHeader, [DateToStr(Now), GetUserName,
GetComputerName]));
OutList.Add(DefHeader2);
S := '';
for I := 0 to lvReport.Columns.Count - 1 do
S := S + lvReport.Columns[I].Caption + Tab;
OutList.Add(S);
S := '';
with lvReport do
for I := 0 to Items.Count - 1 do
begin
with Items[I] do
begin
S := S + Caption + Tab;
for J := 0 to SubItems.Count - 1 do
S := S + SubItems[J] + Tab;
OutList.Add(S);
end;
S := '';
end;
OutList.SaveToFile(Filename);
OutList.Free;
end;
Free;
end;
end;
procedure TProfReport.OKBtnClick(Sender: TObject);
begin
Close;
end;
procedure TProfReport.TrimBtnClick(Sender: TObject);
var
I: Integer;
begin
lvReport.Items.BeginUpdate;
for I := lvReport.Items.Count - 1 downto 0 do
{ no calls = not used }
if lvReport.Items[I].SubItems[1] = '0' then
lvReport.Items.Delete(I);
lvReport.Items.EndUpdate;
end;
end.