codetools: started FindAssignMethod

git-svn-id: trunk@30491 -

.gitattributes

@@ -415,6 +415,8 @@ components/codetools/examples/addeventmethod.lpi svneol=native#text/plain
 components/codetools/examples/addeventmethod.lpr svneol=native#text/plain
 components/codetools/examples/addmethod.lpi svneol=native#text/plain
 components/codetools/examples/addmethod.lpr svneol=native#text/plain
+components/codetools/examples/addmethodassign.lpi svneol=native#text/plain
+components/codetools/examples/addmethodassign.lpr svneol=native#text/plain
 components/codetools/examples/autoindent.lpi svneol=native#text/plain
 components/codetools/examples/autoindent.pas svneol=native#text/plain
 components/codetools/examples/codecompletion.lpi svneol=native#text/plain
@@ -461,6 +463,7 @@ components/codetools/examples/runcfgscript.lpr svneol=native#text/plain
 components/codetools/examples/scanexamples/BigLettersUnit.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/abstractclass1.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/addeventexample.pas svneol=native#text/plain
+components/codetools/examples/scanexamples/assignexample1.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/brokenfilenames.pas svneol=native#text/plain
 components/codetools/examples/scanexamples/brokenincfiles.inc svneol=native#text/plain
 components/codetools/examples/scanexamples/completion1.pas svneol=native#text/plain

components/codetools/codecompletiontool.pas

@@ -244,6 +244,18 @@ type
                         SourceChangeCache: TSourceChangeCache): boolean;
     function AddPublishedVariable(const UpperClassName,VarName, VarType: string;
                       SourceChangeCache: TSourceChangeCache): boolean; override;
+    function GatherPublishedMethods(ClassNode: TCodeTreeNode;
+                              out ListOfPFindContext: TFPList): boolean;
+
+    // graph of definitions of a unit
+    function GatherUnitDefinitions(out TreeOfCodeTreeNodeExt: TAVLTree;
+                      OnlyInterface, ExceptionOnRedefinition: boolean): boolean;
+    function BuildUnitDefinitionGraph(
+                        out DefinitionsTreeOfCodeTreeNodeExt: TAVLTree;
+                        out Graph: TCodeGraph; OnlyInterface: boolean): boolean;
+    procedure WriteCodeGraphDebugReport(Graph: TCodeGraph);
+
+    // redefinitions
     function GetRedefinitionNodeText(Node: TCodeTreeNode): string;
     function FindRedefinitions(out TreeOfCodeTreeNodeExt: TAVLTree;
                         WithEnums: boolean): boolean;
@@ -253,22 +265,24 @@ type
                                   OnlyWrongType: boolean): boolean;
     function FixAliasDefinitions(TreeOfCodeTreeNodeExt: TAVLTree;
                                 SourceChangeCache: TSourceChangeCache): boolean;
+
+    // const functions
     function FindConstFunctions(out TreeOfCodeTreeNodeExt: TAVLTree): boolean;
     function ReplaceConstFunctions(TreeOfCodeTreeNodeExt: TAVLTree;
                                 SourceChangeCache: TSourceChangeCache): boolean;
     function FindTypeCastFunctions(out TreeOfCodeTreeNodeExt: TAVLTree): boolean;
+
+    // typecast functions
     function ReplaceTypeCastFunctions(TreeOfCodeTreeNodeExt: TAVLTree;
                                 SourceChangeCache: TSourceChangeCache): boolean;
     function MovePointerTypesToTargetSections(
                                 SourceChangeCache: TSourceChangeCache): boolean;
+
+    // sort procs
     function FixForwardDefinitions(SourceChangeCache: TSourceChangeCache
                                    ): boolean;
