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 Procedure List - Lazarus addon
22
23 Author: Graeme Geldenhuys (graemeg@gmail.com)
24 Inspired by: GExperts (www.gexperts.org)
25 Last Modified: 2006-06-05
26
27 Abstract:
28 The procedure list enables you to view a list of Free Pascal / Lazarus
29 procedures in the current unit and quickly jump to the implementation of a
30 given procedure. Include files are also supported.
31
32 }
33
34 unit ProcedureList;
35
36 {$mode objfpc}{$H+}
37
38 interface
39
40 uses
41 Classes, SysUtils,
42 // LCL
43 LCLType, Forms, Controls, Dialogs, ComCtrls, ExtCtrls, StdCtrls, Clipbrd,
44 Graphics, Grids,
45 // LazUtils
46 LazStringUtils,
47 // Codetools
48 CodeTree, CodeToolManager, CodeCache, PascalParserTool, KeywordFuncLists,
49 // IDEIntf
50 LazIDEIntf, IDEImagesIntf, SrcEditorIntf, IDEWindowIntf,
51 // IDE
52 EnvironmentOpts, LazarusIDEStrConsts;
53
54 type
55
56 { TGridRowObject }
57
58 TGridRowObject = class
59 public
60 ImageIdx: Integer;
61 NodeStartPos: Integer;
62 FullProcedureName: string;
63 constructor Create;
64 end;
65
66 { TProcedureListForm }
67 TProcedureListForm = class(TForm)
68 cbObjects: TComboBox;
69 edMethods: TEdit;
70 lblObjects: TLabel;
71 lblSearch: TLabel;
72 pnlHeader: TPanel;
73 StatusBar: TStatusBar;
74 SG: TStringGrid;
75 TB: TToolBar;
76 tbAbout: TToolButton;
77 tbCopy: TToolButton;
78 ToolButton2: TToolButton;
79 tbJumpTo: TToolButton;
80 ToolButton4: TToolButton;
81 tbFilterAny: TToolButton;
82 tbFilterStart: TToolButton;
83 ToolButton7: TToolButton;
84 tbChangeFont: TToolButton;
85 ToolButton9: TToolButton;
86 procedure edMethodsKeyDown(Sender: TObject; var Key: Word;
87 {%H-}Shift: TShiftState);
88 procedure edMethodsKeyPress(Sender: TObject; var Key: char);
89 procedure FormCreate(Sender: TObject);
90 procedure FormDestroy(Sender: TObject);
91 procedure FormKeyPress(Sender: TObject; var Key: char);
92 procedure FormResize(Sender: TObject);
93 procedure FormShow(Sender: TObject);
94 procedure SGDblClick(Sender: TObject);
95 procedure SGDrawCell(Sender: TObject; aCol, aRow: Integer; aRect: TRect;
96 {%H-}aState: TGridDrawState);
97 procedure SGSelectCell(Sender: TObject; {%H-}aCol, aRow: Integer;
98 var {%H-}CanSelect: Boolean);
99 procedure SomethingChange(Sender: TObject);
100 procedure tbAboutClick(Sender: TObject);
101 procedure tbCopyClick(Sender: TObject);
102 private
103 FCaret: TCodeXYPosition;
104 FMainFilename: string;
105 FNewTopLine: integer;
106 FImageIdxProcedure: Integer;
Integernull107 FImageIdxFunction: Integer;
108 { Initialise GUI }
109 procedure SetupGUI;
110 { Move editors focus to selected method. }
111 procedure JumpToSelection;
112 { Populates Listview based on selected Class and user entered filter. }
113 procedure PopulateGrid;
114 { Populates only tho cbObjects combo with available classes. }
115 procedure PopulateObjectsCombo;
116 procedure AddToGrid(pCodeTool: TCodeTool; pNode: TCodeTreeNode);
PassFilternull117 function PassFilter(pSearchAll: boolean; pProcName, pSearchStr: string; pCodeTool: TCodeTool; pNode: TCodeTreeNode): boolean;
118 procedure ClearGrid;
119 public
120 property MainFilename: string read FMainFilename;
121 property Caret: TCodeXYPosition read FCaret;
122 property NewTopLine: integer read FNewTopLine;
123 end;
124
125
126 procedure ExecuteProcedureList(Sender: TObject);
127
128 implementation
129
130 {$R *.lfm}
131
132 const
133 SG_COLIDX_IMAGE = 0;
134 SG_COLIDX_PROCEDURE = 1;
135 SG_COLIDX_TYPE = 2;
136 SG_COLIDX_LINE = 3;
137 cAbout =
138 'Procedure List (Lazarus addon)' + #10#10 +
139 'Author: Graeme Geldenhuys (graemeg@gmail.com)' + #10 +
140 'Inspired by: GExperts (www.gexperts.org)';
141
142
143 { This is where it all starts. Gets called from Lazarus. }
144 procedure ExecuteProcedureList(Sender: TObject);
145 var
146 frm: TProcedureListForm;
147 begin
148 Assert(Sender<>nil); // removes compiler warning
149
150 frm := TProcedureListForm.Create(nil);
151 try
152 frm.ShowModal;
153 if frm.ModalResult = mrOK then // we need to jump
154 begin
155 LazarusIDE.DoOpenFileAndJumpToPos(frm.Caret.Code.Filename,
156 Point(frm.Caret.X, frm.Caret.Y), frm.NewTopLine, -1,-1,
157 [ofRegularFile,ofUseCache]);
158 end;
159 finally
160 frm.Free;
161 end;
162 end;
163
164
FilterFitsnull165 function FilterFits(const SubStr, Str: string): boolean;
166 var
167 Src: PChar;
168 PFilter: PChar;
169 c: Char;
170 i: Integer;
171 begin
172 Result := SubStr='';
173 if not Result then
174 begin
175 Src := PChar(Str);
176 PFilter := PChar(SubStr);
177 repeat
178 c := Src^;
179
180 if PFilter^ = '.' then
181 begin
182 Inc(PFilter);
183 if PFilter^ = #0 then
184 exit(true);
185 repeat
186 inc(Src);
187 c := Src^;
188 if c = '.' then
189 begin
190 Inc(Src);
191 break;
192 end;
193 until c = #0;
194 end;
195
196 if c <> #0 then
197 begin
198 if UpChars[Src^] = UpChars[PFilter^] then
199 begin
200 i := 1;
201 while (UpChars[Src[i]] = UpChars[PFilter[i]]) and not ((PFilter[i] = #0) or (PFilter[i] = '.')) do
202 inc(i);
203 if PFilter[i] = #0 then
204 begin
205 exit(true);
206 end
207 else
208 if PFilter[i] = '.' then
209 begin
210 PFilter := PChar(Copy(SubStr, i+2, Length(SubStr)-(i+1)));
211 if PFilter^ = #0 then
212 exit(true);
213 while true do
214 begin
215 inc(Src);
216 c := Src^;
217 if (c = #0) or (c = '.') then
218 break;
219 end;
220 end;
221 end;
222 end
223 else
224 exit(false);
225 inc(Src);
226 until false;
227 end;
228 end;
229
230 { TGridRowObject }
231
232 constructor TGridRowObject.Create;
233 begin
234 ImageIdx := -1;
235 NodeStartPos := -1;
236 FullProcedureName := '';
237 end;
238
239
240 { TProcedureListForm }
241
242 procedure TProcedureListForm.FormCreate(Sender: TObject);
243 begin
244 if SourceEditorManagerIntf.ActiveEditor = nil then
245 begin
246 //SetupGUI makes the dialog look as it should, and is clears the listview
247 //thus preventing a crash when clicking on the LV
248 SetupGUI;
249 Exit; //==>
250 end;
251
252 FMainFilename := SourceEditorManagerIntf.ActiveEditor.Filename;
253 Caption := Caption + ExtractFileName(FMainFilename);
254 SetupGUI;
255 PopulateObjectsCombo;
256 PopulateGrid;
257 StatusBar.Panels[0].Text := self.MainFilename;
258 tbFilterStart.Down := EnvironmentOptions.ProcedureListFilterStart;
259 IDEDialogLayoutList.ApplyLayout(Self, 950, 680);
260 end;
261
262 procedure TProcedureListForm.FormDestroy(Sender: TObject);
263 begin
264 EnvironmentOptions.ProcedureListFilterStart := tbFilterStart.Down;
265 ClearGrid;
266 IDEDialogLayoutList.SaveLayout(self);
267 end;
268
269 procedure TProcedureListForm.FormResize(Sender: TObject);
270 begin
271 StatusBar.Panels[0].Width := self.ClientWidth - 105;
272 end;
273
274 procedure TProcedureListForm.FormShow(Sender: TObject);
275 begin
276 edMethods.SetFocus;
277 cbObjects.DropDownCount := EnvironmentOptions.DropDownCount;
278 end;
279
280 procedure TProcedureListForm.SGDblClick(Sender: TObject);
281 begin
282 JumpToSelection;
283 end;
284
285 procedure TProcedureListForm.SGDrawCell(Sender: TObject; aCol, aRow: Integer;
286 aRect: TRect; aState: TGridDrawState);
287 var
288 bmp: TBitmap;
289 grid: TStringGrid;
290 iconTop, imageIdx: Integer;
291 rowObj: TGridRowObject;
292 begin
293 grid := TStringGrid(Sender);
294
295 if (aCol = 0) and (aRow >= grid.FixedRows) then
296 begin
297 rowObj := TGridRowObject(grid.Rows[aRow].Objects[0]);
298 if Assigned(rowObj) then
299 begin
300 imageIdx := rowObj.ImageIdx;
301
302 bmp := TBitmap.Create;
303 try
304 IDEImages.Images_16.GetBitmap(imageIdx, bmp);
305 iconTop := ((aRect.Bottom - aRect.Top) - bmp.Height) div 2 + aRect.Top;
306 grid.Canvas.Draw(aRect.Left,iconTop, bmp);
307 finally
308 bmp.Free;
309 end;
310 end;
311 end;
312 end;
313
314 procedure TProcedureListForm.SGSelectCell(Sender: TObject; aCol, aRow: Integer;
315 var CanSelect: Boolean);
316 var
317 rowObject: TGridRowObject;
318 begin
319 rowObject := TGridRowObject(TStringGrid(Sender).Rows[aRow].Objects[0]);
320
321 if Assigned(rowObject) then
322 begin
323 StatusBar.Panels[0].Text := rowObject.FullProcedureName;
324 end;
325 end;
326
327 procedure TProcedureListForm.SetupGUI;
328 begin
329 self.KeyPreview := True;
330 self.Position := poScreenCenter;
331
332 // assign resource strings to Captions and Hints
333 self.Caption := lisPListProcedureList;
334 lblObjects.Caption := lisPListObjects;
335 lblSearch.Caption := lisMenuSearch;
336 tbAbout.Hint := lisMenuTemplateAbout;
337 tbJumpTo.Hint := lisPListJumpToSelection;
338 tbFilterAny.Hint := lisPListFilterAny;
339 tbFilterStart.Hint := lisPListFilterStart;
340 tbChangeFont.Hint := lisPListChangeFont;
341 tbCopy.Hint := lisPListCopyMethodToClipboard;
342 SG.Columns[SG_COLIDX_PROCEDURE].Title.Caption := lisProcedure;
343 SG.Columns[SG_COLIDX_TYPE].Title.Caption := lisPListType;
344 SG.Columns[SG_COLIDX_LINE].Title.Caption := dlgAddHiAttrGroupLine;
345
346 // assign resource images to toolbuttons
347 TB.Images := IDEImages.Images_16;
348 tbCopy.ImageIndex := IDEImages.LoadImage('laz_copy');
349 tbChangeFont.ImageIndex := IDEImages.LoadImage('item_font');
350 tbAbout.ImageIndex := IDEImages.LoadImage('menu_information');
351 tbJumpTo.ImageIndex := IDEImages.LoadImage('menu_goto_line');
352 tbFilterAny.ImageIndex := IDEImages.LoadImage('filter_any_place');
353 tbFilterStart.ImageIndex := IDEImages.LoadImage('filter_from_begin');
354
355 SG.Columns[SG_COLIDX_IMAGE].Width := 20;
356 SG.Columns[SG_COLIDX_PROCEDURE].Width := 300;
357 SG.Columns[SG_COLIDX_TYPE].Width := 110;
358 SG.Columns[SG_COLIDX_LINE].Width := 60;
359
360 FImageIdxProcedure := IDEImages.LoadImage('cc_procedure');
361 FImageIdxFunction := IDEImages.LoadImage('cc_function');;
362
363 cbObjects.Style := csDropDownList;
364 cbObjects.Sorted := True;
365 cbObjects.DropDownCount := 8;
366 end;
367
368
369 procedure TProcedureListForm.JumpToSelection;
370 var
371 CodeBuffer: TCodeBuffer;
372 ACodeTool: TCodeTool;
373 lRowObject: TGridRowObject;
374 begin
375 if SG.Row < SG.FixedRows then
376 Exit;
377
378 lRowObject := TGridRowObject(SG.Rows[SG.Row].Objects[0]);
379 if not Assigned(lRowObject) then
380 Exit;
381
382 if lRowObject.NodeStartPos < 0 then
383 Exit;
384
385 CodeBuffer := CodeToolBoss.LoadFile(MainFilename,false,false);
386 if CodeBuffer = nil then
387 Exit; //==>
388
389 ACodeTool := nil;
390 CodeToolBoss.Explore(CodeBuffer,ACodeTool,false);
391 if ACodeTool = nil then
392 Exit; //==>
393
394 if not ACodeTool.CleanPosToCaretAndTopLine(lRowObject.NodeStartPos, FCaret, FNewTopLine) then
395 Exit; //==>
396
397 { This should close the form }
398 self.ModalResult := mrOK;
399 end;
400
401
402 procedure TProcedureListForm.PopulateGrid;
403 var
404 lSrcEditor: TSourceEditorInterface;
405 lCodeBuffer: TCodeBuffer;
406 lCodeTool: TCodeTool;
407 lNode: TCodeTreeNode;
408 begin
409 SG.BeginUpdate;
410 try
411 ClearGrid;
412
413 { get active source editor }
414 lSrcEditor := SourceEditorManagerIntf.ActiveEditor;
415 if lSrcEditor = nil then
416 Exit; //==>
417 lCodeBuffer := lSrcEditor.CodeToolsBuffer as TCodeBuffer;
418
419 { parse source }
420 CodeToolBoss.Explore(lCodeBuffer,lCodeTool,False);
421
422 { copy the tree }
423 if (lCodeTool = nil)
424 or (lCodeTool.Tree = nil)
425 or (lCodeTool.Tree.Root = nil) then
426 Exit; //==>
427
428 { Find the starting point }
429 lNode := lCodeTool.FindImplementationNode;
430 if lNode = nil then
431 begin
432 { fall back - guess we are working with a program or there is a syntax error }
433 lNode := lCodeTool.Tree.Root;
434 end;
435
436 { populate the listview here }
437 lNode := lNode.FirstChild;
438 while lNode <> nil do
439 begin
440 if lNode.Desc = ctnProcedure then
441 begin
442 AddToGrid(lCodeTool, lNode);
443 end;
444 lNode := lNode.Next;
445 end;
446 finally
447 if SG.RowCount > 0 then
448 begin
449 SG.Row := SG.FixedRows;
450 end;
451 SG.EndUpdate;
452 end;
453 end;
454
455
456 procedure TProcedureListForm.PopulateObjectsCombo;
457 var
458 lSrcEditor: TSourceEditorInterface;
459 lCodeBuffer: TCodeBuffer;
460 lCodeTool: TCodeTool;
461 lNode: TCodeTreeNode;
462 lNodeText: string;
463 begin
464 cbObjects.Items.Clear;
465 try
466 { get active source editor }
467 lSrcEditor := SourceEditorManagerIntf.ActiveEditor;
468 if lSrcEditor = nil then
469 Exit; //==>
470 lCodeBuffer := lSrcEditor.CodeToolsBuffer as TCodeBuffer;
471
472 { parse source }
473 CodeToolBoss.Explore(lCodeBuffer,lCodeTool,False);
474
475 if (lCodeTool = nil)
476 or (lCodeTool.Tree = nil)
477 or (lCodeTool.Tree.Root = nil) then
478 Exit; //==>
479
480 { copy the tree }
481 if Assigned(lCodeTool.Tree) then
482 begin
483 { Find the starting point }
484 lNode := lCodeTool.FindImplementationNode;
485 if lNode = nil then
486 begin
487 { fall back - guess we are working with a program unit }
488 lNode := lCodeTool.Tree.Root;
489 end;
490 { populate the Combobox here! }
491 lNode := lNode.FirstChild;
492 while lNode <> nil do
493 begin
494 if lNode.Desc = ctnProcedure then
495 begin
496 lNodeText := lCodeTool.ExtractClassNameOfProcNode(lNode);
497 cbObjects.Items.Add(lNodeText);
498 end;
499 lNode := lNode.NextBrother;
500 end;
501 end;
502 cbObjects.Sorted := true;
503 cbObjects.Sorted := false;
504 cbObjects.Items.Insert(0, lisPListAll);
505 cbObjects.Items.Insert(1, lisPListNone);
506 finally
507 cbObjects.ItemIndex := 0; // select <All> as the default
508 if (cbObjects.Items.Count > 0) and (cbObjects.Text = '') then // some widgetsets have issues here so we do this
509 cbObjects.Text := cbObjects.Items[0];
510 end;
511 end;
512
513
514 procedure TProcedureListForm.AddToGrid(pCodeTool: TCodeTool; pNode: TCodeTreeNode);
515 var
516 lNodeText: string;
517 lCaret: TCodeXYPosition;
518 FSearchAll: boolean;
519 lAttr: TProcHeadAttributes;
520 lRowObject: TGridRowObject;
521 lRowIdx: Integer;
522 begin
523 FSearchAll := cbObjects.Text = lisPListAll;
524
525 if FSearchAll and tbFilterAny.Down then
526 begin
527 lAttr := [phpWithoutClassKeyword, phpWithoutParamList, phpWithoutBrackets,
528 phpWithoutSemicolon, phpAddClassName, phpAddParentProcs];
529 end
530 else
531 begin
532 lAttr := [phpWithoutClassKeyword, phpWithoutParamList, phpWithoutBrackets,
533 phpWithoutSemicolon, phpWithoutClassName];
534 end;
535
536 lNodeText := pCodeTool.ExtractProcHead(pNode, lAttr);
537
538 { Must we add this pNode or not? }
539 if not PassFilter(FSearchAll, lNodeText, edMethods.Text, pCodeTool, pNode) then
540 Exit; //==>
541
542 { Add new row }
543 lRowIdx := SG.RowCount;
544 SG.RowCount := lRowIdx + 1;
545 lRowObject := TGridRowObject.Create;
546 SG.Rows[lRowIdx].Objects[0] := lRowObject;
547
548 { procedure name }
549 lNodeText := pCodeTool.ExtractProcHead(pNode,
550 [phpAddParentProcs, phpWithoutParamList, phpWithoutBrackets, phpWithoutSemicolon]);
551 SG.Cells[SG_COLIDX_PROCEDURE,lRowIdx] := lNodeText;
552
553 { type }
554 lNodeText := pCodeTool.ExtractProcHead(pNode,
555 [phpWithStart, phpWithoutParamList, phpWithoutBrackets, phpWithoutSemicolon,
556 phpWithoutClassName, phpWithoutName]);
557 SG.Cells[SG_COLIDX_TYPE,lRowIdx] := lNodeText;
558
559 { line number }
560 if pCodeTool.CleanPosToCaret(pNode.StartPos, lCaret) then
561 SG.Cells[SG_COLIDX_LINE,lRowIdx] := IntToStr(lCaret.Y);
562
563
564 { start pos - used by JumpToSelected() }
565 lRowObject.NodeStartPos := pNode.StartPos;
566
567 { full procedure name used in statusbar }
568 lNodeText := pCodeTool.ExtractProcHead(pNode,
569 [phpWithStart,phpAddParentProcs,phpWithVarModifiers,
570 phpWithParameterNames,phpWithDefaultValues,phpWithResultType,
571 phpWithOfObject,phpWithCallingSpecs,phpWithProcModifiers]);
572 lRowObject.FullProcedureName := lNodeText;
573
574 if PosI('procedure', lNodeText) > 0 then
575 lRowObject.ImageIdx := FImageIdxProcedure
576 else
577 lRowObject.ImageIdx := FImageIdxFunction;
578
579 end;
580
581
582 { Do we pass all the filter tests to continue? }
TProcedureListForm.PassFilternull583 function TProcedureListForm.PassFilter(pSearchAll: boolean;
584 pProcName, pSearchStr: string; pCodeTool: TCodeTool; pNode: TCodeTreeNode
585 ): boolean;
586 var
587 lClass: string;
588
ClassMatchesnull589 function ClassMatches: boolean;
590 begin
591 { lets filter by class selection. }
592 lClass := pCodeTool.ExtractClassNameOfProcNode(pNode);
593 if cbObjects.Text = lisPListNone then
594 Result := lClass = ''
595 else
596 Result := lClass = cbObjects.Text;
597
598 end;
599
600 begin
601 Result := False;
602 if (Length(pSearchStr) = 0) then // seach string is empty
603 begin
604 if pSearchAll then
605 Result := True
606 else
607 Result := ClassMatches;
608 end
609 else
610 if not pSearchAll and tbFilterStart.Down then
611 Result := ClassMatches and LazStartsStr(pSearchStr, pProcName)
612 else
613 if not pSearchAll and tbFilterAny.Down then
614 Result := ClassMatches and FilterFits(pSearchStr, pProcName)
615 else
616 if pSearchAll and tbFilterStart.Down then
617 Result := LazStartsStr(pSearchStr, pProcName)
618 else
619 if pSearchAll then
620 Result := FilterFits(pSearchStr, pProcName);
621 end;
622
623 procedure TProcedureListForm.ClearGrid;
624 var
625 i: Integer;
626 begin
627 for i:=SG.FixedRows to SG.RowCount - 1 do
628 SG.Rows[i].Objects[0].Free;
629
630 SG.RowCount := SG.FixedRows;
631 end;
632
633
634 procedure TProcedureListForm.FormKeyPress(Sender: TObject; var Key: char);
635 begin
636 if Key = #27 then // Escape key
637 begin
638 self.ModalResult := mrCancel;
639 end;
640 end;
641
642 procedure TProcedureListForm.edMethodsKeyPress(Sender: TObject; var Key: char);
643 begin
644 case Key of
645 #13:
646 begin
647 JumpToSelection;
648 Key := #0;
649 end;
650 #27:
651 begin
652 self.ModalResult := mrCancel;
653 Key := #0;
654 end;
655 end;
656 end;
657
658 procedure TProcedureListForm.edMethodsKeyDown(Sender: TObject; var Key: Word;
659 Shift: TShiftState);
660 begin
661 if SG.RowCount <= SG.FixedRows then
662 Exit;
663
664 if Key = VK_DOWN then
665 begin
666 if SG.Row < (SG.RowCount - 1) then
667 SG.Row := SG.Row + 1;
668 end
669 else if Key = VK_Up then
670 begin
671 if SG.Row > SG.FixedRows then
672 SG.Row := SG.Row - 1;
673 end
674 else if Key = VK_Home then
675 begin
676 if SG.RowCount > SG.FixedRows then
677 SG.Row := SG.FixedRows;
678 end
679 else if Key = VK_End then
680 begin
681 if SG.RowCount > SG.FixedRows then
682 SG.Row := SG.RowCount - 1;
683 end;
684
685 end;
686
687 procedure TProcedureListForm.SomethingChange(Sender: TObject);
688 begin
689 PopulateGrid;
690 end;
691
692 procedure TProcedureListForm.tbAboutClick(Sender: TObject);
693 begin
694 ShowMessage(cAbout);
695 end;
696
697 procedure TProcedureListForm.tbCopyClick(Sender: TObject);
698 begin
699 if SG.Row > 0 then
700 Clipboard.AsText := SG.Cells[SG_COLIDX_PROCEDURE,SG.Row];
701 end;
702
703 end.
704