diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..604a703 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +lib/ +backup/ diff --git a/LazProfiler.lpk b/LazProfiler.lpk index a70f650..fc1d31a 100644 --- a/LazProfiler.lpk +++ b/LazProfiler.lpk @@ -1,6 +1,6 @@ - + @@ -9,6 +9,7 @@ + @@ -16,7 +17,7 @@ - + @@ -40,6 +41,7 @@ + diff --git a/LazProfilerAddon.pas b/LazProfilerAddon.pas index e39eac9..456abbe 100644 --- a/LazProfilerAddon.pas +++ b/LazProfilerAddon.pas @@ -36,20 +36,18 @@ interface TLPFile = class private - fFilename, - fFilenameUp, - fPackageName: String; - fChanged: Boolean; + fFilename, fFilenameUp, fPackageName: string; + fChanged: boolean; fText: TStringList; - fSaved: Boolean; + fSaved: boolean; protected public - constructor Create(pFilename, pPackageName: String); + constructor Create(pFilename, pPackageName: string); destructor Destroy; override; - function Save: Boolean; - property Filename: String read fFilename; - property FilenameUp: String read fFilenameUp; - property PackageName: String read fPackageName; + function Save: boolean; + property Filename: string read fFilename; + property FilenameUp: string read fFilenameUp; + property PackageName: string read fPackageName; property Changed: boolean read fChanged write fChanged; property Text: TStringList read fText; end; @@ -61,7 +59,7 @@ TLPFileList = class(specialize TObjectList) private protected public - function IndexOf(pFilename: String): SizeInt; overload; + function IndexOf(pFilename: string): SizeInt; overload; end; @@ -75,11 +73,12 @@ TLPvtvPasProc = class(TvtvObj) public constructor Create(pProc: TLPPasProc); procedure UpdateCheckState; - function CellText(Column: TColumnIndex; TextType: TVSTTextType): String; override; - function ImageIndex(pColumn: TColumnIndex): Integer; override; + function CellText(Column: TColumnIndex; TextType: TVSTTextType): string; override; + function ImageIndex(pColumn: TColumnIndex): integer; override; procedure InitNode(pVST: TBaseVirtualTree; pNode: PVirtualNode); override; property PasProc: TLPPasProc read fPasProc; end; + PLPvtvProc = ^TLPvtvPasProc; @@ -90,10 +89,10 @@ TLPvtvPasClass = class(TLPvtvPasProc) fPasClass: TLPPasClass; protected public - constructor Create(pNameOfClass, pUnitName, pFileName, pPackageName: String); + constructor Create(pNameOfClass, pUnitName, pFileName, pPackageName: string); destructor Destroy; override; - function CellText(Column: TColumnIndex; TextType: TVSTTextType): String; override; - function ImageIndex(pColumn: TColumnIndex): Integer; override; + function CellText(Column: TColumnIndex; TextType: TVSTTextType): string; override; + function ImageIndex(pColumn: TColumnIndex): integer; override; function InitialStates: TVirtualNodeInitStates; override; procedure UpdateExpanded; override; property PasClass: TLPPasClass read fPasClass write fPasClass; @@ -107,10 +106,10 @@ TLPvtvPasUnit = class(TLPvtvPasProc) fPasUnit: TLPPasUnit; protected public - constructor Create(pUnitName, pFileName, pPackageName: String); + constructor Create(pUnitName, pFileName, pPackageName: string); destructor Destroy; override; - function CellText(Column: TColumnIndex; TextType: TVSTTextType): String; override; - function ImageIndex(pColumn: TColumnIndex): Integer; override; + function CellText(Column: TColumnIndex; TextType: TVSTTextType): string; override; + function ImageIndex(pColumn: TColumnIndex): integer; override; function InitialStates: TVirtualNodeInitStates; override; procedure UpdateExpanded; override; property PasUnit: TLPPasUnit read fPasUnit write fPasUnit; @@ -124,10 +123,10 @@ TLPvtvPasPackage = class(TLPvtvPasProc) fPasPackage: TLPPasPackage; protected public - constructor Create(pPackageName: String); + constructor Create(pPackageName: string); destructor Destroy; override; - function CellText(Column: TColumnIndex; TextType: TVSTTextType): String; override; - function ImageIndex(pColumn: TColumnIndex): Integer; override; + function CellText(Column: TColumnIndex; TextType: TVSTTextType): string; override; + function ImageIndex(pColumn: TColumnIndex): integer; override; function InitialStates: TVirtualNodeInitStates; override; procedure UpdateExpanded; override; property PasPackage: TLPPasPackage read fPasPackage write fPasPackage; @@ -138,41 +137,44 @@ TLPvtvPasPackage = class(TLPvtvPasProc) TProfilerAddon = class(TCustomLazProfiler) private - fProfiling: Boolean; + fProfiling: boolean; fProject: TLazProject; - fSourcesInstrumented: Boolean; - fFileList, - fIncludeList: TLPFileList; - fProjectDir: String; - fIncludePath: String; - fTargetDir: String; - fTargetName: String; - fOldModified: Boolean; - procedure BuildFileList(pExtensionMask: String; pCheckForBelongsToProject: Boolean); - function AddProc(pName: String; pToken: Integer; pNameOfClass, pUnitName, pFileName, pPackageName: String; pRow: Integer): Integer; - procedure SetActive(pActive: Boolean); + fSourcesInstrumented: boolean; + fFileList, fIncludeList: TLPFileList; + fProjectDir: string; + fIncludePath: string; + fTargetDir: string; + fTargetName: string; + fOldModified: boolean; + procedure BuildFileList(pExtensionMask: string; pCheckForBelongsToProject: boolean); + function AddProc(pName: string; pToken: integer; + pNameOfClass, pUnitName, pFileName, pPackageName: string; pRow: integer): integer; + procedure SetActive(pActive: boolean); protected - fEpikTimerPath: String; - fLazProfilerPath: String; - fUnitOutputDirectory: String; + fEpikTimerPath: string; + fLazProfilerPath: string; + fUnitOutputDirectory: string; fOldPackageList: TLPPasPackageList; fOldUnitList: TLPPasUnitList; fOldClassList: TLPPasClassList; fOldProcList: TLPPasProcList; procedure ModifySettings; - function ParseSources(pInstrument: Boolean): Boolean; - function ParseSource(pFile: TLPFile; pInstrument: Boolean): Boolean; + function ParseSources(pInstrument: boolean): boolean; + function ParseSource(pFile: TLPFile; pInstrument: boolean): boolean; procedure RestoreModifiedSettings; procedure RestoreSources; procedure RestoreSource(pFile: TLPFile); - function ProjectRunWithoutDebugBuilding(Sender: TObject; var Handled: boolean): TModalResult; - procedure ProjectBuildingFinished(Sender: TObject; BuildSuccessful: Boolean); + function ProjectRunWithoutDebugBuilding(Sender: TObject; + var Handled: boolean): TModalResult; + procedure ProjectBuildingFinished(Sender: TObject; BuildSuccessful: boolean); procedure RunFinished(Sender: TObject); procedure LoadResult; function ProjectOpened(Sender: TObject; pProject: TLazProject): TModalResult; function ProjectClose(Sender: TObject; AProject: TLazProject): TModalResult; - function SaveEditorFile(Sender: TObject; aFile: TLazProjectFile; SaveStep: TSaveEditorFileStep; TargetFilename: string): TModalResult; - procedure CreateProfilerWindow(Sender: TObject; pFormName: string; var pForm: TCustomForm; DoDisableAutoSizing: boolean); + function SaveEditorFile(Sender: TObject; aFile: TLazProjectFile; + SaveStep: TSaveEditorFileStep; TargetFilename: string): TModalResult; + procedure CreateProfilerWindow(Sender: TObject; pFormName: string; + var pForm: TCustomForm; DoDisableAutoSizing: boolean); procedure UpdateUI; public constructor Create; @@ -181,7 +183,7 @@ TProfilerAddon = class(TCustomLazProfiler) procedure ShowProfilerWindow(Sender: TObject); procedure CleanUp(Sender: TObject); property Project: TLazProject read fProject; - property Active: Boolean read fActive write SetActive; + property Active: boolean read fActive write SetActive; end; @@ -221,12 +223,13 @@ implementation TBlockEntry = class public token: TToken; - name, nameofclass: String; - level: Integer; + Name, nameofclass: string; + level: integer; parent: TBlockEntry; - gap: String; - procid: Integer; - constructor Create(pToken: TToken; pName: String; pLevel: Integer; pParent: TBlockEntry); + gap: string; + procid: integer; + constructor Create(pToken: TToken; pName: string; pLevel: integer; + pParent: TBlockEntry); destructor Destroy; override; end; @@ -239,12 +242,12 @@ TBlockEntry = class cProfilerFormName = 'LazProfilerForm'; cAutoRestore = True; -function TokenToStr(TokenType: TToken): String; +function TokenToStr(TokenType: TToken): string; begin WriteStr(Result, TokenType); end; -function CheckStateToStr(pCheckState: TCheckState): String; +function CheckStateToStr(pCheckState: TCheckState): string; begin WriteStr(Result, pCheckState); end; @@ -252,10 +255,11 @@ function CheckStateToStr(pCheckState: TCheckState): String; procedure Register; var - lIdx: Integer; + lIdx: integer; begin RunCmd := TIDEMenuCommand.Create('itmRunMenuRunWithProfiler'); - with RunCmd do begin + with RunCmd do + begin Caption := 'Profile'; OnClick := @Addon.Start; end; @@ -265,8 +269,11 @@ procedure Register; itmRunnning.Insert(lIdx + 1, RunCmd); - RegisterIDEMenuCommand(itmViewMainWindows, 'itmViewMainWindowsProfiler','Profiler (Results and Configuration)',@Addon.ShowProfilerWindow, nil); - RegisterIDEMenuCommand(itmRunnning, 'itmRunMenuProfilerCleanUp','Cleanup Profiler and restore original files',@Addon.CleanUp, nil); + RegisterIDEMenuCommand(itmViewMainWindows, + 'itmViewMainWindowsProfiler', 'Profiler (Results and Configuration)', + @Addon.ShowProfilerWindow, nil); + RegisterIDEMenuCommand(itmRunnning, 'itmRunMenuProfilerCleanUp', + 'Cleanup Profiler and restore original files', @Addon.CleanUp, nil); LazarusIDE.AddHandlerOnRunWithoutDebugBuilding(@Addon.ProjectRunWithoutDebugBuilding); LazarusIDE.AddHandlerOnProjectBuildingFinished(@Addon.ProjectBuildingFinished); LazarusIDE.AddHandlerOnRunFinished(@Addon.RunFinished); { needs trunk 56254 } @@ -274,13 +281,14 @@ procedure Register; LazarusIDE.AddHandlerOnProjectClose(@Addon.ProjectClose); LazarusIDE.AddHandlerOnSaveEditorFile(@Addon.SaveEditorFile); - IDEWindowCreators.Add(cProfilerFormName, nil, @Addon.CreateProfilerWindow, '100', '10%', '+300', '+50%'); + IDEWindowCreators.Add(cProfilerFormName, nil, @Addon.CreateProfilerWindow, + '100', '10%', '+300', '+50%'); end; { TLPvtvPasPackage } -constructor TLPvtvPasPackage.Create(pPackageName: String); +constructor TLPvtvPasPackage.Create(pPackageName: string); begin inherited Create(TLPPasProc.Create('', 0, '', '', '', pPackageName, 1)); end; @@ -291,18 +299,20 @@ destructor TLPvtvPasPackage.Destroy; inherited Destroy; end; -function TLPvtvPasPackage.CellText(Column: TColumnIndex; TextType: TVSTTextType): String; +function TLPvtvPasPackage.CellText(Column: TColumnIndex; TextType: TVSTTextType): string; begin - if Column = 0 then begin + if Column = 0 then + begin if fPasProc.PackageIsProject then CellText := Addon.Project.Title else CellText := fPasProc.PackageName; - end else + end + else CellText := ''; end; -function TLPvtvPasPackage.ImageIndex(pColumn: TColumnIndex): Integer; +function TLPvtvPasPackage.ImageIndex(pColumn: TColumnIndex): integer; begin if pColumn = 0 then if fPasProc.PackageIsProject then @@ -316,9 +326,11 @@ function TLPvtvPasPackage.ImageIndex(pColumn: TColumnIndex): Integer; function TLPvtvPasPackage.InitialStates: TVirtualNodeInitStates; begin Result := inherited InitialStates; - if not Assigned(fPasPackage) then begin - WriteLn('!!! TLPvtvPasPackage: ', fPasProc.PackageName, ' fPasPackage=Nil'); - end else + if not Assigned(fPasPackage) then + begin + // WriteLn('!!! TLPvtvPasPackage: ', fPasProc.PackageName, ' fPasPackage=Nil'); + end + else if fPasPackage.Expanded then Result := Result + [ivsExpanded]; end; @@ -331,7 +343,7 @@ procedure TLPvtvPasPackage.UpdateExpanded; { TLPvtvPasUnit } -constructor TLPvtvPasUnit.Create(pUnitName, pFileName, pPackageName: String); +constructor TLPvtvPasUnit.Create(pUnitName, pFileName, pPackageName: string); begin inherited Create(TLPPasProc.Create('', 0, '', pUnitName, pFileName, pPackageName, 1)); end; @@ -342,7 +354,7 @@ destructor TLPvtvPasUnit.Destroy; inherited Destroy; end; -function TLPvtvPasUnit.CellText(Column: TColumnIndex; TextType: TVSTTextType): String; +function TLPvtvPasUnit.CellText(Column: TColumnIndex; TextType: TVSTTextType): string; begin if Column = 0 then CellText := fPasProc.UnitName @@ -350,7 +362,7 @@ function TLPvtvPasUnit.CellText(Column: TColumnIndex; TextType: TVSTTextType): S CellText := ''; end; -function TLPvtvPasUnit.ImageIndex(pColumn: TColumnIndex): Integer; +function TLPvtvPasUnit.ImageIndex(pColumn: TColumnIndex): integer; begin if pColumn = 0 then Result := 0 @@ -361,9 +373,11 @@ function TLPvtvPasUnit.ImageIndex(pColumn: TColumnIndex): Integer; function TLPvtvPasUnit.InitialStates: TVirtualNodeInitStates; begin Result := inherited InitialStates; - if not Assigned(fPasUnit) then begin - WriteLn('!!! TLPvtvPasUnit: ', fPasProc.UnitName, ' fPasUnit=Nil'); - end else + if not Assigned(fPasUnit) then + begin + //WriteLn('!!! TLPvtvPasUnit: ', fPasProc.UnitName, ' fPasUnit=Nil'); + end + else if fPasUnit.Expanded then Result := Result + [ivsExpanded]; end; @@ -376,12 +390,13 @@ procedure TLPvtvPasUnit.UpdateExpanded; { TLPFileList } -function TLPFileList.IndexOf(pFilename: String): SizeInt; +function TLPFileList.IndexOf(pFilename: string): SizeInt; var - i: Integer; + i: integer; begin pFilename := UpperCase(pFilename); - for i := 0 to Count - 1 do begin + for i := 0 to Count - 1 do + begin if UpperCase(Items[i].Filename) = pFilename then Exit(i); end; @@ -391,7 +406,7 @@ function TLPFileList.IndexOf(pFilename: String): SizeInt; { TLPFile } -constructor TLPFile.Create(pFilename, pPackageName: String); +constructor TLPFile.Create(pFilename, pPackageName: string); begin fFilename := pFilename; fFilenameUp := UpperCase(pFilename); @@ -407,26 +422,39 @@ destructor TLPFile.Destroy; inherited Destroy; end; -function TLPFile.Save: Boolean; +function TLPFile.Save: boolean; begin - if not fSaved then begin - if FileExists(fFileName + cBackupExtension) then begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: backup file already exists: ' + fFileName + cBackupExtension, fFileName, 1, 1); // CurTokenPos needs FPC trunk 37235 + if not fSaved then + begin + if FileExists(fFileName + cBackupExtension) then + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: backup file already exists: ' + fFileName + cBackupExtension, + fFileName, 1, 1); // CurTokenPos needs FPC trunk 37235 Exit(False); - end else begin + end + else + begin { make backup } RenameFile(fFileName, fFileName + cBackupExtension); - if FileExists(fFileName) then begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: could not create backup file: ' + fFileName + cBackupExtension, fFileName, 1, 1); // CurTokenPos needs FPC trunk 37235 + if FileExists(fFileName) then + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: could not create backup file: ' + fFileName + cBackupExtension, + fFileName, 1, 1); // CurTokenPos needs FPC trunk 37235 Exit(False); - end else begin + end + else + begin { write modified source } fText.SaveToFile(fFileName); fSaved := True; end; end; - end else begin - WriteLn('*** LazProfiler: !!! re-saving ', fFilename); + end + else + begin + //WriteLn('*** LazProfiler: !!! re-saving ', fFilename); fText.SaveToFile(fFileName); end; Result := True; @@ -435,9 +463,11 @@ function TLPFile.Save: Boolean; { TLPvtvPasClass } -constructor TLPvtvPasClass.Create(pNameOfClass, pUnitName, pFileName, pPackageName: String); +constructor TLPvtvPasClass.Create(pNameOfClass, pUnitName, pFileName, + pPackageName: string); begin - inherited Create(TLPPasProc.Create('', 0, pNameOfClass, pUnitName, pFileName, pPackageName, 1)); + inherited Create(TLPPasProc.Create('', 0, pNameOfClass, pUnitName, + pFileName, pPackageName, 1)); end; destructor TLPvtvPasClass.Destroy; @@ -446,7 +476,7 @@ destructor TLPvtvPasClass.Destroy; inherited Destroy; end; -function TLPvtvPasClass.CellText(Column: TColumnIndex; TextType: TVSTTextType): String; +function TLPvtvPasClass.CellText(Column: TColumnIndex; TextType: TVSTTextType): string; begin if Column = 0 then CellText := fPasProc.NameOfClass @@ -454,7 +484,7 @@ function TLPvtvPasClass.CellText(Column: TColumnIndex; TextType: TVSTTextType): CellText := ''; end; -function TLPvtvPasClass.ImageIndex(pColumn: TColumnIndex): Integer; +function TLPvtvPasClass.ImageIndex(pColumn: TColumnIndex): integer; begin if pColumn = 0 then Result := 1 @@ -465,9 +495,11 @@ function TLPvtvPasClass.ImageIndex(pColumn: TColumnIndex): Integer; function TLPvtvPasClass.InitialStates: TVirtualNodeInitStates; begin Result := inherited InitialStates; - if not Assigned(fPasClass) then begin - WriteLn('!!! TLPvtvPasClass: ', fPasProc.NameOfClass, ' fPasClass=Nil'); - end else + if not Assigned(fPasClass) then + begin + //WriteLn('!!! TLPvtvPasClass: ', fPasProc.NameOfClass, ' fPasClass=Nil'); + end + else if fPasClass.Expanded then Result := Result + [ivsExpanded]; end; @@ -482,22 +514,27 @@ procedure TLPvtvPasClass.UpdateExpanded; procedure TLPvtvPasProc.UpdateCheckState; var - i: Integer; - lChecked: Boolean; + i: integer; + lChecked: boolean; lChild: TLPvtvPasProc; - function Check(pObj: TLPvtvPasProc): Boolean; + function Check(pObj: TLPvtvPasProc): boolean; var - i: Integer; + i: integer; begin Result := True; - if pObj.Childs.Count = 0 then begin - if pObj.PasProc.Instrument <> lChecked then begin + if pObj.Childs.Count = 0 then + begin + if pObj.PasProc.Instrument <> lChecked then + begin fNode^.CheckState := csMixedNormal; Exit(False); end; - end else begin - for i := 0 to pObj.Childs.Count - 1 do begin + end + else + begin + for i := 0 to pObj.Childs.Count - 1 do + begin if not Check(TLPvtvPasProc(pObj.Childs[i])) then Exit(False); end; @@ -508,10 +545,12 @@ procedure TLPvtvPasProc.UpdateCheckState; if fChilds.Count = 0 then Exit; - lChild := Self; while lChild.Childs.Count > 0 do lChild := TLPvtvPasProc(lChild.Childs[0]); + lChild := Self; + while lChild.Childs.Count > 0 do lChild := TLPvtvPasProc(lChild.Childs[0]); lChecked := lChild.PasProc.Instrument; - if not Check(Self) then begin + if not Check(Self) then + begin fVst.InvalidateNode(fNode); Exit; end; @@ -526,12 +565,13 @@ procedure TLPvtvPasProc.UpdateCheckState; procedure TLPvtvPasProc.SetCheckState(pCheckState: TCheckState); var lParent: TLPvtvPasProc; - i: Integer; + i: integer; begin inherited SetCheckState(pCheckState); fPasProc.Instrument := pCheckState = csCheckedNormal; lParent := TLPvtvPasProc(fParent); - while Assigned(lParent) do begin + while Assigned(lParent) do + begin TLPvtvPasProc(lParent).UpdateCheckState; lParent := TLPvtvPasProc(lParent.Parent); end; @@ -544,13 +584,17 @@ constructor TLPvtvPasProc.Create(pProc: TLPPasProc); fPasProc := pProc; end; -function TLPvtvPasProc.CellText(Column: TColumnIndex; TextType: TVSTTextType): String; +function TLPvtvPasProc.CellText(Column: TColumnIndex; TextType: TVSTTextType): string; begin case Column of cNameCol: CellText := fPasProc.Name; - cClassCol: CellText := IfThen(TVirtualStringTree(fVst).Header.SortColumn in [1, 2, 3], '', fPasProc.NameOfClass); - cUnitCol: CellText := IfThen(TVirtualStringTree(fVst).Header.SortColumn in [1, 2, 3], '', fPasProc.UnitName); - cPackageCol: CellText := IfThen(TVirtualStringTree(fVst).Header.SortColumn in [1, 2, 3], '', IfThen(fPasProc.PackageName = '?', LazarusIDE.ActiveProject.Title, fPasProc.PackageName)); + cClassCol: CellText := IfThen(TLazVirtualStringTree(fVst).Header.SortColumn in + [1, 2, 3], '', fPasProc.NameOfClass); + cUnitCol: CellText := IfThen(TLazVirtualStringTree(fVst).Header.SortColumn in + [1, 2, 3], '', fPasProc.UnitName); + cPackageCol: CellText := IfThen(TLazVirtualStringTree(fVst).Header.SortColumn in + [1, 2, 3], '', IfThen(fPasProc.PackageName = '?', LazarusIDE.ActiveProject.Title, + fPasProc.PackageName)); cCountCol: CellText := fPasProc.CountStr; cPerNetCol: CellText := fPasProc.PerNetStr; cSumNetCol: CellText := fPasProc.SumNetStr; @@ -561,18 +605,22 @@ function TLPvtvPasProc.CellText(Column: TColumnIndex; TextType: TVSTTextType): S end; end; -function TLPvtvPasProc.ImageIndex(pColumn: TColumnIndex): Integer; +function TLPvtvPasProc.ImageIndex(pColumn: TColumnIndex): integer; begin - if pColumn = 0 then begin + if pColumn = 0 then + begin case TToken(fPasProc.Kind) of tkconstructor: Result := 2; - tkdestructor: Result := 3; + tkdestructor: Result := 3; tkoperator, - tkprocedure: Result := 4; - tkfunction: Result := 5; - else Result := 6; + tkprocedure: Result := 4; + tkfunction: Result := 5; + else + Result := 6; end; - end else begin + end + else + begin Result := -1; end; end; @@ -591,13 +639,13 @@ procedure TLPvtvPasProc.InitNode(pVST: TBaseVirtualTree; pNode: PVirtualNode); { TBlockEntry } -constructor TBlockEntry.Create(pToken: TToken; pName: String; - pLevel: Integer; pParent: TBlockEntry); +constructor TBlockEntry.Create(pToken: TToken; pName: string; + pLevel: integer; pParent: TBlockEntry); var - i: Integer; + i: integer; begin token := pToken; - name := pName; + Name := pName; nameofclass := ''; level := pLevel; parent := pParent; @@ -608,7 +656,7 @@ constructor TBlockEntry.Create(pToken: TToken; pName: String; destructor TBlockEntry.Destroy; begin - name := ''; + Name := ''; gap := ''; inherited Destroy; end; @@ -616,42 +664,50 @@ destructor TBlockEntry.Destroy; { TProfilerAddon } -procedure TProfilerAddon.BuildFileList(pExtensionMask: String; pCheckForBelongsToProject: Boolean); +procedure TProfilerAddon.BuildFileList(pExtensionMask: string; + pCheckForBelongsToProject: boolean); var - lFPCSrcDir, lLazSrcDir, lPath: String; + lFPCSrcDir, lLazSrcDir, lPath: string; lPathList: TStringList; - lLengthFPCSrcDir, lLengthLazSrcDir, i, j: Integer; + lLengthFPCSrcDir, lLengthLazSrcDir, i, j: integer; lPkgList: TFPList; lUnits: TStrings; - function BelongsToProject(pFileName: string; var pPackageName: String): Boolean; + function BelongsToProject(pFileName: string; var pPackageName: string): boolean; var Owners: TFPList; - i: Integer; + i: integer; o: TObject; begin Result := False; pPackageName := '?'; Owners := PackageEditingInterface.GetPossibleOwnersOfUnit(pFileName, []); - if not Assigned(Owners) then begin + if not Assigned(Owners) then + begin // unit is not directly associated with a project/package // maybe the unit was for some reason not added, but is reachable // search in all unit paths of all projects/packages // Beware: This can lead to false hits - Owners:=PackageEditingInterface.GetPossibleOwnersOfUnit(pFileName, [piosfExcludeOwned,piosfIncludeSourceDirectories]); + Owners := PackageEditingInterface.GetPossibleOwnersOfUnit(pFileName, + [piosfExcludeOwned, piosfIncludeSourceDirectories]); end; if not Assigned(Owners) then Exit; try //debugln('*** LazProfiler Owner of ' + pFileName); - for i := 0 to Owners.Count - 1 do begin + for i := 0 to Owners.Count - 1 do + begin o := TObject(Owners[i]); - if o is TIDEPackage then begin - pPackageName := ExtractFileNameWithoutExt(ExtractFilenameOnly(TIDEPackage(o).Filename)); + if o is TIDEPackage then + begin + pPackageName := ExtractFileNameWithoutExt( + ExtractFilenameOnly(TIDEPackage(o).Filename)); //debugln(' ' + pPackageName); Exit(True); - end else if (o is TLazProject) - and (TLazProject(o).ProjectInfoFile = fProject.ProjectInfoFile) then begin + end + else if (o is TLazProject) and (TLazProject(o).ProjectInfoFile = + fProject.ProjectInfoFile) then + begin //pPackageName := TLazProject(o).Title; //debugln(' ' + pPackageName); Exit(True); @@ -662,20 +718,19 @@ procedure TProfilerAddon.BuildFileList(pExtensionMask: String; pCheckForBelongsT end; end; - procedure AddFile(pFileName: String); + procedure AddFile(pFileName: string); var - lPackageName: String; + lPackageName: string; begin //DebugLn('*** LazProfiler: testing ', ExtractFileName(pFileName)); - if (fFileList.IndexOf(pFileName) >= 0) - or (pCheckForBelongsToProject - and not BelongsToProject(pFileName, lPackageName)) then + if (fFileList.IndexOf(pFileName) >= 0) or + (pCheckForBelongsToProject and not BelongsToProject(pFileName, lPackageName)) then Exit; //DebugLn('*** LazProfiler: added ', lPackageName, ' - ', ExtractFileName(pFileName)); fFileList.Add(TLPFile.Create(pFileName, lPackageName)); end; - procedure ScanDir(pDir, pExtensionMask: String); + procedure ScanDir(pDir, pExtensionMask: string); var Info: TSearchRec; ExtensionList: TStrings; @@ -692,11 +747,13 @@ procedure TProfilerAddon.BuildFileList(pExtensionMask: String; pCheckForBelongsT if FindFirst(pDir + AllFilesMask, faAnyFile and faDirectory, Info) = 0 then begin repeat - if ((Info.Attr and faDirectory) = faDirectory) then begin - if (Info.Name <> '.') - and (Info.Name <> '..') then + if ((Info.Attr and faDirectory) = faDirectory) then + begin + if (Info.Name <> '.') and (Info.Name <> '..') then ScanDir(pDir + Info.Name, pExtensionMask); - end else begin + end + else + begin if ExtensionList.IndexOf(ExtractFileExt(Info.Name)) <> -1 then AddFile(pDir + Info.Name); end; @@ -709,16 +766,16 @@ procedure TProfilerAddon.BuildFileList(pExtensionMask: String; pCheckForBelongsT procedure CheckDir(pList: TStringList); var - lPath, lPathUp: String; - i: Integer; + lPath, lPathUp: string; + i: integer; begin - for i := 0 to pList.Count - 1 do begin + for i := 0 to pList.Count - 1 do + begin lPath := lPathList[i]; lPathUp := UpperCase(lPath); - if (lPathUp <> '') - and (LeftStr(lPathUp, lLengthFPCSrcDir) <> lFPCSrcDir) - and (LeftStr(lPathUp, lLengthLazSrcDir) <> lLazSrcDir) then - ScanDir(lPath, pExtensionMask) + if (lPathUp <> '') and (LeftStr(lPathUp, lLengthFPCSrcDir) <> + lFPCSrcDir) and (LeftStr(lPathUp, lLengthLazSrcDir) <> lLazSrcDir) then + ScanDir(lPath, pExtensionMask); end; end; @@ -735,34 +792,42 @@ procedure TProfilerAddon.BuildFileList(pExtensionMask: String; pCheckForBelongsT IDEMacros.SubstituteMacros(lLazSrcDir); lLazSrcDir := UpperCase(lLazSrcDir); lLengthLazSrcDir := length(lLazSrcDir); - { scan pathes } lPathList := TStringList.Create; try //lPathList.DelimitedText := CodeToolBoss.GetUnitPathForDirectory(''); PackageEditingInterface.GetRequiredPackages(fProject, lPkgList, [pirNotRecursive]); - for i := 0 to lPkgList.Count - 1 do begin - //debugln(' Package: ' + TIDEPackage(lPkgList[i]).Filename); - lPath := ExtractFilePath(TIDEPackage(lPkgList[i]).Filename); - if lPathList.IndexOf(lPath) = -1 then - lPathList.Add(lPath); - lUnits := LazarusIDE.FindUnitsOfOwner(TIDEPackage(lPkgList[i]), [fuooListed,fuooUsed]); // add fuooPackages to include units from packages - try - for j:=0 to lUnits.Count-1 do begin - //debugln(' Unit: ' + lUnits[j]); - lPath := ExtractFilePath(lUnits[j]); - if lPathList.IndexOf(lPath) = -1 then - lPathList.Add(lPath); + if lPkgList <> nil then + begin + for i := 0 to lPkgList.Count - 1 do + begin + //debugln(' Package: ' + TIDEPackage(lPkgList[i]).Filename); + lPath := ExtractFilePath(TIDEPackage(lPkgList[i]).Filename); + if lPathList.IndexOf(lPath) = -1 then + lPathList.Add(lPath); + lUnits := LazarusIDE.FindUnitsOfOwner(TIDEPackage(lPkgList[i]), + [fuooListed, fuooUsed]); // add fuooPackages to include units from packages + try + for j := 0 to lUnits.Count - 1 do + begin + //debugln(' Unit: ' + lUnits[j]); + lPath := ExtractFilePath(lUnits[j]); + if lPathList.IndexOf(lPath) = -1 then + lPathList.Add(lPath); + end; + finally + lUnits.Free; end; - finally - lUnits.Free; end; + lPkgList.Free; end; - lPkgList.Free; - lUnits := LazarusIDE.FindUnitsOfOwner(fProject,[fuooListed,fuooUsed]); // add fuooPackages to include units from packages + lUnits := LazarusIDE.FindUnitsOfOwner(fProject, [fuooListed, fuooUsed]); + // add fuooPackages to include units from packages + if lUnits <> nil then try - for i:=0 to lUnits.Count-1 do begin + for i := 0 to lUnits.Count - 1 do + begin //debugln(' Unit: ' + lUnits[i]); lPath := ExtractFilePath(lUnits[i]); if lPathList.IndexOf(lPath) = -1 then @@ -772,6 +837,7 @@ procedure TProfilerAddon.BuildFileList(pExtensionMask: String; pCheckForBelongsT lUnits.Free; end; + { scan sources} CheckDir(lPathList); finally @@ -779,26 +845,29 @@ procedure TProfilerAddon.BuildFileList(pExtensionMask: String; pCheckForBelongsT end; end; -function TProfilerAddon.AddProc(pName: String; pToken: Integer; pNameOfClass, - pUnitName, pFileName, pPackageName: String; pRow: Integer): Integer; +function TProfilerAddon.AddProc(pName: string; pToken: integer; + pNameOfClass, pUnitName, pFileName, pPackageName: string; pRow: integer): integer; var lPasPackage: TLPPasPackage; lPasUnit: TLPPasUnit; lPasClass: TLPPasClass; lPasProc: TLPPasProc; - lUpName, lUpFileName, lUpNameOfClass: String; - i: Integer; + lUpName, lUpFileName, lUpNameOfClass: string; + i: integer; begin //DebugLn(' AddProc(%s, %s)', [pName, pNameOfClass]); - // package - lPasPackage := Nil; + lPasPackage := nil; i := fPackageList.IndexOf(pPackageName); - if i >= 0 then begin + if i >= 0 then + begin lPasPackage := fPackageList[i]; - end else begin + end + else + begin i := fOldPackageList.IndexOf(pPackageName); - if i >= 0 then begin + if i >= 0 then + begin lPasPackage := fOldPackageList.ExtractIndex(i); end; if not Assigned(lPasPackage) then @@ -807,13 +876,17 @@ function TProfilerAddon.AddProc(pName: String; pToken: Integer; pNameOfClass, end; // unit - lPasUnit := Nil; + lPasUnit := nil; i := fUnitList.IndexOf(pUnitName, pFileName, pPackageName); - if i >= 0 then begin + if i >= 0 then + begin lPasUnit := fUnitList[i]; - end else begin + end + else + begin i := fOldUnitList.IndexOf(pUnitName, pFileName, pPackageName); - if i >= 0 then begin + if i >= 0 then + begin lPasUnit := fOldUnitList.ExtractIndex(i); end; if not Assigned(lPasUnit) then @@ -823,13 +896,17 @@ function TProfilerAddon.AddProc(pName: String; pToken: Integer; pNameOfClass, end; // class - lPasClass := Nil; + lPasClass := nil; i := fClassList.IndexOf(pNameOfClass, pUnitName, pFileName, pPackageName); - if i >= 0 then begin + if i >= 0 then + begin lPasClass := fClassList[i]; - end else begin + end + else + begin i := fOldClassList.IndexOf(pNameOfClass, pUnitName, pFileName, pPackageName); - if i >= 0 then begin + if i >= 0 then + begin lPasClass := fOldClassList.ExtractIndex(i); end; if not Assigned(lPasClass) then @@ -840,9 +917,10 @@ function TProfilerAddon.AddProc(pName: String; pToken: Integer; pNameOfClass, end; // proc - lPasProc := Nil; + lPasProc := nil; i := fOldProcList.IndexOf(pName, pNameOfClass, pUnitName, pFileName, pPackageName); - if i >= 0 then begin + if i >= 0 then + begin lPasProc := fOldProcList.ExtractIndex(i); lPasProc.Name := pName; lPasProc.Kind := pToken; @@ -853,7 +931,8 @@ function TProfilerAddon.AddProc(pName: String; pToken: Integer; pNameOfClass, lPasProc.Init; end; if not Assigned(lPasProc) then - lPasProc := TLPPasProc.Create(pName, pToken, pNameOfClass, pUnitName, pFileName, pPackageName, pRow); + lPasProc := TLPPasProc.Create(pName, pToken, pNameOfClass, pUnitName, + pFileName, pPackageName, pRow); //if not Assigned(lPasUnit) then // DebugLn(' lPasUnit=Nil'); //if not Assigned(lPasClass) then @@ -867,13 +946,14 @@ function TProfilerAddon.AddProc(pName: String; pToken: Integer; pNameOfClass, Result := -1; end; -procedure TProfilerAddon.SetActive(pActive: Boolean); +procedure TProfilerAddon.SetActive(pActive: boolean); begin if fActive = pActive then Exit; fActive := pActive; Screen.Cursor := crHourGlass; try - if fActive then begin + if fActive then + begin ParseSources(False); end; UpdateUI; @@ -886,16 +966,21 @@ procedure TProfilerAddon.SetActive(pActive: Boolean); procedure TProfilerAddon.ModifySettings; var - i: Integer; + i: integer; lFiles: TStringList; lPkg: TIDEProjPackBase; lPasPkg: TLPPasPackage; begin - for i := 0 to fPackageList.Count - 1 do begin + + for i := 0 to fPackageList.Count - 1 do + begin lPasPkg := fPackageList[i]; - if lPasPkg.PackageIsProject then begin + if lPasPkg.PackageIsProject then + begin lPkg := fProject; - end else begin + end + else + begin lPkg := PackageEditingInterface.FindPackageWithName(lPasPkg.PackageName); //PackageEditingInterface.DoOpenPackageWithName(lPasPkg.PackageName, [pofDoNotOpenEditor], False); end; @@ -920,28 +1005,28 @@ procedure TProfilerAddon.ModifySettings; procedure TProfilerAddon.LoadResult; begin LoadFromFile(fTargetDir + fTargetName + cSettingExtension); - if fProcList.Count = 0 then begin + if fProcList.Count = 0 then + begin ParseSources(False); end; UpdateUI; end; -function TProfilerAddon.ParseSources(pInstrument: Boolean): Boolean; +function TProfilerAddon.ParseSources(pInstrument: boolean): boolean; var - i: Integer; + i: integer; lLRS: TLazarusResourceStream; lList4: TLPPasPackageList; lList3: TLPPasUnitList; lList2: TLPPasClassList; lList: TLPPasProcList; lPkg: TIDEPackage; - begin Result := True; RestoreSources; if not fActive then Exit; - WriteLn('*** LazProfiler: ParseSources(', BoolToStr(pInstrument, True), ')'); + //WriteLn('*** LazProfiler: ParseSources(', BoolToStr(pInstrument, True), ')'); lList4 := fOldPackageList; fOldPackageList := fPackageList; @@ -971,7 +1056,8 @@ function TProfilerAddon.ParseSources(pInstrument: Boolean): Boolean; if not ParseSource(fFileList[i], pInstrument) then Result := False; - if pInstrument then begin + if pInstrument then + begin for i := 0 to fIncludeList.Count - 1 do if fIncludeList[i].Changed then fIncludeList[i].Save; @@ -982,35 +1068,43 @@ function TProfilerAddon.ParseSources(pInstrument: Boolean): Boolean; end; end; -function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boolean; +function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: boolean): boolean; var lIncludeDirs: TStringList; fr: TFileResolver; pas: TPascalScanner; token, lPart, lLastBlockToken, lToken: TToken; - level, lProfilingChangeLevel, i: Integer; + level, lProfilingChangeLevel, i: integer; lImpUsesPos, lIntUsesPos, lImpPos, lIntPos: TPoint; lBlockStack: TBlocList; lBlock, lTempBlock, lStartProc: TBlockEntry; - lName, lParents, lUpComment, lNameOfClass, lUnitName, lIncludePath: String; - lProfiling: Boolean; + lName, lParents, lUpComment, lNameOfClass, lUnitName, lIncludePath: string; + lProfiling: boolean; lPos: SizeInt; lCurFile: TLPFile; + lCurrentToken: TToken; procedure CheckFile; var - lCurFileNameUp: String; - i: Integer; + lCurFileNameUp: string; + i: integer; begin lCurFileNameUp := UpperCase(pas.CurFilename); - if lCurFileNameUp <> UpperCase(lCurFile.Filename) then begin - if lCurFileNameUp = UpperCase(pFile.Filename) then begin - lCurFile := pFile - end else begin + if lCurFileNameUp <> UpperCase(lCurFile.Filename) then + begin + if lCurFileNameUp = UpperCase(pFile.Filename) then + begin + lCurFile := pFile; + end + else + begin i := fIncludeList.IndexOf(pas.CurFilename); - if i >= 0 then begin + if i >= 0 then + begin lCurFile := fIncludeList[i]; - end else begin + end + else + begin //DebugLn(' Added Include %s', [pas.CurFilename]); lCurFile := TLPFile.Create(pas.CurFilename, pFile.PackageName); fIncludeList.Add(lCurFile); @@ -1019,9 +1113,9 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole end; end; - procedure InsertEnter(pRow, pCol: Integer; pProcID: Integer); + procedure InsertEnter(pRow, pCol: integer; pProcID: integer); var - lLine: String; + lLine: string; begin CheckFile; lLine := lCurFile.Text[pRow]; @@ -1030,20 +1124,21 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole lCurFile.Changed := True; end; - procedure InsertExit(pRow, pCol: Integer; pProcID: Integer); + procedure InsertExit(pRow, pCol: integer; pProcID: integer); var - lLine: String; + lLine: string; begin CheckFile; lLine := lCurFile.Text[pRow]; - Insert('finally LazProfiler.ExitProfiling(' + IntToStr(pProcID) + '); end; ', lLine, pCol); + Insert('finally LazProfiler.ExitProfiling(' + IntToStr(pProcID) + + '); end; ', lLine, pCol); lCurFile.Text[pRow] := lLine; lCurFile.Changed := True; end; - procedure InsertStart(pRow, pCol: Integer); + procedure InsertStart(pRow, pCol: integer); var - lLine: String; + lLine: string; begin CheckFile; lLine := lCurFile.Text[pRow]; @@ -1052,9 +1147,9 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole lCurFile.Changed := True; end; - procedure InsertStop(pRow, pCol: Integer); + procedure InsertStop(pRow, pCol: integer); var - lLine: String; + lLine: string; begin CheckFile; lLine := lCurFile.Text[pRow]; @@ -1063,9 +1158,9 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole lCurFile.Changed := True; end; - procedure InsertUnit(pRow, pCol: Integer); + procedure InsertUnit(pRow, pCol: integer); var - lLine: String; + lLine: string; begin CheckFile; lLine := lCurFile.Text[pRow]; @@ -1074,30 +1169,30 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole lCurFile.Changed := True; end; - procedure InsertUses(pRow, pCol: Integer); + procedure InsertUses(pRow, pCol: integer); begin CheckFile; lCurFile.Text.Insert(pRow, 'Uses LazProfilerRunTime;'); lCurFile.Changed := True; end; - function InStruct: Boolean; + function InStruct: boolean; var b: TBlockEntry; begin Result := False; b := lBlock; - while Assigned(b) - and (Result = False) do begin + while Assigned(b) and (Result = False) do + begin if b.token in [tkclass, tkobject, tkrecord] then Result := True; b := b.parent; end; end; - procedure NewBlock(pToken: TToken; pName: String); + procedure NewBlock(pToken: TToken; pName: string); begin - inc(level); + Inc(level); if Assigned(lBlock) then lBlockStack.Push(lBlock); lBlock := TBlockEntry.Create(pToken, pName, level, lBlock); @@ -1106,14 +1201,15 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole procedure PopBlock; begin - if Assigned(lBlock) then begin + if Assigned(lBlock) then + begin //Debugln(' - %s - %d - %s', [lBlock.name, lBlock.level, TokenToStr(lBlock.token)]); lBlock.Free; if lBlockStack.Count > 0 then lBlock := lBlockStack.Pop else lBlock := nil; - dec(level); + Dec(level); end; end; @@ -1126,36 +1222,42 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole procedure DoProc; begin - if not (lPart = tkinterface) - and not InStruct then begin + if not (lPart = tkinterface) and not InStruct then + begin NewBlock(pas.CurToken, pas.CurTokenString); - while pas.FetchToken <> tkIdentifier do; + while pas.FetchToken <> tkIdentifier do ; lNameOfClass := ''; lName := pas.CurTokenString; - while not (pas.FetchToken in [tkWhitespace, tkBraceOpen, tkSemicolon]) do case pas.CurToken of - tkDot: begin - if lNameOfClass = '' then begin - lNameOfClass := lName; - lName := ''; - end else - lName := lName + '.' - end; - tkIdentifier: begin - lName := lName + pas.CurTokenString; - end; - else begin - lName := lName + Copy(TokenToStr(pas.CurToken), 3); + while not (pas.FetchToken in [tkWhitespace, tkBraceOpen, tkSemicolon]) do + case pas.CurToken of + tkDot: begin + if lNameOfClass = '' then + begin + lNameOfClass := lName; + lName := ''; + end + else + lName := lName + '.'; + end; + tkIdentifier: begin + lName := lName + pas.CurTokenString; + end; + else + begin + lName := lName + Copy(TokenToStr(pas.CurToken), 3); + end; end; - end; if lBlock.token = tkoperator then lName := 'operator ' + lName; - lBlock.name := lName; + lBlock.Name := lName; lBlock.nameofclass := lNameOfClass; end; end; begin + try + Result := True; lCurFile := pFile; //WriteLn(' '+pFile.FileName); @@ -1174,7 +1276,7 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole end; pas := TPascalScanner.Create(fr); pas.TokenOptions := [toOperatorToken]; - pas.AddDefine('fpc', true); + pas.AddDefine('fpc', True); lBlockStack := TBlocList.Create(False); try { parse and modify } @@ -1188,194 +1290,281 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole lStartProc := nil; lProfiling := True; lProfilingChangeLevel := 0; +// ShowMessage(pFile.FileName); pas.OpenFile(pFile.FileName); - while True do case pas.FetchToken of - tkunit, tkprogram: begin - while pas.FetchToken <> tkIdentifier do; - lUnitName := pas.CurTokenString; - end; - tkAsm: if Assigned(lBlock) - and not (lBlock.token in [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) then - NewBlock(pas.CurToken, ''); - tkBegin: +// ShowMessage('ParseSource4'); + while True do begin - if Assigned(lBlock) - and (lBlock.token in [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) then begin - if lProfiling then begin - { insert: lazprofiler.enter() } - lToken := lBlock.token; - lName := lBlock.name; - lNameOfClass := lBlock.nameofclass; - lTempBlock := lBlock.parent; - if Assigned(lTempBlock) and (lTempBlock.token in [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) then begin - lParents := 'in '+lTempBlock.name; - lNameOfClass := lTempBlock.nameofclass; - lTempBlock := lTempBlock.parent; - while Assigned(lTempBlock) do begin - lParents := lTempBlock.name + ' in ' + lParents; - lNameOfClass := lTempBlock.nameofclass; - lTempBlock := lTempBlock.parent; + try + lCurrentToken := pas.FetchToken; + case lCurrentToken of + tkunit, tkprogram: + begin + while pas.FetchToken <> tkIdentifier do ; + lUnitName := pas.CurTokenString; end; - lName := lName +' (' + lParents + ')'; - end; - //DebugLn({lBlock.gap + }'-> ' + lName + ' ' + IntToStr(level)); - CheckFile; - lBlock.procid := AddProc(lName, Integer(lToken), lNameOfClass, lUnitName, lCurFile.FileName, lCurFile.PackageName, pas.CurRow - 1); - if lBlock.procid <> -1 then - InsertEnter(pas.CurRow - 1, pas.CurColumn, lBlock.procid); - //WriteLn(' +', lName, ' - ', IntToStr(lBlock.procid), ' - ', lCurFile.PackageName, '.', ExtractFileName(lCurFile.Filename)); - end; - end; - NewBlock(pas.CurToken, ''); - end; - tkCase: if not Assigned(lBlock) - or not (lBlock.token in [tkclass, tkobject, tkrecord]) then begin - NewBlock(pas.CurToken, ''); - end; - tkEnd: - begin - if Assigned(lBlock) then - lLastBlockToken := lBlock.token - else - lLastBlockToken := tkEOF; - PopBlock; - if Assigned(lBlock) - and (lBlock.token in [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) - and (lLastBlockToken = tkbegin) then begin - if lProfiling then begin - { insert lazprofiler.exit } - //DebugLn(' ' + lBlock.Name + ' ' + IntToStr(level)); - if lBlock.procid <> -1 then begin - InsertExit(pas.CurRow - 1, pas.CurTokenPos.Column, lBlock.procid); // CurTokenPos needs FPC trunk 37235 - if lBlock = lStartProc then begin - CheckFile; - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: Profiler not stopped in ' + lStartProc.name, lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - Exit(False); + tkAsm: + begin + if Assigned(lBlock) and not (lBlock.token in + [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) then + NewBlock(pas.CurToken, ''); end; - end; - end; - PopBlock; - end; - end; - tktry: - NewBlock(pas.CurToken, ''); - tkconstructor, - tkdestructor, - tkFunction, - tkProcedure, - tkoperator: - DoProc; - tkidentifier: - if UpperCase(pas.CurTokenString) = 'EXTERNAL' then - PopBlock; - tkclass, - tkobject, - tkRecord: begin - NewBlock(pas.CurToken, ''); - while pas.FetchToken in [tkTab, tkWhitespace, tkComment, tkLineEnding] do; - if pas.CurToken in [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator] then begin - { class function/procedure/operator } - PopBlock; - DoProc; - end; - end; - tkuses: begin - case lPart of - tkinterface: - lIntUsesPos := Point(pas.CurColumn, pas.CurRow - 1); - else - { tkimplementation or tkUnknown } - lImpUsesPos := Point(pas.CurColumn, pas.CurRow - 1); - end; - end; - tkinterface: begin - lIntPos := Point(0, pas.CurRow); - lPart := tkinterface; - end; - tkimplementation: begin - //debugln(' IMPLEMENTATION'); - ClearStack; - lImpPos := Point(0, pas.CurRow); - lPart := tkimplementation; - end; - tkComment: begin - CheckFile; - lUpComment := UpperCase(Trim(pas.CurTokenString)); - if lUpComment = 'START-PROFILER' then begin - if not lProfiling then - Continue; - if Assigned(lStartProc) then begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: START-PROFILER: Profiler already started', lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - exit(False); - end else begin - lTempBlock := lBlock; - while Assigned(lTempBlock) - and not (lTempBlock.token in [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) do - lTempBlock := lTempBlock.parent; - if Assigned(lTempBlock) then begin - if lTempBlock.procid <> -1 then begin - //WriteLn('*** LazProfiler: START-PROFILER: ', lCurFile.Filename, ' - ', IntToStr(pas.CurRow)); - lStartProc := lTempBlock; - InsertStart(pas.CurRow - 1, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - fAutoStart := False; + tkBegin: + begin + if Assigned(lBlock) and (lBlock.token in + [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) then + begin + if lProfiling then + begin + { insert: lazprofiler.enter() } + lToken := lBlock.token; + lName := lBlock.Name; + lNameOfClass := lBlock.nameofclass; + lTempBlock := lBlock.parent; + if Assigned(lTempBlock) and (lTempBlock.token in + [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) then + begin + lParents := 'in ' + lTempBlock.Name; + lNameOfClass := lTempBlock.nameofclass; + lTempBlock := lTempBlock.parent; + while Assigned(lTempBlock) do + begin + lParents := lTempBlock.Name + ' in ' + lParents; + lNameOfClass := lTempBlock.nameofclass; + lTempBlock := lTempBlock.parent; + end; + lName := lName + ' (' + lParents + ')'; + end; + //DebugLn({lBlock.gap + }'-> ' + lName + ' ' + IntToStr(level)); + CheckFile; + lBlock.procid := AddProc(lName, integer(lToken), lNameOfClass, + lUnitName, lCurFile.FileName, lCurFile.PackageName, pas.CurRow - 1); + if lBlock.procid <> -1 then + InsertEnter(pas.CurRow - 1, pas.CurColumn, lBlock.procid); + //WriteLn(' +', lName, ' - ', IntToStr(lBlock.procid), ' - ', lCurFile.PackageName, '.', ExtractFileName(lCurFile.Filename)); + end; + end; + NewBlock(pas.CurToken, ''); end; - end else begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: START-PROFILER: not in procedure/function', lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - exit(False); - end; - end; - end else if lUpComment = 'STOP-PROFILER' then begin - if not lProfiling then - Continue; - lTempBlock := lBlock; - while Assigned(lTempBlock) and not (lTempBlock.token in [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) do lTempBlock := lTempBlock.parent; - if Assigned(lTempBlock) then begin - if lTempBlock.procid <> -1 then begin - if not Assigned(lStartProc) then begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: STOP-PROFILER: Profiler not started', lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - exit(False); - end else begin - if lTempBlock = lStartProc then begin - //WriteLn('*** LazProfiler: STOP-PROFILER: ', lCurFile.Filename, ' - ', IntToStr(pas.CurRow)); - InsertStop(pas.CurRow - 1, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - lStartProc := nil; - end else begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: STOP-PROFILER: Profiler not started in same procedure/function', lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - exit(False); + tkCase: + begin + if not Assigned(lBlock) or not (lBlock.token in [tkclass, tkobject, tkrecord]) then + begin + NewBlock(pas.CurToken, ''); end; end; - end; - end else begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: STOP-PROFILER: not in procedure/function', lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - exit(False); - end; - end else if lUpComment = 'PROFILER-NO' then begin - if not lProfiling then begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: PROFILER-NO: set twice', lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - exit(False); - end; - lProfiling := False; - lProfilingChangeLevel := level; - end else if lUpComment = 'PROFILER-YES' then begin - if lProfiling then begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: PROFILER-YES: set twice', lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - exit(False); - end; - if lProfilingChangeLevel <> level then begin - IDEMessagesWindow.AddCustomMessage(mluFatal, 'LazProfiler: PROFILER-YES: not set on same level as PROFILER-NO', lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 - exit(False); - end; - lProfiling := True + tkEnd: + begin + if Assigned(lBlock) then + lLastBlockToken := lBlock.token + else + lLastBlockToken := tkEOF; + PopBlock; + if Assigned(lBlock) and (lBlock.token in + [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) and + (lLastBlockToken = tkbegin) then + begin + if lProfiling then + begin + { insert lazprofiler.exit } + //DebugLn(' ' + lBlock.Name + ' ' + IntToStr(level)); + if lBlock.procid <> -1 then + begin + InsertExit(pas.CurRow - 1, pas.CurTokenPos.Column, lBlock.procid); + // CurTokenPos needs FPC trunk 37235 + if lBlock = lStartProc then + begin + CheckFile; + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: Profiler not stopped in ' + lStartProc.Name, lCurFile.FileName, + pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 + Exit(False); + end; + end; + end; + PopBlock; + end; + end; + tktry: + begin + NewBlock(pas.CurToken, ''); + end; + tkconstructor, tkdestructor, tkFunction, tkProcedure, tkoperator: + DoProc; + tkidentifier: + begin + if UpperCase(pas.CurTokenString) = 'EXTERNAL' then + PopBlock; + end; + tkclass, tkobject, tkRecord: + begin + NewBlock(pas.CurToken, ''); + while pas.FetchToken in [tkTab, tkWhitespace, tkComment, tkLineEnding] do ; + if pas.CurToken in [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator] then + begin + { class function/procedure/operator } + PopBlock; + DoProc; + end; + end; + tkuses: + begin + case lPart of + tkinterface: + lIntUsesPos := Point(pas.CurColumn, pas.CurRow - 1); + else + { tkimplementation or tkUnknown } + lImpUsesPos := Point(pas.CurColumn, pas.CurRow - 1); + end; + end; + tkinterface: + begin + lIntPos := Point(0, pas.CurRow); + lPart := tkinterface; + end; + tkimplementation: + begin + ClearStack; + lImpPos := Point(0, pas.CurRow); + lPart := tkimplementation; + end; + tkComment: + begin + CheckFile; + lUpComment := UpperCase(Trim(pas.CurTokenString)); + if lUpComment = 'START-PROFILER' then + begin + if not lProfiling then + Continue; + if Assigned(lStartProc) then + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: START-PROFILER: Profiler already started', lCurFile.FileName, + pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 + exit(False); + end + else + begin + lTempBlock := lBlock; + while Assigned(lTempBlock) and not + (lTempBlock.token in [tkprocedure, tkfunction, tkconstructor, + tkdestructor, tkoperator]) do + lTempBlock := lTempBlock.parent; + if Assigned(lTempBlock) then + begin + if lTempBlock.procid <> -1 then + begin + //WriteLn('*** LazProfiler: START-PROFILER: ', lCurFile.Filename, ' - ', IntToStr(pas.CurRow)); + lStartProc := lTempBlock; + InsertStart(pas.CurRow - 1, pas.CurTokenPos.Column); + // CurTokenPos needs FPC trunk 37235 + fAutoStart := False; + end; + end + else + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: START-PROFILER: not in procedure/function', lCurFile.FileName, + pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 + exit(False); + end; + end; + end + else if lUpComment = 'STOP-PROFILER' then + begin + if not lProfiling then + Continue; + lTempBlock := lBlock; + while Assigned(lTempBlock) and not (lTempBlock.token in + [tkprocedure, tkfunction, tkconstructor, tkdestructor, tkoperator]) do + lTempBlock := lTempBlock.parent; + if Assigned(lTempBlock) then + begin + if lTempBlock.procid <> -1 then + begin + if not Assigned(lStartProc) then + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: STOP-PROFILER: Profiler not started', lCurFile.FileName, + pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 + exit(False); + end + else + begin + if lTempBlock = lStartProc then + begin + //WriteLn('*** LazProfiler: STOP-PROFILER: ', lCurFile.Filename, ' - ', IntToStr(pas.CurRow)); + InsertStop(pas.CurRow - 1, pas.CurTokenPos.Column); + // CurTokenPos needs FPC trunk 37235 + lStartProc := nil; + end + else + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: STOP-PROFILER: Profiler not started in same procedure/function', + lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); + // CurTokenPos needs FPC trunk 37235 + exit(False); + end; + end; + end; + end + else + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: STOP-PROFILER: not in procedure/function', lCurFile.FileName, + pas.CurRow, pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 + exit(False); + end; + end + else if lUpComment = 'PROFILER-NO' then + begin + if not lProfiling then + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: PROFILER-NO: set twice', lCurFile.FileName, pas.CurRow, + pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 + exit(False); + end; + lProfiling := False; + lProfilingChangeLevel := level; + end + else if lUpComment = 'PROFILER-YES' then + begin + if lProfiling then + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: PROFILER-YES: set twice', lCurFile.FileName, pas.CurRow, + pas.CurTokenPos.Column); // CurTokenPos needs FPC trunk 37235 + exit(False); + end; + if lProfilingChangeLevel <> level then + begin + IDEMessagesWindow.AddCustomMessage(mluFatal, + 'LazProfiler: PROFILER-YES: not set on same level as PROFILER-NO', + lCurFile.FileName, pas.CurRow, pas.CurTokenPos.Column); + // CurTokenPos needs FPC trunk 37235 + exit(False); + end; + lProfiling := True; + end; + end; + tkEOF: + begin + break; + end; + end; // case + except + on E: Exception do; +// ShowMessage('Error Fetch Token'); end; end; - tkEOF: - break; - end; - if pInstrument - and pFile.Changed then begin + if pInstrument and pFile.Changed then + begin { insert uses } - if UpperCase(ExtractFileExt(pFile.FileName)) <> '.INC' then begin + if UpperCase(ExtractFileExt(pFile.FileName)) <> '.INC' then + begin if lImpUsesPos <> Point(-1, -1) then InsertUnit(lImpUsesPos.y, lImpUsesPos.x) else if lIntUsesPos <> Point(-1, -1) then @@ -1395,24 +1584,32 @@ function TProfilerAddon.ParseSource(pFile: TLPFile; pInstrument: Boolean): Boole fr.Free; end; - if pInstrument - and pfile.Changed - and not pFile.Save then + if pInstrument and pfile.Changed and not pFile.Save then Exit(False); + + except + on E: Exception do + ShowMessage(E.Message); + end; + //ShowMessage('ParseSource10'); end; procedure TProfilerAddon.RestoreModifiedSettings; var - i: Integer; + i: integer; lPasPkg: TLPPasPackage; lFiles: TStringList; lPkg: TIDEProjPackBase; begin - for i := 0 to fPackageList.Count -1 do begin + for i := 0 to fPackageList.Count - 1 do + begin lPasPkg := fPackageList[i]; - if lPasPkg.PackageIsProject then begin + if lPasPkg.PackageIsProject then + begin lPkg := fProject; - end else begin + end + else + begin lPkg := PackageEditingInterface.FindPackageWithName(fPackageList[i].PackageName); end; lFiles := TStringList.Create; @@ -1420,7 +1617,8 @@ procedure TProfilerAddon.RestoreModifiedSettings; lFiles.Delimiter := ';'; lFiles.StrictDelimiter := True; lFiles.DelimitedText := lPkg.LazCompilerOptions.OtherUnitFiles; - if lFiles.Count > 1 then begin + if lFiles.Count > 1 then + begin if lFiles[0] = fLazProfilerPath then lFiles.Delete(0); if lFiles[0] = fEpikTimerPath then @@ -1434,18 +1632,18 @@ procedure TProfilerAddon.RestoreModifiedSettings; lPkg.LazCompilerOptions.UnitOutputDirectory := lPasPkg.UnitOutputDirectory; end; // hint: save will only happen if ToolStatus is itNone or itDebugger: needs trunc 60719 - if not (LazarusIDE.ToolStatus in [itNone, itDebugger]) then - WriteLn('*** LazProfiler: RestoreModifiedSettings: Saving project and packages will not work. Use at least Lazarus trunk r60719.'); + // if not (LazarusIDE.ToolStatus in [itNone, itDebugger]) then + // WriteLn('*** LazProfiler: RestoreModifiedSettings: Saving project and packages will not work. Use at least Lazarus trunk r60719.'); LazarusIDE.DoSaveProject([]); PackageEditingInterface.DoSaveAllPackages([]); end; procedure TProfilerAddon.RestoreSources; var - i: Integer; + i: integer; lPkg: TIDEPackage; - procedure DeleteRT(pDir: String); + procedure DeleteRT(pDir: string); begin DeleteFile(pDir + cRunTimeFileName); DeleteFile(pDir + cCoreFileName); @@ -1453,8 +1651,7 @@ procedure TProfilerAddon.RestoreSources; end; begin - WriteLn('*** LazProfiler: RestoreSources'); - + // WriteLn('*** LazProfiler: RestoreSources'); BuildFileList(cBackupExtension, False); //fFileList.Sort; @@ -1468,11 +1665,13 @@ procedure TProfilerAddon.RestoreSources; procedure TProfilerAddon.RestoreSource(pFile: TLPFile); var - lOrigFileName: String; + lOrigFileName: string; begin //DebugLn(' ' + pFile.FileName); - lOrigFileName := LeftStr(pFile.Filename, length(pFile.Filename) - length(cBackupExtension)); - if FileExists(pFile.Filename) then begin + lOrigFileName := LeftStr(pFile.Filename, length(pFile.Filename) - + length(cBackupExtension)); + if FileExists(pFile.Filename) then + begin DeleteFile(lOrigFileName); RenameFile(pFile.Filename, lOrigFileName); //todo: touch file here to force rebuild @@ -1482,8 +1681,9 @@ procedure TProfilerAddon.RestoreSource(pFile: TLPFile); function TProfilerAddon.ProjectRunWithoutDebugBuilding(Sender: TObject; var Handled: boolean): TModalResult; begin - Result := mrOK; - if fProfiling then begin + Result := mrOk; + if fProfiling then + begin ModifySettings; // disable CheckFilesOnDisk LazarusIDE.CheckFilesOnDiskEnabled := False; { needs trunk 56204 } @@ -1492,16 +1692,18 @@ function TProfilerAddon.ProjectRunWithoutDebugBuilding(Sender: TObject; end; end; -procedure TProfilerAddon.ProjectBuildingFinished(Sender: TObject; BuildSuccessful: Boolean); +procedure TProfilerAddon.ProjectBuildingFinished(Sender: TObject; + BuildSuccessful: boolean); begin - if not fSourcesInstrumented then begin - if (LazarusIDE.ActiveProject <> nil) - and (pfAlwaysBuild in LazarusIDE.ActiveProject.Flags) then + if not fSourcesInstrumented then + begin + if (LazarusIDE.ActiveProject <> nil) and (pfAlwaysBuild in + LazarusIDE.ActiveProject.Flags) then LazarusIDE.ActiveProject.Flags := LazarusIDE.ActiveProject.Flags - [pfAlwaysBuild]; end; - if fProfiling then begin - if BuildSuccessful - and cAutoRestore then + if fProfiling then + begin + if BuildSuccessful and cAutoRestore then RestoreSources; // enable CheckFilesOnDisk LazarusIDE.CheckFilesOnDiskEnabled := True; { needs trunk 56204 } @@ -1513,7 +1715,8 @@ procedure TProfilerAddon.RunFinished(Sender: TObject); begin //WriteLn('*** LazProfiler: RunFinished'); LoadResult; - if fProfiling then begin + if fProfiling then + begin // enable CheckFilesOnDisk LazarusIDE.CheckFilesOnDiskEnabled := True; { needs trunk 56204 } // force rebuild on next run/compile @@ -1524,16 +1727,19 @@ procedure TProfilerAddon.RunFinished(Sender: TObject); if Assigned(ProfilerWindow) then ProfilerWindow.PageControl.ActivePageIndex := 0; fProfiling := False; - end else begin + end + else + begin fProcList.Init; end; end; -function TProfilerAddon.ProjectOpened(Sender: TObject; pProject: TLazProject): TModalResult; +function TProfilerAddon.ProjectOpened(Sender: TObject; + pProject: TLazProject): TModalResult; var - lTargetFileName: String; + lTargetFileName: string; begin - Result := mrOK; + Result := mrOk; //WriteLn('*** LazProfiler: ProjectOpened: '+pProject.ProjectInfoFile); fProject := pProject; fProcList.Clear; @@ -1555,14 +1761,13 @@ function TProfilerAddon.ProjectOpened(Sender: TObject; pProject: TLazProject): T pProject.Modified := False; end; -function TProfilerAddon.ProjectClose(Sender: TObject; AProject: TLazProject): TModalResult; +function TProfilerAddon.ProjectClose(Sender: TObject; + AProject: TLazProject): TModalResult; begin - Result := mrOK; - if FileExists(fTargetDir + fTargetName + cSettingExtension) - or ( - Assigned(ProfilerWindow) - and ProfilerWindow.DataChanged - ) then begin + Result := mrOk; + if FileExists(fTargetDir + fTargetName + cSettingExtension) or + (Assigned(ProfilerWindow) and ProfilerWindow.DataChanged) then + begin //WriteLn('*** LazProfiler: ProjectClose'); fNeedsRebuild := pfAlwaysBuild in AProject.Flags; SaveXML(fTargetDir + fTargetName + cSettingExtension); @@ -1576,21 +1781,23 @@ function TProfilerAddon.ProjectClose(Sender: TObject; AProject: TLazProject): TM function TProfilerAddon.SaveEditorFile(Sender: TObject; aFile: TLazProjectFile; SaveStep: TSaveEditorFileStep; TargetFilename: string): TModalResult; var - i: Integer; + i: integer; lFile: TLPFile; begin - Result := mrOK; - if fSourcesInstrumented - and (SaveStep = sefsAfterWrite) then begin + Result := mrOk; + if fSourcesInstrumented and (SaveStep = sefsAfterWrite) then + begin // prior r60687 ide checks if file on disk has been modified an writes it to disk // which destroys the instrumented source, so write it again TargetFilename := UpperCase(TargetFilename); - for i := 0 to fFileList.Count - 1 do begin + for i := 0 to fFileList.Count - 1 do + begin lFile := fFileList[i]; if lFile.FilenameUp = TargetFilename then lFile.Save; end; - for i := 0 to fIncludeList.Count - 1 do begin + for i := 0 to fIncludeList.Count - 1 do + begin lFile := fIncludeList[i]; if lFile.FilenameUp = TargetFilename then lFile.Save; @@ -1607,7 +1814,8 @@ constructor TProfilerAddon.Create; fOldClassList := TLPPasClassList.Create(True); fIncludeList := TLPFileList.Create(True); fOldProcList := TLPPasProcList.Create(True); - fUnitOutputDirectory := SysUtils.GetTempDir(False) + 'LazProfiler' + PathDelim + '$(TargetCPU)-$(TargetOS)'; + fUnitOutputDirectory := SysUtils.GetTempDir(False) + 'LazProfiler' + + PathDelim + '$(TargetCPU)-$(TargetOS)'; end; destructor TProfilerAddon.Destroy; @@ -1621,16 +1829,19 @@ destructor TProfilerAddon.Destroy; inherited Destroy; end; -procedure TProfilerAddon.CreateProfilerWindow(Sender: TObject; pFormName: string; var pForm: TCustomForm; DoDisableAutoSizing: boolean); +procedure TProfilerAddon.CreateProfilerWindow(Sender: TObject; + pFormName: string; var pForm: TCustomForm; DoDisableAutoSizing: boolean); begin - if CompareText(pFormName, cProfilerFormName)<>0 then exit; - IDEWindowCreators.CreateForm(ProfilerWindow, TLazProfilerForm, DoDisableAutosizing, LazarusIDE.OwningComponent); - pForm:=ProfilerWindow; + if CompareText(pFormName, cProfilerFormName) <> 0 then exit; + IDEWindowCreators.CreateForm(ProfilerWindow, TLazProfilerForm, + DoDisableAutosizing, LazarusIDE.OwningComponent); + pForm := ProfilerWindow; end; procedure TProfilerAddon.UpdateUI; begin - if not Assigned(ProfilerWindow) then begin + if not Assigned(ProfilerWindow) then + begin IDEWindowCreators.CreateForm(ProfilerWindow, TLazProfilerForm, False, Application); if Assigned(IDEDockMaster) then IDEDockMaster.MakeIDEWindowDockable(ProfilerWindow); @@ -1638,17 +1849,20 @@ procedure TProfilerAddon.UpdateUI; ProfilerWindow.VST.Header.SortColumn := SortColumn; ProfilerWindow.VST.Header.SortDirection := TSortDirection(SortDirection); RunCmd.Enabled := fActive; - if fActive then begin + if fActive then + begin ProfilerWindow.Data := fProcList; - end else begin - ProfilerWindow.Data := Nil; + end + else + begin + ProfilerWindow.Data := nil; end; ProfilerWindow.CBActive.Checked := fActive; end; procedure TProfilerAddon.Start(Sender: TObject); var - lTargetFileName: String; + lTargetFileName: string; lProject: TLazProject; lPKg: TIDEPackage; begin @@ -1683,14 +1897,15 @@ procedure TProfilerAddon.Start(Sender: TObject); RestoreSources; - if LazarusIDE.DoBuildProject(crRun, [pbfSkipLinking]) <> mrOK then + if LazarusIDE.DoBuildProject(crRun, [pbfSkipLinking]) <> mrOk then Exit; if (IDEMessagesWindow <> nil) then IDEMessagesWindow.Clear; fProfiling := True; - if LazarusIDE.DoRunProjectWithoutDebug<>mrOK then begin + if LazarusIDE.DoRunProjectWithoutDebug <> mrOk then + begin { error while compiling profiled project } fProfiling := False; LazarusIDE.CheckFilesOnDiskEnabled := True; { needs trunk 56204 } @@ -1701,19 +1916,21 @@ procedure TProfilerAddon.Start(Sender: TObject); procedure TProfilerAddon.ShowProfilerWindow(Sender: TObject); begin IDEWindowCreators.ShowForm(cProfilerFormName, True); - if Assigned(ProfilerWindow) then with ProfilerWindow do begin - if fActive then - PageControl.ActivePageIndex := 0 - else begin - PageControl.ActivePageIndex := 1; - CBActive.SetFocus; + if Assigned(ProfilerWindow) then with ProfilerWindow do + begin + if fActive then + PageControl.ActivePageIndex := 0 + else + begin + PageControl.ActivePageIndex := 1; + CBActive.SetFocus; + end; end; - end; end; procedure TProfilerAddon.CleanUp(Sender: TObject); var - lTargetFileName: String; + lTargetFileName: string; lProject: TLazProject; begin //DebugLn('LazProfiler: cleanup'); diff --git a/LazProfilerCore.pas b/LazProfilerCore.pas index 48aca78..77ce387 100644 --- a/LazProfilerCore.pas +++ b/LazProfilerCore.pas @@ -1430,7 +1430,7 @@ procedure TLazProfiler.EnterProfiling(pProcID: Integer); Lock; try if pProcID >= fProcList.Count then begin - WriteLn('TLazProfiler.EnterProfiling: pProcID >= fProcList.Count: '+IntToStr(pProcID)+'>='+IntToStr(fProcList.Count)); + //WriteLn('TLazProfiler.EnterProfiling: pProcID >= fProcList.Count: '+IntToStr(pProcID)+'>='+IntToStr(fProcList.Count)); Exit; end; lIdx := ThreadIndex(ThreadID); @@ -1458,11 +1458,11 @@ procedure TLazProfiler.ExitProfiling(pProcID: Integer); lCurStackFrame := fCurStackFrame[lIdx]; lCurStackFrame.fTicksEnd := lTimeStamp; if pProcID >= fProcList.Count then begin - WriteLn('TLazProfiler.ExitProfiling: pProcID >= fProcList.Count: '+IntToStr(pProcID)+'>='+IntToStr(fProcList.Count)); + //WriteLn('TLazProfiler.ExitProfiling: pProcID >= fProcList.Count: '+IntToStr(pProcID)+'>='+IntToStr(fProcList.Count)); Exit; end; - if lCurStackFrame.fPasProc <> fProcList[pProcID] then - WriteLn('TLazProfiler.ExitProfiling: Stack mismatch: '+lCurStackFrame.fPasProc.Name+'<->'+fProcList[pProcID].name); +// if lCurStackFrame.fPasProc <> fProcList[pProcID] then +// WriteLn('TLazProfiler.ExitProfiling: Stack mismatch: '+lCurStackFrame.fPasProc.Name+'<->'+fProcList[pProcID].name); if fPauseCount[lIdx] = 0 then begin lCurStackFrame.fOff := fOffTicks[lIdx]; fOffTicks[lIdx] := 0; @@ -1479,7 +1479,7 @@ procedure TLazProfiler.ExitProfiling(pProcID: Integer); procedure TLazProfiler.StartProfiling; begin fRunning := True; - WriteLn('### LazProfiler: Start'); + // WriteLn('### LazProfiler: Start'); end; procedure TLazProfiler.PauseProfiling; @@ -1515,7 +1515,7 @@ procedure TLazProfiler.ContinueProfiling; procedure TLazProfiler.StopProfiling; begin fRunning := False; - WriteLn('### LazProfiler: Stop'); + //WriteLn('### LazProfiler: Stop'); end; constructor TLazProfiler.Create(pProgramm: String); @@ -1578,9 +1578,9 @@ destructor TLazProfiler.Destroy; SetLength(fOffTicks, 0); fTimer.Free; if fTicks > 0 then - fProcList.Convert(fTicks) - else - WriteLn('*** LazProfiler: fTicks='+IntToStr(fTicks)); + fProcList.Convert(fTicks); +// else +// WriteLn('*** LazProfiler: fTicks='+IntToStr(fTicks)); if fLoaded then SaveXML(fName + cSettingExtension); DoneCriticalSection(fLock); diff --git a/LazProfilerWindow.lfm b/LazProfilerWindow.lfm index 9b3765a..62bffaf 100644 --- a/LazProfilerWindow.lfm +++ b/LazProfilerWindow.lfm @@ -1,13 +1,14 @@ object LazProfilerForm: TLazProfilerForm Left = 488 - Height = 201 + Height = 402 Top = 163 - Width = 605 + Width = 1210 Caption = 'Profiler' - ClientHeight = 201 - ClientWidth = 605 + ClientHeight = 402 + ClientWidth = 1210 + DesignTimePPI = 192 + Font.Height = -24 Position = poScreenCenter - LCLVersion = '2.1.0.0' object PageControl: TPageControl Left = 0 Height = 201 @@ -39,25 +40,23 @@ object LazProfilerForm: TLazProfilerForm MinWidth = 100 Position = 0 Text = 'Name' - Width = 437 + Width = 874 end item MinWidth = 85 Position = 1 Text = 'Class' - Width = 100 end item MinWidth = 80 Position = 2 Text = 'Unit' - Width = 100 end item MinWidth = 110 Position = 3 Text = 'Package' - Width = 110 + Width = 220 end item Alignment = taRightJustify @@ -65,7 +64,7 @@ object LazProfilerForm: TLazProfilerForm MinWidth = 60 Position = 4 Text = 'Count' - Width = 60 + Width = 120 end item Alignment = taRightJustify @@ -73,7 +72,7 @@ object LazProfilerForm: TLazProfilerForm MinWidth = 65 Position = 5 Text = '% Net' - Width = 65 + Width = 130 end item Alignment = taRightJustify @@ -81,7 +80,7 @@ object LazProfilerForm: TLazProfilerForm MinWidth = 60 Position = 6 Text = 'Σ Net' - Width = 60 + Width = 120 end item Alignment = taRightJustify @@ -89,7 +88,7 @@ object LazProfilerForm: TLazProfilerForm MinWidth = 75 Position = 7 Text = '% Gross' - Width = 75 + Width = 150 end item Alignment = taRightJustify @@ -97,7 +96,7 @@ object LazProfilerForm: TLazProfilerForm MinWidth = 70 Position = 8 Text = 'Σ Gross' - Width = 70 + Width = 140 end item Alignment = taRightJustify @@ -105,7 +104,7 @@ object LazProfilerForm: TLazProfilerForm MinWidth = 65 Position = 9 Text = 'Ø Net' - Width = 65 + Width = 130 end item Alignment = taRightJustify @@ -113,8 +112,9 @@ object LazProfilerForm: TLazProfilerForm MinWidth = 75 Position = 10 Text = 'Ø Gross' - Width = 75 + Width = 150 end> + Header.Height = 82 Header.Options = [hoColumnResize, hoDblClickResize, hoShowSortGlyphs, hoVisible] Header.SortColumn = 0 Images = Icons @@ -146,310 +146,89 @@ object LazProfilerForm: TLazProfilerForm ClientWidth = 597 ParentFont = False object CBActive: TCheckBox - Left = 8 + Left = 16 Height = 19 - Top = 8 + Top = 16 Width = 121 Caption = 'Activate LazProfiler' - OnChange = CBActiveChange TabOrder = 0 + OnChange = CBActiveChange end end end object Icons: TImageList Scaled = True - Left = 372 - Top = 133 + Left = 744 + Top = 266 Bitmap = { - 4C69090000001000000010000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000009B5306FF9B53 - 06FF9B5306FF9B5306FF9B5306FF9C5408FB9C52043E00000000000000000000 - 00000000000000000000000000000000000000000000000000009B5306FFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFF9B5306FFA05B11F49B510842000000000000 - 00000000000000000000000000000000000000000000000000009B5306FFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFF9B5306FFE7D6C3FFA05B11F49B5108420000 - 00000000000000000000000000000000000000000000000000009B5306FFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFF9B5306FF9B5306FF9B5306FF9C5408FC0000 - 00000000000000000000000000000000000000000000000000009B5306FFFFFF - FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF9B5306FF0000 - 00000000000000000000000000000000000000000000000000009B5306FFFFFF - FFFFFFFFFFFFF4F4F4FFFFFFFFFFF4F4F4FFFFFFFFFFFFFFFFFF9B5306FF0000 - 00000000000000000000000000000000000000000000000000009B5306FFFFFF - FFFFEFEFEFFF959595FFFFFFFFFF8C8C8CFFF8F8F8FFFFFFFFFF9B5306FF0000 - 00000000000000000000000000000000000000000000000000009B5306FFFCFC - FCFF898989FFEAEAEAFFFFFFFFFFDCDCDCFF949494FFFFFFFFFF9B5306FF0000 - 00000000000000000000000000000000000000000000000000009B5306FFFBFB - FBFF808080FFE9E9E9FFFFFFFFFFDCDCDCFF898989FFFFFFFFFF9B5306FF0000 - 00000000000000000000000000000000000000000000000000009B5306FFFFFF - FFFFEAEAEAFF939393FFFFFFFFFF888888FFF5F5F5FFFFFFFFFF9B5306FF0000 - 00000000000000000000000000000000000000000000000000009B5306FFFFFF - FFFFFFFFFFFFF7F7F7FFFFFFFFFFF7F7F7FFFFFFFFFFFFFFFFFF9B5306FF0000 - 00000000000000000000000000000000000000000000000000009B5306FF9B53 - 06FF9B5306FF9B5306FF9B5306FF9B5306FF9B5306FF9B5306FF9B5306FF0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00001A7EC1801A7EC18800000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000001A7E - C1801A7DC2FF1A7DC2FF1A7EC188000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000000000001A7EC1801A7D - C2FF1A7DC2FF1A7DC2FF1A7DC2FF1A7EC1880000000000000000000000000000 - 000000000000000000000000000000000000000000001A7EC1801A7DC2FF1A7D - C2FF1A7DC2FF1A7DC2FF1A7DC2FF1A7CC37F0000000000000000000000000000 - 0000000000000000000000000000000000001A7EC1801A7DC2FF1A7DC2FF1A7D - C2FF1A7DC2FF1A7DC2FF1A7CC37F0000000000000000000000001A7EC1801A7E - C188000000000000000000000000000000001A7CC3771A7DC2FF1A7DC2FF1A7D - C2FF1A7DC2FF1A7DC2FF0000000000000000000000001A7EC1801A7DC2FF1A7D - C2FF1A7EC188000000000000000000000000000000001A7CC3771A7DC2FF1A7D - C2FF1A7CC37F1A7DC2FF00000000000000001A7EC1801A7DC2FF1A7DC2FF1A7D - C2FF1A7CC37F00000000000000000000000000000000000000001A7EC1801A7E - C180000000001A7DC2FF1A7DC2FF1A7DC2FF1A7DC2FF1A7DC2FF1A7DC2FF1A7C - C37F000000000000000000000000000000000000000000000000000000000000 - 000000000000000000001A7DC2FF00000000000000001A7EC1801A7EC1800000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000001A7DC2FF0000000000000000000000001A7EC1801A7E - C188000000000000000000000000000000000000000000000000000000000000 - 000000000000000000001A7DC2FF00000000000000001A7EC1801A7DC2FF1A7D - C2FF1A7EC1880000000000000000000000000000000000000000000000000000 - 000000000000000000001A7DC2FF1A7DC2FF1A7DC2FF1A7DC2FF1A7DC2FF1A7D - C2FF1A7CC37F0000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000001A7CC3771A7DC2FF1A7DC2FF1A7C - C37F000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000000000001A7EC1801A7EC1800000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000429C311F469B31CD469B31CD429C311F00000000000000000000 - 00000000000000000000000000000000000000000000000000000000000000FF - 0002459A2F9C479B30FD469B30FF469B30FF479B30FD459A2F9C00FF00020000 - 0000000000000000000000000000000000000000000000000000489F3055469C - 31F1469B30FF469B30F4479B2F61489F3055469C31F1469B30FF469B30F4479B - 2F610000000000000000000000000000000000000000479B31CA469B30FF479B - 30FD459A2F9C00FF0002000000000000000000FF0002459A2F9C479B30FD469B - 30FF469C30A300000000000000000000000000000000469B30F4469B30FF469B - 30FF459B30C100FF0003000000000000000000FF0003459B30C1469B30FF469B - 30FF469B30F4000000000000000000000000000000002C611EEF3C862AFA469B - 30FC469B30FF469B30FC4499307B459C3076469B30FC469B30FF469B30FC3C85 - 2AFB2C611EEF0000000000000000000000000000000012290DEF234F17EF00AA - 0003459B30C1469B30FF469B30FF469B30FF469B30FF459B30C100AA0003234F - 17EF12290DEF000000000000000000000000000000000E1F0AEF0E1F0AEF0000 - 0000000000003E93332D469B31F7479B30F83E93332D00000000000000000E1F - 0AEF0E1F0AEF00000000000000000000000000000000060D04EF060D04EF0000 - 000000000000000000001D4115BF1D4115BF000000000000000000000000060E - 04EF060E04EF00000000000000000000000000000000000000EF000000F80000 - 001F0000000000000000000000BF000000BF00000000000000000000001F0000 - 00F8000000EF00000000000000000000000000000000000000BD000000FF0000 - 00FD0000009C00000002000000BF000000BF000000020000009C000000FD0000 - 00FF000000B30000000000000000000000000000000000000000000000560000 - 00F2000000FF000000F3000000E1000000E0000000F2000000FF000000F30000 - 005C000000000000000000000000000000000000000000000000000000000000 - 00020000009C000000FD000000FF000000FF000000FD0000009C000000020000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000001F000000CF000000DA0000001F00000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000001F000000CD000000CD0000001F00000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00020000009C000000FD000000FF000000FF000000FD0000009C000000020000 - 0000000000000000000000000000000000000000000000000000000000550000 - 00F1000000FF000000F40000006100000055000000F1000000FF000000F40000 - 00610000000000000000000000000000000000000000000000A3000000FF0000 - 00FD0000009C000000020000000000000000000000020000009C010101FD0304 - 09FF000000A300000000000000000000000000000000000000D2000000FF0000 - 00FD0000009C0000000200000000000000000000000304040BC1070814FF0809 - 16FF060711F400000000000000000000000000000000010311C4000000E00000 - 00F2000000FF000000F30000005C04040976060711FC080916FF060711FC0708 - 13FB060719EF00000000000000000000000000000000050A3CD205072ECE0000 - 000202020AA0000000FD010204FF080916FF070814FF04040BC100000003070B - 2BEF0A0E4EEF00000000000000000000000000000000091063E1080E56DC0000 - 00000000000000071623070817FB070814FC0606062D00000000000000000B11 - 5FEF0D1582EF000000000000000000000000000000000D1584EF0B147AEA0000 - 00000000000000000000080A21F507091DF40000000000000000000000000D15 - 84EF0D1584EF00000000000000000000000000000000101BA5EF0F1CA5F81021 - 9C1F00000000000000000B0E42F80C1362F7000000000000000010219C1F0F1C - A5F8101BA5EF00000000000000000000000000000000101BA5BD101BA5FF101B - A5FD101AA59C0000FF020D1475FB0F1996FB0000FF02101AA59C101BA5FD101B - A5FF111BA5B300000000000000000000000000000000000000000F1AA457101B - A4F2101BA5FF101BA4F2101BA5FD101BA5FE101BA4F2101BA5FF101BA4F20F1A - A457000000000000000000000000000000000000000000000000000000000000 - FF02101AA59C101BA5FD101BA5FF101BA5FF101BA5FD101AA59C0000FF020000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000010219C1F101BA4CF101BA5DA10219C1F00000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000060503010654B2B93654B2B936050301000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0001654A2B60654C2BE9654B2BFC654B2BFC654C2BE9654A2B60000000010000 - 0000000000000000000000000000000000000000000000000000674C2B2F654B - 2BC4654B2BFF644B2BCB634C2B36674C2B2F654B2BC4654B2BFF644B2BCB634C - 2B360000000000000000000000000000000000000000664B2B7D654B2BFC654C - 2BE9654A2B6000000001000000000000000000000001654A2B60654C2BE9654B - 2BFC664B2B7D00000000000000000000000000000000654B2BBF654B2BFF654C - 2BE9654A2B6000000001000000000000000000000001654A2B60654C2BE9654B - 2BFF654B2BBF00000000000000000000000000000000654B2BBF654B2BD9654B - 2BC5654B2BFF654B2BC5654A2B30654A2B30654B2BC5654B2BFF654B2BC5654B - 2BD9654B2BBF00000000000000000000000000000000654B2BBF654B2BBF0000 - 0001654A2B60654C2BE9654B2BFC654B2BFC654C2BE9654A2B6000000001654B - 2BBF654B2BBF00000000000000000000000000000000654B2BBF654B2BBF0000 - 00000000000060503010654B2BD5654B2BD5605030100000000000000000654B - 2BBF654B2BBF00000000000000000000000000000000654B2BBF654B2BBF0000 - 00000000000000000000654B2BBF654B2BBF000000000000000000000000654B - 2BBF654B2BBF00000000000000000000000000000000654B2BBF654B2BD66050 - 30100000000000000000654B2BBF654B2BBF000000000000000060503010654B - 2BD6654B2BBF00000000000000000000000000000000664B2B7D654B2BFC654C - 2BE9654A2B6000000001654B2BBF654B2BBF00000001654A2B60654C2BE9654B - 2BFC664B2B7D0000000000000000000000000000000000000000654A2B30654B - 2BC5654B2BFF654B2BC5654B2BD9654B2BD9654B2BC5654B2BFF654B2BC5654A - 2B30000000000000000000000000000000000000000000000000000000000000 - 0001654A2B60654C2BE9654B2BFF654B2BFF654C2BE9654A2B60000000010000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000060503010654B2B93654B2B936050301000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000005000CF104900C9934900C9935000CF1000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - FF014800CA604800CAE94800CAFC4800CAFC4800CAE94800CA600000FF010000 - 00000000000000000000000000000000000000000000000000004700C92F4800 - CAC44800CAFF4800CACB4700CB364700C92F4800CAC44800CAFF4800CACB4700 - CB3600000000000000000000000000000000000000004700CA7D4800CAFC4800 - CAE94800CA600000FF0100000000000000000000FF014800CA604800CAE94800 - CAFC4700CA7D000000000000000000000000000000004800CABF4800CAFF4800 - CAE94800CA600000FF0100000000000000000000FF014800CA604800CAE94800 - CAFF4800CABF000000000000000000000000000000004800CABF4800CAD94800 - CAC54800CAFF4800CAC54A00CA304A00CA304800CAC54800CAFF4800CAC54800 - CAD94800CABF000000000000000000000000000000004800CABF4800CABF0000 - FF014800CA604800CAE94800CAFC4800CAFC4800CAE94800CA600000FF014800 - CABF4800CABF000000000000000000000000000000004800CABF4800CABF0000 - 0000000000005000CF104800CAD54800CAD55000CF1000000000000000004800 - CABF4800CABF000000000000000000000000000000004800CABF4800CABF0000 - 000000000000000000004800CABF4800CABF0000000000000000000000004800 - CABF4800CABF000000000000000000000000000000004800CABF4700CBD65000 - CF1000000000000000004800CABF4800CABF00000000000000005000CF104700 - CBD64800CABF000000000000000000000000000000004700CA7D4800CAFC4800 - CAE94800CA600000FF014800CABF4800CABF0000FF014800CA604800CAE94800 - CAFC4700CA7D00000000000000000000000000000000000000004A00CA304800 - CAC54800CAFF4800CAC54800CAD94800CAD94800CAC54800CAFF4800CAC54A00 - CA30000000000000000000000000000000000000000000000000000000000000 - FF014800CA604800CAE94800CAFF4800CAFF4800CAE94800CA600000FF010000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000005000CF104900C9934900C9935000CF1000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000FFFFFFFFFFFFFFFFFFFFFFFFFCFCFCFFD3D3 - E5FFA5A3F5FF817DEEFF6A67E9FF6360E7FF6F6BE8FF918FE9FFCCCCE1FFFCFC - FCFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEEEDF2FFA9A8F7FF7C77 - F1FF7976F0FF7177EFFF6577EEFF5C72EBFF5A61E7FF5351E3FF4B46DFFF8582 - ECFFEAEAF0FFFFFFFFFFFFFFFFFFFFFFFFFFEEEDF2FF9895F4FF827FF3FF8087 - F6FF4FAEF8FF14DFFDFF01F1FFFF00F2FFFF0AE2FDFF26ABF3FF4758E3FF443E - DCFF625EE1FFEAEAF0FFFFFFFFFFFCFCFCFFA9A8F7FF827FF3FF868CF7FF35CB - FDFF00F2FFFF03F0FFFF0CE7FEFF0CE5FEFF04ECFFFF00F2FFFF18BEF6FF4349 - DEFF3B36D9FF7976E1FFFBFBFCFFD3D3E5FF7B78F1FF8583F5FF8993F9FF36D2 - FFFF11E7FFFF55B2FAFF7786F4FF6F79F0FF4D8EF1FF0BE2FDFF00F2FFFF3370 - E6FF3C37DAFF322DD5FFC7C6DFFFA5A3F5FF7976F0FF8582F5FF8F8CF9FF9397 - FBFF7DA0FBFF8B88F7FF807DF3FF7571EFFF6966EAFF21C0F7FF00F2FFFF2989 - EBFF3C36D9FF302AD5FF7673E3FF827DEEFF7572EFFF7F7CF2FF8784F5FF8C89 - F7FF8B88F7FF8482F4FF7B79F1FF677AEFFF4298F2FF08E6FEFF01EFFFFF3469 - E4FF3A35D9FF2E29D4FF433ED7FF6B67E9FF6F6CECFF7774F0FF7E7AF2FF807E - F3FF807DF3FF6F85F3FF2EC2F9FF11DEFCFF01F0FFFF00F1FFFF1EACF2FF4042 - DDFF3732D7FF2B26D3FF322ED3FF6460E7FF6764E9FF6E6BECFF7370EEFF7572 - EFFF7571EEFF5B89F1FF01F0FFFF01EFFFFF10D4FAFF2C96EEFF444CE0FF3E39 - DAFF332ED6FF2823D2FF2B26D1FF6F6CE8FF5E5AE6FF6460E8FF6864EAFF6A66 - EBFF6965EAFF537FEEFF02EFFFFF0ED7FBFF4862E5FF4A47DFFF423DDCFF3833 - D8FF2E29D4FF2823D2FF423DD6FF9190E9FF5450E2FF5855E4FF5C59E5FF5E5B - E6FF5E5AE6FF5561E7FF3A85ECFF3C75E9FF4949E0FF433EDCFF3A35D9FF312C - D5FF2823D2FF2B26D2FF726FE2FFCDCCE1FF4B46DFFF4E4AE0FF514DE2FF524F - E2FF524EE2FF4F4EE1FF4951E1FF454ADFFF423DDCFF3A35D9FF322DD6FF2925 - D3FF2823D1FF231DCFFFC4C3DEFFFCFCFCFF7C79ECFF443EDCFF4641DDFF4742 - DDFF4742DDFF3865E4FF07E0FCFF13BAF4FF3639D9FF312CD5FF2A25D3FF2621 - D1FF251FD0FF6A66DFFFFBFBFBFFFFFFFFFFEAEAF0FF625EE1FF3B35D9FF3C36 - D9FF3B36D9FF2D60E2FF00F2FFFF0BC6F6FF2C30D5FF2823D2FF2823D1FF251F - D0FF4B47D9FFE8E8EFFFFFFFFFFFFFFFFFFFFFFFFFFFEAEAF0FF7976E1FF312C - D5FF2F2AD5FF2D30D5FF2445DAFF223BD7FF2824D2FF2B26D2FF231DCFFF6B62 - DEFFE8E8EEFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFBFBFCFFC7C6 - DFFF7774E3FF423ED6FF322ED3FF2B25D1FF413DD6FF726FE2FFC4C3DEFFFBFB - FBFFFFFFFFFFFFFFFFFFFFFFFFFF000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00004CA152FF4CA152FF4CA152FF4CA152FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00004CA152FF8ACF94FF8ACF94FF4CA152FF0000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00004CA152FF8ACF94FF8ACF94FF4CA152FF0000000000000000000000000000 - 0000000000000000000000000000000000004CA152FF4CA152FF4CA152FF4CA1 - 52FF4CA152FF8ACF94FF8ACF94FF4CA152FF4CA152FF4CA152FF4CA152FF0000 - 0000000000000000000000000000000000004CA152FF8ACF94FF8ACF94FF8ACF - 94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF4CA152FF0000 - 0000000000000000000000000000000000004CA152FF8ACF94FF8ACF94FF8ACF - 94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF4CA152FF0000 - 0000000000000000000000000000000000004CA152FF4CA152FF4CA152FF8ACF - 94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF4CA152FF4CA1 - 52FF4CA152FF4CA152FF000000000000000000000000000000004CA152FF8ACF - 94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF - 94FF8ACF94FF4CA152FF000000000000000000000000000000004CA152FF8ACF - 94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF - 94FF8ACF94FF4CA152FF00000000000000004CA152FF4CA152FF4CA152FF8ACF - 94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF4CA152FF4CA1 - 52FF4CA152FF4CA152FF00000000000000004CA152FF8ACF94FF8ACF94FF8ACF - 94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF8ACF94FF4CA152FF0000 - 0000000000000000000000000000000000004CA152FF8ACF94FF8ACF94FF8ACF - 94FF4CA152FF4CA152FF4CA152FF4CA152FF8ACF94FF8ACF94FF4CA152FF0000 - 0000000000000000000000000000000000004CA152FF8ACF94FF8ACF94FF8ACF - 94FF4CA152FF00000000000000004CA152FF8ACF94FF8ACF94FF4CA152FF0000 - 0000000000000000000000000000000000004CA152FF4CA152FF4CA152FF4CA1 - 52FF4CA152FF00000000000000004CA152FF4CA152FF4CA152FF4CA152FF0000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000C8733BF3C87137FFC87137FFC871 - 37FFC87137FFC87137FFC87137FFC87137FFC87137FFC87137FFC87137FFC871 - 37FFC87137FFC8733BF30000000000000000C87137FFC87137FFC87137FFC871 - 37FFC87137FFC87137FFC87137FFC87137FFC87137FFC87137FFC87137FFC871 - 37FFC87137FFC87137FF0000000000000000C87137FFC87137FFC87137FFC871 - 37FFC87137FFC87137FFC87137FFC87137FFC87137FFC87137FFC87137FFC871 - 37FFC87137FFC87137FF0000000000000000C87137FFFFFFFFFFFFFFFFFFFFFF - FFFFFEFEFEFFFCFCFCFFFBFBFBFFFAFAFAFFF9F9F9FFF7F7F7FFF6F6F6FFF5F5 - F5FFF3F3F3FFC87137FF0000000000000000C87137FFFFFFFFFFFFFFFFFFFDFD - FDFFFCFCFCFFFBFBFBFFF9F9F9FFF8F8F8FFF7F7F7FFF5F5F5FFF4F4F4FFF3F3 - F3FFF1F1F1FFC87137FF0000000000000000C87137FFFEFEFEFFEBEBEBFF9696 - 96FFF6F6F6FFF9F9F9FFF8F8F8FFF6F6F6FFF5F5F5FFF4F4F4FFF2F2F2FFF1F1 - F1FFF0F0F0FFC87137FF0000000000000000C87137FFFDFDFDFFF8F8F8FF8383 - 83FF7F7F7FFFF2F2F2FFF6F6F6FFF5F5F5FFF3F3F3FFF2F2F2FFF1F1F1FFEFEF - EFFFEEEEEEFFC87137FF0000000000000000C87137FFFBFBFBFFF9F9F9FFF0F0 - F0FF5B5B5BFFA8A8A8FFF4F4F4FFF3F3F3FFF2F2F2FFF0F0F0FFEFEFEFFFEEEE - EEFFECECECFFC87137FF0000000000000000C87137FFF9F9F9FFF5F5F5FF8282 - 82FF7E7E7EFFEFEFEFFFF2F2F2FFF1F1F1FFF0F0F0FFEEEEEEFFEDEDEDFFECEC - ECFFEAEAEAFFC87137FF0000000000000000C87137FFF7F7F7FFE5E5E5FF9393 - 93FFEFEFEFFFF2F2F2FFF1F1F1FFEFEFEFFFEEEEEEFFEDEDEDFFEBEBEBFFEAEA - EAFFE9E9E9FFC87137FF0000000000000000C87137FFF6F6F6FFF4F4F4FFF3F3 - F3FFF2F2F2FFF0F0F0FF666666FF666666FF666666FF666666FFEAEAEAFFE8E8 - E8FFE7E7E7FFC87137FF0000000000000000C87137FFF4F4F4FFF2F2F2FFF1F1 - F1FFF0F0F0FFEFEFEFFFEDEDEDFFECECECFFEBEBEBFFE9E9E9FFE8E8E8FFE7E7 - E7FFE6E6E6FFC87137FF0000000000000000C87137FFF2F2F2FFF1F1F1FFEFEF - EFFFEEEEEEFFEDEDEDFFEBEBEBFFEAEAEAFFE9E9E9FFE7E7E7FFE6E6E6FFE6E6 - E6FFE6E6E6FFC87137FF0000000000000000C8733BF3C87137FFC87137FFC871 - 37FFC87137FFC87137FFC87137FFC87137FFC87137FFC87137FFC87137FFC871 - 37FFC87137FFC8733BF300000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000 + 4C7A090000001000000010000000670800000000000078DAE59A7B5054F715C7 + 17D8B03C04A16AD2688D638D4E1481451B4C22612A1190477C86340D8EC50758 + 63A7440D521F3C8A62A0659A66509A16666AC730631FD33FDAFF3A9352A3A609 + C652216061883C94C702EEB20F586077F9F677EEDE5DEFDEBD77D905CDC4C96F + E63BFBE3DCF3F99DF33BBFF35B46AE0AC5D767D4EE0A845875AF0559EA762A13 + BDE5C5836C17B3234DB53B829266CB0FB45DF56A0D395EB017ABAFBC782D6F79 + 93C9E4F2E90BAFD3E970E1C2056E5E555585898909AF79ABD58ACACA4A0C0D0D + 714C676727CE9F3FEF356FB158505A5A0A8D46E3E4693D5FF2A7D8D5D5D5DCBC + A2A2026363633ED7CF6C36BB7C7ACBCF24C537602C2EBE52CA54316BB6E86370 + F2710D17D6C7352459D2E9AB250F8B95AB0BF32B94E27DA98BCB1A2CAE9077CB + 4F664F7C7EA5DC5C6A3F5ED6C3B99E38077EEDD9F0B3E92BD91A78DB130FA106 + 526733873B55FAB87C0724D5C52D4BA98DBB49A2B9D72014FEC9BF8BAD4BAD55 + DB526AD520D19C6CF4CC13BAE5F7EAAC94BA383DCF99526B63F74AD9A4D8D4DA + B846D958E29CEAD497C43CADEDC837B9567D853101023E806C8EE7E42BE6D7EE + 7D4697706ECD147B66E57DAC9B7FAB3E955CA73E2EB42594AFB190AF98FFD6EA + 30DD8A6D4FE9147F728BF52027F68C7CC857CC872F0BD1911C3F2756AF8F6667 + 67667B9EA0B99C9F630486297524A16DE9A6450D2417BF70E617AED4491C01D9 + 269884BDD2C0CB3196F13E52FC475CA5150A1B531D93BF80F7E76D36DEE7EF32 + 2DF43A9381F73132F530758B6CBB67E860712C714EDE0EDA6B135387A8268FCB + A09C6FF2F225FFB9D42F8B49CF3374C7F6CAD8A4C6250FB1B89CFCFCFC6C01CA + 60F0BEE2D1EC810F502A43AFA882162228F84904AA22DDEEBF5F40E435A95E53 + 2A838F337F2BCF5955410B2C81AAA7DDFAFF899084E6275431FFA1B8FEFE2117 + 290F3F7F25178FE2527CCA43151AA50B09DFEAC60747ECEF090A7FBDD369503D + B94215F49485B1D6C0C040E7FD0F8DFC912E6C51991B1FB6E8AC2E74E1C921A1 + 2D2864F9982A78A949EC4712F3114BEA75F3BF533F11B1BCCED92BA1E14913F3 + 16EC333B7DD833CE87F94AF01F3181C916B1B89ED51FFE610B0B2CF39FAEB1D0 + 9C6CDC33E613B9A45EF2FECF5FFCE10F22967C68B0AFC37D92FFB4D0463E33FC + 02738925CEC9DB4B407B65F19A18DB21ACC9E33272B6AB237233A2AA4934F701 + F5CB4D8FCAC9CD8CD230D6CA89E6CC46CF3C810733A36299FF35261CC888BAB1 + 3F332A5ECA26C5E66544157988E59213F98A79666FA0185EF0205F19BE9DE93A + EF739D316A4E429BDD478E6F98A97E023F395E787EAD24E1F979CBFB6213D8DB + 3CC5E2736A93E2A5CE4FAE2652E7C7C593AEB5DB99F8D0BFF0D0138FEAFE7C2D + C6764553449AE2B36A12CDBD27E1B745D198C3A461B2F2A2790E3DF344A62A3E + 8B657ED798C074235571235ECA26CD3616C9C772CD897CDDFEEDA1686CE063CC + C4934F830CDFCE749DF7B99EAE6854938436DE478E6F98A97E0FFCE4F807E7C7 + 7E6E2509CFCF5BDE179BC3CECEA6CD532C7A463E52BCD4F9C9D544EAFC68C8D4 + DAED4C7CE85FC8F7C4A3BA3FBE0DE1DF97E96FB72D2D7DA8BF34869F1769F1D6 + 410DF6E70C20FFF020DE7F4F83CF3FEFE17CA486F6BE017FBC6CC6E9423D4E1C + 1FC591421D720BB5D87D74186FEE1DC0AE1D779191D285F2B2110C0D8DBAB11F + 5C30A1ACC488D277C7B1EDAF1358D865839F1E501880905E1B56FDD988D437EE + 62736227F6EDE971AE41F9505C62CF5599F1FC0D1BC704B0C7F306A631AF6F1A + CA11FB3ADFFEE7385E49BB838DF1ED2CC71E582CF6FD9EFA991EE567C650593D + 89F866207200C8FADB140ACF99907F6214AFFE4A8FD05EFBBAEBDFEE47C2860E + AC8B6EC5BF3FE9E26A45FB2D2F1BC37B5593A8FE8D0545172DF8658519A54546 + 141CD1E150DE1096FFCBCCF1AB2B8791C0E2ABD7B4E2F8B1BB2863752E38AA43 + C96903DE3D3B86AA4A33C79E2D33E1D4093D0E9ED421E9030382FAA7E1A703BE + 77E81E5E7ABE1D31ABBFC02B89B771989D51FE4F4650F8CE288A4F1A505A6CE4 + E2E6971B11F3F12422EF58E1C76AA160B57CE62F067C3FE94B6C58771B51AB5A + B02EA60507D8F91E3CA0C14F0F8FE0D8DBF65C0A8E68915DA9E7388A19F1C514 + D6D668B139B31B892F76607D4C1B9E5BD1CCD6B8C5620F62CF9BFD6C9D41FCF8 + C010DECA1BC6A1DC21EC2AD1C29FB1E1B72DD8B2AF0FE9A95D487AB9132FACFF + 1F973BF1492FB7E1FD5F6BF0DAF65EBC91750FBB7FD8873DD9FDDC7A59AC675E + 2A1F414281066969DD6CAF9DDCBEE3D6B6F2B19B7134BF1737594F525F6D4DEF + C68E577BB1731BD3D65E6CDBDA83B41D3D484EB7C725765D741B56AF6C61FC2D + AC58DA846B57EF70FD73FAC408D757299BBE446A925D2FE4DE83AADB8A05FF30 + 21FE457BDC358C5DB5FC16562EFB2FDB6717F7AEC2FEBE6194EBC98D2C069D2D + F557744E2F77DEA19F8C63ADDA9E33C5253623B51D83833A973B406B504F529C + 58D61BD18C7936B903DFDD781BCF3D6BDF2FE57C78DF1DC66A25EF20F533F564 + E13B779194D8C69D6FD4CA5BD8C4EA4CB5A2FD3A72768C47F19D92F9879D106A + 36FC2F9ACE73FA2A7871BE627EA6BD08FD3DE951F2E2BCE5784F7BF1360FB95C + 66CBCF35FF875D7F4FBDE02DEF4B2F4AF5DFC3BA4B5FC5F8F4D846E3A74736C0 + 2731C6C9FBCAF27A98BC704C4F4F73BF17E8BB726A6A0A939393DC7BE0F1F171 + EE5DB2D16894E56D369B93258EDE9D134B1CBD8B2756AFD7BBF1147378781835 + 35355C1C07EB8849ACC160E0D8D1D151379EE292FF993367505252C2F90AF375 + B0F46E5FABD5BAF18E7C69EDECEC6C5CBE7CD9992FB16477B02323236E3CB114 + ABACAC0CC5C5C59CAF305FE2EEDFBFCFB1F47E5ECC538DFAFAFAB8F7F642D611 + 9358AA0FB1F47F03C43CED559C6F5E5E9E8B881D1C1CC4C0C0801B2FAE2FC575 + E44B7129A683EDEFEF77E367CAD7C139E4C2CFF1FECC65FC1F5692378A } BitmapAdv = { 4C69020000004C7A090000001800000018000000310F00000000000078DAED9C diff --git a/LazProfilerWindow.pas b/LazProfilerWindow.pas index 1b0451e..11b207d 100644 --- a/LazProfilerWindow.pas +++ b/LazProfilerWindow.pas @@ -82,21 +82,21 @@ TLazProfilerForm = class(TForm) { TLPProcClassComparer } TLPProcClassComparer = class(specialize TComparer) - function Compare(constref Left, Right: TLPPasProc): Integer; override; overload; + function Compare({$IF FPC_FULLVERSION < 30300} constref {$ELSE} const {$ENDIF} Left, Right: TLPPasProc): Integer; override; overload; end; { TLPProcUnitComparer } TLPProcUnitComparer = class(specialize TComparer) - function Compare(constref Left, Right: TLPPasProc): Integer; override; overload; + function Compare({$IF FPC_FULLVERSION < 30300} constref {$ELSE} const {$ENDIF} Left, Right: TLPPasProc): Integer; override; overload; end; { TLPProcPackageComparer } TLPProcPackageComparer = class(specialize TComparer) - function Compare(constref Left, Right: TLPPasProc): Integer; override; overload; + function Compare({$IF FPC_FULLVERSION < 30300} constref {$ELSE} const {$ENDIF} Left, Right: TLPPasProc): Integer; override; overload; end; implementation @@ -116,7 +116,7 @@ implementation { TLPProcPackageComparer } -function TLPProcPackageComparer.Compare(constref Left, Right: TLPPasProc): Integer; +function TLPProcPackageComparer.Compare({$IF FPC_FULLVERSION < 30300} constref {$ELSE} const {$ENDIF} Left, Right: TLPPasProc): Integer; begin if Left.PackageIsProject and not Right.PackageIsProject then @@ -133,7 +133,7 @@ function TLPProcPackageComparer.Compare(constref Left, Right: TLPPasProc): Integ { TLPProcUnitComparer } -function TLPProcUnitComparer.Compare(constref Left, Right: TLPPasProc): Integer; +function TLPProcUnitComparer.Compare({$IF FPC_FULLVERSION < 30300} constref {$ELSE} const {$ENDIF} Left, Right: TLPPasProc): Integer; begin Result := strcomp(PChar(Left.UnitNameUp), PChar(Right.UnitNameUp)); if Result = 0 then Result := strcomp(PChar(Left.NameOfClassUp), PChar(Right.NameOfClassUp)); @@ -143,7 +143,7 @@ function TLPProcUnitComparer.Compare(constref Left, Right: TLPPasProc): Integer; { TLPProcClassComparer } -function TLPProcClassComparer.Compare(constref Left, Right: TLPPasProc): Integer; +function TLPProcClassComparer.Compare({$IF FPC_FULLVERSION < 30300} constref {$ELSE} const {$ENDIF} Left, Right: TLPPasProc): Integer; begin Result := strcomp(PChar(Left.NameOfClassUp), PChar(Right.NameOfClassUp)); if Result = 0 then Result := strcomp(PChar(Left.NameUp), PChar(Right.NameUp)); @@ -370,7 +370,7 @@ procedure TLazProfilerForm.VSTResize(Sender: TObject); var i, lSize, lMaxSize, lMinSize, lCalcSize: Integer; begin - with Sender as TVirtualStringTree do begin + with Sender as TLazVirtualStringTree do begin UpdateVerticalScrollBar(False); lSize := ClientRect.Right - ClientRect.Left; lMaxSize := 0; @@ -419,7 +419,7 @@ procedure TLazProfilerForm.VSTStructureChange(Sender: TBaseVirtualTree; Node: PV var i, lNewColSize: Integer; begin - with Sender as TVirtualStringTree do begin + with Sender as TLazVirtualStringTree do begin for i := 0 to cColumnCount - 1 do begin lNewColSize := GetMaxColumnWidth(i); if lNewColSize < Header.Columns[i].MinWidth then