You've already forked lazarus-ccr
jvcllaz: Add TJvProfiler.
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
525
components/jvcllaz/run/JvCmp/jvprofilerform.pas
Normal file
525
components/jvcllaz/run/JvCmp/jvprofilerform.pas
Normal 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.
|
||||
Reference in New Issue
Block a user