Converter: improved and refactored lfm form file conversion, coordinate offsets and added properties.

git-svn-id: trunk@29346 -

converter/convcodetool.pas

@@ -101,8 +101,6 @@ type
     function FindApptypeConsole: boolean;
     function FixMainClassAncestor(const AClassName: string;
                                   AReplaceTypes: TStringToStringTree): boolean;
-    function CheckTopOffsets(LFMBuf: TCodeBuffer; LFMTree: TLFMTree;
-               VisOffsets: TVisualOffsets; ValueNodes: TObjectList): boolean;
   public
     property HasFormFile: boolean read fHasFormFile write fHasFormFile;
     property LowerCaseRes: boolean read fLowerCaseRes write fLowerCaseRes;
@@ -723,320 +721,5 @@ begin
   Result:=true;
 end;  // ReplaceFuncCalls
 
-function TConvDelphiCodeTool.CheckTopOffsets(LFMBuf: TCodeBuffer; LFMTree: TLFMTree;
-                     VisOffsets: TVisualOffsets; ValueNodes: TObjectList): boolean;
-// Collect a list of coord attributes for components that are inside
-//  a visual container component. An offset will be added to those attributes.
-// Parameters: VisOffsets has names of parent container types.
-//   ValueNodes - the found coord attributes are added here as TSrcPropOffset objects.
-// Based on function CheckLFM.
-var
-  RootContext: TFindContext;
-
-  function CheckLFMObjectValues(LFMObject: TLFMObjectNode;
-    const ClassContext: TFindContext; GrandClassName: string): boolean; forward;
-
-  function FindLFMIdentifier(LFMNode: TLFMTreeNode; const IdentName: string;
-    const ClassContext: TFindContext; out IdentContext: TFindContext): boolean;
-  var
-    Params: TFindDeclarationParams;
-    IsPublished: Boolean;
-  begin
-    Result:=false;
-    IdentContext:=CleanFindContext;
-    IsPublished:=false;
-    if (ClassContext.Node=nil) or (not (ClassContext.Node.Desc in AllClasses)) then
-      exit;
-    Params:=TFindDeclarationParams.Create;
-    try
-      Params.Flags:=[fdfSearchInAncestors,fdfExceptionOnNotFound,
-                     fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
-                     fdfIgnoreOverloadedProcs];
-      Params.ContextNode:=ClassContext.Node;
-      Params.SetIdentifier(ClassContext.Tool,PChar(Pointer(IdentName)),nil);
-      try
-        if ClassContext.Tool.FindIdentifierInContext(Params) then begin
-          Result:=true;
-          repeat
-            IdentContext:=CreateFindContext(Params);
-            if (not IsPublished)
-            and (IdentContext.Node.HasParentOfType(ctnClassPublished)) then
-              IsPublished:=true;
-            if (IdentContext.Node<>nil)
-            and (IdentContext.Node.Desc=ctnProperty)
-            and (IdentContext.Tool.PropNodeIsTypeLess(IdentContext.Node)) then
-            begin
-              // this is a typeless property -> search further
-              Params.Clear;
-              Params.Flags:=[fdfSearchInAncestors, fdfIgnoreMissingParams,
-                             fdfIgnoreCurContextNode, fdfIgnoreOverloadedProcs];
-              Params.ContextNode:=IdentContext.Node.Parent;
-              while (Params.ContextNode<>nil)
-              and (not (Params.ContextNode.Desc in AllClasses)) do
-                Params.ContextNode:=Params.ContextNode.Parent;
-              if Params.ContextNode<>nil then begin
-                Params.SetIdentifier(ClassContext.Tool,PChar(Pointer(IdentName)),nil);
-                if not IdentContext.Tool.FindIdentifierInContext(Params) then
-                  break;
-              end;
-            end else
-              break;
-          until false;
-        end;
-      except
-        on E: ECodeToolError do ;        // ignore search/parse errors
-      end;
-    finally
-      Params.Free;
-    end;
-  end;
-
-  function FindClassNodeForLFMObject(LFMNode: TLFMTreeNode;
-    StartTool: TFindDeclarationTool; DefinitionNode: TCodeTreeNode): TFindContext;
-  var
-    Params: TFindDeclarationParams;
-    Identifier: PChar;
-    OldInput: TFindDeclarationInput;
-  begin
-    Result:=CleanFindContext;
-    if (DefinitionNode.Desc=ctnIdentifier) then
-      Identifier:=@StartTool.Src[DefinitionNode.StartPos]
-    else if DefinitionNode.Desc=ctnProperty then
-      Identifier:=StartTool.GetPropertyTypeIdentifier(DefinitionNode)
-    else
-      Identifier:=nil;
-    if Identifier=nil then exit;
-    Params:=TFindDeclarationParams.Create;
-    try
-      Params.Flags:=[fdfSearchInAncestors, fdfExceptionOnNotFound,
-                     fdfSearchInParentNodes, fdfExceptionOnPredefinedIdent,
-                     fdfIgnoreMissingParams, fdfIgnoreOverloadedProcs];
-      Params.ContextNode:=DefinitionNode;
-      Params.SetIdentifier(StartTool,Identifier,nil);
-      try
-        Params.Save(OldInput);
-        if StartTool.FindIdentifierInContext(Params) then begin
-          Params.Load(OldInput,true);
-          Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode);
-          if (Result.Node=nil)
-          or (not (Result.Node.Desc in AllClasses)) then
-            Result:=CleanFindContext;
-        end;
-      except
-        on E: ECodeToolError do ;        // ignore search/parse errors
-      end;
-    finally
-      Params.Free;
-    end;
-  end;
-
-  function FindClassContext(const ClassName: string): TFindContext;
-  var
-    Params: TFindDeclarationParams;
-    Identifier: PChar;
-    OldInput: TFindDeclarationInput;
-    StartTool: TStandardCodeTool;
-  begin
-    Result:=CleanFindContext;
-    Params:=TFindDeclarationParams.Create;
-    StartTool:=fCTLink.CodeTool;
-    Identifier:=PChar(Pointer(ClassName));
-    try
-      Params.Flags:=[fdfExceptionOnNotFound, fdfSearchInParentNodes,
-                     fdfExceptionOnPredefinedIdent,fdfIgnoreMissingParams,
-                     fdfIgnoreOverloadedProcs];
-      with fCTLink.CodeTool do begin
-        Params.ContextNode:=FindInterfaceNode;
-        if Params.ContextNode=nil then
-          Params.ContextNode:=FindMainUsesSection;
-        Params.SetIdentifier(StartTool,Identifier,nil);
-        try
-          Params.Save(OldInput);
-          if FindIdentifierInContext(Params) then begin
-            Params.Load(OldInput,true);
-            Result:=Params.NewCodeTool.FindBaseTypeOfNode(Params,Params.NewNode);
-            if (Result.Node=nil)
-            or (not (Result.Node.Desc in AllClasses)) then
-              Result:=CleanFindContext;
-          end;
-        except
-          on E: ECodeToolError do ;          // ignore search/parse errors
-        end;
-      end;
-    finally
-      Params.Free;
-    end;
-  end;
-
-  procedure CheckLFMChildObject(LFMObject: TLFMObjectNode; const ParentName: string);
-  var
-    VarTypeName: String;
-    ChildContext: TFindContext;
-    ClassContext: TFindContext;
-    DefinitionNode: TCodeTreeNode;
-  begin
-    // find variable for object
-    if LFMObject.Name='' then exit;
-    if FindLFMIdentifier(LFMObject, LFMObject.Name, RootContext, ChildContext) then begin
-      if ChildContext.Node=nil then exit;
-      // check if identifier is a variable or property
-      VarTypeName:='';
-      if (ChildContext.Node.Desc=ctnVarDefinition) then begin
-        DefinitionNode:=ChildContext.Tool.FindTypeNodeOfDefinition(ChildContext.Node);
-        if DefinitionNode=nil then exit;
-        VarTypeName:=ChildContext.Tool.ExtractDefinitionNodeType(ChildContext.Node);
-      end else if (ChildContext.Node.Desc=ctnProperty) then begin
-        DefinitionNode:=ChildContext.Node;
-        VarTypeName:=ChildContext.Tool.ExtractPropType(ChildContext.Node,false,false);
-      end else
-        exit;
-      // check if variable/property has a compatible type
-      if (VarTypeName<>'') and (LFMObject.TypeName<>'')
-          and (CompareIdentifiers(PChar(VarTypeName),
-                                  PChar(LFMObject.TypeName))<>0) then  exit;
-      // find class node
-      ClassContext:=FindClassNodeForLFMObject(LFMObject, ChildContext.Tool, DefinitionNode);
-    end else
-      ClassContext:=FindClassContext(LFMObject.TypeName);  // try the object type
-    // check child LFM nodes
-    // ClassContext.Node=nil when the parent class is not found in source.
-    if ClassContext.Node<>nil then
-      CheckLFMObjectValues(LFMObject, ClassContext, ParentName);
-  end;
-
-  function FindClassNodeForPropertyType(LFMProperty: TLFMPropertyNode;
-    const PropertyContext: TFindContext): TFindContext;
-  var
-    Params: TFindDeclarationParams;
-  begin
-    Result:=CleanFindContext;
-    Params:=TFindDeclarationParams.Create;
-    try
-      Params.Flags:=[fdfSearchInAncestors,  fdfExceptionOnNotFound,
-                     fdfSearchInParentNodes,fdfExceptionOnPredefinedIdent,
-                     fdfIgnoreMissingParams,fdfIgnoreOverloadedProcs];
-      Params.ContextNode:=PropertyContext.Node;
-      Params.SetIdentifier(PropertyContext.Tool,nil,nil);
-      try
-        Result:=PropertyContext.Tool.FindBaseTypeOfNode(Params, PropertyContext.Node);
-      except
-        on E: ECodeToolError do ;              // ignore search/parse errors
-      end;
-    finally
-      Params.Free;
-    end;
-  end;
-
-  procedure CheckLFMProperty(LFMProperty: TLFMPropertyNode; const ParentContext: TFindContext;
-    const GrandClassName, ParentClassName: string);
-  // Check properties. Stores info about Top and Left properties for later adjustment.
-  // Parameters: LFMProperty is the property node
-  //   ParentContext is the context, where properties are searched (class or property).
-  //   GrandClassName and ParentClassName are the class type names.
-  var
-    i, ind: Integer;
-    ValNode: TLFMValueNode;
-    CurName, Prop: string;
-    CurPropContext: TFindContext;
-    SearchContext: TFindContext;
-  begin
-    // find complete property name
-    Prop:=LFMProperty.CompleteName;
-    if Prop='' then exit;
-    if (Prop='Top') or (Prop='Left') then begin
-      if (GrandClassName<>'') and VisOffsets.Find(GrandClassName, ind) then begin
-        if LFMProperty.FirstChild is TLFMValueNode then begin
-          ValNode:=LFMProperty.FirstChild as TLFMValueNode;
-          ValueNodes.Add(TSrcPropOffset.Create(GrandClassName,ParentClassName,
-                                               Prop,ValNode.StartPos));
-        end;
-      end;
-    end;
-    // find every part of the property name
-    SearchContext:=ParentContext;
-    for i:=0 to LFMProperty.NameParts.Count-1 do begin
-      if SearchContext.Node.Desc=ctnProperty then begin
-        // get the type of the property and search the class node
-        SearchContext:=FindClassNodeForPropertyType(LFMProperty, SearchContext);
-        if SearchContext.Node=nil then exit;
-      end;
-      CurName:=LFMProperty.NameParts.Names[i];
-      if not FindLFMIdentifier(LFMProperty, CurName, SearchContext, CurPropContext) then
-        break;
-      if CurPropContext.Node=nil then break;
-      SearchContext:=CurPropContext;
-    end;
-  end;
-
-  function CheckLFMObjectValues(LFMObject: TLFMObjectNode;
-    const ClassContext: TFindContext; GrandClassName: string): boolean;
-  var
-    CurLFMNode: TLFMTreeNode;
-    ParentName: string;
-  begin
-    ParentName:=ClassContext.Tool.ExtractClassName(ClassContext.Node, False);
-    CurLFMNode:=LFMObject.FirstChild;
-    while CurLFMNode<>nil do begin
-      case CurLFMNode.TheType of
-      lfmnObject:
-        CheckLFMChildObject(TLFMObjectNode(CurLFMNode), ParentName);
-      lfmnProperty:
-        CheckLFMProperty(TLFMPropertyNode(CurLFMNode), ClassContext,
-                         GrandClassName, ParentName);
-      end;
-      CurLFMNode:=CurLFMNode.NextSibling;
-    end;
-    Result:=true;
-  end;
-
-  function CheckLFMRoot(RootLFMNode: TLFMTreeNode): boolean;
-  var
-    LookupRootLFMNode: TLFMObjectNode;
-    LookupRootTypeName: String;
-    RootClassNode: TCodeTreeNode;
-  begin
-    Result:=false;
-    // get root object node
-    if (RootLFMNode=nil) or (not (RootLFMNode is TLFMObjectNode)) then exit;
-    LookupRootLFMNode:=TLFMObjectNode(RootLFMNode);
-
-    // get type name of root object
-    LookupRootTypeName:=UpperCaseStr(LookupRootLFMNode.TypeName);
-    if LookupRootTypeName='' then exit;
-
-    // find root type
-    RootClassNode:=fCTLink.CodeTool.FindClassNodeInUnit(LookupRootTypeName,
-                                                        true,false,false,false);
-    RootContext:=CleanFindContext;
-    RootContext.Node:=RootClassNode;
-    RootContext.Tool:=fCTLink.CodeTool;
-    if RootClassNode=nil then exit;
-    Result:=CheckLFMObjectValues(LookupRootLFMNode, RootContext, '');
-  end;
-
-var
-  CurRootLFMNode: TLFMTreeNode;
-begin
-  Result:=false;
-  // create tree from LFM file
-  LFMTree:=DefaultLFMTrees.GetLFMTree(LFMBuf,true);
-  fCTLink.CodeTool.ActivateGlobalWriteLock;
-  try
-    if not LFMTree.ParseIfNeeded then exit;
-    // parse unit and find LookupRoot
-    fCTLink.CodeTool.BuildTree(true);
-    // find every identifier
-    CurRootLFMNode:=LFMTree.Root;
-    while CurRootLFMNode<>nil do begin
-      if not CheckLFMRoot(CurRootLFMNode) then exit;
-      CurRootLFMNode:=CurRootLFMNode.NextSibling;
-    end;
-  finally
-    fCTLink.CodeTool.DeactivateGlobalWriteLock;
-  end;
-  Result:=LFMTree.FirstError=nil;
-end;  // CheckTopOffsets
-
-
 end.
 

