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

codetools: lfm utility functions

Browse Source
This commit is contained in:
mattias 2025-08-12 16:51:02 +02:00
parent a0b66588f4
commit 9d84de61b6
2 changed files with 185 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
components/codetools/lfmtrees.pas
View File

@ -93,6 +93,7 @@ type
constructor CreateVirtual; override;
function GetFullName(UnitNameSep: char = '/'; WithName: boolean = true): string;
function GetIdentifier: string; override;
function GetPropertyPath: string;
end;
{ TLFMNameParts }
@ -123,6 +124,7 @@ type
destructor Destroy; override;
procedure Clear;
procedure Add(const Name: string; NamePosition: integer);
function GetPropertyPath: string;
end;
@ -144,7 +146,8 @@ type
public
ValueType: TLFMValueType;
constructor CreateVirtual; override;
function ReadString: string;
function ReadString: string; // for a string value
procedure ReadLines(List: TStrings);
end;
@ -315,7 +318,7 @@ type
function FirstErrorAsString: string;
function FindProperty(PropertyPath: string;
ContextNode: TLFMTreeNode): TLFMPropertyNode;
ContextNode: TLFMTreeNode = nil): TLFMPropertyNode;
function TokenIsSymbol(const s: Shortstring): boolean;
function TokenIsIdentifier(const s: Shortstring): boolean;
@ -372,7 +375,14 @@ const
'EndNotFound'
);
TLFMValueTypeNames: array[TLFMValueType] of string = (
LFMNodeTypeNames: array[TLFMNodeType] of string = (
'Object',
'Property',
'Value',
'Enum'
);
LFMValueTypeNames: array[TLFMValueType] of string = (
'None',
'Integer',
'Float',
@ -977,8 +987,11 @@ begin
begin
CreateChildNode(TLFMValueNodeList);
NextToken;
while FTokenChar <> ')' do
while FTokenChar <> ')' do begin
if FTokenKind<>ltkString then
ParseErrorExp('string');
ProcessValue;
end;
NextToken;
CloseChildNode;
end;
@ -1502,6 +1515,19 @@ begin
Result:=GetFullName;
end;
function TLFMObjectNode.GetPropertyPath: string;
var
Node: TLFMTreeNode;
begin
Result:=Name;
Node:=Parent;
while Node<>nil do begin
if Node is TLFMObjectNode then
Result:=TLFMObjectNode(Node).Name+'.'+Result;
Node:=Node.Parent;
end;
end;
{ TLFMPropertyNode }
constructor TLFMPropertyNode.CreateVirtual;
@ -1532,6 +1558,13 @@ begin
CompleteName:=Name;
end;
function TLFMPropertyNode.GetPropertyPath: string;
begin
Result:=CompleteName;
if Parent is TLFMObjectNode then
Result:=TLFMObjectNode(Parent).GetPropertyPath+'.'+Result;
end;
{ TLFMValueNode }
constructor TLFMValueNode.CreateVirtual;
@ -1542,30 +1575,62 @@ end;
function TLFMValueNode.ReadString: string;
var
p: LongInt;
Src: String;
i: integer;
AtomStart: LongInt;
p, StartP, i: integer;
begin
Result:='';
if ValueType<>lfmvString then exit;
p:=StartPos;
AtomStart:=p;
Src:=Tree.LFMBuffer.Source;
repeat
ReadRawNextPascalAtom(Src,p,AtomStart);
if AtomStart>length(Src) then exit;
if Src[AtomStart]='''' then begin
Result:=Result+copy(Src,AtomStart+1,p-AtomStart-2)
end else if Src[AtomStart]='+' then begin
// skip
end else if Src[AtomStart]='#' then begin
i:=StrToIntDef(copy(Src,AtomStart+1,p-AtomStart-1),-1);
if (i<0) or (i>255) then exit;
Result:=Result+chr(i);
end else
exit;
until false;
p:=StartPos;
while p<EndPos do begin
case Src[p] of
'''':
begin
inc(p);
StartP:=p;
repeat
if p=EndPos then exit; // error
if Src[p]='''' then break;
inc(p);
until false;
Result:=Result+copy(Src,StartP,p-StartP);
inc(p);
end;
'+':
inc(p); // one string broken into several lines
'#':
begin
i:=0;
inc(p);
while (p<EndPos) and (Src[p] in ['0'..'9']) do begin
i:=i*10 + ord(Src[p])-ord('0');
if i>255 then
exit; // error
inc(p);
end;
Result:=Result+chr(i);
end;
' ',#9,#10,#13: inc(p);
else
exit; // error
end;
end;
end;
procedure TLFMValueNode.ReadLines(List: TStrings);
var
Node: TLFMValueNode;
begin
if ValueType=lfmvString then
List.Add(ReadString)
else if ValueType=lfmvList then begin
Node:=FirstChild as TLFMValueNode;
while Node<>nil do begin
if Node.ValueType=lfmvString then
List.Add(Node.ReadString);
Node:=TLFMValueNode(Node.NextSibling);
end;
end;
end;
{ TLFMValueNodeSymbol }

161
components/codetools/tests/testlfmtrees.pas
View File

@ -16,6 +16,7 @@ type
private
FControlsCode: TCodeBuffer;
FLFMCode: TCodeBuffer;
FLFMTree: TLFMTree;
FUnitCode: TCodeBuffer;
FSources: TFPList; // list of TCodeBuffer
procedure CodeToolBossFindDefineProperty(Sender: TObject; const PersistentClassName,
@ -35,6 +36,8 @@ type
destructor Destroy; override;
procedure CheckLFM;
procedure CheckLFMExpectedError(ErrorType: TLFMErrorType; const CursorPos: TCodeXYPosition; ErrorMsg: string);
function CheckHasProperty(const PropertyPath: string): TLFMPropertyNode;
function CheckPropertyType(const PropertyPath: string; ValueType: TLFMValueType): TLFMValueNode;
procedure ParseLFM;
procedure WriteSource(const CursorPos: TCodeXYPosition);
property SourceCount: integer read GetSourceCount;
@ -42,6 +45,7 @@ type
property ControlsCode: TCodeBuffer read FControlsCode;
property UnitCode: TCodeBuffer read FUnitCode;
property LFMCode: TCodeBuffer read FLFMCode;
property LFMTree: TLFMTree read FLFMTree;
end;
{ TTestLFMTrees }
@ -93,6 +97,7 @@ procedure TCustomTestLFMTrees.SetUp;
begin
inherited SetUp;
CodeToolBoss.OnFindDefineProperty:=@CodeToolBossFindDefineProperty;
FLFMTree:=nil;
end;
procedure TCustomTestLFMTrees.TearDown;
@ -100,6 +105,7 @@ var
i: Integer;
Buf: TCodeBuffer;
begin
FreeAndNil(FLFMTree);
for i:=0 to FSources.Count-1 do begin
Buf:=Sources[i];
Buf.IsDeleted:=true;
@ -220,90 +226,107 @@ end;
procedure TCustomTestLFMTrees.CheckLFM;
var
LFMTree: TLFMTree;
LFMErr: TLFMError;
begin
LFMTree:=nil;
try
if CodeToolBoss.CheckLFM(UnitCode,LFMCode,LFMTree,true,true,true) then
exit;
WriteSource(CodeXYPosition(CodeToolBoss.ErrorColumn,CodeToolBoss.ErrorLine,CodeToolBoss.ErrorCode));
if LFMTree<>nil then begin
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
writeln('LFM Error: (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
LFMErr:=LFMErr.NextError;
end;
if CodeToolBoss.CheckLFM(UnitCode,LFMCode,FLFMTree,true,true,true) then
exit;
WriteSource(CodeXYPosition(CodeToolBoss.ErrorColumn,CodeToolBoss.ErrorLine,CodeToolBoss.ErrorCode));
if LFMTree<>nil then begin
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
writeln('LFM Error: (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
LFMErr:=LFMErr.NextError;
end;
Fail('CheckLFM error "'+CodeToolBoss.ErrorMessage+'"');
finally
LFMTree.Free;
end;
Fail('CheckLFM error "'+CodeToolBoss.ErrorMessage+'"');
end;
procedure TCustomTestLFMTrees.CheckLFMExpectedError(ErrorType: TLFMErrorType;
const CursorPos: TCodeXYPosition; ErrorMsg: string);
var
LFMTree: TLFMTree;
LFMErr: TLFMError;
begin
LFMTree:=nil;
try
if CodeToolBoss.CheckLFM(UnitCode,LFMCode,LFMTree,true,true,true) then begin
WriteSource(CursorPos);
Fail('TCustomTestLFMTrees.CheckLFMParseError Missing '+LFMErrorTypeNames[ErrorType]+': '+CursorPos.Code.Filename+'('+IntToStr(CursorPos.Y)+','+IntToStr(CursorPos.X)+'): '+ErrorMsg);
end;
if LFMTree=nil then begin
WriteSource(CursorPos);
Fail('missing LFMTree');
end;
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
//writeln('LFM Error: (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
if (CursorPos.Code=LFMErr.Source)
and (CursorPos.X=LFMErr.Caret.X)
and (CursorPos.Y=LFMErr.Caret.Y)
and (ErrorType=LFMErr.ErrorType)
and (LFMErr.ErrorMessage=ErrorMsg) then
begin
// error found
exit;
end;
LFMErr:=LFMErr.NextError;
end;
writeln('LFM Error Candidates:');
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
writeln('LFM-Error: ',LFMErr.ErrorType,': (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
LFMErr:=LFMErr.NextError;
end;
if CodeToolBoss.CheckLFM(UnitCode,LFMCode,FLFMTree,true,true,true) then begin
WriteSource(CursorPos);
Fail('TCustomTestLFMTrees.CheckLFMParseError Missing '+LFMErrorTypeNames[ErrorType]+': '+CursorPos.Code.Filename+'('+IntToStr(CursorPos.Y)+','+IntToStr(CursorPos.X)+'): '+ErrorMsg);
finally
LFMTree.Free;
end;
if LFMTree=nil then begin
WriteSource(CursorPos);
Fail('missing LFMTree');
end;
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
//writeln('LFM Error: (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
if (CursorPos.Code=LFMErr.Source)
and (CursorPos.X=LFMErr.Caret.X)
and (CursorPos.Y=LFMErr.Caret.Y)
and (ErrorType=LFMErr.ErrorType)
and (LFMErr.ErrorMessage=ErrorMsg) then
begin
// error found
exit;
end;
LFMErr:=LFMErr.NextError;
end;
writeln('LFM Error Candidates:');
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
writeln('LFM-Error: ',LFMErr.ErrorType,': (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
LFMErr:=LFMErr.NextError;
end;
Fail('TCustomTestLFMTrees.CheckLFMParseError Missing '+LFMErrorTypeNames[ErrorType]+': '+CursorPos.Code.Filename+'('+IntToStr(CursorPos.Y)+','+IntToStr(CursorPos.X)+'): '+ErrorMsg);
end;
function TCustomTestLFMTrees.CheckHasProperty(const PropertyPath: string): TLFMPropertyNode;
var
Node: TLFMTreeNode;
begin
if LFMTree=nil then
Fail('CheckHasNode Tree=nil PropertyPath="'+PropertyPath+'"');
Result:=LFMTree.FindProperty(PropertyPath);
if Result=nil then begin
debugln(['TCustomTestLFMTrees.CheckHasNode property candidates:']);
Node:=LFMTree.Root;
while Node<>nil do begin
if Node is TLFMPropertyNode then
debugln(' ',TLFMPropertyNode(Node).GetPropertyPath);
Node:=Node.Next;
end;
Fail('CheckHasNode missing PropertyPath="'+PropertyPath+'"');
end;
end;
function TCustomTestLFMTrees.CheckPropertyType(const PropertyPath: string; ValueType: TLFMValueType
): TLFMValueNode;
var
PropNode: TLFMPropertyNode;
begin
Result:=nil;
PropNode:=CheckHasProperty(PropertyPath);
if PropNode.FirstChild=nil then
Fail('Missing value node: "'+PropertyPath+'"');
if not (PropNode.FirstChild is TLFMValueNode) then
Fail('Expected value node "'+PropertyPath+'", but got '+PropNode.FirstChild.ClassName);
Result:=TLFMValueNode(PropNode.FirstChild);
if Result.ValueType<>ValueType then
Fail('Expected "'+PropertyPath+'" expected value type='+LFMValueTypeNames[ValueType]+', but found '+LFMValueTypeNames[Result.ValueType]);
end;
procedure TCustomTestLFMTrees.ParseLFM;
var
LFMTree: TLFMTree;
LFMErr: TLFMError;
begin
LFMTree:=nil;
try
if CodeToolBoss.ParseLFM(LFMCode,LFMTree) then exit;
WriteSource(CodeXYPosition(CodeToolBoss.ErrorColumn,CodeToolBoss.ErrorLine,CodeToolBoss.ErrorCode));
if LFMTree<>nil then begin
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
writeln('LFM Error: (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
LFMErr:=LFMErr.NextError;
end;
if CodeToolBoss.ParseLFM(LFMCode,FLFMTree) then exit;
WriteSource(CodeXYPosition(CodeToolBoss.ErrorColumn,CodeToolBoss.ErrorLine,CodeToolBoss.ErrorCode));
if LFMTree<>nil then begin
LFMErr:=LFMTree.FirstError;
while LFMErr<>nil do begin
writeln('LFM Error: (',LFMErr.Caret.Y,',',LFMErr.Caret.X,') ',LFMErr.ErrorMessage);
LFMErr:=LFMErr.NextError;
end;
Fail('CheckLFM error "'+CodeToolBoss.ErrorMessage+'"');
finally
LFMTree.Free;
end;
Fail('CheckLFM error "'+CodeToolBoss.ErrorMessage+'"');
end;
procedure TCustomTestLFMTrees.WriteSource(const CursorPos: TCodeXYPosition);
@ -466,7 +489,11 @@ begin
end;
procedure TTestLFMTrees.LFM_List;
var
Node, StrNode: TLFMValueNode;
begin
// Note: the TStrings.Lines is unknown to codetools
// test that at least the list is parsed, even though it cannot be resolved
AddControls;
AddFormUnit(['Button1: TButton']);
FLFMCode:=AddSource('unit1.lfm',LinesToStr([
@ -474,12 +501,18 @@ begin
' object Button1: TButton',
' Lines.Strings = (',
' ''Memo1''',
' ''Foo''',
' ''Foo''+',
' ''Bar''#10''ABC''',
' )',
' end',
'end'
]));
CheckLFM;
Node:=CheckPropertyType('Form1.Button1.Lines.Strings',lfmvList);
StrNode:=Node.FirstChild as TLFMValueNode;
AssertEquals('First Line','Memo1',StrNode.ReadString);
StrNode:=StrNode.NextSibling as TLFMValueNode;
AssertEquals('Second Line','FooBar'#10'ABC',StrNode.ReadString);
end;
procedure TTestLFMTrees.LFM_Collection;