-    function GatherUnitDefinitions(out TreeOfCodeTreeNodeExt: TAVLTree;
-                      OnlyInterface, ExceptionOnRedefinition: boolean): boolean;
-    function BuildUnitDefinitionGraph(
-                        out DefinitionsTreeOfCodeTreeNodeExt: TAVLTree;
-                        out Graph: TCodeGraph; OnlyInterface: boolean): boolean;
-    procedure WriteCodeGraphDebugReport(Graph: TCodeGraph);
+
+    // empty functions
     function FindEmptyMethods(CursorPos: TCodeXYPosition;
                               const AClassName: string; // can be ''
                               const Sections: TPascalClassSections;
@@ -286,12 +300,23 @@ type
                               out AllRemoved: boolean;
                               const Attr: TProcHeadAttributes;
                               out RemovedProcHeads: TStrings): boolean;
-    function GatherPublishedMethods(ClassNode: TCodeTreeNode;
-                              out ListOfPFindContext: TFPList): boolean;
+
+    // assign/init records/classes
+    function FindAssignMethod(CursorPos: TCodeXYPosition;
+        out ClassNode, AncestorClassNode: TCodeTreeNode;
+        out AssignDeclNode: TCodeTreeNode;
+        var MemberNodeExts: TAVLTree; // tree of TCodeTreeNodeExtension, Node=var or property, Data=write property
+        out AssignBodyNode: TCodeTreeNode): boolean;
+    function AddAssignMethod(MemberNodeExts: TAVLTree;
+        const ProcName, ParamName, ParamType: string;
+        CallInherited, CallInheritedOnlyInElse: boolean;
+        SourceChanger: TSourceChangeCache): boolean;
 
     // custom class completion
     function InitClassCompletion(const AClassName: string;
                                  SourceChangeCache: TSourceChangeCache): boolean;
+    function InitClassCompletion(ClassNode: TCodeTreeNode;
+                                 SourceChangeCache: TSourceChangeCache): boolean;
     function ApplyClassCompletion(AddMissingProcBodies: boolean): boolean;
     function ProcExistsInCodeCompleteClass(
                                     const NameAndParamsUpCase: string): boolean;
@@ -4987,6 +5012,237 @@ begin
   end;
 end;
 