converter/convertertypes.pas

@@ -12,7 +12,7 @@ type
   TAddUnitEvent = procedure(AUnitName: string) of object;
   TCheckUnitEvent = function (AUnitName: string): Boolean of object;
 
-  { TopOffset }
+  { TSrcPropOffset }
 
   // Used when fixing top coordinates of controls inside a visual container.
   TSrcPropOffset = class
@@ -32,7 +32,7 @@ type
 
   { TVisualOffset }
 
-  // User defined settings.
+  // User defined settings of visual offsets.
   TVisualOffset = class
   private
     fParentType: string;
@@ -50,6 +50,7 @@ type
 
   { TVisualOffsets }
 
+  // Collection of TVisualOffset items.
   TVisualOffsets = class(TObjectList)
   private
     function GetVisualOffset(Index: Integer): TVisualOffset;
@@ -63,7 +64,23 @@ type
                                                  write SetVisualOffset; default;
   end;
 
-  // types for errors
+  { TAddPropEntry }
+
+  // A new property to be added to lfm form file.
+  TAddPropEntry = class
+  private
+    fStartPos: integer;
+    fEndPos: integer;
+    fNewText: string;
+    fParentType: string;
+  public
+    constructor Create(aStartPos, aEndPos: Integer; const aNewText, aParentType: string);
+    destructor Destroy; override;
+    property StartPos: integer read fStartPos;
+    property EndPos: integer read fEndPos;
+    property NewText: string read fNewText;
+    property ParentType: string read fParentType;
+  end;
 
   { EConverterError }
 
