← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/codetools/methodjumptool.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/codetools/methodjumptool.pas
65
65
    function FindJumpPointInProcNode(ProcNode: TCodeTreeNode;
66
66
        out NewPos: TCodeXYPosition; out NewTopLine: integer): boolean;
67
67
    function GatherProcNodes(StartNode: TCodeTreeNode;
68
 
        Attr: TProcHeadAttributes; const UpperClassName: string): TAVLTree;
 
68
        Attr: TProcHeadAttributes; const FilterClassName: string): TAVLTree;
69
69
    function FindFirstDifferenceNode(SearchForNodes, SearchInNodes: TAVLTree;
70
70
        var DiffTxtPos: integer): TAVLTreeNode;
71
71
    function JumpToMethod(const ProcHead: string; Attr: TProcHeadAttributes;
115
115
      OldAVLNode1:=AVLNode1;
116
116
      AVLNode1:=Tree1.FindSuccessor(AVLNode1);
117
117
      if not KeepTree1 then begin
118
 
        NodeExtMemManager.DisposeNode(TCodeTreeNodeExtension(OldAVLNode1.Data));
119
 
        Tree1.Delete(OldAVLNode1);
 
118
        Tree1.FreeAndDelete(OldAVLNode1);
120
119
      end;
121
120
      OldAVLNode2:=AVLNode2;
122
121
      AVLNode2:=Tree2.FindSuccessor(AVLNode2);
123
 
      NodeExtMemManager.DisposeNode(TCodeTreeNodeExtension(OldAVLNode2.Data));
124
 
      Tree2.Delete(OldAVLNode2);
 
122
      Tree2.FreeAndDelete(OldAVLNode2);
125
123
    end;
126
124
  end;
127
125
end;
327
325
  SearchedClassname, SearchedProcName, SearchedParamList: string;
328
326
  SearchForNodes, SearchInNodes: TAVLTree;
329
327
  BodyAVLNode, DefAVLNode: TAVLTreeNode;
 
328
  ProcName: String;
330
329
begin
331
330
  Result:=false;
332
331
  RevertableJump:=false;
335
334
  {$IFDEF CTDEBUG}
336
335
  DebugLn('TMethodJumpingCodeTool.FindJumpPoint A  CursorPos=',dbgs(CursorPos.X),',',dbgs(CursorPos.Y));
337
336
  {$ENDIF}
338
 
  BuildTreeAndGetCleanPos(trAll,CursorPos,CleanCursorPos,[]);
 
337
  BuildTreeAndGetCleanPos(CursorPos,CleanCursorPos);
339
338
  GetLineInfo(CleanCursorPos,LineStart,LineEnd,FirstAtomStart,LastAtomEnd);
340
339
  if CleanCursorPos<FirstAtomStart then CleanCursorPos:=FirstAtomStart;
341
340
  if CleanCursorPos>=LastAtomEnd then CleanCursorPos:=LastAtomEnd-1;
348
347
  // find CodeTreeNode at cursor
349
348
  CursorNode:=FindDeepestNodeAtPos(CleanCursorPos,true);
350
349
  {$IFDEF CTDEBUG}
351
 
  DebugLn('TMethodJumpingCodeTool.FindJumpPoint C ',NodeDescriptionAsString(CursorNode.Desc));
 
350
  DebugLn('TMethodJumpingCodeTool.FindJumpPoint CursorNode=',CursorNode.DescAsString);
352
351
  {$ENDIF}
353
352
  // first test if in a class
354
 
  ClassNode:=CursorNode.GetNodeOfTypes([ctnClass,ctnObject,
355
 
                                     ctnObjCClass,ctnObjCCategory,ctnCPPClass]);
 
353
  ClassNode:=CursorNode.GetNodeOfTypes([ctnClass,ctnClassInterface,
 
354
      ctnDispinterface,ctnObject,ctnRecordType,
 
355
      ctnObjCClass,ctnObjCCategory,ctnObjCProtocol,
 
356
      ctnCPPClass]);
356
357
  if ClassNode<>nil then begin
357
 
    // cursor is in class/object definition
358
 
    // search in all implemented class procedures for the body 
 
358
    // cursor is in class/object/interface definition
 
359
    // Interfaces have no method bodies, but if the class was refactored it has
 
360
    // and then jumping is a nide feature
 
361
    // => search in all implemented class procedures for the body
359
362
    {$IFDEF CTDEBUG}
360
 
    DebugLn('TMethodJumpingCodeTool.FindJumpPoint D ',NodeDescriptionAsString(ClassNode.Desc));
 
363
    DebugLn('TMethodJumpingCodeTool.FindJumpPoint ClasNode=',ClassNode.DescAsString);
361
364
    {$ENDIF}
362
365
    if (ClassNode.SubDesc and ctnsForwardDeclaration)>0 then exit;
363
366
    // parse class and build CodeTreeNodes for all properties/methods
364
367
    {$IFDEF CTDEBUG}
365
368
    DebugLn('TMethodJumpingCodeTool.FindJumpPoint E ',dbgs(CleanCursorPos),', |',copy(Src,CleanCursorPos,8));
366
369
    {$ENDIF}
367
 
    BuildSubTreeForClass(ClassNode);
368
 
    TypeSectionNode:=ClassNode.GetNodeOfType(ctnTypeSection);
 
370
    TypeSectionNode:=ClassNode.GetTopMostNodeOfType(ctnTypeSection);
369
371
    // search the method node under the cursor
370
372
    CursorNode:=FindDeepestNodeAtPos(CleanCursorPos,true).
371
373
                                                    GetNodeOfType(ctnProcedure);
385
387
      {$IFDEF CTDEBUG}
386
388
      DebugLn('TMethodJumpingCodeTool.FindJumpPoint G Gather method definitions ...');
387
389
      {$ENDIF}
388
 
      while (StartNode<>nil) and (StartNode.FirstChild=nil) do
389
 
        StartNode:=StartNode.NextBrother;
390
 
      if StartNode=nil then exit;
391
 
      StartNode:=StartNode.FirstChild;
392
390
      {$IFDEF CTDEBUG}
393
391
      DebugLn('TMethodJumpingCodeTool.FindJumpPoint H Gather SearchForNodes ...');
394
392
      {$ENDIF}
401
399
      // gather the method bodies
402
400
      SearchInNodes:=GatherProcNodes(TypeSectionNode,
403
401
         [phpInUpperCase,phpIgnoreForwards,phpOnlyWithClassname],
404
 
         ExtractClassName(ClassNode,true));
 
402
         ExtractClassName(ClassNode,true,true));
