paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-07 22:58:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@29346 -
This commit is contained in:
juha 2011-02-03 09:29:54 +00:00
parent 9d296783e5
commit e187934649
3 changed files with 99 additions and 358 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

317
converter/convcodetool.pas
View File

@ -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.

57
converter/convertertypes.pas
View File

@ -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 }
constructor EDelphiConverterError.Create(const AMessage: string);
begin
inherited Create('Converter: '+AMessage);
end;
{ TopOffset }
{ TSrcPropOffset }
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.

83
converter/missingpropertiesdlg.pas
View File

@ -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,15 +350,14 @@ 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.
for i := aSrcOffsets.Count-1 downto 0 do begin
for i:=aSrcOffsets.Count-1 downto 0 do begin
TopOffs:=TSrcPropOffset(aSrcOffsets[i]);
if fSettings.CoordOffsets.Find(TopOffs.ParentType, ind) then begin
VisOffs:=fSettings.CoordOffsets[ind];
@ -367,8 +369,7 @@ begin
except on EConvertError do
OldNum:=0;
end;
Ofs:=VisOffs.ByProperty(TopOffs.PropName);
NewNum:=OldNum-Ofs;
NewNum:=OldNum-VisOffs.ByProperty(TopOffs.PropName);
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,33 +480,44 @@ 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;
LoopCount:=0;
repeat
if CodeToolBoss.CheckLFM(fPascalBuffer,fLFMBuffer,fLFMTree,
fRootMustBeClassInUnit,fRootMustBeClassInIntf,fObjectsMustExists) then
Result:=mrOk
else // Rename/remove properties and types interactively.
Result:=ShowRepairLFMWizard; // Can return mrRetry.
Inc(LoopCount);
until (Result in [mrOK, mrCancel]) or (LoopCount=10);
// Show remaining errors to user.
WriteLFMErrors;
if (Result=mrOK) and (fSettings.CoordOffsMode=rsEnabled) then begin
// Fix top offsets of some components in visual containers
if ConvTool.CheckTopOffsets(fLFMBuffer, fLFMTree,
fSettings.CoordOffsets, ValueTreeNodes) then
Result:=ReplaceTopOffsets(ValueTreeNodes)
else
Result:=mrCancel;
end;
finally
ValueTreeNodes.Free;
ConvTool.Free;
end;
LoopCount:=0;
repeat
if CodeToolBoss.CheckLFM(fPascalBuffer,fLFMBuffer,fLFMTree,
fRootMustBeClassInUnit,fRootMustBeClassInIntf,fObjectsMustExists) then
Result:=mrOk
else // Rename/remove properties and types interactively.
Result:=ShowRepairLFMWizard; // Can return mrRetry.
Inc(LoopCount);
until (Result in [mrOK, mrCancel]) or (LoopCount=10);
// Show remaining errors to user.
WriteLFMErrors;
if (Result=mrOK) and (fSettings.CoordOffsMode=rsEnabled) then begin
// Fix top offsets of some components in visual containers
FormFileTool:=TFormFileConverter.Create(fCTLink, fLFMBuffer);
SrcCoordOffs:=TObjectList.Create;
SrcNewProps:=TObjectList.Create;
try
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
SrcNewProps.Free;
SrcCoordOffs.Free;
FormFileTool.Free;
end;
end;
end;