@@ -74,15 +91,7 @@ type
 
 implementation
 
-{ EConverterError }
+{ TSrcPropOffset }
-
-constructor EDelphiConverterError.Create(const AMessage: string);
-begin
-  inherited Create('Converter: '+AMessage);
-end;
-
-
-{ TopOffset }
 
 constructor TSrcPropOffset.Create(aParentType, aChildType, aPropName: string; aStartPos: integer);
 begin
@@ -97,7 +106,6 @@ begin
   inherited Destroy;
 end;
 
-
 { TVisualOffset }
 
 constructor TVisualOffset.Create(const aParentType: string; aTop, aLeft: Integer);
@@ -122,7 +130,6 @@ begin
     Result:=0
 end;
 
-
 { TVisualOffsets }
 
 constructor TVisualOffsets.Create;
@@ -172,6 +179,28 @@ begin
   Inherited Items[Index]:=AValue;
 end;
 
+{ TAddPropEntry }
+
+constructor TAddPropEntry.Create(aStartPos, aEndPos: Integer; const aNewText, aParentType: string);
+begin
+  inherited Create;
+  fStartPos:=aStartPos;
+  fEndPos:=aEndPos;
+  fNewText:=aNewText;
+  fParentType:=aParentType;
+end;
+
+destructor TAddPropEntry.Destroy;
+begin
+  inherited Destroy;
+end;
+
+{ EConverterError }
+
+constructor EDelphiConverterError.Create(const AMessage: string);
+begin
+  inherited Create('Converter: '+AMessage);
+end;
 
 end.
 