405
403
      try
406
404
        // remove all corresponding methods
407
405
        RemoveCorrespondingProcNodes(SearchInNodes,SearchForNodes,false);
428
426
        Result:=JumpToProc(CursorNode,JumpToProcAttr,
429
427
                           ProcNode,JumpToProcAttr);
430
428
      finally
431
 
        NodeExtMemManager.DisposeAVLTree(SearchForNodes);
432
 
        NodeExtMemManager.DisposeAVLTree(SearchInNodes);
 
429
        DisposeAVLTree(SearchForNodes);
 
430
        DisposeAVLTree(SearchInNodes);
433
431
      end;
434
432
    end;
435
433
    exit;
517
515
        end;
518
516
        
519
517
      finally
520
 
        NodeExtMemManager.DisposeAVLTree(SearchForNodes);
521
 
        NodeExtMemManager.DisposeAVLTree(SearchInNodes);
 
518
        DisposeAVLTree(SearchForNodes);
 
519
        DisposeAVLTree(SearchInNodes);
522
520
      end;
523
521
    end else begin
524
522
      // procedure is not forward, search on same proc level
525
523
      {$IFDEF CTDEBUG}
526
 
      DebugLn('TMethodJumpingCodeTool.FindJumpPoint 4A');
 
524
      DebugLn('TMethodJumpingCodeTool.FindJumpPoint proc body');
527
525
      {$ENDIF}
528
 
      SearchedClassname:=ExtractClassNameOfProcNode(ProcNode);
 
526
      SearchedClassname:=ExtractClassNameOfProcNode(ProcNode,true);
