1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Author: Mattias Gaertner
22
23 Abstract:
24 Find all alternative declarations of an identifier.
25
26 TCarbonControl = class(TCarbonWidget)
27 procedure TCarbonControl.CreateWidget(const AParams: TCreateParams);
28 TCarbonCustomCheckBox = class(TCarbonControl)
29 TCarbonCheckBox = class(TCarbonCustomCheckBox)
30 procedure TCarbonCheckBox.CreateWidget(const AParams: TCreateParams);
31
32 }
33 unit FindOverloadsDlg;
34
35 {$mode objfpc}{$H+}
36
37 interface
38
39 uses
40 Classes, SysUtils, Laz_AVL_Tree,
41 // LCL
42 LCLProc, LazFileUtils, Forms, Controls, StdCtrls, ButtonPanel, ComCtrls,
43 // codetools
44 FindDeclarationTool, PascalParserTool, CodeTree, CodeCache, CodeToolManager,
45 FindOverloads,
46 // IDE
47 LazIDEIntf, ProjectIntf, SrcEditorIntf, IDEProcs;
48
49 type
50
51 { TFOWFile }
52
53 TFOWFile = class
54 private
55 FCode: TCodeBuffer;
56 FFilename: string;
57 FOnlyInterface: boolean;
58 FScanned: boolean;
59 procedure SetCode(const AValue: TCodeBuffer);
60 procedure SetScanned(const AValue: boolean);
61 public
62 constructor Create(const TheFilename: string);
63 destructor Destroy; override;
64 property Filename: string read FFilename;
65 property OnlyInterface: boolean read FOnlyInterface write FOnlyInterface;
66 property Scanned: boolean read FScanned write SetScanned;
67 property Code: TCodeBuffer read FCode write SetCode;
68 end;
69
70 TFindOverloadsScope = (
71 fosProject,
72 fosPackages,
73 fosOtherSources
74 );
75 TFindOverloadsScopes = set of TFindOverloadsScope;
76
77 TFOWStage = (
78 fowsStart,
79 fowsFinished
80 );
81
82 { TFindOverloadsWorker }
83
84 TFindOverloadsWorker = class
85 private
86 FFiles: TAvlTree;
87 FScanFiles: TAvlTree;
88 FStagePosition: integer;
89 FStagePosMax: integer;
90 FStageTitle: string;
91 procedure CollectProjectFiles;
92 procedure CollectPackageFiles;
93 procedure CollectOtherSourceFiles;
94 procedure ScanSomeFiles;
95 procedure ScanFile(AFile: TFOWFile);
96 procedure CollectStartSource;
97 public
98 StartSourceScanned: boolean;
99 Scopes: TFindOverloadsScopes;
100 CompletedScopes: TFindOverloadsScopes;
101 Graph: TDeclarationOverloadsGraph;
102 constructor Create;
103 destructor Destroy; override;
104 procedure Clear;
105 procedure Work;
Donenull106 function Done: boolean;
107 procedure StopSearching;
AddFileToScannull108 function AddFileToScan(const Filename: string;
109 CheckExtension: boolean = true): TFOWFile;
FindFilenull110 function FindFile(const Filename: string): TFOWFile;
111 property Files: TAvlTree read FFiles; // tree of TFindOverloadsWorkerFile
112 property ScanFiles: TAvlTree read FScanFiles;// tree of TFindOverloadsWorkerFile
113 property StageTitle: string read FStageTitle write FStageTitle;
114 property StagePosition: integer read FStagePosition write FStagePosition;
115 property StagePosMax: integer read FStagePosMax write FStagePosMax;
116 end;
117
118 { TFindOverloadsDialog }
119
120 TFindOverloadsDialog = class(TForm)
121 ButtonPanel1: TButtonPanel;
122 SearchAllCheckBox: TCheckBox;
123 CurGroupBox: TGroupBox;
124 ResultsProgressBar: TProgressBar;
125 ResultsGroupBox: TGroupBox;
126 CurTreeView: TTreeView;
127 ResultsTreeView: TTreeView;
128 procedure ButtonPanel1Click(Sender: TObject);
129 procedure FormCreate(Sender: TObject);
130 procedure FormDestroy(Sender: TObject);
131 procedure OnIdle(Sender: TObject; var Done: Boolean);
132 private
133 FIdleConnected: boolean;
134 fCurTreeViewComplete: boolean;
135 fWorker: TFindOverloadsWorker;
136 procedure SetIdleConnected(const AValue: boolean);
137 procedure UpdateProgress;
138 procedure StopWorking;
139 procedure UpdateCurTreeView;
140 public
141 property Worker: TFindOverloadsWorker read fWorker;
142 property IdleConnected: boolean read FIdleConnected write SetIdleConnected;
143 end;
144
ShowFindOverloadsDialognull145 function ShowFindOverloadsDialog: TModalResult;
ShowFindOverloadsDialognull146 function ShowFindOverloadsDialog(Code: TCodeBuffer; X, Y: integer): TModalResult;
147
CompareFOWFilesnull148 function CompareFOWFiles(File1, File2: TFOWFile): integer;
CompareFilenameWithFOWFilenull149 function CompareFilenameWithFOWFile(FilenameAnsiString, FOWFile: Pointer): integer;
150
151 implementation
152
153 {$R *.lfm}
154
ShowFindOverloadsDialognull155 function ShowFindOverloadsDialog: TModalResult;
156 var
157 SrcEdit: TSourceEditorInterface;
158 Code: TCodeBuffer;
159 XY: TPoint;
160 begin
161 SrcEdit:=SourceEditorManagerIntf.ActiveEditor;
162 if SrcEdit=nil then
163 exit(mrCancel);
164 Code:=TCodeBuffer(SrcEdit.CodeToolsBuffer);
165 XY:=SrcEdit.CursorTextXY;
166 Result:=ShowFindOverloadsDialog(Code,XY.X,XY.Y);
167 end;
168
ShowFindOverloadsDialognull169 function ShowFindOverloadsDialog(Code: TCodeBuffer; X, Y: integer): TModalResult;
170 var
171 FindOverloadsDialog: TFindOverloadsDialog;
172 Graph: TDeclarationOverloadsGraph;
173 begin
174 if not LazarusIDE.BeginCodeTools then exit;
175 Graph:=nil;
176 FindOverloadsDialog:=nil;
177 CodeToolBoss.ActivateWriteLock;
178 try
179 if not CodeToolBoss.GatherOverloads(Code,X,Y,Graph) then begin
180 LazarusIDE.DoJumpToCodeToolBossError;
181 exit(mrCancel);
182 end;
183 //DebugLn(['ShowFindOverloadsDialog ',Graph.StartCode.Filename,' ',Graph.StartX,',',Graph.StartY]);
184 FindOverloadsDialog:=TFindOverloadsDialog.Create(nil);
185 FindOverloadsDialog.Worker.Graph:=Graph;
186 Result:=FindOverloadsDialog.ShowModal;
187 finally
188 CodeToolBoss.DeactivateWriteLock;
189 FindOverloadsDialog.Free;
190 Graph.Free;
191 end;
192 end;
193
CompareFOWFilesnull194 function CompareFOWFiles(File1, File2: TFOWFile): integer;
195 begin
196 Result:=CompareFilenames(File1.Filename,File2.Filename);
197 end;
198
CompareFilenameWithFOWFilenull199 function CompareFilenameWithFOWFile(FilenameAnsiString, FOWFile: Pointer): integer;
200 begin
201 Result:=CompareFilenames(ansistring(FilenameAnsiString),TFOWFile(FOWFile).Filename);
202 end;
203
204 { TFindOverloadsDialog }
205
206 procedure TFindOverloadsDialog.FormCreate(Sender: TObject);
207 begin
208 Caption:='Find overloads';
209 CurGroupBox.Caption:='Current identifier';
210 ResultsGroupBox.Caption:='Overloads';
211 SearchAllCheckBox.Caption:='Search in other sources too';
212 SearchAllCheckBox.ShowHint:=true;
213 SearchAllCheckBox.Hint:='Enable this to search in system sources too. For example the RTL and FCL sources. This can take some minutes on slow machines.';
214
215 ButtonPanel1.CancelButton.OnClick:=@ButtonPanel1Click;
216
217 fWorker:=TFindOverloadsWorker.Create;
218 IdleConnected:=true;
219 UpdateProgress;
220 end;
221
222 procedure TFindOverloadsDialog.ButtonPanel1Click(Sender: TObject);
223 begin
224 StopWorking;
225 end;
226
227 procedure TFindOverloadsDialog.FormDestroy(Sender: TObject);
228 begin
229 IdleConnected:=false;
230 FreeAndNil(fWorker);
231 end;
232
233 procedure TFindOverloadsDialog.OnIdle(Sender: TObject; var Done: Boolean);
234 begin
235 fWorker.Work;
236 Done:=fWorker.Done;
237 if Done then
238 IdleConnected:=false;
239 UpdateProgress;
240 if not fCurTreeViewComplete then
241 UpdateCurTreeView;
242 end;
243
244 procedure TFindOverloadsDialog.SetIdleConnected(const AValue: boolean);
245 begin
246 if FIdleConnected=AValue then exit;
247 FIdleConnected:=AValue;
248 if FIdleConnected then begin
249 ButtonPanel1.CancelButton.Enabled:=true;
250 ButtonPanel1.CloseButton.Enabled:=false;
251 Application.AddOnIdleHandler(@OnIdle)
252 end else begin
253 ButtonPanel1.CancelButton.Enabled:=false;
254 ButtonPanel1.CloseButton.Enabled:=true;
255 Application.RemoveOnIdleHandler(@OnIdle);
256 end;
257 end;
258
259 procedure TFindOverloadsDialog.UpdateProgress;
260 begin
261 if Worker.Done then
262 ResultsProgressBar.Visible:=false
263 else begin
264 ResultsProgressBar.Max:=Worker.StagePosMax;
265 ResultsProgressBar.Position:=Worker.StagePosition;
266 ResultsProgressBar.Visible:=true;
267 end;
268 end;
269
270 procedure TFindOverloadsDialog.StopWorking;
271 begin
272 IdleConnected:=false;
273 Worker.StopSearching;
274 end;
275
276 procedure TFindOverloadsDialog.UpdateCurTreeView;
277 var
278 s: String;
279 Node: TCodeTreeNode;
280 Tool: TFindDeclarationTool;
281 ParentNode: TCodeTreeNode;
282 begin
283 fCurTreeViewComplete:=true;
284 CurTreeView.BeginUpdate;
285 CurTreeView.Items.Clear;
286 Node:=Worker.Graph.StartCodeNode;
287 Tool:=Worker.Graph.StartTool;
288 if Node<>nil then begin
289 DebugLn(['TFindOverloadsDialog.UpdateCurTreeView ',Node.DescAsString,' ',dbgstr(copy(Tool.Src,Node.StartPos,20))]);
290 // unit name
291 s:=Tool.GetSourceName(false)+': ';
292 // keyword
293 case Node.Desc of
294 ctnEnumIdentifier: s:=s+'enum';
295 ctnVarDefinition: s:=s+'var';
296 ctnConstDefinition: s:=s+'const';
297 ctnTypeDefinition: s:=s+'type';
298 ctnGenericType: s:=s+'generic';
299 ctnProperty: s:=s+'property';
300 ctnProcedure: s:=s+'procedure';
301 ctnUseUnit: s:=s+'uses';
302 ctnUnit: s:=s+'unit';
303 ctnProgram: s:=s+'program';
304 ctnPackage: s:=s+'package';
305 ctnLibrary: s:=s+'library';
306 end;
307 s:=s+' ';
308 // context
309 if Node.Desc<>ctnEnumIdentifier then
310 begin
311 ParentNode:=Node.Parent;
312 while ParentNode<>nil do begin
313 case ParentNode.Desc of
314 ctnTypeDefinition,ctnGenericType:
315 s:=s+Tool.ExtractDefinitionName(Node)+'.';
316 end;
317 ParentNode:=ParentNode.Parent;
318 end;
319 end;
320 // name
321 case Node.Desc of
322 ctnEnumIdentifier, ctnTypeDefinition, ctnConstDefinition, ctnVarDefinition,
323 ctnGenericType:
324 s:=s+Tool.ExtractDefinitionName(Node);
325 ctnProperty:
326 s:=s+Tool.ExtractPropName(Node,false);
327 ctnProcedure:
328 s:=s+Tool.ExtractProcName(Node,[phpWithoutClassName,phpCommentsToSpace]);
329 ctnUseUnit:
330 s:=s+Tool.ExtractNode(Node,[phpCommentsToSpace]);
331 ctnUnit,ctnProgram,ctnPackage,ctnLibrary:
332 s:=s+Tool.GetSourceName(false);
333 end;
334 // add node
335 CurTreeView.Items.Add(nil,s);
336 end;
337 CurTreeView.EndUpdate;
338 end;
339
340 { TFOWFile }
341
342 procedure TFOWFile.SetCode(const AValue: TCodeBuffer);
343 begin
344 if FCode=AValue then exit;
345 FCode:=AValue;
346 end;
347
348 procedure TFOWFile.SetScanned(const AValue: boolean);
349 begin
350 if FScanned=AValue then exit;
351 FScanned:=AValue;
352 end;
353
354 constructor TFOWFile.Create(const TheFilename: string);
355 begin
356 FFilename:=TheFilename;
357 FOnlyInterface:=true;
358 end;
359
360 destructor TFOWFile.Destroy;
361 begin
362 inherited Destroy;
363 end;
364
365 { TFindOverloadsWorker }
366
367 procedure TFindOverloadsWorker.CollectProjectFiles;
368 var
369 AProject: TLazProject;
370 i: Integer;
371 ProjFile: TLazProjectFile;
372 begin
373 AProject:=LazarusIDE.ActiveProject;
374 if AProject<>nil then begin
375 for i:=0 to AProject.FileCount-1 do begin
376 ProjFile:=AProject.Files[i];
377 if ProjFile.IsPartOfProject then
378 AddFileToScan(ProjFile.Filename);
379 end;
380 end;
381 Include(CompletedScopes,fosProject);
382 end;
383
384 procedure TFindOverloadsWorker.CollectPackageFiles;
385 begin
386
387 Include(CompletedScopes,fosPackages);
388 end;
389
390 procedure TFindOverloadsWorker.CollectOtherSourceFiles;
391 begin
392
393 Include(CompletedScopes,fosOtherSources);
394 end;
395
396 procedure TFindOverloadsWorker.ScanSomeFiles;
397 const
398 MaxScanTime = 0.3/86400; // 0.3 seconds
399 var
400 StartTime: TDateTime;
401 CurFile: TFOWFile;
402 begin
403 StartTime:=Now;
404 while FScanFiles.Count>0 do begin
405 CurFile:=TFOWFile(FScanFiles.FindLowest.Data);
406 ScanFile(CurFile);
407 if Now-StartTime>=MaxScanTime then
408 break;
409 end;
410 end;
411
412 procedure TFindOverloadsWorker.ScanFile(AFile: TFOWFile);
413 var
414 Tool: TCodeTool;
415 Filename: String;
416 MainFile: TFOWFile;
417 Code: TCodeBuffer;
418 begin
419 FScanFiles.Remove(AFile);
420 if AFile.Scanned then exit;
421 AFile.Scanned:=true;
422 //DebugLn(['TFindOverloadsWorker.ScanFile File=',AFile.Filename]);
423 // get codetool
424 Filename:=TrimFilename(AFile.Filename);
425 Code:=CodeToolBoss.LoadFile(Filename,true,false);
426 if Code=nil then begin
427 DebugLn(['TFindOverloadsWorker.ScanFile file not readable: ',Filename]);
428 exit;
429 end;
430 Tool:=TCodeTool(CodeToolBoss.GetCodeToolForSource(Code,true,false));
431 if Tool=nil then begin
432 DebugLn(['TFindOverloadsWorker.ScanFile file not in a unit: ',Filename]);
433 exit;
434 end;
435 // check if AFile is an include file
436 Filename:=Tool.MainFilename;
437 MainFile:=FindFile(Filename);
438 // get unit
439 if MainFile=nil then begin
440 MainFile:=TFOWFile.Create(Filename);
441 FFiles.Add(MainFile);
442 end;
443 if (MainFile<>AFile) and MainFile.Scanned then begin
444 //DebugLn(['TFindOverloadsWorker.ScanFile already scanned: ',Filename]);
445 exit;
446 end;
447 // scan unit
448 FScanFiles.Remove(MainFile);
449 MainFile.Scanned:=true;
450 if not AFile.OnlyInterface then
451 MainFile.OnlyInterface:=false;
452 //DebugLn(['TFindOverloadsWorker.ScanFile scanning: ',Tool.MainFilename]);
453 Graph.ScanToolForIdentifier(Tool,MainFile.OnlyInterface);
454 end;
455
456 procedure TFindOverloadsWorker.CollectStartSource;
457 var
458 Filename: String;
459 aFile: TFOWFile;
460 begin
461 Filename:=Graph.StartCode.Filename;
462 aFile:=FindFile(Filename);
463 if aFile=nil then begin
464 aFile:=TFOWFile.Create(Filename);
465 aFile.OnlyInterface:=false;
466 FFiles.Add(aFile);
467 FScanFiles.Add(aFile);
468 end;
469 end;
470
AddFileToScannull471 function TFindOverloadsWorker.AddFileToScan(const Filename: string;
472 CheckExtension: boolean): TFOWFile;
473 begin
474 if CheckExtension and (not FilenameIsPascalSource(Filename)) then
475 exit(nil);
476 Result:=FindFile(Filename);
477 if Result<>nil then exit;
478 Result:=TFOWFile.Create(Filename);
479 FFiles.Add(Result);
480 FScanFiles.Add(Result);
481 end;
482
TFindOverloadsWorker.FindFilenull483 function TFindOverloadsWorker.FindFile(const Filename: string): TFOWFile;
484 var
485 AVLNode: TAvlTreeNode;
486 begin
487 AVLNode:=FFiles.FindKey(Pointer(Filename),@CompareFilenameWithFOWFile);
488 if AVLNode<>nil then
489 Result:=TFOWFile(AVLNode.Data)
490 else
491 Result:=nil;
492 end;
493
494 constructor TFindOverloadsWorker.Create;
495 begin
496 Scopes:=[fosProject,fosPackages];
497 FFiles:=TAvlTree.Create(TListSortCompare(@CompareFOWFiles));
498 FScanFiles:=TAvlTree.Create(TListSortCompare(@CompareFOWFiles));
499 FStagePosMax:=100;
500 end;
501
502 destructor TFindOverloadsWorker.Destroy;
503 begin
504 Clear;
505 FreeAndNil(FFiles);
506 FreeAndNil(FScanFiles);
507 inherited Destroy;
508 end;
509
510 procedure TFindOverloadsWorker.Clear;
511 begin
512 FFiles.FreeAndClear;
513 FScanFiles.Clear;
514 FStageTitle:='Finished';
515 FStagePosition:=0;
516 FStagePosMax:=100;
517 StartSourceScanned:=false;
518 end;
519
520 procedure TFindOverloadsWorker.Work;
521 begin
522 DebugLn(['TFindOverloadsWorker.Work START']);
523 if FScanFiles.Count>0 then begin
524 // scan files
525 ScanSomeFiles;
526 end
527 else if not StartSourceScanned then
528 begin
529 StageTitle:='Scanning start source ...';
530 StagePosition:=10;
531 StartSourceScanned:=true;
532 CollectStartSource;
533 end
534 else if (fosProject in Scopes) and not (fosProject in CompletedScopes) then
535 begin
536 // collect project files
537 StageTitle:='Scanning project ...';
538 StagePosition:=20;
539 CollectProjectFiles;
540 end
541 else if (fosPackages in Scopes) and not (fosPackages in CompletedScopes) then
542 begin
543 // collect package files
544 StageTitle:='Scanning packages ...';
545 StagePosition:=40;
546 CollectPackageFiles;
547 end
548 else if (fosOtherSources in Scopes) and not (fosOtherSources in CompletedScopes)
549 then begin
550 // collect other sources
551 StageTitle:='Scanning other sources ...';
552 StagePosition:=60;
553 CollectOtherSourceFiles;
554 end else begin
555 StageTitle:='Finished';
556 StagePosition:=StagePosMax;
557 Graph.ComputeShortestPaths;
558 end;
559 DebugLn(['TFindOverloadsWorker.Work END ',StageTitle,' ',StagePosition,'/',StagePosMax]);
560 end;
561
Donenull562 function TFindOverloadsWorker.Done: boolean;
563 begin
564 Result:=(Scopes-CompletedScopes=[]) and (FScanFiles.Count=0);
565 end;
566
567 procedure TFindOverloadsWorker.StopSearching;
568 begin
569 CompletedScopes:=Scopes;
570 FScanFiles.Clear;
571 Graph.ComputeShortestPaths;
572 end;
573
574 end.
575
576