converter/missingpropertiesdlg.pas

@@ -78,6 +78,7 @@ type
     fTypeReplaceGrid: TStringGrid;
     function ReplaceAndRemoveAll: TModalResult;
     function ReplaceTopOffsets(aSrcOffsets: TList): TModalResult;
+    function AddNewProps(aNewProps: TList): TModalResult;
     // Fill StringGrids with missing properties and types from fLFMTree.
     procedure FillReplaceGrids;
   protected
@@ -134,6 +135,8 @@ implementation
 
 {$R *.lfm}
 
+uses FormFileConv;
+
 function ConvertDfmToLfm(const DfmFilename: string): TModalResult;
 var
   DFMConverter: TDFMConverter;
@@ -347,11 +350,10 @@ end;
 
 function TLFMFixer.ReplaceTopOffsets(aSrcOffsets: TList): TModalResult;
 // Replace top coordinates of controls in visual containers.
-// Returns mrOK if no types were changed, and mrCancel if there was an error.
 var
   TopOffs: TSrcPropOffset;
   VisOffs: TVisualOffset;
-  OldNum, Ofs, NewNum, Len, ind, i: integer;
+  OldNum, NewNum, Len, ind, i: integer;
 begin
   Result:=mrOK;
   // Add offset to top coordinates.