529
527
      StartNode:=FindFirstNodeOnSameLvl(ProcNode);
530
528
      {$IFDEF CTDEBUG}
531
 
      DebugLn('TMethodJumpingCodeTool.FindJumpPoint 4B ',dbgs(StartNode<>nil),' ',SearchedClassName);
 
529
      DebugLn('TMethodJumpingCodeTool.FindJumpPoint body to decl: ',dbgs(StartNode<>nil),' Class="',SearchedClassName,'"');
532
530
      {$ENDIF}
533
531
      if StartNode=nil then exit;
534
532
      if SearchedClassname<>'' then begin
535
533
        // search class node
536
 
        ClassNode:=FindClassNode(StartNode,UpperCaseStr(SearchedClassName),
537
 
                     true,false);
 
534
        ClassNode:=FindClassNode(StartNode,SearchedClassName,true,false);
538
535
        {$IFDEF CTDEBUG}
539
 
        DebugLn('TMethodJumpingCodeTool.FindJumpPoint 4C ',dbgs(ClassNode<>nil));
 
536
        DebugLn('TMethodJumpingCodeTool.FindJumpPoint class found: ',dbgs(ClassNode<>nil));
540
537
        {$ENDIF}
541
 
        if ClassNode=nil then exit;
542
 
        BuildSubTreeForClass(ClassNode);
 
538
        if ClassNode=nil then begin
 
539
          MoveCursorToProcName(ProcNode,false);
 
540
          RaiseException('class not found "'+SearchedClassname+'"');
 
541
        end;
543
542
        // search first class grand child node
544
543
        StartNode:=ClassNode.FirstChild;
545
544
        while (StartNode<>nil) and (StartNode.FirstChild=nil) do
547
546
        {$IFDEF CTDEBUG}
548
547
        DebugLn('TMethodJumpingCodeTool.FindJumpPoint 4D ',dbgs(StartNode<>nil));
549
548
        {$ENDIF}
550
 
        if StartNode=nil then exit;
551
 
        StartNode:=StartNode.FirstChild;
 
549
        if StartNode=nil then begin
 
550
          ProcName:=ExtractProcName(ProcNode,[]);
 
551
          MoveCursorToNodeStart(ClassNode);
 
552
          RaiseException('method "'+ProcName+'" has no declaration');
 
553
        end;
552
554
        // search method with same name and param list
553
555
        Result:=FindBestProcNode(ProcNode,[phpWithoutClassName,phpInUpperCase],
554
556
                                 StartNode,[phpInUpperCase],false);
564
566
        DebugLn('TMethodJumpingCodeTool.FindJumpPoint 4F ');
565
567
        {$ENDIF}
566
568
        // gather method bodies
567
 
        TypeSectionNode:=ClassNode.Parent;
568
 
        if (TypeSectionNode<>nil) and (TypeSectionNode.Parent<>nil)
569
 
        and (TypeSectionNode.Parent.Desc=ctnTypeSection) then
570
 
          TypeSectionNode:=TypeSectionNode.Parent;
 
569
        TypeSectionNode:=ClassNode.GetTopMostNodeOfType(ctnTypeSection);
571
570
        SearchForNodes:=GatherProcNodes(TypeSectionNode,
572
571
           [phpInUpperCase,phpIgnoreForwards,phpOnlyWithClassname],
573
 
           ExtractClassName(ClassNode,true));
 
572
           ExtractClassName(ClassNode,true,true));
574
573
        try
575
574
          // remove corresponding methods
576
575
          RemoveCorrespondingProcNodes(SearchForNodes,SearchInNodes,false);
577
576
          {$IFDEF CTDEBUG}
578
577
          DebugLn('TMethodJumpingCodeTool.FindJumpPoint 4G DiffNodes=',dbgs(SearchInNodes.Count));
579
578
          {$ENDIF}
580
 
          if SearchInNodes.Count=0 then exit;
 
579
          if SearchInNodes.Count=0 then begin
 
580
            ProcName:=ExtractProcName(ProcNode,[]);
 
581
            MoveCursorToNodeStart(ClassNode);
 