+function TCodeCompletionCodeTool.FindAssignMethod(CursorPos: TCodeXYPosition;
+  out ClassNode, AncestorClassNode: TCodeTreeNode;
+  out AssignDeclNode: TCodeTreeNode; var MemberNodeExts: TAVLTree;
+  out AssignBodyNode: TCodeTreeNode): boolean;
+{ if CursorPos is in a class declaration search for a method "Assign"
+  and its corresponding body.
+  If CursorPos is in a method body use this as a Assign method and return
+  its corresponding declararion.
+  If neither return false.
+  Also return a tree of all variables and properties (excluding ancestors).
+}
+
+  procedure SearchAssign(Node: TCodeTreeNode);
+  var
+    Child: TCodeTreeNode;
+  begin
+    if Node=nil then exit;
+    Child:=Node.FirstChild;
+    while Child<>nil do begin
+      if Child.Desc in AllClassSections then
+        SearchAssign(Child)
+      else if Child.Desc=ctnProcedure then begin
+        if ExtractProcName(Child,[phpInUpperCase])='ASSIGN' then begin
+          if AssignDeclNode<>nil then begin
+            debugln(['WARNING: TCodeCompletionCodeTool.FindAssignMethod.SearchAssign'
+              +' multiple Assign methods found, using the first at ',CleanPosToStr(AssignDeclNode.StartPos)]);
+          end else
+            AssignDeclNode:=Child;
+        end;
+      end;
+      Child:=Child.NextBrother;
+    end;
+  end;
+
+  procedure GatherAssignableMembers(Node: TCodeTreeNode);
+  var
+    Child: TCodeTreeNode;
+    NodeExt: TCodeTreeNodeExtension;
+  begin
+    if Node=nil then exit;
+    Child:=Node.FirstChild;
+    while Child<>nil do begin
+      if Child.Desc in AllClassSections then
+        GatherAssignableMembers(Child)
+      else if (Child.Desc=ctnVarDefinition)
+      or ((Child.Desc=ctnProperty)
+        and (PropertyHasSpecifier(Child,'read'))
+        and (PropertyHasSpecifier(Child,'write')))
+      then begin
+        // a variable or a property which is readable and writable
+        if MemberNodeExts=nil then
+          MemberNodeExts:=TAVLTree.Create(@CompareCodeTreeNodeExtTxtAndPos);
+        NodeExt:=TCodeTreeNodeExtension.Create;
+        NodeExt.Node:=Child;
+        NodeExt.Position:=Child.StartPos;
+        if Child.Desc=ctnVarDefinition then
+          NodeExt.Txt:=ExtractDefinitionName(Child)
+        else
+          NodeExt.Txt:=ExtractPropName(Child,false);
+        MemberNodeExts.Add(NodeExt);
+      end;
+
+      Child:=Child.NextBrother;
+    end;
+  end;
+
+  procedure FindVarsWrittenByProperties;
+  var
+    AVLNode: TAVLTreeNode;
+    NodeExt: TCodeTreeNodeExtension;
+    WrittenNodeExt: TCodeTreeNodeExtension;
+  begin
+    if MemberNodeExts=nil then exit;
+    AVLNode:=MemberNodeExts.FindLowest;
+    while AVLNode<>nil do begin
+      NodeExt:=TCodeTreeNodeExtension(AVLNode.Data);
+      if NodeExt.Node.Desc=ctnProperty then begin
+        if PropertyHasSpecifier(NodeExt.Node,'write') then begin
+          ReadNextAtom;
+          if AtomIsIdentifier(false) then begin
+            WrittenNodeExt:=FindCodeTreeNodeExtWithIdentifier(MemberNodeExts,
+                                      @Src[CurPos.StartPos]);
+            if WrittenNodeExt<>nil then
+              WrittenNodeExt.Data:=NodeExt.Node;
+          end;
+        end;
+      end;
+      AVLNode:=MemberNodeExts.FindSuccessor(AVLNode);
+    end;
+  end;
+
+  procedure FindAncestor;
+  var
+    Params: TFindDeclarationParams;
+  begin
+    if ClassNode=nil then exit;
+    Params:=TFindDeclarationParams.Create;
+    try
+      //FindAncestorOfClassInheritance();
+
+    finally
+      Params.Free;
+    end;
+  end;
+
+var
+  CleanPos: integer;
+  CursorNode: TCodeTreeNode;
+  Node: TCodeTreeNode;
+begin
+  Result:=false;
+  ClassNode:=nil;
+  AncestorClassNode:=nil;
+  AssignDeclNode:=nil;
+  AssignBodyNode:=nil;
+  BuildTreeAndGetCleanPos(CursorPos,CleanPos);
+  // check context
+  CursorNode:=FindDeepestNodeAtPos(CleanPos,true);
+  Node:=CursorNode;
+  while (Node<>nil) do begin
+    if (Node.Desc=ctnProcedure) then begin
+      if NodeIsMethodBody(Node) then begin
+        // cursor in method body
+        AssignBodyNode:=Node;
+        Result:=true;
+        AssignDeclNode:=FindCorrespondingProcNode(AssignBodyNode);
+        if AssignDeclNode<>nil then
+          ClassNode:=FindClassOrInterfaceNode(AssignDeclNode.Parent);
+        break;
+      end;
+    end else if (Node.Desc in AllClassObjects) then begin
+      // cursor in class/record
+      Result:=true;
+      ClassNode:=Node;
+      SearchAssign(ClassNode);
+      if AssignDeclNode<>nil then
+        AssignBodyNode:=FindCorrespondingProcNode(AssignDeclNode);
+      break;
+    end;
+    Node:=Node.Parent;
+  end;
+  if ClassNode=nil then exit;
+  GatherAssignableMembers(ClassNode);
+  FindVarsWrittenByProperties;
+  FindAncestor;
+end;
+
+function TCodeCompletionCodeTool.AddAssignMethod(MemberNodeExts: TAVLTree;
+  const ProcName, ParamName, ParamType: string; CallInherited,
+  CallInheritedOnlyInElse: boolean; SourceChanger: TSourceChangeCache): boolean;
+var
+  AVLNode: TAVLTreeNode;
+  NodeExt: TCodeTreeNodeExtension;
+  Node: TCodeTreeNode;
+  CleanDef: String;
+  Def: String;
+  ClassNode: TCodeTreeNode;
+  aClassName: String;
+  ProcBody: String;
+  e: String;
+  SameType: boolean;
+  Indent: Integer;
+  IndentStep: LongInt;
+  LocalVar: String;
+begin
+  Result:=false;
+  if (MemberNodeExts=nil) or (MemberNodeExts.Count=0) then exit(true);
+  if (ParamName='') or (ParamType='') then exit;
+  ClassNode:=nil;
+  CleanDef:='procedure '+ProcName+'(:'+ParamType+')';
+  Def:='procedure '+ProcName+'('+ParamName+':'+ParamType+')';
+  ProcBody:='';
+  AVLNode:=MemberNodeExts.FindLowest;
+  e:=SourceChanger.BeautifyCodeOptions.LineEnd;
+  SameType:=true;
+  Indent:=0;
+  IndentStep:=SourceChanger.BeautifyCodeOptions.Indent;
+  LocalVar:=ParamName;
+  while AVLNode<>nil do begin
+    NodeExt:=TCodeTreeNodeExtension(AVLNode.Data);
+    Node:=NodeExt.Node;
+    if ClassNode=nil then begin
+      // first assignment
+      // => get the classnode, create the proc header
+      ClassNode:=FindClassOrInterfaceNode(Node.Parent);
+      aClassName:=ExtractClassName(ClassNode,false);
+      SameType:=CompareIdentifiers(PChar(aClassName),PChar(ParamType))=0;
+      ProcBody:='procedure '+aClassName+'.'+ProcName+'('+ParamName+':'+ParamType+')'+e;
+      if not SameType then begin
+        LocalVar:='aSrc';
+        if CompareIdentifiers(PChar(LocalVar),PChar(ParamName))=0 then
+          LocalVar:='aSource';
+        ProcBody:=ProcBody+'var'+e
+           +GetIndentStr(Indent+IndentStep)+LocalVar+':'+aClassName+';'+e;
+      end;
+      ProcBody:=ProcBody+'begin'+e;
+      inc(Indent,IndentStep);
+      if CallInherited and (not CallInheritedOnlyInElse) then
+        ProcBody:=ProcBody
+          +GetIndentStr(Indent)+'inherited '+ProcName+'('+ParamName+');'+e;
+      if not SameType then begin
+        // add a parameter check to the new procedure
+        ProcBody:=ProcBody
+            +GetIndentStr(Indent)+'if '+ParamName+' is '+aClassName+' then'+e
+            +GetIndentStr(Indent)+'begin'+e;
+        inc(Indent,IndentStep);
+        ProcBody:=ProcBody+GetIndentStr(Indent)+LocalVar+':='+aClassName+'('+ParamName+');'+e;
+      end;
+    end;
+    // add assignment
+    ProcBody:=ProcBody+GetIndentStr(Indent)+NodeExt.Txt+':='+LocalVar+'.'+NodeExt.Txt+';'+e;
+    AVLNode:=MemberNodeExts.FindSuccessor(AVLNode);
+  end;
+  if not SameType then begin
+    // close if block
+    dec(Indent,IndentStep);
+    if CallInherited and CallInheritedOnlyInElse then begin
+      ProcBody:=ProcBody+GetIndentStr(Indent)+'end else'+e
+          +GetIndentStr(Indent+IndentStep)+'inherited '+ProcName+'('+ParamName+');'+e;
+    end else begin
+      ProcBody:=ProcBody+GetIndentStr(Indent)+'end;'+e
+    end;
+  end;
+  // close procedure body
+  ProcBody:=ProcBody+'end;';
+  // apply
+  if not InitClassCompletion(ClassNode,SourceChanger) then exit;
+  AddClassInsertion(CleanDef,Def,ProcName,ncpPublicProcs,nil,ProcBody);
+  Result:=ApplyClassCompletion(true);
+end;
+
 function TCodeCompletionCodeTool.GatherPublishedMethods(
   ClassNode: TCodeTreeNode; out ListOfPFindContext: TFPList): boolean;
 var