@@ -367,8 +369,7 @@ begin
       except on EConvertError do
         OldNum:=0;
       end;
-      Ofs:=VisOffs.ByProperty(TopOffs.PropName);
+      NewNum:=OldNum-VisOffs.ByProperty(TopOffs.PropName);
-      NewNum:=OldNum-Ofs;
       if NewNum<0 then
         NewNum:=0;
       fLFMBuffer.Replace(TopOffs.StartPos, Len, IntToStr(NewNum));
@@ -378,6 +379,21 @@ begin
   end;
 end;
 
+function TLFMFixer.AddNewProps(aNewProps: TList): TModalResult;
+// Add new property to the lfm file.
+var
+  Entry: TAddPropEntry;
+  i: integer;
+begin
+  Result:=mrOK;
+  for i:=aNewProps.Count-1 downto 0 do begin
+    Entry:=TAddPropEntry(aNewProps[i]);
+    fLFMBuffer.Replace(Entry.StartPos, Entry.EndPos-Entry.StartPos,Entry.NewText);
+    IDEMessagesWindow.AddMsg(Format('Added property "%s" for %s.',
+                                   [Entry.NewText, Entry.ParentType]),'',-1);
+  end;
+end;
+
 procedure TLFMFixer.FillReplaceGrids;
 var
   PropUpdater: TGridUpdater;