582
            RaiseException('method "'+ProcName+'" has no declaration');
 
583
          end;
581
584
          // search for a method with same name but different param list
582
585
          ProcNode:=FindProcNodeInTreeWithName(SearchInNodes,
583
586
                ExtractProcName(ProcNode,[phpWithoutClassName,phpInUpperCase]));
586
589
          end;
587
590
          Result:=JumpToProc(CursorNode,JumpToProcAttr,ProcNode,JumpToProcAttr);
588
591
        finally
589
 
          NodeExtMemManager.DisposeAVLTree(SearchForNodes);
590
 
          NodeExtMemManager.DisposeAVLTree(SearchInNodes);
 
592
          DisposeAVLTree(SearchForNodes);
 
593
          DisposeAVLTree(SearchInNodes);
591
594
        end;
592
595
        exit;
593
596
      end else begin
664
667
          end;
665
668
 
666
669
        finally
667
 
          NodeExtMemManager.DisposeAVLTree(SearchForNodes);
668
 
          NodeExtMemManager.DisposeAVLTree(SearchInNodes);
 
670
          DisposeAVLTree(SearchForNodes);
 
671
          DisposeAVLTree(SearchInNodes);
669
672
        end;
670
673
      end;
671
674
    end;
769
772
end;
770
773
 
771
774
function TMethodJumpingCodeTool.GatherProcNodes(StartNode: TCodeTreeNode;
772
 
  Attr: TProcHeadAttributes; const UpperClassName: string): TAVLTree;
773
 
// create a tree of TCodeTreeNodeExtension
 
775
  Attr: TProcHeadAttributes; const FilterClassName: string): TAVLTree;
 
776
// create a tree of TCodeTreeNodeExtension sorted with CompareCodeTreeNodeExt
 
777
// Node.Desc = ctnProcedure
 
778
// Node.Txt = ExtractProcHead(Node,Attr)
774
779
var CurProcName: string;
775
780
  ANode: TCodeTreeNode;
776
781
  NewNodeExt: TCodeTreeNodeExtension;
777
782
  cmp: boolean;
778
783
  CurClassName: String;
779
784
begin
 
785
  //debugln(['TMethodJumpingCodeTool.GatherProcNodes START']);
780
786
  Result:=TAVLTree.Create(@CompareCodeTreeNodeExt);
 
787
  if (StartNode=nil) or (StartNode.Parent=nil) then exit;
781
788
  ANode:=StartNode;
782
789
  while (ANode<>nil) do begin
 
790
    //debugln(['TMethodJumpingCodeTool.GatherProcNodes ',ANode.DescAsString]);
783
791
    if ANode.Desc=ctnProcedure then begin
784
792
      if (not ((phpIgnoreForwards in Attr)
785
793
           and ((ANode.SubDesc and ctnsForwardDeclaration)>0)))
786
794
      and (not ((phpIgnoreProcsWithBody in Attr)
787
795
            and (FindProcBody(ANode)<>nil))) then
788
796
      begin
789
 
        //DebugLn('[TMethodJumpingCodeTool.GatherProcNodes] B');
 
797
        //DebugLn('[TMethodJumpingCodeTool.GatherProcNodes] Proc found');
790
798
        cmp:=true;
791
799
        if (phpOnlyWithClassname in Attr) then begin
792
 
          CurClassName:=ExtractClassNameOfProcNode(ANode);
793
 
          //DebugLn('[TMethodJumpingCodeTool.GatherProcNodes] B2 "',CurClassName,'" =? ',UpperClassName);
 
800
          CurClassName:=ExtractClassNameOfProcNode(ANode,true);
 
801
          //DebugLn('[TMethodJumpingCodeTool.GatherProcNodes] Proc Class="',CurClassName,'" =? ',FilterClassName,'=Filter');
794
802
 
795
 
          if CompareIdentifiers(PChar(UpperClassName),PChar(CurClassName))<>0 then
 
803
          if CompareText(FilterClassName,CurClassName)<>0 then
796
804
            cmp:=false;
797
805
        end;
