mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-09 05:33:05 +02:00
928 lines
28 KiB
ObjectPascal
928 lines
28 KiB
ObjectPascal
{
|
|
***************************************************************************
|
|
* *
|
|
* This source is free software; you can redistribute it and/or modify *
|
|
* it under the terms of the GNU General Public License as published by *
|
|
* the Free Software Foundation; either version 2 of the License, or *
|
|
* (at your option) any later version. *
|
|
* *
|
|
* This code is distributed in the hope that it will be useful, but *
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
|
* General Public License for more details. *
|
|
* *
|
|
* A copy of the GNU General Public License is available on the World *
|
|
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
|
* obtain it by writing to the Free Software Foundation, *
|
|
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
|
|
* *
|
|
***************************************************************************
|
|
|
|
Author: Mattias Gaertner
|
|
|
|
Abstract:
|
|
Shows all overloads of the procedure/method at sourcee editor position.
|
|
Sortable columns:
|
|
Path: unitnames.classes
|
|
(If not filtered:) Compatibility: exact, compatible, incompatible
|
|
Distance
|
|
Last visited
|
|
Filter:
|
|
Params must be compatible: Yes, No
|
|
(Only for method:) Only descendants, have same ancestor method, all
|
|
(Only for method:) Show abstract methods and interfaces
|
|
|
|
ToDo:
|
|
-show line number
|
|
-param compatibility
|
|
-last visited
|
|
-filter by ancestor
|
|
-hint: show file name + param list
|
|
}
|
|
unit CodyFindOverloads;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, AVL_Tree, contnrs, FileUtil, LazLoggerBase, LazUtilities,
|
|
CodyUtils, CodeToolManager, CodeTree, CodeCache, FindDeclarationTool,
|
|
PascalParserTool, BasicCodeTools, CTUnitGraph, FileProcs, StdCodeTools,
|
|
CodeGraph, LazIDEIntf, IDEWindowIntf, ProjectIntf, Forms, Controls, Graphics,
|
|
Dialogs, ExtCtrls, StdCtrls, Grids, ComCtrls;
|
|
|
|
type
|
|
TCFOUnit = class(TUGUnit)
|
|
public
|
|
end;
|
|
|
|
TCFONode = class(TCodeGraphNode)
|
|
public
|
|
Tool: TFindDeclarationTool;
|
|
|
|
// for ctnProcedure:
|
|
Compatibility: TTypeCompatibility;
|
|
Distance: integer;
|
|
ShortestPathNode: TCFONode;
|
|
end;
|
|
|
|
TCFOEdgeType = (
|
|
cfoetReachable, // FromNode (proc) is reachable by ToNode(program)
|
|
cfoetMethodOf, // FromNode (proc) is method of ToNode (class)
|
|
cfoetDescendantOf // FromNode (class) is descendant of ToNode (class)
|
|
);
|
|
|
|
TCFOEdge = class(TCodeGraphEdge)
|
|
public
|
|
Typ: TCFOEdgeType;
|
|
end;
|
|
|
|
TCFOProc = class
|
|
public
|
|
XYPos: TCodeXYPosition;
|
|
Name: string;
|
|
ClassPath: string;
|
|
TheUnitName: string;
|
|
Caption: string;
|
|
Params: string;
|
|
Distance: integer;
|
|
Compatibility: TTypeCompatibility;
|
|
end;
|
|
|
|
type
|
|
TCFOFlag = (
|
|
cfofParsing,
|
|
cfofGatherProcs
|
|
);
|
|
TCFOFlags = set of TCFOFlag;
|
|
|
|
{ TCodyFindOverloadsWindow }
|
|
|
|
TCodyFindOverloadsWindow = class(TForm)
|
|
BtnPanel: TPanel;
|
|
CompatibleParamsCheckBox: TCheckBox;
|
|
FilterGroupBox: TGroupBox;
|
|
HideAbstractCheckBox: TCheckBox;
|
|
JumpToButton: TButton;
|
|
ProgressBar1: TProgressBar;
|
|
RefreshButton: TButton;
|
|
RelationComboBox: TComboBox;
|
|
RelationLabel: TLabel;
|
|
ResultsGroupBox: TGroupBox;
|
|
ResultsStringGrid: TStringGrid;
|
|
Timer1: TTimer;
|
|
procedure FormClose(Sender: TObject; var {%H-}CloseAction: TCloseAction);
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormDestroy(Sender: TObject);
|
|
procedure JumpToButtonClick(Sender: TObject);
|
|
procedure OnIdle(Sender: TObject; var Done: Boolean);
|
|
procedure RefreshButtonClick(Sender: TObject);
|
|
procedure ResultsStringGridColRowExchanged(Sender: TObject;
|
|
IsColumn: Boolean; sIndex, tIndex: Integer);
|
|
procedure ResultsStringGridCompareCells(Sender: TObject; ACol, ARow, BCol,
|
|
BRow: Integer; var Result: integer);
|
|
procedure ResultsStringGridDblClick(Sender: TObject);
|
|
procedure Timer1Timer(Sender: TObject);
|
|
private
|
|
FIdleConnected: boolean;
|
|
FFlags: TCFOFlags;
|
|
FProcList: TObjectList;
|
|
FTargetName: string;
|
|
FTargetPath: string;
|
|
FTargetXYPosition: TCodeXYPosition;
|
|
FUsesGraph: TUsesGraph;
|
|
function GetProcCount: integer;
|
|
function GetProcs(Index: integer): TCFOProc;
|
|
procedure SetIdleConnected(AValue: boolean);
|
|
procedure CreateUsesGraph(out TheUsesGraph: TUsesGraph);
|
|
procedure StartParsing;
|
|
procedure AbortParsing;
|
|
procedure AddStartAndTargetUnits;
|
|
procedure GatherProcsOfAllUnits;
|
|
procedure GatherProcsOfUnit(NodeGraph: TCodeGraph; ProgNode: TCodeTreeNode;
|
|
CurUnit: TCFOUnit; ExcludeAbstractProcs: boolean;
|
|
var TargetGraphNode: TCFONode);
|
|
procedure CalcDistances(NodeGraph: TCodeGraph; TargetGraphNode: TCFONode);
|
|
procedure CreateProcList(NodeGraph: TCodeGraph; TargetGraphNode: TCFONode);
|
|
procedure FillGrid;
|
|
procedure FreeUsesGraph;
|
|
function GetDefaultCaption: string;
|
|
procedure FillFilterControls(ProcTool: TFindDeclarationTool;
|
|
ProcNode: TCodeTreeNode);
|
|
protected
|
|
procedure UpdateShowing; override;
|
|
public
|
|
procedure JumpToIdentifier;
|
|
function Init: boolean;
|
|
property IdleConnected: boolean read FIdleConnected write SetIdleConnected;
|
|
property ProcCount: integer read GetProcCount;
|
|
property Procs[Index: integer]: TCFOProc read GetProcs;
|
|
property TargetXYPosition: TCodeXYPosition read FTargetXYPosition;
|
|
property TargetName: string read FTargetName;
|
|
property TargetPath: string read FTargetPath;
|
|
property UsesGraph: TUsesGraph read FUsesGraph;
|
|
end;
|
|
|
|
var
|
|
CodyFindOverloadsWindow: TCodyFindOverloadsWindow;
|
|
|
|
procedure ShowFindOverloadsClicked(Sender: TObject);
|
|
procedure ShowFindOverloads(State: TIWGetFormState = iwgfShowOnTop);
|
|
|
|
function CompareCFONodeByDistance(Node1, Node2: Pointer): integer;
|
|
|
|
implementation
|
|
|
|
procedure ShowFindOverloadsClicked(Sender: TObject);
|
|
begin
|
|
ShowFindOverloads;
|
|
end;
|
|
|
|
procedure ShowFindOverloads(State: TIWGetFormState);
|
|
begin
|
|
if CodyFindOverloadsWindow = nil then
|
|
IDEWindowCreators.CreateForm(CodyFindOverloadsWindow,TCodyFindOverloadsWindow,
|
|
State=iwgfDisabled,LazarusIDE.OwningComponent)
|
|
else if State=iwgfDisabled then
|
|
CodyFindOverloadsWindow.DisableAlign;
|
|
if State>=iwgfShow then
|
|
IDEWindowCreators.ShowForm(CodyFindOverloadsWindow,State=iwgfShowOnTop);
|
|
end;
|
|
|
|
function CompareCFONodeByDistance(Node1, Node2: Pointer): integer;
|
|
var
|
|
n1: TCFONode absolute Node1;
|
|
n2: TCFONode absolute Node2;
|
|
begin
|
|
if n1.Distance<n2.Distance then
|
|
exit(-1)
|
|
else if n1.Distance>n2.Distance then
|
|
exit(1)
|
|
else
|
|
Result:=ComparePointers(n1.Node,n2.Node);
|
|
end;
|
|
|
|
{$R *.lfm}
|
|
|
|
{ TCodyFindOverloadsWindow }
|
|
|
|
procedure TCodyFindOverloadsWindow.FormCreate(Sender: TObject);
|
|
begin
|
|
FProcList:=TObjectList.Create(true);
|
|
|
|
Caption:=GetDefaultCaption;
|
|
RefreshButton.Caption:='Refresh';
|
|
JumpToButton.Caption:='Jump to';
|
|
|
|
FilterGroupBox.Caption:='Filter';
|
|
CompatibleParamsCheckBox.Caption:='Only procedures with compatible parameters';
|
|
CompatibleParamsCheckBox.Hint:='If unchecked list also procedures with same name, but incompatible parameter lists.';
|
|
HideAbstractCheckBox.Caption:='Hide abstract methods and methods of class interfaces';
|
|
RelationLabel.Caption:='Relations:';
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.FormDestroy(Sender: TObject);
|
|
begin
|
|
FreeAndNil(FProcList);
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.FormClose(Sender: TObject;
|
|
var CloseAction: TCloseAction);
|
|
begin
|
|
AbortParsing;
|
|
FreeUsesGraph;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.JumpToButtonClick(Sender: TObject);
|
|
begin
|
|
JumpToIdentifier;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.OnIdle(Sender: TObject; var Done: Boolean);
|
|
var
|
|
Completed: boolean;
|
|
begin
|
|
if cfofParsing in FFlags then begin
|
|
fUsesGraph.Parse(true,Completed,200);
|
|
if Completed then begin
|
|
FFlags:=FFlags-[cfofParsing]+[cfofGatherProcs];
|
|
end;
|
|
end else if cfofGatherProcs in FFlags then begin
|
|
GatherProcsOfAllUnits;
|
|
end else
|
|
IdleConnected:=false;
|
|
Done:=not IdleConnected;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.RefreshButtonClick(Sender: TObject);
|
|
begin
|
|
if cfofParsing in FFlags then exit;
|
|
Init;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.ResultsStringGridColRowExchanged(
|
|
Sender: TObject; IsColumn: Boolean; sIndex, tIndex: Integer);
|
|
begin
|
|
if (not IsColumn) and (sIndex>0) and (sIndex<=ProcCount)
|
|
and (tIndex>0) and (tIndex<=ProcCount) then
|
|
FProcList.Exchange(sIndex-1,tIndex-1);
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.ResultsStringGridCompareCells(
|
|
Sender: TObject; ACol, ARow, BCol, BRow: Integer; var Result: integer);
|
|
var
|
|
AProc, BProc: TCFOProc;
|
|
begin
|
|
if (ARow>0) and (ARow<=ProcCount) and (ACol=BCol)
|
|
and (BRow>0) and (BRow<=ProcCount) then begin
|
|
AProc:=Procs[ARow-1];
|
|
BProc:=Procs[BRow-1];
|
|
case ACol of
|
|
0: Result:=CompareText(AProc.Caption,BProc.Caption);
|
|
1: Result:=ord(AProc.Compatibility)-ord(BProc.Compatibility);
|
|
2: Result:=ord(AProc.Distance)-ord(BProc.Distance);
|
|
end;
|
|
if ResultsStringGrid.SortOrder=soDescending then
|
|
Result:=-Result;
|
|
//debugln(['TCodyFindOverloadsWindow.ResultsStringGridCompareCells "',AProc.Caption,'" "',BProc.Caption,'" ',Result]);
|
|
end else
|
|
debugln(['TCodyFindOverloadsWindow.ResultsStringGridCompareCells invalid ACol=',ACol,' ARow=',ARow,' BCol=',BCol,' BRow=',BRow]);
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.ResultsStringGridDblClick(Sender: TObject);
|
|
begin
|
|
JumpToIdentifier;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.Timer1Timer(Sender: TObject);
|
|
var
|
|
Cnt: Integer;
|
|
begin
|
|
if (FUsesGraph=nil) then exit;
|
|
Cnt:=0;
|
|
if FUsesGraph.FilesTree<>nil then
|
|
Cnt:=FUsesGraph.FilesTree.Count;
|
|
ResultsGroupBox.Caption:=Format('Scanning: %s units ...', [IntToStr(Cnt)]);
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.SetIdleConnected(AValue: boolean);
|
|
begin
|
|
if FIdleConnected=AValue then Exit;
|
|
FIdleConnected:=AValue;
|
|
if Application=nil then exit;
|
|
if IdleConnected then
|
|
Application.AddOnIdleHandler(@OnIdle)
|
|
else
|
|
Application.RemoveOnIdleHandler(@OnIdle);
|
|
end;
|
|
|
|
function TCodyFindOverloadsWindow.GetProcCount: integer;
|
|
begin
|
|
Result:=FProcList.Count;
|
|
end;
|
|
|
|
function TCodyFindOverloadsWindow.GetProcs(Index: integer): TCFOProc;
|
|
begin
|
|
Result:=TCFOProc(FProcList[Index]);
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.CreateUsesGraph(out TheUsesGraph: TUsesGraph
|
|
);
|
|
begin
|
|
TheUsesGraph:=CodeToolBoss.CreateUsesGraph;
|
|
if not TCFOUnit.InheritsFrom(TheUsesGraph.UnitClass) then
|
|
RaiseCatchableException('');
|
|
TheUsesGraph.UnitClass:=TCFOUnit;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.StartParsing;
|
|
begin
|
|
if (FUsesGraph<>nil) or (cfofParsing in FFlags) then
|
|
RaiseCatchableException('');
|
|
Include(FFlags,cfofParsing);
|
|
|
|
ProgressBar1.Visible:=true;
|
|
ProgressBar1.Style:=pbstMarquee;
|
|
ResultsGroupBox.Caption:='Scanning ...';
|
|
Timer1.Enabled:=true;
|
|
RefreshButton.Enabled:=false;
|
|
|
|
CreateUsesGraph(FUsesGraph);
|
|
|
|
LazarusIDE.BeginCodeTools;
|
|
AddStartAndTargetUnits;
|
|
|
|
IdleConnected:=true;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.AbortParsing;
|
|
begin
|
|
FFlags:=[];
|
|
IdleConnected:=false;
|
|
ProgressBar1.Visible:=false;
|
|
RefreshButton.Enabled:=true;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.AddStartAndTargetUnits;
|
|
var
|
|
aProject: TLazProject;
|
|
begin
|
|
FUsesGraph.TargetAll:=true;
|
|
// project lpr
|
|
aProject:=LazarusIDE.ActiveProject;
|
|
if (aProject<>nil) and (aProject.MainFile<>nil) then
|
|
FUsesGraph.AddStartUnit(aProject.MainFile.Filename);
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.GatherProcsOfAllUnits;
|
|
var
|
|
FileNode: TAVLTreeNode;
|
|
CurUnit: TCFOUnit;
|
|
NodeGraph: TCodeGraph;
|
|
ProgNode: TCodeTreeNode;
|
|
ExcludeAbstractProcs: Boolean;
|
|
TargetGraphNode: TCFONode;
|
|
begin
|
|
Exclude(FFlags,cfofGatherProcs);
|
|
Timer1.Enabled:=false;
|
|
// hide progress bar and update stats
|
|
ProgressBar1.Visible:=false;
|
|
RefreshButton.Enabled:=true;
|
|
ResultsGroupBox.Caption:=Format('Units: %s', [IntToStr(FUsesGraph.FilesTree.Count)]);
|
|
|
|
if FUsesGraph=nil then
|
|
exit;
|
|
debugln(['TCodyFindOverloadsWindow.GatherProcsOfAllUnits START']);
|
|
|
|
ExcludeAbstractProcs:=HideAbstractCheckBox.Checked;
|
|
ProgNode:=TCodeTreeNode.Create;
|
|
NodeGraph:=TCodeGraph.Create(TCFONode,TCFOEdge);
|
|
try
|
|
NodeGraph.AddGraphNode(ProgNode);
|
|
|
|
TargetGraphNode:=nil;
|
|
FileNode:=FUsesGraph.FilesTree.FindLowest;
|
|
while FileNode<>nil do begin
|
|
CurUnit:=TCFOUnit(FileNode.Data);
|
|
GatherProcsOfUnit(NodeGraph,ProgNode,CurUnit,ExcludeAbstractProcs,
|
|
TargetGraphNode);
|
|
FileNode:=FUsesGraph.FilesTree.FindSuccessor(FileNode);
|
|
end;
|
|
|
|
// ToDo: filter using RelationComboBox
|
|
|
|
if TargetGraphNode<>nil then
|
|
CalcDistances(NodeGraph,TargetGraphNode);
|
|
|
|
CreateProcList(NodeGraph,TargetGraphNode);
|
|
|
|
FillGrid;
|
|
finally
|
|
NodeGraph.Free;
|
|
ProgNode.Free;
|
|
end;
|
|
debugln(['TCodyFindOverloadsWindow.GatherProcsOfAllUnits END']);
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.GatherProcsOfUnit(NodeGraph: TCodeGraph;
|
|
ProgNode: TCodeTreeNode; CurUnit: TCFOUnit; ExcludeAbstractProcs: boolean;
|
|
var TargetGraphNode: TCFONode);
|
|
|
|
procedure AddAncestors(Tool: TFindDeclarationTool; ClassNode: TCodeTreeNode); forward;
|
|
|
|
function AddClassNode(Tool: TFindDeclarationTool; ClassNode: TCodeTreeNode): TCFONode;
|
|
var
|
|
Edge: TCFOEdge;
|
|
begin
|
|
if ClassNode=nil then
|
|
RaiseCatchableException('');
|
|
Result:=TCFONode(NodeGraph.GetGraphNode(ClassNode,false));
|
|
if Result<>nil then exit;
|
|
//debugln(['AddClassNode ',Tool.ExtractClassName(ClassNode,false)]);
|
|
Result:=TCFONode(NodeGraph.AddGraphNode(ClassNode));
|
|
Result.Tool:=Tool;
|
|
// create edge "reachable", so that all nodes are reachable
|
|
Edge:=TCFOEdge(NodeGraph.AddEdge(ClassNode,ProgNode));
|
|
Edge.Typ:=cfoetReachable;
|
|
AddAncestors(Tool,ClassNode);
|
|
end;
|
|
|
|
procedure AddAncestors(Tool: TFindDeclarationTool; ClassNode: TCodeTreeNode);
|
|
var
|
|
ListOfPFindContext: TFPList;
|
|
Params: TFindDeclarationParams;
|
|
Ancestor: PFindContext;
|
|
i: Integer;
|
|
Edge: TCFOEdge;
|
|
begin
|
|
//debugln(['AddAncestors ',Tool.ExtractClassName(ClassNode,false)]);
|
|
ListOfPFindContext:=nil;
|
|
Params:=TFindDeclarationParams.Create(nil);
|
|
try
|
|
Tool.FindAncestorsOfClass(ClassNode,ListOfPFindContext,Params,true,false);
|
|
if ListOfPFindContext<>nil then begin
|
|
for i:=0 to ListOfPFindContext.Count-1 do begin
|
|
Ancestor:=PFindContext(ListOfPFindContext[i]);
|
|
AddClassNode(Ancestor^.Tool,Ancestor^.Node);
|
|
// create edge "descendant of"
|
|
Edge:=TCFOEdge(NodeGraph.AddEdge(ClassNode,Ancestor^.Node));
|
|
Edge.Typ:=cfoetDescendantOf;
|
|
end;
|
|
end;
|
|
finally
|
|
Params.Free;
|
|
FreeListOfPFindContext(ListOfPFindContext);
|
|
end;
|
|
end;
|
|
|
|
procedure AddProcNode(Tool: TFindDeclarationTool; ProcNode: TCodeTreeNode;
|
|
TargetCleanPos: integer);
|
|
var
|
|
CurProcName: String;
|
|
GraphProcNode: TCFONode;
|
|
ClassNode: TCodeTreeNode;
|
|
Edge: TCFOEdge;
|
|
Compatibility: TTypeCompatibility;
|
|
IsTargetProc: Boolean;
|
|
begin
|
|
// check name
|
|
CurProcName:=Tool.ExtractProcName(ProcNode,[phpWithoutClassName]);
|
|
if CompareIdentifiers(PChar(CurProcName),PChar(FTargetName))<>0 then exit;
|
|
|
|
debugln(['TCodyFindOverloadsWindow.GatherProcsOfUnit ',Tool.CleanPosToStr(ProcNode.StartPos,true)]);
|
|
|
|
// check if method
|
|
ClassNode:=ProcNode.Parent;
|
|
while ClassNode<>nil do begin
|
|
if ClassNode.Desc in AllClasses then break;
|
|
ClassNode:=ClassNode.Parent;
|
|
end;
|
|
if ClassNode<>nil then begin
|
|
if ExcludeAbstractProcs then begin
|
|
if ClassNode.Desc in AllClassInterfaces then exit;
|
|
if Tool.ProcNodeHasSpecifier(ProcNode,psABSTRACT) then exit;
|
|
end;
|
|
end;
|
|
|
|
Compatibility:=tcExact;
|
|
if (TargetGraphNode=nil)
|
|
and (ProcNode.StartPos<=TargetCleanPos)
|
|
and (TargetCleanPos<ProcNode.FirstChild.EndPos) then begin
|
|
// this is the target proc
|
|
IsTargetProc:=true;
|
|
end else begin
|
|
// ToDo: check param compatibility
|
|
IsTargetProc:=false;
|
|
|
|
end;
|
|
|
|
// add node
|
|
GraphProcNode:=TCFONode(NodeGraph.AddGraphNode(ProcNode));
|
|
GraphProcNode.Tool:=Tool;
|
|
GraphProcNode.Compatibility:=Compatibility;
|
|
if IsTargetProc then
|
|
TargetGraphNode:=GraphProcNode;
|
|
|
|
// add edges
|
|
if ClassNode<>nil then begin
|
|
// create nodes for class and ancestors
|
|
AddClassNode(Tool,ClassNode);
|
|
// create edge "is method of"
|
|
Edge:=TCFOEdge(NodeGraph.AddEdge(ProcNode,ClassNode));
|
|
Edge.Typ:=cfoetMethodOf;
|
|
end else begin
|
|
// not a method
|
|
// create edge "reachable", so that all nodes are reachable
|
|
Edge:=TCFOEdge(NodeGraph.AddEdge(ProcNode,ProgNode));
|
|
Edge.Typ:=cfoetReachable;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
Tool: TStandardCodeTool;
|
|
ProcNode: TCodeTreeNode;
|
|
TargetCleanPos: integer;
|
|
begin
|
|
if ugufLoadError in CurUnit.Flags then exit;
|
|
if not (ugufReached in CurUnit.Flags) then exit; // this unit was not reached
|
|
if ugufIsIncludeFile in CurUnit.Flags then exit;
|
|
Tool:=CurUnit.Tool;
|
|
if (TargetGraphNode<>nil)
|
|
or (Tool.CaretToCleanPos(TargetXYPosition,TargetCleanPos)<>0) then
|
|
TargetCleanPos:=0;
|
|
|
|
ProcNode:=Tool.Tree.Root;
|
|
while ProcNode<>nil do begin
|
|
if ProcNode.Desc in [ctnImplementation,ctnBeginBlock] then break;
|
|
if ProcNode.Desc=ctnProcedure then
|
|
AddProcNode(Tool,ProcNode,TargetCleanPos);
|
|
ProcNode:=ProcNode.Next;
|
|
end;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.CalcDistances(NodeGraph: TCodeGraph;
|
|
TargetGraphNode: TCFONode);
|
|
var
|
|
Unvisited: TAVLTree;
|
|
|
|
procedure UpdateDistancesAlongEdges(GraphNode: TCFONode; Edges: TAVLTree);
|
|
var
|
|
AVLNode: TAVLTreeNode;
|
|
Edge: TCFOEdge;
|
|
NewDistance: Integer;
|
|
OtherNode: TCFONode;
|
|
WasUnvisited: Boolean;
|
|
begin
|
|
if Edges=nil then exit;
|
|
AVLNode:=Edges.FindLowest;
|
|
while AVLNode<>nil do begin
|
|
Edge:=TCFOEdge(AVLNode.Data);
|
|
NewDistance:=GraphNode.Distance;
|
|
case Edge.Typ of
|
|
cfoetReachable: NewDistance+=100000;// not related
|
|
cfoetMethodOf: ; // methods within one class are close
|
|
cfoetDescendantOf:
|
|
if GraphNode=Edge.FromNode then
|
|
NewDistance+=10 // going to the ancestors
|
|
else
|
|
NewDistance+=1; // going to the descendants
|
|
end;
|
|
if GraphNode=Edge.FromNode then begin
|
|
OtherNode:=TCFONode(Edge.ToNode);
|
|
end else begin
|
|
OtherNode:=TCFONode(Edge.FromNode);
|
|
end;
|
|
if NewDistance<OtherNode.Distance then begin
|
|
WasUnvisited:=Unvisited.Find(OtherNode)<>nil;
|
|
if WasUnvisited then
|
|
Unvisited.Remove(OtherNode);
|
|
OtherNode.Distance:=NewDistance;
|
|
OtherNode.ShortestPathNode:=GraphNode;
|
|
if WasUnvisited then
|
|
Unvisited.Add(OtherNode);
|
|
end;
|
|
AVLNode:=Edges.FindSuccessor(AVLNode);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
AVLNode: TAVLTreeNode;
|
|
GraphNode: TCFONode;
|
|
begin
|
|
debugln(['TCodyFindOverloadsWindow.CalcDistances ']);
|
|
|
|
Unvisited:=TAVLTree.Create(@CompareCFONodeByDistance);
|
|
try
|
|
// Dijkstra's shotest path algorithm
|
|
|
|
// build Unvisited queue, set Distance of TargetGraphNode to 0
|
|
// infinite Distance all other
|
|
AVLNode:=NodeGraph.Nodes.FindLowest;
|
|
while AVLNode<>nil do begin
|
|
GraphNode:=TCFONode(AVLNode.Data);
|
|
if GraphNode=TargetGraphNode then
|
|
GraphNode.Distance:=0
|
|
else
|
|
GraphNode.Distance:=High(integer);
|
|
Unvisited.Add(GraphNode);
|
|
AVLNode:=NodeGraph.Nodes.FindSuccessor(AVLNode);
|
|
end;
|
|
|
|
// for each node with minimum distance ...
|
|
while Unvisited.Count>0 do begin
|
|
// get unvisited node with minimum distance
|
|
AVLNode:=Unvisited.FindLowest;
|
|
GraphNode:=TCFONode(AVLNode.Data);
|
|
//debugln(['TCodyFindOverloadsWindow.CalcDistances GraphNode=',GraphNode.Tool.ExtractProcName(GraphNode.Node,[phpAddClassName]),' Distance=',GraphNode.Distance]);
|
|
Unvisited.Delete(AVLNode);
|
|
UpdateDistancesAlongEdges(GraphNode,GraphNode.InTree);
|
|
UpdateDistancesAlongEdges(GraphNode,GraphNode.OutTree);
|
|
end;
|
|
finally
|
|
Unvisited.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.CreateProcList(NodeGraph: TCodeGraph;
|
|
TargetGraphNode: TCFONode);
|
|
var
|
|
AVLNode: TAVLTreeNode;
|
|
aProc: TCFOProc;
|
|
GraphNode: TCFONode;
|
|
Tool: TFindDeclarationTool;
|
|
Node: TCodeTreeNode;
|
|
begin
|
|
FProcList.Clear;
|
|
|
|
AVLNode:=NodeGraph.Nodes.FindLowest;
|
|
while AVLNode<>nil do begin
|
|
GraphNode:=TCFONode(AVLNode.Data);
|
|
AVLNode:=NodeGraph.Nodes.FindSuccessor(AVLNode);
|
|
if GraphNode=TargetGraphNode then continue;
|
|
if GraphNode.Node.Desc<>ctnProcedure then continue;
|
|
aProc:=TCFOProc.Create;
|
|
|
|
Tool:=GraphNode.Tool;
|
|
Node:=GraphNode.Node;
|
|
Tool.CleanPosToCaret(Node.FirstChild.StartPos,aProc.XYPos);
|
|
aProc.Name:=Tool.ExtractProcName(Node,[phpWithoutClassName]);
|
|
aProc.ClassPath:=Tool.ExtractClassPath(Node);
|
|
aProc.TheUnitName:=Tool.GetSourceName(false);
|
|
aProc.Compatibility:=GraphNode.Compatibility;
|
|
aProc.Distance:=GraphNode.Distance;
|
|
FProcList.Add(aProc);
|
|
end;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.FillGrid;
|
|
var
|
|
Grid: TStringGrid;
|
|
Row: Integer;
|
|
s: String;
|
|
aProc: TCFOProc;
|
|
begin
|
|
Grid:=ResultsStringGrid;
|
|
Grid.BeginUpdate;
|
|
Grid.Visible:=true;
|
|
Grid.Columns[0].Title.Caption:='Name';
|
|
Grid.Columns[1].Title.Caption:='Compatibility';
|
|
Grid.Columns[2].Title.Caption:='Distance';
|
|
|
|
Grid.RowCount:=ProcCount+1;
|
|
for Row:=1 to ProcCount do begin
|
|
aProc:=Procs[Row-1];
|
|
|
|
// path
|
|
s:=aProc.TheUnitName+': ';
|
|
if aProc.ClassPath<>'' then
|
|
s+=aProc.ClassPath+'.';
|
|
s+=aProc.Name;
|
|
aProc.Caption:=s;
|
|
Grid.Cells[0,Row]:=s;
|
|
|
|
case aProc.Compatibility of
|
|
tcExact: s:='fits exactly';
|
|
tcCompatible: s:='compatible';
|
|
tcIncompatible: s:='incompatible';
|
|
end;
|
|
Grid.Cells[1,Row]:=s;
|
|
|
|
Grid.Cells[2,Row]:=IntToStr(aProc.Distance);
|
|
end;
|
|
|
|
Grid.EndUpdate(true);
|
|
|
|
Grid.HandleNeeded;
|
|
|
|
// ToDo: resize columns
|
|
|
|
JumpToButton.Enabled:=Grid.Row>0;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.FreeUsesGraph;
|
|
begin
|
|
FreeAndNil(FUsesGraph);
|
|
end;
|
|
|
|
function TCodyFindOverloadsWindow.GetDefaultCaption: string;
|
|
begin
|
|
Result:='Cody - Find Overloads';
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.FillFilterControls(
|
|
ProcTool: TFindDeclarationTool; ProcNode: TCodeTreeNode);
|
|
var
|
|
sl: TStringList;
|
|
ClassNode: TCodeTreeNode;
|
|
ListOfPFindContext: TFPList;
|
|
i: Integer;
|
|
aContext: PFindContext;
|
|
begin
|
|
// RelationComboBox
|
|
sl:=TStringList.Create;
|
|
try
|
|
ClassNode:=ProcNode;
|
|
while (ClassNode<>nil) and (not (ClassNode.Desc in AllClasses)) do
|
|
ClassNode:=ClassNode.Parent;
|
|
if ClassNode<>nil then begin
|
|
// method
|
|
sl.Add('Only descendants of '+ProcTool.ExtractClassName(ClassNode,false));
|
|
ListOfPFindContext:=nil;
|
|
try
|
|
ProcTool.FindClassAndAncestors(ClassNode,ListOfPFindContext,false);
|
|
if ListOfPFindContext<>nil then begin
|
|
for i:=0 to ListOfPFindContext.Count-1 do begin
|
|
aContext:=PFindContext(ListOfPFindContext[i]);
|
|
sl.Add('Only descendants of '+aContext^.Tool.ExtractClassName(aContext^.Node,false));
|
|
end;
|
|
end;
|
|
finally
|
|
FreeListOfPFindContext(ListOfPFindContext);
|
|
end;
|
|
sl.Add('Only methods');
|
|
end else begin
|
|
// procedure, non method
|
|
sl.Add('Only non methods');
|
|
end;
|
|
sl.Add('Any');
|
|
RelationComboBox.Items:=sl;
|
|
if sl.IndexOf(RelationComboBox.Text)<0 then
|
|
RelationComboBox.Text:='Any';
|
|
finally
|
|
sl.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.UpdateShowing;
|
|
begin
|
|
inherited UpdateShowing;
|
|
if IsVisible and (FUsesGraph=nil) then begin
|
|
Init;
|
|
end;
|
|
end;
|
|
|
|
procedure TCodyFindOverloadsWindow.JumpToIdentifier;
|
|
var
|
|
i: Integer;
|
|
aProc: TCFOProc;
|
|
begin
|
|
i:=ResultsStringGrid.Row-1;
|
|
if (i<0) or (i>=ProcCount) then exit;
|
|
aProc:=Procs[i];
|
|
LazarusIDE.DoOpenFileAndJumpToPos(aProc.XYPos.Code.Filename,
|
|
Point(aProc.XYPos.X,aProc.XYPos.Y),-1,-1,-1,[]);
|
|
end;
|
|
|
|
function TCodyFindOverloadsWindow.Init: boolean;
|
|
var
|
|
CurTool: TCodeTool;
|
|
CurNode: TCodeTreeNode;
|
|
CurCodePos: TCodeXYPosition;
|
|
CurCleanPos: integer;
|
|
|
|
procedure FindProcDeclaration(ProcTool: TFindDeclarationTool;
|
|
var ProcNode: TCodeTreeNode);
|
|
// find the method declaration of a method body
|
|
// find the forward or interface declaration of a proc body
|
|
var
|
|
Node: TCodeTreeNode;
|
|
begin
|
|
if ProcNode=nil then exit;
|
|
if ProcNode.Desc=ctnProcedureHead then
|
|
ProcNode:=ProcNode.Parent;
|
|
if ProcNode.Desc<>ctnProcedure then exit;
|
|
if ProcNode.Parent.Desc=ctnInterface then exit;
|
|
if (ProcNode.Parent.Desc=ctnImplementation)
|
|
or ProcTool.NodeIsMethodBody(ProcNode)
|
|
or (not ProcTool.NodeIsForwardProc(ProcNode)) then begin
|
|
Node:=ProcTool.FindCorrespondingProcNode(ProcNode,[phpWithoutClassName]);
|
|
if Node=nil then exit;
|
|
ProcNode:=Node;
|
|
end;
|
|
end;
|
|
|
|
function CheckCursorAtProcCall(StatementNode: TCodeTreeNode;
|
|
out ProcTool: TFindDeclarationTool; out ProcNode: TCodeTreeNode): boolean;
|
|
var
|
|
CurIdentStart, CurIdentEnd, NewTopLine: integer;
|
|
NewTool: TFindDeclarationTool;
|
|
NewNode: TCodeTreeNode;
|
|
NewPos: TCodeXYPosition;
|
|
begin
|
|
Result:=true;
|
|
ProcTool:=nil;
|
|
ProcNode:=nil;
|
|
if StatementNode=nil then exit;
|
|
// cursor in statement => check if on a proc call.
|
|
if (CurCodePos.Code=nil) then exit;
|
|
GetIdentStartEndAtPosition(CurTool.Src,CurCleanPos,CurIdentStart,CurIdentEnd);
|
|
if CurIdentStart>=CurIdentEnd then exit;
|
|
DebugLn(['TCodyFindOverloadsDialog.Init.IsCursorAtProcCall checking identifier "',copy(CurTool.Src,CurIdentStart,CurIdentEnd-CurIdentStart),'"']);
|
|
if not CurTool.FindDeclaration(CurCodePos,DefaultFindSmartFlags,
|
|
NewTool,NewNode,NewPos,NewTopLine)
|
|
then begin
|
|
ResultsGroupBox.Caption:='Parse error';
|
|
LazarusIDE.DoJumpToCodeToolBossError;
|
|
exit(false);
|
|
end;
|
|
if NewNode.Desc in [ctnProcedure,ctnProcedureHead] then begin
|
|
ProcTool:=NewTool;
|
|
ProcNode:=NewNode;
|
|
FindProcDeclaration(ProcTool,ProcNode);
|
|
debugln(['TCodyFindOverloadsDialog.Init.CheckCursorAtProcCall TargetProc ',ProcTool.CleanPosToStr(ProcNode.StartPos,true),' Class=',ProcTool.ExtractProcName(ProcNode,[phpAddClassName])]);
|
|
end;
|
|
end;
|
|
|
|
var
|
|
ProcNode, Node, BeginNode, TargetProcNode: TCodeTreeNode;
|
|
ErrorHandled: boolean;
|
|
CurInitError: TCUParseError;
|
|
TargetTool: TFindDeclarationTool;
|
|
begin
|
|
Result:=false;
|
|
Caption:=GetDefaultCaption;
|
|
|
|
AbortParsing;
|
|
ResultsStringGrid.Visible:=false;
|
|
JumpToButton.Enabled:=false;
|
|
FTargetName:='';
|
|
FTargetPath:='';
|
|
FTargetXYPosition:=CleanCodeXYPosition;
|
|
FreeUsesGraph;
|
|
|
|
// parse source
|
|
CurInitError:=ParseTilCursor(CurTool, CurCleanPos, CurNode, ErrorHandled, true, @CurCodePos);
|
|
if CurInitError<>cupeSuccess then begin
|
|
ResultsGroupBox.Caption:='Parse error';
|
|
exit;
|
|
end;
|
|
|
|
// find target proc node
|
|
ProcNode:=nil;
|
|
BeginNode:=nil;
|
|
Node:=CurNode;
|
|
TargetTool:=nil;
|
|
TargetProcNode:=nil;
|
|
while Node<>nil do begin
|
|
if Node.Desc=ctnProcedure then begin
|
|
ProcNode:=Node;
|
|
break;
|
|
end else if (BeginNode=nil) and (Node.Desc=ctnBeginBlock) then begin
|
|
BeginNode:=Node;
|
|
if not CheckCursorAtProcCall(BeginNode,TargetTool,TargetProcNode) then
|
|
exit;
|
|
end;
|
|
Node:=Node.Parent;
|
|
end;
|
|
|
|
FindProcDeclaration(CurTool,ProcNode);
|
|
if ProcNode<>nil then begin
|
|
// ToDo: add to visited procs
|
|
debugln(['TCodyFindOverloadsDialog.Init ContextProc ',CurTool.CleanPosToStr(ProcNode.StartPos,true),' Class=',CurTool.ExtractProcName(ProcNode,[phpAddClassName])]);
|
|
end;
|
|
|
|
if TargetProcNode=nil then begin
|
|
TargetTool:=CurTool;
|
|
TargetProcNode:=ProcNode;
|
|
end;
|
|
if TargetProcNode=nil then begin
|
|
ResultsGroupBox.Caption:='Need source editor at procedure call or declaration';
|
|
exit;
|
|
end;
|
|
|
|
FTargetName:=TargetTool.ExtractProcName(TargetProcNode,[phpWithoutClassName]);
|
|
FTargetPath:=TargetTool.ExtractProcName(TargetProcNode,[phpAddClassName]);
|
|
TargetTool.CleanPosToCaret(TargetProcNode.StartPos,FTargetXYPosition);
|
|
Caption:=GetDefaultCaption+' - '+FTargetPath;
|
|
|
|
FillFilterControls(TargetTool,TargetProcNode);
|
|
|
|
StartParsing;
|
|
|
|
Result:=true;
|
|
end;
|
|
|
|
end.
|
|
|