@@ -454,7 +470,9 @@ end;
 function TLFMFixer.Repair: TModalResult;
 var
   ConvTool: TConvDelphiCodeTool;
-  ValueTreeNodes: TObjectList;
+  FormFileTool: TFormFileConverter;
+  SrcCoordOffs: TObjectList;
+  SrcNewProps: TObjectList;
   LoopCount: integer;
 begin
   Result:=mrCancel;
@@ -462,10 +480,12 @@ begin
   if not fLFMTree.ParseIfNeeded then exit;
   // Change a type that main form inherits from to a fall-back type if needed.
   ConvTool:=TConvDelphiCodeTool.Create(fCTLink);
-  ValueTreeNodes:=TObjectList.Create;
   try
     if not ConvTool.FixMainClassAncestor(TLFMObjectNode(fLFMTree.Root).TypeName,
                                          fSettings.ReplaceTypes) then exit;
+  finally
+    ConvTool.Free;
+  end;
   LoopCount:=0;
   repeat
     if CodeToolBoss.CheckLFM(fPascalBuffer,fLFMBuffer,fLFMTree,
@@ -479,15 +499,24 @@ begin
   WriteLFMErrors;
   if (Result=mrOK) and (fSettings.CoordOffsMode=rsEnabled) then begin
     // Fix top offsets of some components in visual containers
-      if ConvTool.CheckTopOffsets(fLFMBuffer, fLFMTree,
+    FormFileTool:=TFormFileConverter.Create(fCTLink, fLFMBuffer);
-                                  fSettings.CoordOffsets, ValueTreeNodes) then
+    SrcCoordOffs:=TObjectList.Create;
-        Result:=ReplaceTopOffsets(ValueTreeNodes)
+    SrcNewProps:=TObjectList.Create;
-      else
+    try
-        Result:=mrCancel;
+      FormFileTool.VisOffsets:=fSettings.CoordOffsets;
+      FormFileTool.SrcCoordOffs:=SrcCoordOffs;
+      FormFileTool.SrcNewProps:=SrcNewProps;
+      Result:=FormFileTool.Convert;
+      if Result=mrOK then begin
+        Result:=ReplaceTopOffsets(SrcCoordOffs);
+        if Result=mrOK then
+          Result:=AddNewProps(SrcNewProps);
       end;
     finally
-    ValueTreeNodes.Free;
+      SrcNewProps.Free;
-    ConvTool.Free;
+      SrcCoordOffs.Free;
+      FormFileTool.Free;
+    end;
   end;
 end;