798
806
        if cmp and (phpIgnoreMethods in Attr) then begin
799
 
          if (ANode.GetNodeOfTypes([ctnClass,ctnObject,
 
807
          if (ANode.GetNodeOfTypes([ctnClass,ctnObject,ctnRecordType,
800
808
                                ctnObjCClass,ctnObjCCategory,ctnCPPClass])<>nil)
801
 
          or (ExtractClassNameOfProcNode(ANode)<>'')
 
809
          or (ExtractClassNameOfProcNode(ANode,true)<>'')
802
810
          then
803
811
            cmp:=false;
804
812
        end;
805
813
        if cmp then begin
806
 
          //DebugLn('[TMethodJumpingCodeTool.GatherProcNodes] C');
 
814
          //DebugLn('[TMethodJumpingCodeTool.GatherProcNodes] Proc with right class');
807
815
          CurProcName:=ExtractProcHead(ANode,Attr);
808
 
          //DebugLn(['[TMethodJumpingCodeTool.GatherProcNodes] D "',CurProcName,'" ',phpInUpperCase in Attr]);
 
816
          //DebugLn(['[TMethodJumpingCodeTool.GatherProcNodes] Proc with right class, name="',CurProcName,'" phpInUpperCase=',phpInUpperCase in Attr]);
809
817
          if (CurProcName<>'') then begin
810
 
            NewNodeExt:=NodeExtMemManager.NewNode;
 
818
            NewNodeExt:=TCodeTreeNodeExtension.Create;
811
819
            with NewNodeExt do begin
812
820
              Node:=ANode;
813
821
              Txt:=CurProcName;
818
826
      end;
819
827
    end;
820
828
    // next node
821
 
    ANode:=FindNextNodeOnSameLvl(ANode);
 
829
    if (ANode.FirstChild<>nil)
 
830
    and (ANode.Desc in (AllClassSections+[ctnImplementation])) then
 
831
      ANode:=ANode.FirstChild
 
832
    else begin
 
833
      while ANode.NextBrother=nil do begin
 
834
        ANode:=ANode.Parent;
 
835
        if ANode=nil then break;
 
836
        if not (ANode.Desc in (AllClassSections+[ctnImplementation])) then
 
837
          break;
 
838
      end;
 
839
      if ANode=nil then break;
 
840
      ANode:=ANode.NextBrother;
 
841
    end;
822
842
  end;
 
843
  //debugln(['TMethodJumpingCodeTool.GatherProcNodes END']);
823
844
end;
824
845
 
825
846
function TMethodJumpingCodeTool.FindFirstDifferenceNode(
935
956
    if (PathIndex>SubProcPath.Count) or (StartNode=nil) then exit;
936
957
    ProcHead:=SubProcPath[PathIndex];
937
958
    ProcNode:=FindProcNode(StartNode,ProcHead,Attr);
938
 
    DebugLn('TMethodJumpingCodeTool.SearchSubProcPath A ProcHead="',ProcHead,'" Found=',dbgs(ProcNode<>nil));
 
959
    //DebugLn('TMethodJumpingCodeTool.SearchSubProcPath A ProcHead="',ProcHead,'" Found=',dbgs(ProcNode<>nil));
939
960
    if ProcNode=nil then exit;
940
961
    if PathIndex=SubProcPath.Count-1 then begin
941
962
      Result:=ProcNode;
1057
1078
  StartPos, EndPos: integer;
1058
1079
begin
1059
1080
  Result:=false;
1060
 
  BuildTree(false);
 
1081
  BuildTree(lsrEnd);
1061
1082
  DebugLn(['TMethodJumpingCodeTool.FindJumpPointForLinkerPos ']);
1062
1083
 
1063
1084
  BestPos:=0;
1185
1206
  CurProcHead: string;
1186
1207
begin
1187
1208
  Result:=false;
1188
 
  BuildTree(false);
 
1209
  BuildTree(lsrEnd);
1189
1210
  SectionNode:=Tree.Root;
1190
1211
  while (SectionNode<>nil) do begin
1191
1212
    if SectionNode.Desc in [ctnProgram,ctnImplementation] then begin