@@ -5020,7 +5276,13 @@ begin
   if ScannedRange<>lsrEnd then exit;
   if (SourceChangeCache=nil) or (Scanner=nil) then exit;
   ClassNode:=FindClassNodeInUnit(AClassName,true,false,false,true);
-  if (ClassNode=nil) then exit;
+  Result:=InitClassCompletion(ClassNode,SourceChangeCache);
+end;
+
+function TCodeCompletionCodeTool.InitClassCompletion(ClassNode: TCodeTreeNode;
+  SourceChangeCache: TSourceChangeCache): boolean;
+begin
+  if (ClassNode=nil) then exit(false);
   CodeCompleteClassNode:=ClassNode;
   CodeCompleteSrcChgCache:=SourceChangeCache;
   FreeClassInsertionList;

components/codetools/codetoolmanager.pas

@@ -550,6 +550,13 @@ type
           FunctionResultVariableStartPos: integer = 0
           ): boolean;
 
+    // Assign method
+    function FindAssignMethod(Code: TCodeBuffer; X, Y: integer;
+          out Tool: TCodeTool; out ClassNode, AncestorClassNode: TCodeTreeNode;
+          out AssignDeclNode: TCodeTreeNode;
+          var MemberNodeExts: TAVLTree; // tree of TCodeTreeNodeExtension, Node=var or property, Data=write property
+          out AssignBodyNode: TCodeTreeNode): boolean;
+
     // code templates
     function InsertCodeTemplate(Code: TCodeBuffer;
           SelectionStart, SelectionEnd: TPoint;
@@ -3896,6 +3903,32 @@ begin
   end;
 end;
 
+function TCodeToolManager.FindAssignMethod(Code: TCodeBuffer; X, Y: integer;
+  out Tool: TCodeTool; out ClassNode, AncestorClassNode: TCodeTreeNode;
+  out AssignDeclNode: TCodeTreeNode; var MemberNodeExts: TAVLTree;
+  out AssignBodyNode: TCodeTreeNode): boolean;
+var
+  CodePos: TCodeXYPosition;
+begin
+  {$IFDEF CTDEBUG}
+  DebugLn('TCodeToolManager.FindAssignMethod A ',Code.Filename);
+  {$ENDIF}
+  Result:=false;
+  AssignDeclNode:=nil;
+  AssignBodyNode:=nil;
+  if not InitCurCodeTool(Code) then exit;
+  Tool:=FCurCodeTool;
+  CodePos.X:=X;
+  CodePos.Y:=Y;
+  CodePos.Code:=Code;
+  try
+    Result:=FCurCodeTool.FindAssignMethod(CodePos,ClassNode,AncestorClassNode,
+           AssignDeclNode,MemberNodeExts,AssignBodyNode);
+  except
+    on e: Exception do Result:=HandleException(e);
+  end;
+end;
+
 function TCodeToolManager.InsertCodeTemplate(Code: TCodeBuffer;
   SelectionStart, SelectionEnd: TPoint; TopLine: integer;
   CodeTemplate: TCodeToolTemplate; var NewCode: TCodeBuffer; var NewX, NewY,

components/codetools/codetree.pas

@@ -309,10 +309,11 @@ function CompareTxtWithCodeTreeNodeExt(p: Pointer;
                                        NodeData: pointer): integer;
 function CompareIdentifierWithCodeTreeNodeExt(p: Pointer;
                                               NodeData: pointer): integer;
-function CompareCodeTreeNodeExt(NodeData1, NodeData2: pointer): integer;
-function CompareCodeTreeNodeExtWithPos(NodeData1, NodeData2: pointer): integer;
+function CompareCodeTreeNodeExt(NodeData1, NodeData2: pointer): integer; // Txt
+function CompareCodeTreeNodeExtWithPos(NodeData1, NodeData2: pointer): integer; // Position
 function CompareCodeTreeNodeExtWithNodeStartPos(
-  NodeData1, NodeData2: pointer): integer;
+  NodeData1, NodeData2: pointer): integer; // Node.StartPos
+function CompareCodeTreeNodeExtTxtAndPos(NodeData1, NodeData2: pointer): integer; // Txt, then Position
 function CompareCodeTreeNodeExtWithNode(NodeData1, NodeData2: pointer): integer;
 function ComparePointerWithCodeTreeNodeExtNode(p: Pointer;
                                                NodeExt: pointer): integer;
@@ -497,9 +498,8 @@ function CompareTxtWithCodeTreeNodeExt(p: Pointer; NodeData: pointer
   ): integer;
 var
   s: String;
-  NodeExt: TCodeTreeNodeExtension;
+  NodeExt: TCodeTreeNodeExtension absolute NodeData;
 begin
-  NodeExt:=TCodeTreeNodeExtension(NodeData);
   s:=PAnsistring(p)^;
   Result:=CompareTextIgnoringSpace(s,NodeExt.Txt,false);
   //debugln('CompareTxtWithCodeTreeNodeExt ',NodeExt.Txt,' ',s,' ',dbgs(Result));
@@ -508,17 +508,17 @@ end;
 function CompareIdentifierWithCodeTreeNodeExt(p: Pointer; NodeData: pointer
   ): integer;
 var
-  NodeExt: TCodeTreeNodeExtension;
+  NodeExt: TCodeTreeNodeExtension absolute NodeData;
 begin
   NodeExt:=TCodeTreeNodeExtension(NodeData);
   Result:=CompareIdentifierPtrs(p,Pointer(NodeExt.Txt));
 end;
 
 function CompareCodeTreeNodeExt(NodeData1, NodeData2: pointer): integer;
-var NodeExt1, NodeExt2: TCodeTreeNodeExtension;
+var
+  NodeExt1: TCodeTreeNodeExtension absolute NodeData1;
+  NodeExt2: TCodeTreeNodeExtension absolute NodeData2;
 begin
-  NodeExt1:=TCodeTreeNodeExtension(NodeData1);
-  NodeExt2:=TCodeTreeNodeExtension(NodeData2);
   Result:=CompareTextIgnoringSpace(NodeExt1.Txt,NodeExt2.Txt,false);
 end;
 
@@ -549,6 +549,22 @@ begin
     Result:=0;
 end;
 
+function CompareCodeTreeNodeExtTxtAndPos(NodeData1, NodeData2: pointer
+  ): integer;
+var
+  NodeExt1: TCodeTreeNodeExtension absolute NodeData1;
+  NodeExt2: TCodeTreeNodeExtension absolute NodeData2;
+begin
+  Result:=CompareTextIgnoringSpace(NodeExt1.Txt,NodeExt2.Txt,false);
+  if Result<>0 then exit;
+  if NodeExt1.Position<NodeExt2.Position then
+    Result:=1
+  else if NodeExt1.Position>NodeExt2.Position then
+    Result:=-1
+  else
+    Result:=0;
+end;
+
 function CompareCodeTreeNodeExtWithNode(NodeData1, NodeData2: pointer): integer;
 var
   Node1: TCodeTreeNode;

components/codetools/examples/addmethodassign.lpi

@@ -0,0 +1,66 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <LRSInOutputDirectory Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="addmethodassign"/>
+    </General>
+    <BuildModes Count="1">
+      <Item1 Name="default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="CodeTools"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="4">
+      <Unit0>
+        <Filename Value="addmethodassign.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="addmethodassign"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="scanexamples/simpleunit1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="SimpleUnit1"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="scanexamples/addeventexample.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="AddEventExample"/>
+      </Unit2>
+      <Unit3>
+        <Filename Value="scanexamples/assignexample1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="AssignExample1"/>
+      </Unit3>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="10"/>
+    <SearchPaths>
+      <OtherUnitFiles Value="scanexamples"/>
+    </SearchPaths>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>

components/codetools/examples/addmethodassign.lpr

@@ -0,0 +1,104 @@
+{
+ ***************************************************************************
+ *                                                                         *
+ *   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:
+    Demonstrating, how to add a method Assign to a class.
+}
+program AddMethodAssign;
+
+{$mode objfpc}{$H+}
+
+uses
+  Classes, SysUtils, CodeCache, CodeToolManager, FileProcs, AVL_Tree,
+  BasicCodeTools, SourceChanger, CodeTree, AssignExample1;
+  
+var
+  Filename: string;
+  Code: TCodeBuffer;
+  Tool: TCodeTool;
+  AssignDeclNode: TCodeTreeNode;
+  MemberNodeExts: TAVLTree;
+  AssignBodyNode: TCodeTreeNode;
+  AVLNode: TAVLTreeNode;
+  NodeExt: TCodeTreeNodeExtension;
+  NextAVLNode: TAVLTreeNode;
+  ClassNode: TCodeTreeNode;
+  AncestorClassNode: TCodeTreeNode;
+begin
+  // load the file
+  Filename:=ExpandFileName(SetDirSeparators('scanexamples/assignexample1.pas'));
+  Code:=CodeToolBoss.LoadFile(Filename,false,false);
+  if Code=nil then
+    raise Exception.Create('loading failed '+Filename);
+
+  // parse the unit, check if in a class with an Assign method
+  try
+    MemberNodeExts:=nil;
+    if not CodeToolBoss.FindAssignMethod(Code,3,18,Tool,
+      ClassNode,AncestorClassNode,
+      AssignDeclNode,MemberNodeExts,AssignBodyNode) then
+      raise Exception.Create('parser error');
+
+    debugln(['Assign declaration found: ',AssignDeclNode<>nil]);
+    debugln(['Assign body found: ',AssignBodyNode<>nil]);
+
+    // remove nodes which are written by a property
+    if MemberNodeExts<>nil then begin
+      AVLNode:=MemberNodeExts.FindLowest;
+      while AVLNode<>nil do begin
+        NextAVLNode:=MemberNodeExts.FindSuccessor(AVLNode);
+        NodeExt:=TCodeTreeNodeExtension(AVLNode.Data);
+        if NodeExt.Data<>nil then begin
+          debugln(['skipping identifier ',NodeExt.Txt,' because it is written by a property']);
+          MemberNodeExts.FreeAndDelete(AVLNode);
+        end else begin
+          debugln('assigning identifier ',NodeExt.Txt,' ...');
+        end;
+        AVLNode:=NextAVLNode;
+      end;
+    end;
+    if (MemberNodeExts=nil) or (MemberNodeExts.Count=0) then begin
+      debugln('no assignable members found');
+      exit;
+    end;
+
+    //
+    if AssignDeclNode=nil then begin
+      if not Tool.AddAssignMethod(MemberNodeExts,'Assign','Source','TObject',
+             true,false,
+             CodeToolBoss.SourceChangeCache)
+      then
+        raise Exception.Create('AddAssignMethod failed');
+    end else begin
+      debugln(['there is already an Assign method']);
+    end;
+
+  finally
+    DisposeAVLTree(MemberNodeExts);
+  end;
+  // write the new source:
+  writeln('-----------------------------------');
+  writeln('New source:');
+  writeln(Code.Source);
+  writeln('-----------------------------------');
+end.
+

components/codetools/examples/scanexamples/assignexample1.pas

@@ -0,0 +1,32 @@
+unit AssignExample1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, sysutils;
+
+type
+
+  { TMyPersistent }
+
+  TMyPersistent = class(TComponent)
+  private
+    FMyInt: integer;
+  public
+    procedure CopyFrom(Src: TMyPersistent);
+    property MyInt: integer read FMyInt write FMyInt;
+  end;
+
+implementation
+
+{ TMyPersistent }
+
+procedure TMyPersistent.CopyFrom(Src: TMyPersistent);
+begin
+
+end;
+
+end.
+