diff --git a/components/jvcllaz/design/JvCmp/images/images.txt b/components/jvcllaz/design/JvCmp/images/images.txt index 5ba43caa5..7d746f99a 100644 --- a/components/jvcllaz/design/JvCmp/images/images.txt +++ b/components/jvcllaz/design/JvCmp/images/images.txt @@ -1,3 +1,4 @@ tjvstrholder.bmp tjvmultistringholder.bmp tjvspellchecker.bmp +tjvprofiler.bmp \ No newline at end of file diff --git a/components/jvcllaz/design/JvCmp/images/tjvprofiler.bmp b/components/jvcllaz/design/JvCmp/images/tjvprofiler.bmp new file mode 100644 index 000000000..d375adac2 Binary files /dev/null and b/components/jvcllaz/design/JvCmp/images/tjvprofiler.bmp differ diff --git a/components/jvcllaz/design/JvCmp/jvcmpreg.pas b/components/jvcllaz/design/JvCmp/jvcmpreg.pas index 07fdf930d..79c753311 100644 --- a/components/jvcllaz/design/JvCmp/jvcmpreg.pas +++ b/components/jvcllaz/design/JvCmp/jvcmpreg.pas @@ -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); diff --git a/components/jvcllaz/examples/JvProfiler32/Profiler32MainFormU.lfm b/components/jvcllaz/examples/JvProfiler32/Profiler32MainFormU.lfm new file mode 100644 index 000000000..80112a0da --- /dev/null +++ b/components/jvcllaz/examples/JvProfiler32/Profiler32MainFormU.lfm @@ -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 diff --git a/components/jvcllaz/examples/JvProfiler32/Profiler32MainFormU.pas b/components/jvcllaz/examples/JvProfiler32/Profiler32MainFormU.pas new file mode 100644 index 000000000..49ac528fc --- /dev/null +++ b/components/jvcllaz/examples/JvProfiler32/Profiler32MainFormU.pas @@ -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. diff --git a/components/jvcllaz/examples/JvProfiler32/ProfilerDemo.lpi b/components/jvcllaz/examples/JvProfiler32/ProfilerDemo.lpi new file mode 100644 index 000000000..67d5acf3c --- /dev/null +++ b/components/jvcllaz/examples/JvProfiler32/ProfilerDemo.lpi @@ -0,0 +1,81 @@ + + + + + + + + + <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> diff --git a/components/jvcllaz/examples/JvProfiler32/ProfilerDemo.lpr b/components/jvcllaz/examples/JvProfiler32/ProfilerDemo.lpr new file mode 100644 index 000000000..e79fa4a95 --- /dev/null +++ b/components/jvcllaz/examples/JvProfiler32/ProfilerDemo.lpr @@ -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. diff --git a/components/jvcllaz/packages/JvCmpR.lpk b/components/jvcllaz/packages/JvCmpR.lpk index e877b1871..b79745f1b 100644 --- a/components/jvcllaz/packages/JvCmpR.lpk +++ b/components/jvcllaz/packages/JvCmpR.lpk @@ -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> diff --git a/components/jvcllaz/resource/jvcmpreg.res b/components/jvcllaz/resource/jvcmpreg.res index c0698327e..f09d1de21 100644 Binary files a/components/jvcllaz/resource/jvcmpreg.res and b/components/jvcllaz/resource/jvcmpreg.res differ diff --git a/components/jvcllaz/run/JvCmp/jvprofilerform.lfm b/components/jvcllaz/run/JvCmp/jvprofilerform.lfm new file mode 100644 index 000000000..64242ba01 --- /dev/null +++ b/components/jvcllaz/run/JvCmp/jvprofilerform.lfm @@ -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 diff --git a/components/jvcllaz/run/JvCmp/jvprofilerform.pas b/components/jvcllaz/run/JvCmp/jvprofilerform.pas new file mode 100644 index 000000000..6073e55d8 --- /dev/null +++ b/components/jvcllaz/run/JvCmp/jvprofilerform.pas @@ -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.