40
40
FPCAdds, TypInfo, DynQueue, LCLProc, LCLStrConsts, LazConfigStorage;
48
46
LRSComment = // do not translate this!
114
112
var LRSTranslator: TAbstractTranslator;
122
TLRSORStackItem = record
124
ItemType: TLRSItemType;
126
PushCount: integer; // waiting for this number of Pop
127
ItemNr: integer; // nr in a collection or list
129
PLRSORStackItem = ^TLRSORStackItem;
116
131
{ TLRSObjectReader }
118
133
TLRSObjectReader = class(TAbstractObjectReader)
122
137
FBufSize: Integer;
123
138
FBufPos: Integer;
124
139
FBufEnd: Integer;
140
FStack: PLRSORStackItem;
141
FStackPointer: integer;
142
FStackCapacity: integer;
125
144
procedure SkipProperty;
126
145
procedure SkipSetBody;
146
procedure Push(ItemType: TLRSItemType; const AName: string = '';
147
Root: TComponent = nil; PushCount: integer = 1);
149
procedure ClearStack;
150
function InternalReadValue: TValueType;
151
procedure EndPropertyIfOpen;
128
153
function ReadIntegerContent: integer;
136
161
procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
137
162
var CompClassName, CompName: String); override;
138
163
function BeginProperty: String; override;
164
function GetStackPath: string;
140
166
procedure Read(var Buf; Count: LongInt); override;
141
167
procedure ReadBinary(const DestData: TMemoryStream); override;
152
178
function ReadStr: String; override;
153
179
function ReadString(StringType: TValueType): String; override;
154
180
function ReadWideString: WideString; override;
156
181
function ReadUnicodeString: UnicodeString; override;
158
182
procedure SkipComponent(SkipComponentInfos: Boolean); override;
159
183
procedure SkipValue; override;
161
185
property Stream: TStream read FStream;
186
property Reader: TReader read FReader write FReader;
163
188
TLRSObjectReaderClass = class of TLRSObjectReader;
176
201
WriteEmptyInheritedChilds = false (default).
179
This allows to delete/rename controls in ancestors without the need
204
This allows one to delete/rename controls in ancestors without the need
180
205
to update all descendants.
211
238
FStackPointer: integer;
212
239
FStackCapacity: integer;
213
240
FWriteEmptyInheritedChilds: boolean;
214
function GetInstanceStack(Index: integer): TPersistent;
215
procedure Push(const AName: string = ''; Instance: TPersistent = nil;
216
PushCount: integer = 1; SkipIfEmpty: boolean = false);
242
procedure Push(ItemType: TLRSItemType; const AName: string = '';
243
Root: TComponent = nil; PushCount: integer = 1;
244
SkipIfEmpty: boolean = false);
217
245
procedure EndHeader;
218
246
procedure Pop(WriteNull: boolean);
219
247
procedure ClearStack;
248
276
procedure EndList; override;
249
277
procedure BeginProperty(const PropName: String); override;
250
278
procedure EndProperty; override;
251
function GetStackPath(Root: TComponent): string;
279
function GetStackPath: string;
253
281
procedure Write(const Buffer; Count: Longint); override;
254
282
procedure WriteBinary(const Buffer; Count: LongInt); override;
263
291
procedure WriteSet(Value: LongInt; SetType: Pointer); override;
264
292
procedure WriteString(const Value: String); override;
265
293
procedure WriteWideString(const Value: WideString); override;
267
294
procedure WriteUnicodeString(const Value: UnicodeString); override;
270
property InstanceStackPointer: integer read FStackPointer;
271
property InstanceStack[Index: integer]: TPersistent read GetInstanceStack;
272
296
property WriteEmptyInheritedChilds: boolean read FWriteEmptyInheritedChilds write FWriteEmptyInheritedChilds;
297
property Writer: TWriter read FWriter write FWriter;
274
299
TLRSObjectWriterClass = class of TLRSObjectWriter;
276
301
TLRPositionLink = record
277
302
LFMPosition: int64;
278
303
LRSPosition: int64;
363
390
function TokenSymbolIs(const S: string): Boolean;
364
391
property FloatType: Char read fFloatType;
365
392
property SourceLine: Integer read fSourceLine;
393
function SourceColumn: integer;
366
394
property Token: Char read fToken;
456
484
var RootComponent: TComponent;
457
485
OnFindComponentClass: TFindComponentClassEvent;
458
486
TheOwner: TComponent = nil;
459
Parent: TComponent = nil);
487
Parent: TComponent = nil;
488
ReaderRoot: TComponent = nil);
460
489
procedure WriteComponentAsTextToStream(AStream: TStream;
461
490
AComponent: TComponent);
462
491
procedure ReadComponentFromTextStream(AStream: TStream;
882
911
procedure ReadComponentFromBinaryStream(AStream: TStream;
883
912
var RootComponent: TComponent;
884
913
OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
914
Parent: TComponent; ReaderRoot: TComponent);
887
916
DestroyDriver: Boolean;
926
955
UniqueNamer:=TReaderUniqueNamer.Create;
927
956
Reader:=CreateLRSReader(AStream,DestroyDriver);
928
Reader.Root:=RootComponent;
957
if ReaderRoot = nil then
958
Reader.Root:=RootComponent
960
Reader.Root:=ReaderRoot;
929
961
Reader.Owner:=TheOwner;
930
962
Reader.Parent:=Parent;
931
963
Reader.OnFindComponentClass:=OnFindComponentClass;
1364
1395
LRSObjectTextToBinary(LFMStream,BinStream);
1365
1396
BinStream.Position:=0;
1366
BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName
1397
BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName,'FORMDATA');
1369
1399
BinStream.Free;
1540
1570
r1:=TLResource(FList[i]);
1541
1571
r2:=TLResource(FList[i+1]);
1542
1572
if (AnsiCompareText(r1.Name,r2.Name)=0) and (r1.ValueType=r2.ValueType) then
1543
1574
DebugLn(['TLResourceList.Sort ',i,' DUPLICATE RESOURCE FOUND: ',r1.Name,':',r1.ValueType]);
2292
2325
vaWString: Result:='vaWString';
2293
2326
vaInt64: Result:='vaInt64';
2294
2327
vaUTF8String: Result:='vaUTF8String';
2296
2328
vaUString: Result:='vaUString';
2297
2329
vaQWord : Result:='vaQWord';
2299
2330
else Result:='Unknown ValueType='+dbgs(Ord(ValueType));
2452
2483
ACurrency:=ReadLRSCurrency(Input);
2453
2484
OutLn(FloatToStr(ACurrency));
2455
vaWString{$IFNDEF VER2_2},vaUString{$ENDIF}: begin
2486
vaWString,vaUString: begin
2456
2487
AWideString:=ReadLRSWideString(Input);
2457
2488
OutWideString(AWideString);
2644
2675
Output.Write(s[1], Length(s));
2678
procedure WriteWideString(const s: WideString);
2680
WriteLRSInteger(Output,Length(s));
2681
if Length(s) > 0 then
2682
Output.Write(s[1], Length(s)*2);
2647
2685
procedure WriteInteger(value: LongInt);
2649
2687
if (value >= -128) and (value <= 127) then begin
2748
2786
WriteLRSExtended(Output,flt);
2749
2787
ParserNextToken;
2753
2791
toStringBuf := parser.TokenString;
2754
2792
//DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
2769
2807
WriteLongString(toStringBuf);
2812
toStringBuf := parser.TokenString;
2813
//DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
2814
while ParserNextToken = '+' do
2816
ParserNextToken; // Get next string fragment
2817
if not (parser.Token in [toString,toWString]) then
2818
parser.CheckToken(toString);
2819
toStringBuf := toStringBuf + parser.TokenString;
2821
Output.WriteByte(Ord(vaWString));
2822
WriteWideString(UTF8Decode(toStringBuf));
2774
2826
if CompareText(parser.TokenString, 'True') = 0 then
2883
2935
if parser.TokenSymbolIs('OBJECT') then
2884
2936
Flags :=0 { IsInherited := False }
2937
else if parser.TokenSymbolIs('INHERITED') then
2938
Flags := 1 { IsInherited := True; }
2886
if parser.TokenSymbolIs('INHERITED') then
2887
Flags := 1 { IsInherited := True; }
2889
parser.CheckTokenSymbol('INLINE');
2940
parser.CheckTokenSymbol('INLINE');
2893
2943
ParserNextToken;
2894
2944
parser.CheckToken(toSymbol);
2949
3001
OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
2950
3002
DefaultFormatSettings.ThousandSeparator:=',';
2952
Output.Write(FilerSignature[1], length(FilerSignature));
3006
Output.Write(FilerSignature[1], length(FilerSignature));
3009
until parser.TokenString='';
3011
Output.WriteByte(0); // Terminate object list
2956
3014
DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
3084
3142
Result.OnPropertyNotFound := @(PropertiesToSkip.DoPropertyNotFound);
3086
3144
DestroyDriver:=false;
3087
if Result.Driver.ClassType=LRSObjectReaderClass then exit;
3145
if Result.Driver.ClassType=LRSObjectReaderClass then
3147
TLRSObjectReader(Result.Driver).Reader:=Result;
3088
3150
// hack to set a write protected variable.
3089
3151
// DestroyDriver:=true; TReader will free it
3090
3152
Driver:=LRSObjectReaderClass.Create(s,4096);
3091
3153
p:=@Result.Driver;
3092
3154
Result.Driver.Free;
3093
3155
TAbstractObjectReader(p^):=Driver;
3156
TLRSObjectReader(Driver).Reader:=Result;
3096
3159
function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;
3100
3163
Driver:=LRSObjectWriterClass.Create(s,4096);
3101
3164
DestroyDriver:=true;
3102
3165
Result:=TWriter.Create(Driver);
3166
TLRSObjectWriter(Driver).Writer:=Result;
3105
3169
{ LRS format converter functions }
3749
3813
while Length(ReadStr) > 0 do;
3816
procedure TLRSObjectReader.Push(ItemType: TLRSItemType; const AName: string;
3817
Root: TComponent; PushCount: integer);
3819
if FStackPointer=FStackCapacity then begin
3820
FStackCapacity:=FStackCapacity*2+10;
3821
ReAllocMem(FStack,SizeOf(TLRSORStackItem)*FStackCapacity);
3822
FillByte(FStack[FStackPointer],SizeOf(TLRSORStackItem)*(FStackCapacity-FStackPointer),0);
3824
//DebugLn(['TLRSObjectReader.Push AName=',AName,' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount]);
3825
FStack[FStackPointer].Name:=AName;
3826
FStack[FStackPointer].ItemType:=ItemType;
3827
FStack[FStackPointer].Root:=Root;
3828
FStack[FStackPointer].PushCount:=PushCount;
3829
FStack[FStackPointer].ItemNr:=-1;
3833
procedure TLRSObjectReader.Pop;
3835
Item: PLRSORStackItem;
3837
if FStackPointer=0 then
3838
raise Exception.Create('Error: TLRSObjectReader.Pop stack is empty');
3839
Item:=@FStack[FStackPointer-1];
3840
//DebugLn(['TLRSObjectReader.Pop AName=',Item^.Name,
3841
// ' Type=',GetEnumName(TypeInfo(TLRSItemType), Integer(item^.ItemType)),
3842
// ' PushCount=',item^.PushCount,' StackPtr=', FStackPointer]);
3843
if Item^.PushCount>1 then begin
3844
// stack item still needs more EndList
3845
dec(Item^.PushCount);
3847
// stack item is complete
3852
procedure TLRSObjectReader.ClearStack;
3856
for i:=0 to FStackCapacity-1 do begin
3859
ReAllocMem(FStack,0);
3862
function TLRSObjectReader.InternalReadValue: TValueType;
3866
Result := vaNull; { Necessary in FPC as TValueType is larger than 1 byte! }
3868
Result:=TValueType(b);
3752
3871
function TLRSObjectReader.ReadIntegerContent: integer;
3775
3894
if Assigned(FBuffer) then
3776
3895
FreeMem(FBuffer, FBufSize);
3778
3899
inherited Destroy;
3781
3902
function TLRSObjectReader.ReadValue: TValueType;
3785
Result := vaNull; { Necessary in FPC as TValueType is larger than 1 byte! }
3787
Result:=TValueType(b);
3904
Result := InternalReadValue;
3909
// End previous element collection, list or component.
3910
if FStackPointer > 0 then
3915
Push(lrsitCollection);
3919
// Increase counter for next collection item.
3920
if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
3921
Inc(FStack[FStackPointer-1].ItemNr);
3790
3927
function TLRSObjectReader.NextValue: TValueType;
3792
Result := ReadValue;
3929
Result := InternalReadValue;
3793
3930
{ We only 'peek' at the next value, so seek back to unget the read value: }
3840
3979
CompClassName := ReadStr;
3841
3980
CompName := ReadStr;
3982
// Top component is addressed by ClassName.
3983
if FStackPointer = 0 then
3985
ItemName := CompClassName;
3990
ItemName := CompName;
3991
if Assigned(Reader) then
3992
// Reader.LookupRoot is the current Root component.
3993
ItemRoot := Reader.LookupRoot
3998
// A component has two lists: properties and childs, hence PopCount=2.
3999
Push(lrsitComponent, ItemName, ItemRoot, 2);
3844
4002
function TLRSObjectReader.BeginProperty: String;
3846
4005
Result := ReadStr;
4006
Push(lrsitProperty, Result);
4009
procedure TLRSObjectReader.EndPropertyIfOpen;
4011
// End previous property.
4012
if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitProperty) then
4016
function TLRSObjectReader.GetStackPath: string;
4020
Item: PLRSORStackItem;
4024
for i:=0 to FStackPointer-1 do
4028
// Reader.Root is the top component in the module.
4029
if Assigned(Reader) and
4030
(Item^.ItemType = lrsitComponent) and
4031
(Item^.Root = Reader.Root) and
4032
(Item^.Root <> nil) then
4034
// Restart path from top component.
4035
Result := Item^.Root.ClassName;
4038
CurName:=Item^.Name;
4039
if CurName<>'' then begin
4040
if Result<>'' then Result:=Result+'.';
4041
Result:=Result+CurName;
4043
if Item^.ItemNr >= 0 then
4044
Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
3849
4048
procedure TLRSObjectReader.ReadBinary(const DestData: TMemoryStream);
4104
4297
vaString, vaIdent:
4106
vaBinary, vaLString, vaWString{$IFNDEF VER2_2}, vaUString{$ENDIF}:
4299
vaBinary, vaLString:
4108
4301
Count:=ReadIntegerContent;
4109
4302
SkipBytes(Count);
4304
vaWString, vaUString:
4306
Count:=ReadIntegerContent;
4140
4338
{ TLRSObjectWriter }
4142
function TLRSObjectWriter.GetInstanceStack(Index: integer): TPersistent;
4144
Result:=FStack[Index].Instance;
4147
procedure TLRSObjectWriter.Push(const AName: string; Instance: TPersistent;
4148
PushCount: integer; SkipIfEmpty: boolean);
4340
procedure TLRSObjectWriter.Push(ItemType: TLRSItemType; const AName: string;
4341
Root: TComponent; PushCount: integer;
4342
SkipIfEmpty: boolean);
4150
4344
if FStackPointer=FStackCapacity then begin
4151
4345
FStackCapacity:=FStackCapacity*2+10;
4152
4346
ReAllocMem(FStack,SizeOf(TLRSOWStackItem)*FStackCapacity);
4153
4347
FillByte(FStack[FStackPointer],SizeOf(TLRSOWStackItem)*(FStackCapacity-FStackPointer),0);
4155
//if AName<>'' then DebugLn(['TLRSObjectWriter.Push AName=',AName,' Instance=',DbgsName(Instance),' PushCount=',PushCount,' SkipIfEmpty=',SkipIfEmpty]);
4349
//if AName<>'' then DebugLn(['TLRSObjectWriter.Push AName=',AName, ' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount,' SkipIfEmpty=',SkipIfEmpty]);
4156
4350
FStack[FStackPointer].Name:=AName;
4157
FStack[FStackPointer].Instance:=Instance;
4351
FStack[FStackPointer].ItemType:=ItemType;
4352
FStack[FStackPointer].Root:=Root;
4158
4353
FStack[FStackPointer].PushCount:=PushCount;
4354
FStack[FStackPointer].ItemNr:=-1;
4159
4355
FStack[FStackPointer].SkipIfEmpty:=SkipIfEmpty;
4160
4356
FStack[FStackPointer].BufCount:=0;
4161
4357
if SkipIfEmpty then
4462
4658
CanBeOmitted: boolean;
4660
ItemRoot: TComponent;
4464
4662
//DebugLn(['TLRSObjectWriter.BeginComponent ',FStackPointer]);
4465
4663
// an inherited child component can be omitted if empty
4466
4664
CanBeOmitted:=(not WriteEmptyInheritedChilds)
4467
4665
and (FStackPointer>0) and (ffInherited in Flags)
4468
4666
and (not (ffChildPos in Flags));
4469
// a component has two lists: properties and childs
4470
Push(Component.Name,Component,2,CanBeOmitted);
4668
// Top component is addressed by ClassName.
4669
if FStackPointer = 0 then
4671
ItemName := Component.ClassName;
4676
ItemName := Component.Name;
4677
if Assigned(Writer) then
4678
// Writer.Root is the current Root component.
4679
ItemRoot := Writer.Root
4684
// A component has two lists: properties and childs, hence PopCount=2.
4685
Push(lrsitComponent, ItemName, ItemRoot, 2, CanBeOmitted);
4472
4687
if not FSignatureWritten then
4499
4714
procedure TLRSObjectWriter.BeginList;
4716
// Increase counter for next collection item.
4717
if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
4718
Inc(FStack[FStackPointer-1].ItemNr);
4501
4719
//DebugLn(['TLRSObjectWriter.BeginList ',FStackPointer]);
4503
4721
WriteValue(vaList);
4508
4726
//DebugLn(['TLRSObjectWriter.EndList ',FStackPointer]);
4510
//WriteValue(vaNull);
4513
4730
procedure TLRSObjectWriter.BeginProperty(const PropName: String);
4515
4732
//DebugLn(['TLRSObjectWriter.BeginProperty ',FStackPointer,' ',PropName]);
4733
Push(lrsitProperty, PropName);
4517
4734
WriteStr(PropName);
4526
function TLRSObjectWriter.GetStackPath(Root: TComponent): string;
4743
function TLRSObjectWriter.GetStackPath: string;
4529
CurInstance: TPersistent;
4530
CurComponent: TComponent;
4531
4746
CurName: string;
4747
Item: PLRSOWStackItem;
4534
for i:=0 to FStackPointer-1 do begin
4535
CurInstance:=FStack[i].Instance;
4536
if (CurInstance is TComponent) and (Root<>nil) then begin
4537
CurComponent:=TComponent(CurInstance);
4538
if CurComponent=Root then begin
4539
Result:=CurComponent.ClassName;
4542
if CurComponent.Owner=Root then begin
4543
Result:=CurComponent.Owner.ClassName+'.'+CurComponent.Name;
4751
for i:=0 to FStackPointer-1 do
4755
// Writer.LookupRoot is the top component in the module.
4756
if Assigned(Writer) and
4757
(Item^.ItemType = lrsitComponent) and
4758
(Item^.Root = Writer.LookupRoot) and
4759
(Item^.Root <> nil) then
4761
// Restart path from top component.
4762
Result := Item^.Root.ClassName;
4547
CurName:=FStack[i].Name;
4765
CurName:=Item^.Name;
4548
4766
if CurName<>'' then begin
4549
4767
if Result<>'' then Result:=Result+'.';
4550
4768
Result:=Result+CurName;
4770
if Item^.ItemNr >= 0 then
4771
Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
4654
4874
tset = set of 0..31;
4661
4878
WriteValue(vaSet);
4665
4879
for i := 0 to 31 do
4668
4881
if (i in tset(Value)) then
4669
4882
WriteStr(GetEnumName(PTypeInfo(SetType), i));
4671
if (Value and Mask) <> 0 then
4672
WriteStr(GetEnumName(PTypeInfo(SetType), i));
4993
5199
ComponentSize, SizeLength: int64;
4994
5200
AStream: TMemoryStream;
4996
if not ReadComponentSize(ComponentSize,SizeLength) then exit(false);
4997
if (FQueue.Size-SizeLength<ComponentSize) then exit(false);
5203
if not ReadComponentSize(ComponentSize,SizeLength) then exit;
5204
if (FQueue.Size-SizeLength<ComponentSize) then exit;
4998
5205
// a complete component is in the buffer -> copy it to a stream
4999
5206
AStream:=TMemoryStream.Create;
5124
5332
procedure TUTF8Parser.LoadBuffer;
5125
var toread : integer;
5333
var newread : integer;
5127
toread:=fStream.Size-fStream.Position;
5128
if toread>ParseBufSize then toread:=ParseBufSize;
5134
fStream.ReadBuffer(fBuf[0],toread);
5136
inc(fDeltaPos,fPos);
5335
newread:=fStream.Read(fBuf[0],ParseBufSize);
5337
fLineStart:=fLineStart-fPos; // column = fPos - fLineStart + 1
5340
fEofReached:=newread=0;
5141
5343
procedure TUTF8Parser.CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5143
if fBuf[fPos]=#0 then LoadBuffer;
5345
if fBuf[fPos]<>#0 then exit;
5346
if fPos<fBufLen then begin
5350
if fBuf[fPos]<>#0 then exit;
5351
until (fPos=fBufLen);
5146
5356
procedure TUTF8Parser.ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5200
5410
CheckLoadBuffer;
5201
5411
if fBuf[fPos]=#10 then inc(fPos); //CR LF
5203
else inc(fPos); //LF
5204
5416
inc(fSourceLine);
5205
fDeltaPos:=-(fPos-1);
5208
5420
procedure TUTF8Parser.SkipSpaces;
5210
while fBuf[fPos] in [' ',#9] do
5422
while fBuf[fPos] in [' ',#9] do begin
5214
5428
procedure TUTF8Parser.SkipWhitespace;
5219
5432
case fBuf[fPos] of
5220
5433
' ',#9 : SkipSpaces;
5221
5434
#10,#13 : HandleNewLine
5428
5639
procedure TUTF8Parser.ErrorStr(const Message: string);
5430
raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,fPos+fDeltaPos,SourcePos]);
5641
debugln(['TUTF8Parser.ErrorStr Message="',Message,'" at y=',SourceLine,',x=',SourceColumn]);
5642
raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,SourceColumn,SourcePos]);
5433
5645
procedure TUTF8Parser.HexToBinary(Stream: TStream);
5529
5742
Result:=(fToken=toSymbol) and (CompareText(fLastTokenStr,S)=0);
5745
function TUTF8Parser.SourceColumn: integer;
5747
Result:=fPos-fLineStart+1;
5532
5750
//------------------------------------------------------------------------------
5533
5751
procedure InternalInit;