1{
2  Author: Mattias Gaertner
3
4 *****************************************************************************
5  This file is part of the Lazarus Component Library (LCL)
6
7  See the file COPYING.modifiedLGPL.txt, included in this distribution,
8  for details about the license.
9 *****************************************************************************
10
11  Abstract:
12    This unit maintains and stores all lazarus resources in the global list
13    named LazarusResources and provides methods and types to stream components.
14
15    A lazarus resource is an ansistring, with a name and a valuetype. Both, name
16    and valuetype, are ansistrings as well.
17    Lazarus resources are normally included via an include directive in the
18    initialization part of a unit. To create such include files use the
19    BinaryToLazarusResourceCode procedure.
20    To create a LRS file from an LFM file use the LFMtoLRSfile function which
21    transforms the LFM text to binary format and stores it as Lazarus resource
22    include file.
23}
24unit LResources;
25
26{$mode objfpc}{$H+}
27
28{ $DEFINE WideStringLenDoubled}
29
30interface
31
32uses
33  {$IFDEF Windows}
34  Windows,
35  {$ENDIF}
36  Classes, SysUtils, Types, RtlConsts, TypInfo, variants,
37  // LCL
38  LCLProc, LCLStrConsts,
39  // LazUtils
40  LazConfigStorage, FPCAdds, DynQueue, LazUTF8, LazUTF8Classes, LazLoggerBase;
41
42{$DEFINE UseLRS}
43{$DEFINE UseRES}
44
45const
46  LRSComment =  // do not translate this!
47    'This is an automatically generated lazarus resource file';
48type
49  TFilerSignature = array[1..4] of Char;
50
51
52  { TLResourceList }
53
54  TLResource = class
55  public
56    Name: AnsiString;
57    ValueType: AnsiString;
58    Value: AnsiString;
59  end;
60
61  TLResourceList = class(TObject)
62  private
63    FList: TList;  // main list with all resource pointers
64    FMergeList: TList; // list needed for mergesort
65    FSortedCount: integer; // 0 .. FSortedCount-1 resources are sorted
66    function FindPosition(const Name: AnsiString):integer;
67    function GetItems(Index: integer): TLResource;
68    procedure Sort;
69    procedure MergeSort(List, MergeList: TList; Pos1, Pos2: integer);
70    procedure Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer);
71  public
72    constructor Create;
73    destructor Destroy;  override;
74    procedure Add(const Name, ValueType, Value: AnsiString);
75    procedure Add(const Name, ValueType: AnsiString; const Values: array of string);
76    function Find(const Name: AnsiString): TLResource; overload;
77    function Find(const Name, ValueType: AnsiString): TLResource; overload;
78    function Count: integer;
79    property Items[Index: integer]: TLResource read GetItems;
80  end;
81
82  { TLazarusResourceStream }
83
84  TLazarusResourceStream = class(TCustomMemoryStream)
85  private
86    FLRes: TLResource;
87  {$ifdef UseRES}
88    FPRes: TFPResourceHGLOBAL;
89  {$endif}
90    procedure Initialize(Name, ResType: PChar);
91  public
92    constructor Create(const ResName: string; ResType: PChar);
93    constructor CreateFromID(ResID: Integer; ResType: PChar);
94    constructor CreateFromHandle(AHandle: TLResource); overload;
95  {$ifdef UseRES}
96    // here from FP resource handle
97    constructor CreateFromHandle(Instance: TFPResourceHMODULE; AHandle: TFPResourceHandle); overload;
98  {$endif}
99    destructor Destroy; override;
100    function Write(const Buffer; Count: Longint): Longint; override;
101    property Res: TLResource read FLRes;
102  end;
103
104  { TAbstractTranslator}
105  TAbstractTranslator = class(TObject)//Should it be somewhat more than TObject?
106  public
107    procedure TranslateStringProperty(Sender:TObject; const Instance: TPersistent; PropInfo: PPropInfo; var Content:string);virtual;abstract;
108   //seems like we need nothing more here
109  end;
110
111
112var LRSTranslator: TAbstractTranslator;
113
114type
115  TLRSItemType = (
116    lrsitCollection,
117    lrsitComponent,
118    lrsitList,
119    lrsitProperty
120  );
121
122  TLRSORStackItem = record
123    Name: string;
124    ItemType: TLRSItemType;
125    Root: TComponent;
126    PushCount: integer; // waiting for this number of Pop
127    ItemNr: integer; // nr in a collection or list
128  end;
129  PLRSORStackItem = ^TLRSORStackItem;
130
131  { TLRSObjectReader }
132
133  TLRSObjectReader = class(TAbstractObjectReader)
134  private
135    FStream: TStream;
136    FBuffer: Pointer;
137    FBufSize: Integer;
138    FBufPos: Integer;
139    FBufEnd: Integer;
140    FStack: PLRSORStackItem;
141    FStackPointer: integer;
142    FStackCapacity: integer;
143    FReader: TReader;
144    procedure SkipProperty;
145    procedure SkipSetBody;
146    procedure Push(ItemType: TLRSItemType; const AName: string = '';
147                   Root: TComponent = nil; PushCount: integer = 1);
148    procedure Pop;
149    procedure ClearStack;
150    function InternalReadValue: TValueType;
151    procedure EndPropertyIfOpen;
152  protected
153    function ReadIntegerContent: integer;
154  public
155    constructor Create(AStream: TStream; BufSize: Integer); virtual;
156    destructor Destroy; override;
157
158    function NextValue: TValueType; override;
159    function ReadValue: TValueType; override;
160    procedure BeginRootComponent; override;
161    procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
162      var CompClassName, CompName: String); override;
163    function BeginProperty: String; override;
164    function GetStackPath: string;
165
166    procedure Read(var Buf; Count: LongInt); override;
167    procedure ReadBinary(const DestData: TMemoryStream); override;
168    function ReadFloat: Extended; override;
169    function ReadSingle: Single; override;
170    function ReadCurrency: Currency; override;
171    function ReadDate: TDateTime; override;
172    function ReadIdent(ValueType: TValueType): String; override;
173    function ReadInt8: ShortInt; override;
174    function ReadInt16: SmallInt; override;
175    function ReadInt32: LongInt; override;
176    function ReadInt64: Int64; override;
177    function ReadSet(EnumType: Pointer): Integer; override;
178    {$IF FPC_FULLVERSION >= 30000}
179    procedure ReadSignature; override;
180    {$ENDIF}
181    function ReadStr: String; override;
182    function ReadString(StringType: TValueType): String; override;
183    function ReadWideString: WideString; override;
184    function ReadUnicodeString: UnicodeString; override;
185    procedure SkipComponent(SkipComponentInfos: Boolean); override;
186    procedure SkipValue; override;
187  public
188    property Stream: TStream read FStream;
189    property Reader: TReader read FReader write FReader;
190  end;
191  TLRSObjectReaderClass = class of TLRSObjectReader;
192
193  { TLRSOWStackItem
194    The TLRSObjectWriter can find empty entries and omit writing them to stream.
195    For example:
196        inline ConditionalOptionsFrame: TCompOptsConditionalsFrame
197          inherited COCTreeView: TTreeView
198          end
199          inherited COCPopupMenu: TPopupMenu
200          end
201        end
202
203    The empty inherited child components will not be written if
204      WriteEmptyInheritedChilds = false (default).
205
206    Reason:
207      This allows one to delete/rename controls in ancestors without the need
208      to update all descendants.
209  }
210
211  TLRSOWStackItemState = (
212    lrsowsisStarted,       // now writing header
213    lrsowsisHeaderWritten, // header saved on stack, not yet written to stream, waiting for data
214    lrsowsisDataWritten    // header written to stream, data written
215    );
216
217  TLRSOWStackItem = record
218    Name: string;
219    ItemType: TLRSItemType;
220    Root: TComponent;
221    PushCount: integer; // waiting for this number of Pop
222    ItemNr: integer; // nr in a collection or list
223    SkipIfEmpty: boolean;
224    State: TLRSOWStackItemState;
225    Buffer: Pointer;
226    BufCount: PtrInt;
227    BufCapacity: PtrInt;
228  end;
229  PLRSOWStackItem = ^TLRSOWStackItem;
230
231  { TLRSObjectWriter }
232
233  TLRSObjectWriter = class(TAbstractObjectWriter)
234  private
235    FStream: TStream;
236    FBuffer: Pointer;
237    FBufSize: Integer;
238    FBufPos: Integer;
239    FSignatureWritten: Boolean;
240    FStack: PLRSOWStackItem;
241    FStackPointer: integer;
242    FStackCapacity: integer;
243    FWriteEmptyInheritedChilds: boolean;
244    FWriter: TWriter;
245    procedure Push(ItemType: TLRSItemType; const AName: string = '';
246                   Root: TComponent = nil; PushCount: integer = 1;
247                   SkipIfEmpty: boolean = false);
248    procedure EndHeader;
249    procedure Pop(WriteNull: boolean);
250    procedure ClearStack;
251    procedure FlushStackToStream;
252    procedure WriteToStream(const Buffer; Count: Longint);
253  protected
254    procedure FlushBuffer;
255    procedure WriteValue(Value: TValueType);
256    procedure WriteStr(const Value: String);
257    procedure WriteIntegerContent(i: integer);
258    procedure WriteWordContent(w: word);
259    procedure WriteInt64Content(i: int64);
260    procedure WriteSingleContent(s: single);
261    procedure WriteDoubleContent(d: Double);
262    procedure WriteExtendedContent(e: Extended);
263    procedure WriteCurrencyContent(c: Currency);
264    procedure WriteWideStringContent(const ws: WideString);
265    procedure WriteWordsReversed(p: PWord; Count: integer);
266    procedure WriteNulls(Count: integer);
267  public
268    constructor Create(Stream: TStream; BufSize: Integer); virtual;
269    destructor Destroy; override;
270
271    { Begin/End markers. Those ones who don't have an end indicator, use
272      "EndList", after the occurrence named in the comment. Note that this
273      only counts for "EndList" calls on the same level; each BeginXXX call
274      increases the current level. }
275    procedure BeginCollection; override;{ Ends with the next "EndList" }
276    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
277      ChildPos: Integer); override; { Ends after the second "EndList" }
278    {$IF FPC_FULLVERSION >= 30000}
279    procedure WriteSignature; override;
280    {$ENDIF}
281    procedure BeginList; override;
282    procedure EndList; override;
283    procedure BeginProperty(const PropName: String); override;
284    procedure EndProperty; override;
285    function GetStackPath: string;
286
287    procedure Write(const Buffer; Count: Longint); override;
288    procedure WriteBinary(const Buffer; Count: LongInt); override;
289    procedure WriteBoolean(Value: Boolean); override;
290    procedure WriteFloat(const Value: Extended); override;
291    procedure WriteSingle(const Value: Single); override;
292    procedure WriteCurrency(const Value: Currency); override;
293    procedure WriteDate(const Value: TDateTime); override;
294    procedure WriteIdent(const Ident: string); override;
295    procedure WriteInteger(Value: Int64); override;
296    procedure WriteMethodName(const Name: String); override;
297    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
298    procedure WriteString(const Value: String); override;
299    procedure WriteWideString(const Value: WideString); override;
300    procedure WriteUnicodeString(const Value: UnicodeString); override;
301    procedure WriteVariant(const Value: Variant); override;
302
303    property WriteEmptyInheritedChilds: boolean read FWriteEmptyInheritedChilds write FWriteEmptyInheritedChilds;
304    property Writer: TWriter read FWriter write FWriter;
305  end;
306  TLRSObjectWriterClass = class of TLRSObjectWriter;
307
308  TLRPositionLink = record
309    LFMPosition: int64;
310    LRSPosition: int64;
311    Data: Pointer;
312  end;
313  PLRPositionLink = ^TLRPositionLink;
314
315  { TLRPositionLinks }
316
317  TLRPositionLinks = class
318  private
319    FItems: TFPList;
320    FCount: integer;
321    function GetData(Index: integer): Pointer;
322    function GetLFM(Index: integer): Int64;
323    function GetLRS(Index: integer): Int64;
324    procedure SetCount(const AValue: integer);
325    procedure SetData(Index: integer; const AValue: Pointer);
326    procedure SetLFM(Index: integer; const AValue: Int64);
327    procedure SetLRS(Index: integer; const AValue: Int64);
328  public
329    constructor Create;
330    destructor Destroy; override;
331    procedure Clear;
332    procedure Sort(LFMPositions: Boolean);
333    function IndexOf(const Position: int64; LFMPositions: Boolean): integer;
334    function IndexOfRange(const FromPos, ToPos: int64;
335                          LFMPositions: Boolean): integer;
336    procedure SetPosition(const FromPos, ToPos, MappedPos: int64;
337                          LFMtoLRSPositions: Boolean);
338    procedure Add(const LFMPos, LRSPos: Int64; AData: Pointer);
339  public
340    property LFM[Index: integer]: int64 read GetLFM write SetLFM;
341    property LRS[Index: integer]: int64 read GetLRS write SetLRS;
342    property Data[Index: integer]: Pointer read GetData write SetData;
343    property Count: integer read FCount write SetCount;
344  end;
345
346  { TUTF8Parser }
347
348  TUTF8Parser = class(TObject)
349  private
350    fStream : TStream;
351    fBuf : pchar;
352    fBufLen : integer; // read
353    fPos : integer;
354    fLineStart : integer; // column = fPos - fLineStart + 1
355    fFloatType : char;
356    fSourceLine : integer;
357    fToken : char;
358    fEofReached : boolean;
359    fLastTokenStr : string;
360    function GetTokenName(aTok : char) : string;
361    procedure LoadBuffer;
362    procedure CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
363    procedure ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
364    function IsNumber : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
365    function IsHexNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
366    function IsAlpha : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
367    function IsAlphaNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
368    function GetHexValue(c : char) : byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
369    function GetAlphaNum : string;
370    procedure HandleNewLine;
371    procedure SkipSpaces;
372    procedure SkipWhitespace;
373    procedure HandleEof;
374    procedure HandleAlphaNum;
375    procedure HandleNumber;
376    procedure HandleHexNumber;
377    function HandleQuotedString: string;
378    function HandleDecimalString: string;
379    procedure HandleString;
380    procedure HandleMinus;
381    procedure HandleUnknown;
382  public
383    constructor Create(Stream: TStream);
384    destructor Destroy; override;
385    procedure CheckToken(T: Char);
386    procedure CheckTokenSymbol(const S: string);
387    procedure Error(const Ident: string);
388    procedure ErrorFmt(const Ident: string; const Args: array of const);
389    procedure ErrorStr(const Message: string);
390    procedure HexToBinary(Stream: TStream);
391    function NextToken: Char;
392    function SourcePos: Longint;
393    function TokenComponentIdent: string;
394    function TokenFloat: Extended;
395    function TokenInt: Int64;
396    function TokenString: string;
397    function TokenSymbolIs(const S: string): Boolean;
398    property FloatType: Char read fFloatType;
399    property SourceLine: Integer read fSourceLine;
400    function SourceColumn: integer;
401    property Token: Char read fToken;
402  end;
403
404  { TCustomLazComponentQueue
405    A queue to stream components, used for multithreading or network.
406    The function ConvertComponentAsString converts a component to binary format
407    with a leading size information (using WriteLRSInt64MB).
408    When streaming components over network, they will arrive in chunks.
409    TCustomLazComponentQueue tells you, if a whole component has arrived and if
410    it has completely arrived. }
411  TCustomLazComponentQueue = class(TComponent)
412  private
413    FOnFindComponentClass: TFindComponentClassEvent;
414  protected
415    FQueue: TDynamicDataQueue;
416    function ReadComponentSize(out ComponentSize, SizeLength: int64): Boolean; virtual;
417  public
418    constructor Create(TheOwner: TComponent); override;
419    destructor Destroy; override;
420    procedure Clear;
421    function Write(const Buffer; Count: Longint): Longint;
422    function CopyFrom(AStream: TStream; Count: Longint): Longint;
423    function HasComponent: Boolean; virtual;
424    function ReadComponent(var AComponent: TComponent;
425                           NewOwner: TComponent = nil): Boolean; virtual;
426    function ConvertComponentAsString(AComponent: TComponent): string;
427    property OnFindComponentClass: TFindComponentClassEvent
428                         read FOnFindComponentClass write FOnFindComponentClass;
429  end;
430
431  { TLazComponentQueue }
432
433  TLazComponentQueue = class(TCustomLazComponentQueue)
434  published
435    property Name;
436    property OnFindComponentClass;
437  end;
438
439  TPropertyToSkip = record
440    PersistentClass: TPersistentClass;
441    PropertyName: String;
442    Note: String;
443    HelpKeyword: String;
444  end;
445  PRemovedProperty = ^TPropertyToSkip;
446
447  { TPropertyToSkipList }
448
449  TPropertiesToSkip = class(TList)
450  private
451    function GetItem(AIndex: Integer): PRemovedProperty;
452    procedure SetItem(AIndex: Integer; const AValue: PRemovedProperty);
453  protected
454    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
455    procedure DoPropertyNotFound(Reader: TReader; Instance: TPersistent;
456      var PropName: string; IsPath: boolean; var Handled, Skip: Boolean);
457  public
458    function IndexOf(AInstance: TPersistent; const APropertyName: String): Integer; overload;
459    function IndexOf(AClass: TPersistentClass; APropertyName: String): Integer; overload;
460    function Add(APersistentClass: TPersistentClass; const APropertyName, ANote,
461      AHelpKeyWord: string): Integer; reintroduce;
462    property Items[AIndex: Integer]: PRemovedProperty read GetItem write SetItem;
463  end;
464
465const
466  ObjStreamMaskInherited = 1;
467  ObjStreamMaskChildPos  = 2;
468  ObjStreamMaskInline    = 4;
469
470var
471  LazarusResources: TLResourceList;
472  PropertiesToSkip: TPropertiesToSkip = nil;
473
474  LRSObjectReaderClass: TLRSObjectReaderClass=TLRSObjectReader;
475  LRSObjectWriterClass: TLRSObjectWriterClass=TLRSObjectWriter;
476
477function InitResourceComponent(Instance: TComponent;
478  RootAncestor: TClass):Boolean;
479function InitLazResourceComponent(Instance: TComponent;
480                                  RootAncestor: TClass): Boolean;
481function CreateLRSReader(s: TStream; var DestroyDriver: boolean): TReader;
482function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;
483
484function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean): shortstring;
485procedure GetComponentInfoFromLRSStream(s: TStream;
486                                  out ComponentName, ComponentClassName: string;
487                                  out IsInherited: Boolean);
488procedure WriteComponentAsBinaryToStream(AStream: TStream;
489                                         AComponent: TComponent);
490procedure ReadComponentFromBinaryStream(AStream: TStream;
491                           var RootComponent: TComponent;
492                           OnFindComponentClass: TFindComponentClassEvent;
493                           TheOwner: TComponent = nil;
494                           Parent: TComponent = nil;
495                           ReaderRoot: TComponent = nil);
496procedure WriteComponentAsTextToStream(AStream: TStream;
497                                       AComponent: TComponent);
498procedure ReadComponentFromTextStream(AStream: TStream;
499                           var RootComponent: TComponent;
500                           OnFindComponentClass: TFindComponentClassEvent;
501                           TheOwner: TComponent = nil;
502                           Parent: TComponent = nil);
503procedure SaveComponentToConfig(Config: TConfigStorage; const Path: string;
504                                AComponent: TComponent);
505procedure LoadComponentFromConfig(Config: TConfigStorage; const Path: string;
506                                 var RootComponent: TComponent;
507                                 OnFindComponentClass: TFindComponentClassEvent;
508                                 TheOwner: TComponent = nil;
509                                 Parent: TComponent = nil);
510
511
512function CompareComponents(Component1, Component2: TComponent): boolean;
513function CompareMemStreams(Stream1, Stream2: TCustomMemoryStream): boolean;
514
515procedure BinaryToLazarusResourceCode(BinStream, ResStream: TStream;
516  const ResourceName, ResourceType: String);
517function LFMtoLRSfile(const LFMfilename: string): boolean;// true on success
518function LFMtoLRSstream(LFMStream, LRSStream: TStream): boolean;// true on success
519function FindLFMClassName(LFMStream: TStream):AnsiString;
520procedure ReadLFMHeader(LFMStream: TStream;
521                        out LFMType, LFMComponentName, LFMClassName: String);
522procedure ReadLFMHeader(const LFMSource: string;
523                        out LFMClassName: String; out LFMType: String);
524procedure ReadLFMHeader(const LFMSource: string;
525                        out LFMType, LFMComponentName, LFMClassName: String);
526function ReadLFMHeaderFromFile(const Filename: string;
527                  out LFMType, LFMComponentName, LFMClassName: String): boolean;
528function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer;
529
530type
531  TLRSStreamOriginalFormat = (sofUnknown, sofBinary, sofText);
532
533procedure LRSObjectBinaryToText(Input, Output: TStream); // binary to lfm
534procedure LRSObjectTextToBinary(Input, Output: TStream;  // lfm to binary
535                                Links: TLRPositionLinks = nil);
536procedure LRSObjectToText(Input, Output: TStream;
537  var OriginalFormat: TLRSStreamOriginalFormat);
538
539procedure LRSObjectResourceToText(Input, Output: TStream); // lrs to lfm
540procedure LRSObjectResToText(Input, Output: TStream;
541  var OriginalFormat: TLRSStreamOriginalFormat);
542
543function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat;
544procedure FormDataToText(FormStream, TextStream: TStream;
545  aFormat: TLRSStreamOriginalFormat = sofUnknown);
546
547function FindResourceLFM(ResName: string): HRSRC;
548
549procedure DefineRectProperty(Filer: TFiler; const Name: string;
550                             ARect, DefaultRect: PRect);
551
552procedure ReverseBytes(p: Pointer; Count: integer);
553procedure ReverseByteOrderInWords(p: PWord; Count: integer);
554function ConvertLRSExtendedToDouble(p: Pointer): Double;
555procedure ConvertEndianBigDoubleToLRSExtended(BigEndianDouble,
556                                              LRSExtended: Pointer);
557
558procedure ConvertLEDoubleToLRSExtended(LEDouble, LRSExtended: Pointer);
559
560
561function ReadLRSShortInt(s: TStream): shortint;
562function ReadLRSByte(s: TStream): byte;
563function ReadLRSSmallInt(s: TStream): smallint;
564function ReadLRSWord(s: TStream): word;
565function ReadLRSInteger(s: TStream): integer;
566function ReadLRSCardinal(s: TStream): cardinal;
567function ReadLRSInt64(s: TStream): int64;
568function ReadLRSSingle(s: TStream): Single;
569function ReadLRSDouble(s: TStream): Double;
570function ReadLRSExtended(s: TStream): Extended;
571function ReadLRSCurrency(s: TStream): Currency;
572function ReadLRSWideString(s: TStream): WideString;
573function ReadLRSEndianLittleExtendedAsDouble(s: TStream): Double;
574function ReadLRSValueType(s: TStream): TValueType;
575function ReadLRSInt64MB(s: TStream): int64;// multibyte
576
577procedure WriteLRSSmallInt(s: TStream; const i: smallint);
578procedure WriteLRSWord(s: TStream; const w: word);
579procedure WriteLRSInteger(s: TStream; const i: integer);
580procedure WriteLRSCardinal(s: TStream; const c: cardinal);
581procedure WriteLRSSingle(s: TStream; const si: Single);
582procedure WriteLRSDouble(s: TStream; const d: Double);
583procedure WriteLRSExtended(s: TStream; const e: extended);
584procedure WriteLRSInt64(s: TStream; const i: int64);
585procedure WriteLRSCurrency(s: TStream; const c: Currency);
586procedure WriteLRSWideStringContent(s: TStream; const w: WideString);
587procedure WriteLRSInt64MB(s: TStream; const Value: int64);// multibyte
588
589procedure WriteLRSReversedWord(s: TStream; w: word);
590procedure WriteLRS4BytesReversed(s: TStream; p: Pointer);
591procedure WriteLRS8BytesReversed(s: TStream; p: Pointer);
592procedure WriteLRS10BytesReversed(s: TStream; p: Pointer);
593procedure WriteLRSNull(s: TStream; Count: integer);
594procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream;
595  EndBigDouble: PByte);
596procedure WriteLRSDoubleAsExtended(s: TStream; ADouble: PByte);
597procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer);
598
599function FloatToLFMStr(const Value: extended; Precision, Digits: Integer
600                       ): string;
601
602function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer;
603function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer;
604
605procedure RegisterPropertyToSkip(PersistentClass: TPersistentClass;
606  const PropertyName, Note, HelpKeyWord: string);
607
608procedure Register;
609
610implementation
611
612const
613  LineEnd: ShortString = LineEnding;
614
615var
616  ByteToStr: array[char] of shortstring;
617  ByteToStrValid: boolean=false;
618
619type
620
621  { TDefineRectPropertyClass }
622
623  TDefineRectPropertyClass = class
624  public
625    Value: PRect;
626    DefaultValue: PRect;
627    constructor Create(AValue, ADefaultRect: PRect);
628    procedure ReadData(Reader: TReader);
629    procedure WriteData(Writer: TWriter);
630    function HasData: Boolean;
631  end;
632
633  { TReaderUniqueNamer - dummy class, used by the reader functions to rename
634    components, that are read from a stream, on the fly. }
635
636  TReaderUniqueNamer = class
637    procedure OnSetName(Reader: TReader; Component: TComponent;
638                        var Name: string);
639  end;
640
641{ TPropertiesToSkip }
642
643function TPropertiesToSkip.GetItem(AIndex: Integer): PRemovedProperty;
644begin
645  Result := inherited Get(AIndex);
646end;
647
648procedure TPropertiesToSkip.SetItem(AIndex: Integer;
649  const AValue: PRemovedProperty);
650begin
651  inherited Put(AIndex, AValue);
652end;
653
654procedure TPropertiesToSkip.Notify(Ptr: Pointer; Action: TListNotification);
655begin
656  if Action = lnDeleted then
657    Dispose(PRemovedProperty(Ptr))
658  else
659    inherited Notify(Ptr, Action);
660end;
661
662procedure TPropertiesToSkip.DoPropertyNotFound(Reader: TReader; Instance: TPersistent;
663  var PropName: string; IsPath: boolean; var Handled, Skip: Boolean);
664begin
665  Skip := IndexOf(Instance, PropName) >= 0;
666  Handled := Skip;
667end;
668
669function TPropertiesToSkip.IndexOf(AInstance: TPersistent;
670  const APropertyName: String): Integer;
671begin
672  if AInstance <> nil then
673    Result := IndexOf(TPersistentClass(AInstance.ClassType), APropertyName)
674  else
675    Result := -1;
676end;
677
678function TPropertiesToSkip.IndexOf(AClass: TPersistentClass;
679  APropertyName: String): Integer;
680var
681  PropertyInfo: PRemovedProperty;
682begin
683  APropertyName := LowerCase(APropertyName);
684  Result := Count - 1;
685  while Result >= 0 do
686  begin
687    PropertyInfo := Items[Result];
688    if AClass.InheritsFrom(PropertyInfo^.PersistentClass) and
689       (APropertyName = PropertyInfo^.PropertyName) then
690    begin
691      Exit;
692    end;
693    Dec(Result);
694  end;
695  Result := -1;
696end;
697
698function TPropertiesToSkip.Add(APersistentClass: TPersistentClass;
699  const APropertyName, ANote, AHelpKeyWord: string): Integer;
700var
701  Item: PRemovedProperty;
702begin
703  Result := IndexOf(APersistentClass, APropertyName);
704  if Result = -1 then
705  begin
706    New(Item);
707    Item^.PersistentClass := APersistentClass;
708    Item^.PropertyName := LowerCase(APropertyName);
709    Item^.Note := ANote;
710    Item^.HelpKeyword := AHelpKeyWord;
711    Result := inherited Add(Item);
712  end;
713end;
714
715{ TReaderUniqueNamer }
716
717procedure TReaderUniqueNamer.OnSetName(Reader: TReader; Component: TComponent;
718  var Name: string);
719
720  procedure MakeValidIdentifier;
721  var
722    i: Integer;
723  begin
724    for i:=length(Name) downto 1 do
725      if not (Name[i] in ['0'..'9','_','a'..'z','A'..'Z']) then
726        System.Delete(Name,i,1);
727    if (Name<>'') and (Name[1] in ['0'..'9']) then
728      Name:='_'+Name;
729  end;
730
731  function NameIsUnique: Boolean;
732  var
733    Owner: TComponent;
734    i: Integer;
735    CurComponent: TComponent;
736  begin
737    Result:=true;
738    if Name='' then exit;
739    Owner:=Component.Owner;
740    if Owner=nil then exit;
741    for i:=0 to Owner.ComponentCount-1 do begin
742      CurComponent:=Owner.Components[i];
743      if CurComponent=Component then continue;
744      if CompareText(CurComponent.Name,Name)=0 then exit(false);
745    end;
746  end;
747
748begin
749  MakeValidIdentifier;
750  while not NameIsUnique do
751    Name:=CreateNextIdentifier(Name);
752end;
753
754{ TDefineRectPropertyClass }
755
756constructor TDefineRectPropertyClass.Create(AValue, ADefaultRect: PRect);
757begin
758  Value:=AValue;
759  DefaultValue:=ADefaultRect;
760end;
761
762procedure TDefineRectPropertyClass.ReadData(Reader: TReader);
763begin
764  with Reader do begin
765    ReadListBegin;
766    Value^.Left:=ReadInteger;
767    Value^.Top:=ReadInteger;
768    Value^.Right:=ReadInteger;
769    Value^.Bottom:=ReadInteger;
770    ReadListEnd;
771  end;
772end;
773
774procedure TDefineRectPropertyClass.WriteData(Writer: TWriter);
775begin
776  with Writer do begin
777    WriteListBegin;
778    WriteInteger(Value^.Left);
779    WriteInteger(Value^.Top);
780    WriteInteger(Value^.Right);
781    WriteInteger(Value^.Bottom);
782    WriteListEnd;
783  end;
784end;
785
786function TDefineRectPropertyClass.HasData: Boolean;
787begin
788  if DefaultValue<>nil then begin
789    Result:=(DefaultValue^.Left<>Value^.Left)
790         or (DefaultValue^.Top<>Value^.Top)
791         or (DefaultValue^.Right<>Value^.Right)
792         or (DefaultValue^.Bottom<>Value^.Bottom);
793  end else begin
794    Result:=(Value^.Left<>0)
795         or (Value^.Top<>0)
796         or (Value^.Right<>0)
797         or (Value^.Bottom<>0);
798  end;
799end;
800
801function InitResourceComponent(Instance: TComponent;
802  RootAncestor: TClass):Boolean;
803begin
804  Result := InitLazResourceComponent(Instance, RootAncestor);
805end;
806
807function FindResourceLFM(ResName: string): HRSRC;
808{$if defined(WinCE)}
809//function FindResourceLFM(ResName: string): HRSRC;
810//{$if (FPC_FULLVERSION>=20605) and defined(WinCE)}
811var
812  u: UnicodeString;
813begin
814  u:=ResName;
815  Result := FindResource(HInstance,PWideChar(u),Windows.RT_RCDATA);
816end;
817{$else}
818begin
819  Result := FindResource(HInstance,PChar(ResName),
820    {$if (FPC_FULLVERSION>=20701) and defined(Windows)}Windows.{$endif}RT_RCDATA);
821end;
822{$endif}
823
824procedure DefineRectProperty(Filer: TFiler; const Name: string; ARect,
825  DefaultRect: PRect);
826var
827  PropDef: TDefineRectPropertyClass;
828begin
829  PropDef := TDefineRectPropertyClass.Create(ARect, DefaultRect);
830  try
831    Filer.DefineProperty(Name,@PropDef.ReadData,@PropDef.WriteData,PropDef.HasData);
832  finally
833    PropDef.Free;
834  end;
835end;
836
837procedure InitByteToStr;
838var
839  c: Char;
840begin
841  if ByteToStrValid then exit;
842  for c:=Low(char) to High(char) do
843    ByteToStr[c]:=IntToStr(ord(c));
844  ByteToStrValid:=true;
845end;
846
847function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean
848  ): shortstring;
849var
850  Signature: TFilerSignature;
851  NameLen: byte;
852  OldPosition: Int64;
853begin
854  Result:='';
855  OldPosition:=s.Position;
856  // read signature
857  Signature:='1234';
858  s.Read(Signature[1],length(Signature));
859  if Signature<>FilerSignature then exit;
860  // read classname length
861  NameLen:=0;
862  s.Read(NameLen,1);
863  if (NameLen and $f0) = $f0 then begin
864    // this was the Flag Byte
865    IsInherited := (NameLen and ObjStreamMaskInherited) <> 0;
866    // read namelen
867    s.Read(NameLen,1);
868  end else
869    IsInherited := False;
870  // read classname
871  if NameLen>0 then begin
872    SetLength(Result,NameLen);
873    s.Read(Result[1],NameLen);
874  end;
875  s.Position:=OldPosition;
876end;
877
878procedure GetComponentInfoFromLRSStream(s: TStream; out ComponentName,
879  ComponentClassName: string; out IsInherited: Boolean);
880var
881  Signature: TFilerSignature;
882  NameLen: byte;
883  OldPosition: Int64;
884  Flag: Byte;
885begin
886  ComponentName:='';
887  ComponentClassName:='';
888  OldPosition:=s.Position;
889  // read signature
890  Signature:='1234';
891  s.Read(Signature[1],length(Signature));
892  if Signature<>FilerSignature then exit;
893  // read classname length
894  NameLen:=0;
895  s.Read(NameLen,1);
896  if (NameLen and $f0) = $f0 then begin
897    // Read Flag Byte
898    Flag:=NameLen;
899    IsInherited := (Flag and ObjStreamMaskInherited) <> 0;
900    s.Read(NameLen,1);
901  end else
902    IsInherited := False;
903  // read classname
904  if NameLen>0 then begin
905    SetLength(ComponentClassName,NameLen);
906    s.Read(ComponentClassName[1],NameLen);
907  end;
908  // read component name length
909  NameLen:=0;
910  s.Read(NameLen,1);
911  // read componentname
912  if NameLen>0 then begin
913    SetLength(ComponentName,NameLen);
914    s.Read(ComponentName[1],NameLen);
915  end;
916  s.Position:=OldPosition;
917end;
918
919procedure WriteComponentAsBinaryToStream(AStream: TStream;
920  AComponent: TComponent);
921var
922  Writer: TWriter;
923  DestroyDriver: Boolean;
924begin
925  DestroyDriver:=false;
926  Writer:=nil;
927  try
928    Writer:=CreateLRSWriter(AStream,DestroyDriver);
929    Writer.WriteDescendent(AComponent,nil);
930  finally
931    if DestroyDriver then
932      Writer.Driver.Free;
933    Writer.Free;
934  end;
935end;
936
937procedure ReadComponentFromBinaryStream(AStream: TStream;
938  var RootComponent: TComponent;
939  OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
940  Parent: TComponent; ReaderRoot: TComponent);
941var
942  DestroyDriver: Boolean;
943  Reader: TReader;
944  IsInherited: Boolean;
945  AClassName: String;
946  AClass: TComponentClass;
947  UniqueNamer: TReaderUniqueNamer;
948begin
949  // get root class
950  AClassName:=GetClassNameFromLRSStream(AStream,IsInherited);
951  if IsInherited then begin
952    // inherited is not supported by this simple function
953    {$IFNDEF DisableChecks}
954    DebugLn('ReadComponentFromBinaryStream WARNING: "inherited" is not supported by this simple function');
955    {$ENDIF}
956  end;
957  AClass:=nil;
958  OnFindComponentClass(nil,AClassName,AClass);
959  if AClass=nil then
960    raise EClassNotFound.CreateFmt('Class "%s" not found', [AClassName]);
961
962  if RootComponent=nil then begin
963    // create root component
964    // first create the new instance and set the variable ...
965    RootComponent:=AClass.NewInstance as TComponent;
966    // then call the constructor
967    RootComponent.Create(TheOwner);
968  end else begin
969    // there is a root component, check if class is compatible
970    if not RootComponent.InheritsFrom(AClass) then begin
971      raise EComponentError.CreateFmt('Cannot assign a %s to a %s.',
972                                      [AClassName,RootComponent.ClassName]);
973    end;
974  end;
975
976  // read the root component
977  DestroyDriver:=false;
978  Reader:=nil;
979  UniqueNamer:=nil;
980  try
981    UniqueNamer:=TReaderUniqueNamer.Create;
982    Reader:=CreateLRSReader(AStream,DestroyDriver);
983    if ReaderRoot = nil then
984      Reader.Root:=RootComponent
985    else
986      Reader.Root:=ReaderRoot;
987    Reader.Owner:=TheOwner;
988    Reader.Parent:=Parent;
989    Reader.OnFindComponentClass:=OnFindComponentClass;
990    Reader.OnSetName:=@UniqueNamer.OnSetName;
991    Reader.BeginReferences;
992    try
993      Reader.Driver.BeginRootComponent;
994      RootComponent:=Reader.ReadComponent(RootComponent);
995      Reader.FixupReferences;
996    finally
997      Reader.EndReferences;
998    end;
999  finally
1000    if DestroyDriver then
1001      Reader.Driver.Free;
1002    UniqueNamer.Free;
1003    Reader.Free;
1004  end;
1005end;
1006
1007procedure WriteComponentAsTextToStream(AStream: TStream; AComponent: TComponent);
1008var
1009  BinStream: TMemoryStream;
1010begin
1011  BinStream:=nil;
1012  try
1013    BinStream:=TMemoryStream.Create;
1014    WriteComponentAsBinaryToStream(BinStream,AComponent);
1015    BinStream.Position:=0;
1016    LRSObjectBinaryToText(BinStream,AStream);
1017  finally
1018    BinStream.Free;
1019  end;
1020end;
1021
1022procedure ReadComponentFromTextStream(AStream: TStream;
1023  var RootComponent: TComponent;
1024  OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
1025  Parent: TComponent);
1026var
1027  BinStream: TMemoryStream;
1028begin
1029  BinStream:=nil;
1030  try
1031    BinStream:=TMemoryStream.Create;
1032    LRSObjectTextToBinary(AStream,BinStream);
1033    BinStream.Position:=0;
1034    ReadComponentFromBinaryStream(BinStream,RootComponent,OnFindComponentClass,
1035                                  TheOwner,Parent);
1036  finally
1037    BinStream.Free;
1038  end;
1039end;
1040
1041procedure SaveComponentToConfig(Config: TConfigStorage; const Path: string;
1042  AComponent: TComponent);
1043var
1044  BinStream: TMemoryStream;
1045  TxtStream: TMemoryStream;
1046  s: string;
1047begin
1048  BinStream:=nil;
1049  TxtStream:=nil;
1050  try
1051    // write component to stream
1052    BinStream:=TMemoryStream.Create;
1053    WriteComponentAsBinaryToStream(BinStream,AComponent);
1054    // convert it to human readable text format
1055    BinStream.Position:=0;
1056    TxtStream:=TMemoryStream.Create;
1057    LRSObjectBinaryToText(BinStream,TxtStream);
1058    // convert stream to string
1059    SetLength(s,TxtStream.Size);
1060    TxtStream.Position:=0;
1061    if s<>'' then
1062      TxtStream.Read(s[1],length(s));
1063    // write to config
1064    Config.SetDeleteValue(Path,s,'');
1065  finally
1066    BinStream.Free;
1067    TxtStream.Free;
1068  end;
1069end;
1070
1071procedure LoadComponentFromConfig(Config: TConfigStorage; const Path: string;
1072  var RootComponent: TComponent;
1073  OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
1074  Parent: TComponent);
1075var
1076  s: String;
1077  TxtStream: TMemoryStream;
1078begin
1079  // read from config
1080  s:=Config.GetValue(Path,'');
1081  TxtStream:=nil;
1082  try
1083    TxtStream:=TMemoryStream.Create;
1084    if s<>'' then
1085      TxtStream.Write(s[1],length(s));
1086    TxtStream.Position:=0;
1087    // create component from stream
1088    ReadComponentFromTextStream(TxtStream,RootComponent,OnFindComponentClass,
1089                                TheOwner,Parent);
1090  finally
1091    TxtStream.Free;
1092  end;
1093end;
1094
1095function CompareComponents(Component1, Component2: TComponent): boolean;
1096var
1097  Stream1: TMemoryStream;
1098  Stream2: TMemoryStream;
1099  i: Integer;
1100begin
1101  if Component1=Component2 then exit(true);
1102  Result:=false;
1103  // quick checks
1104  if (Component1=nil) or (Component2=nil) then exit;
1105  if (Component1.ClassType<>Component2.ClassType) then exit;
1106  if Component1.ComponentCount<>Component2.ComponentCount then exit;
1107  for i:=0 to Component1.ComponentCount-1 do begin
1108    if Component1.Components[i].ClassType<>Component2.Components[i].ClassType
1109    then exit;
1110  end;
1111  // expensive streaming test
1112  try
1113    Stream1:=nil;
1114    Stream2:=nil;
1115    try
1116      Stream1:=TMemoryStream.Create;
1117      WriteComponentAsBinaryToStream(Stream1,Component1);
1118      Stream2:=TMemoryStream.Create;
1119      WriteComponentAsBinaryToStream(Stream2,Component2);
1120      Result:=CompareMemStreams(Stream1,Stream2);
1121    finally
1122      Stream1.Free;
1123      Stream2.Free;
1124    end;
1125  except
1126  end;
1127end;
1128
1129function CompareMemStreams(Stream1, Stream2: TCustomMemoryStream
1130  ): boolean;
1131var
1132  p1: Pointer;
1133  p2: Pointer;
1134  Cnt: Int64;
1135  CurCnt: cardinal;
1136begin
1137  if Stream1=Stream2 then exit(true);
1138  Result:=false;
1139  if (Stream1=nil) or (Stream2=nil) then exit;
1140  if Stream1.Size<>Stream2.Size then exit;
1141  Cnt:=Stream1.Size;
1142  p1:=Stream1.Memory;
1143  p2:=Stream2.Memory;
1144  while Cnt>0 do begin
1145    CurCnt:=Cnt;
1146    if CurCnt>=High(Cardinal) then CurCnt:=High(Cardinal);
1147    if not CompareMem(p1,p2,CurCnt) then exit;
1148    inc(p1,CurCnt);
1149    inc(p2,CurCnt);
1150    dec(Cnt,CurCnt);
1151  end;
1152  Result:=true;
1153end;
1154
1155procedure BinaryToLazarusResourceCode(BinStream,ResStream:TStream;
1156  const ResourceName, ResourceType: String);
1157{ example ResStream:
1158  LazarusResources.Add('ResourceName','ResourceType',
1159    #123#45#34#78#18#72#45#34#78#18#72#72##45#34#78#45#34#78#184#34#78#145#34#78
1160    +#83#187#6#78#83
1161  );
1162}
1163const
1164  ReadBufSize = 4096;
1165  WriteBufSize = 4096;
1166var
1167  s, Indent: string;
1168  x: integer;
1169  c: char;
1170  RangeString, NewRangeString: boolean;
1171  RightMargin, CurLine: integer;
1172  WriteBufStart, Writebuf: PChar;
1173  WriteBufPos: Integer;
1174  ReadBufStart, ReadBuf: PChar;
1175  ReadBufPos, ReadBufLen: integer;
1176  MinCharCount: Integer;
1177
1178  procedure FillReadBuf;
1179  begin
1180    ReadBuf:=ReadBufStart;
1181    ReadBufPos:=0;
1182    ReadBufLen:=BinStream.Read(ReadBuf^,ReadBufSize);
1183  end;
1184
1185  procedure InitReadBuf;
1186  begin
1187    GetMem(ReadBufStart,ReadBufSize);
1188    FillReadBuf;
1189  end;
1190
1191  function ReadChar(var c: char): boolean;
1192  begin
1193    if ReadBufPos>=ReadBufLen then begin
1194      FillReadBuf;
1195      if ReadBufLen=0 then begin
1196        Result:=false;
1197        exit;
1198      end;
1199    end;
1200    c:=ReadBuf^;
1201    inc(ReadBuf);
1202    inc(ReadBufPos);
1203    Result:=true;
1204  end;
1205
1206  procedure InitWriteBuf;
1207  begin
1208    GetMem(WriteBufStart,WriteBufSize);
1209    WriteBuf:=WriteBufStart;
1210    WriteBufPos:=0;
1211  end;
1212
1213  procedure FlushWriteBuf;
1214  begin
1215    if WriteBufPos>0 then begin
1216      ResStream.Write(WriteBufStart^,WriteBufPos);
1217      WriteBuf:=WriteBufStart;
1218      WriteBufPos:=0;
1219    end;
1220  end;
1221
1222  procedure WriteChar(c: char);
1223  begin
1224    WriteBuf^:=c;
1225    inc(WriteBufPos);
1226    inc(WriteBuf);
1227    if WriteBufPos>=WriteBufSize then
1228      FlushWriteBuf;
1229  end;
1230
1231  procedure WriteString(const s: string);
1232  var
1233    i: Integer;
1234  begin
1235    for i:=1 to length(s) do WriteChar(s[i]);
1236  end;
1237
1238  procedure WriteShortString(const s: string);
1239  var
1240    i: Integer;
1241  begin
1242    for i:=1 to length(s) do WriteChar(s[i]);
1243  end;
1244
1245begin
1246  // fpc is not optimized for building a constant string out of thousands of
1247  // lines. It needs huge amounts of memory and becomes very slow. Therefore big
1248  // files are split into several strings.
1249
1250  InitReadBuf;
1251  InitWriteBuf;
1252  InitByteToStr;
1253
1254  Indent:='';
1255  s:=Indent+'LazarusResources.Add('''+ResourceName+''','''+ResourceType+''',['+LineEnd;
1256  WriteString(s);
1257  Indent:='  '+Indent;
1258  WriteString(Indent);
1259  x:=length(Indent);
1260  RangeString:=false;
1261  CurLine:=1;
1262  RightMargin:=80;
1263  if ReadBufLen>0 then begin
1264    while ReadChar(c) do begin
1265      NewRangeString:=(ord(c)>=32) and (ord(c)<127);
1266      // check if new char fits into line or if a new line must be started
1267      if NewRangeString then begin
1268        if RangeString then
1269          MinCharCount:=2 // char plus '
1270        else
1271          MinCharCount:=3; // ' plus char plus '
1272        if c='''' then inc(MinCharCount);
1273      end else begin
1274        MinCharCount:=1+length(ByteToStr[c]); // # plus number
1275        if RangeString then
1276          inc(MinCharCount); // plus ' for ending last string constant
1277      end;
1278      if x+MinCharCount>RightMargin then begin
1279        // break line
1280        if RangeString then begin
1281          // end string constant
1282          WriteChar('''');
1283        end;
1284        // write line ending
1285        WriteShortString(LineEnd);
1286        x:=0;
1287        inc(CurLine);
1288        // write indention
1289        WriteString(Indent);
1290        inc(x,length(Indent));
1291        // write operator
1292        if (CurLine and 63)<>1 then
1293          WriteChar('+')
1294        else
1295          WriteChar(',');
1296        inc(x);
1297        RangeString:=false;
1298      end;
1299      // write converted byte
1300      if RangeString<>NewRangeString then begin
1301        WriteChar('''');
1302        inc(x);
1303      end;
1304      if NewRangeString then begin
1305        WriteChar(c);
1306        inc(x);
1307        if c='''' then begin
1308          WriteChar(c);
1309          inc(x);
1310        end;
1311      end else begin
1312        WriteChar('#');
1313        inc(x);
1314        WriteShortString(ByteToStr[c]);
1315        inc(x,length(ByteToStr[c]));
1316      end;
1317      // next
1318      RangeString:=NewRangeString;
1319    end;
1320    if RangeString then begin
1321      WriteChar('''');
1322    end;
1323  end else begin
1324    WriteShortString('''''');
1325  end;
1326  Indent:=copy(Indent,3,length(Indent)-2);
1327  s:=LineEnd+Indent+']);'+LineEnd;
1328  WriteString(s);
1329  FlushWriteBuf;
1330  FreeMem(ReadBufStart);
1331  FreeMem(WriteBufStart);
1332end;
1333
1334function FindLFMClassName(LFMStream:TStream):ansistring;
1335{ examples:
1336  object Form1: TForm1
1337  inherited AboutBox2: TAboutBox2
1338
1339  -> the classname is the last word of the first line
1340}
1341var c:char;
1342  StartPos, EndPos: Int64;
1343begin
1344  Result:='';
1345  StartPos:=-1;
1346  c:=' ';
1347  // read till end of line
1348  repeat
1349    // remember last non identifier char position
1350    if (not (c in ['a'..'z','A'..'Z','0'..'9','_'])) then
1351      StartPos:=LFMStream.Position;
1352    if LFMStream.Read(c,1)<>1 then exit;
1353    if LFMStream.Position>1000 then exit;
1354  until c in [#10,#13];
1355  if StartPos<0 then exit;
1356  EndPos:=LFMStream.Position-1;
1357  if EndPos-StartPos>255 then exit;
1358  SetLength(Result,EndPos-StartPos);
1359  LFMStream.Position:=StartPos;
1360  if Length(Result) > 0 then
1361    LFMStream.Read(Result[1],length(Result));
1362  LFMStream.Position:=0;
1363  if not IsValidIdent(Result) then
1364    Result:='';
1365end;
1366
1367function LFMtoLRSfile(const LFMfilename: string):boolean;
1368// returns true if successful
1369var
1370  LFMFileStream, LRSFileStream: TFileStreamUTF8;
1371  LFMMemStream, LRSMemStream: TMemoryStream;
1372  LRSfilename, LFMfilenameExt: string;
1373begin
1374  Result:=true;
1375  try
1376    LFMFileStream:=TFileStreamUTF8.Create(LFMfilename,fmOpenRead);
1377    LFMMemStream:=TMemoryStream.Create;
1378    LRSMemStream:=TMemoryStream.Create;
1379    try
1380      LFMMemStream.SetSize(LFMFileStream.Size);
1381      LFMMemStream.CopyFrom(LFMFileStream,LFMFileStream.Size);
1382      LFMMemStream.Position:=0;
1383      LFMfilenameExt:=ExtractFileExt(LFMfilename);
1384      LRSfilename:=copy(LFMfilename,1,
1385                    length(LFMfilename)-length(LFMfilenameExt))+'.lrs';
1386      Result:=LFMtoLRSstream(LFMMemStream,LRSMemStream);
1387      if not Result then exit;
1388      LRSMemStream.Position:=0;
1389      LRSFileStream:=TFileStreamUTF8.Create(LRSfilename,fmCreate);
1390      try
1391        LRSFileStream.CopyFrom(LRSMemStream,LRSMemStream.Size);
1392      finally
1393        LRSFileStream.Free;
1394      end;
1395    finally
1396      LFMMemStream.Free;
1397      LRSMemStream.Free;
1398      LFMFileStream.Free;
1399    end;
1400  except
1401    on E: Exception do begin
1402      {$IFNDEF DisableChecks}
1403      DebugLn('LFMtoLRSfile ',E.Message);
1404      {$ENDIF}
1405      Result:=false;
1406    end;
1407  end;
1408end;
1409
1410function LFMtoLRSstream(LFMStream, LRSStream: TStream):boolean;
1411// returns true if successful
1412var FormClassName:ansistring;
1413  BinStream:TMemoryStream;
1414begin
1415  Result:=true;
1416  try
1417    FormClassName:=FindLFMClassName(LFMStream);
1418    BinStream:=TMemoryStream.Create;
1419    try
1420      LRSObjectTextToBinary(LFMStream,BinStream);
1421      BinStream.Position:=0;
1422      BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName,'FORMDATA');
1423    finally
1424      BinStream.Free;
1425    end;
1426  except
1427    on E: Exception do begin
1428      {$IFNDEF DisableChecks}
1429      DebugLn('LFMtoLRSstream ',E.Message);
1430      {$ENDIF}
1431      Result:=false;
1432    end;
1433  end;
1434end;
1435
1436//==============================================================================
1437
1438{ TLResourceList }
1439
1440constructor TLResourceList.Create;
1441begin
1442  FList := TList.Create;
1443  FMergeList := TList.Create;
1444  FSortedCount := 0;
1445end;
1446
1447destructor TLResourceList.Destroy;
1448var
1449  a: integer;
1450begin
1451  for a := 0 to FList.Count - 1 do
1452    TLResource(FList[a]).Free;
1453  FList.Free;
1454  FMergeList.Free;
1455end;
1456
1457function TLResourceList.Count: integer;
1458begin
1459  if (Self<>nil) and (FList<>nil) then
1460    Result:=FList.Count
1461  else
1462    Result:=0;
1463end;
1464
1465procedure TLResourceList.Add(const Name, ValueType: AnsiString;
1466  const Values: array of string);
1467var
1468  NewLResource: TLResource;
1469  i, TotalLen, ValueCount, p: integer;
1470begin
1471  NewLResource := TLResource.Create;
1472  NewLResource.Name := Name;
1473  NewLResource.ValueType := uppercase(ValueType);
1474
1475  ValueCount := High(Values) - Low(Values) + 1;
1476  case ValueCount of
1477    0:
1478      begin
1479        NewLResource.Free;
1480        exit;
1481      end;
1482    1:
1483      NewLResource.Value:=Values[0];
1484  else
1485    TotalLen := 0;
1486    for i := Low(Values) to High(Values) do
1487      inc(TotalLen, length(Values[i]));
1488    SetLength(NewLResource.Value, TotalLen);
1489    p := 1;
1490    for i := Low(Values) to High(Values) do
1491    begin
1492      if length(Values[i]) > 0 then
1493      begin
1494        Move(Values[i][1], NewLResource.Value[p], length(Values[i]));
1495        inc(p, length(Values[i]));
1496      end;
1497    end;
1498  end;
1499
1500  FList.Add(NewLResource);
1501end;
1502
1503function TLResourceList.Find(const Name: AnsiString):TLResource;
1504var
1505  P: Integer;
1506begin
1507  P := FindPosition(Name);
1508  if P >= 0 then
1509    Result := TLResource(FList[P])
1510  else
1511    Result := nil;
1512end;
1513
1514function TLResourceList.Find(const Name, ValueType: AnsiString): TLResource;
1515var
1516  P, I: Integer;
1517begin
1518  P := FindPosition(Name);
1519  if P >= 0 then
1520  begin
1521    // Since we can have many resources that have the same name but different type
1522    // we should look before and after found position (do not forget that we are searching
1523    // them by dividing intervals)
1524
1525    // look before position
1526    for I := P - 1 downto 0 do
1527    begin
1528      Result := TLResource(FList[I]);
1529      if SysUtils.CompareText(Result.Name,Name)<>0 then
1530        break;
1531      if Result.ValueType = ValueType then
1532        Exit;
1533    end;
1534    // look behind position
1535    for I := P to FList.Count - 1 do
1536    begin
1537      Result := TLResource(FList[I]);
1538      if SysUtils.CompareText(Result.Name,Name)<>0 then
1539        break;
1540      if Result.ValueType = ValueType then
1541        Exit;
1542    end;
1543  end;
1544  Result := nil;
1545end;
1546
1547function TLResourceList.FindPosition(const Name: AnsiString): Integer;
1548var
1549  L, R, C: Integer;
1550begin
1551  if FSortedCount < FList.Count then
1552    Sort;
1553  L := 0;
1554  R := FList.Count-1;
1555  while (L <= R) do
1556  begin
1557    Result := (L + R) shr 1;
1558    C := SysUtils.CompareText(Name, TLResource(FList[Result]).Name);
1559    if C < 0 then
1560      R := Result - 1
1561    else
1562    if C > 0 then
1563      L := Result + 1
1564    else
1565      Exit;
1566  end;
1567  Result := -1;
1568end;
1569
1570function TLResourceList.GetItems(Index: integer): TLResource;
1571begin
1572  Result := TLResource(FList[Index]);
1573end;
1574
1575procedure TLResourceList.Sort;
1576{$IFNDEF DisableChecks}
1577var
1578  i: Integer;
1579  r1: TLResource;
1580  r2: TLResource;
1581{$ENDIF}
1582begin
1583  if FSortedCount = FList.Count then
1584    exit;
1585  // sort the unsorted elements
1586  FMergeList.Count := FList.Count;
1587  MergeSort(FList, FMergeList, FSortedCount, FList.Count - 1);
1588  // merge both
1589  Merge(FList, FMergeList, 0, FSortedCount, FList.Count - 1);
1590  FSortedCount := FList.Count;
1591  // check for doubles
1592  {$IFNDEF DisableChecks}
1593  for i:=0 to FList.Count-2 do
1594  begin
1595    r1:=TLResource(FList[i]);
1596    r2:=TLResource(FList[i+1]);
1597    if (SysUtils.CompareText(r1.Name,r2.Name)=0) and (r1.ValueType=r2.ValueType) then
1598    begin
1599      DebugLn(['TLResourceList.Sort ',i,' DUPLICATE RESOURCE FOUND: ',r1.Name,':',r1.ValueType]);
1600      //DumpStack;
1601    end;
1602  end;
1603  {$ENDIF}
1604end;
1605
1606procedure TLResourceList.MergeSort(List, MergeList: TList; Pos1, Pos2: integer);
1607var
1608  cmp, mid: integer;
1609begin
1610  if Pos1 = Pos2 then
1611  begin
1612  end else
1613  if Pos1 + 1 = Pos2 then
1614  begin
1615    cmp := SysUtils.CompareText(TLResource(List[Pos1]).Name, TLResource(List[Pos2]).Name);
1616    if cmp > 0 then
1617    begin
1618      MergeList[Pos1] := List[Pos1];
1619      List[Pos1] := List[Pos2];
1620      List[Pos2] := MergeList[Pos1];
1621    end;
1622  end else
1623  begin
1624    if Pos2 > Pos1 then
1625    begin
1626      mid := (Pos1 + Pos2) shr 1;
1627      MergeSort(List, MergeList, Pos1, mid);
1628      MergeSort(List, MergeList, mid + 1, Pos2);
1629      Merge(List, MergeList, Pos1, mid + 1, Pos2);
1630    end;
1631  end;
1632end;
1633
1634procedure TLResourceList.Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer);
1635// merge two sorted arrays
1636// the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3
1637var
1638  Src1Pos, Src2Pos, DestPos, cmp, a: integer;
1639begin
1640  if (Pos1 >= Pos2) or (Pos2 > Pos3) then
1641    exit;
1642  Src1Pos := Pos2 - 1;
1643  Src2Pos := Pos3;
1644  DestPos := Pos3;
1645  while (Src2Pos >= Pos2) and (Src1Pos >= Pos1) do
1646  begin
1647    cmp:=SysUtils.CompareText(TLResource(List[Src1Pos]).Name, TLResource(List[Src2Pos]).Name);
1648    if cmp > 0 then
1649    begin
1650      MergeList[DestPos] := List[Src1Pos];
1651      dec(Src1Pos);
1652    end else
1653    begin
1654      MergeList[DestPos] := List[Src2Pos];
1655      dec(Src2Pos);
1656    end;
1657    dec(DestPos);
1658  end;
1659  while Src2Pos >= Pos2 do
1660  begin
1661    MergeList[DestPos] := List[Src2Pos];
1662    dec(Src2Pos);
1663    dec(DestPos);
1664  end;
1665  for a := DestPos + 1 to Pos3 do
1666    List[a] := MergeList[a];
1667end;
1668
1669procedure TLResourceList.Add(const Name, ValueType, Value: AnsiString);
1670begin
1671  Add(Name, ValueType, [Value]);
1672end;
1673
1674//------------------------------------------------------------------------------
1675// Delphi object streams
1676
1677type
1678  TDelphiValueType = (dvaNull, dvaList, dvaInt8, dvaInt16, dvaInt32, dvaExtended,
1679    dvaString, dvaIdent, dvaFalse, dvaTrue, dvaBinary, dvaSet, dvaLString,
1680    dvaNil, dvaCollection, dvaSingle, dvaCurrency, dvaDate, dvaWString,
1681    dvaInt64, dvaUTF8String);
1682
1683  TDelphiReader = class
1684  private
1685    FStream: TStream;
1686  protected
1687    procedure SkipBytes(Count: Integer);
1688    procedure SkipSetBody;
1689    procedure SkipProperty;
1690  public
1691    constructor Create(Stream: TStream);
1692    procedure ReadSignature;
1693    procedure Read(out Buf; Count: Longint);
1694    function ReadInteger: Longint;
1695    function ReadValue: TDelphiValueType;
1696    function NextValue: TDelphiValueType;
1697    function ReadStr: string;
1698    function EndOfList: Boolean;
1699    procedure SkipValue;
1700    procedure CheckValue(Value: TDelphiValueType);
1701    procedure ReadListEnd;
1702    procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); virtual;
1703    function ReadFloat: Extended;
1704    function ReadSingle: Single;
1705    function ReadCurrency: Currency;
1706    function ReadDate: TDateTime;
1707    function ReadString: string;
1708    //function ReadWideString: WideString;
1709    function ReadInt64: Int64;
1710    function ReadIdent: string;
1711  end;
1712
1713  TDelphiWriter = class
1714  private
1715    FStream: TStream;
1716  public
1717    constructor Create(Stream: TStream);
1718    procedure Write(const Buf; Count: Longint);
1719  end;
1720
1721{ TDelphiReader }
1722
1723procedure ReadError(Msg: string);
1724begin
1725  raise EReadError.Create(Msg);
1726end;
1727
1728procedure PropValueError;
1729begin
1730  ReadError(rsInvalidPropertyValue);
1731end;
1732
1733procedure TDelphiReader.SkipBytes(Count: Integer);
1734begin
1735  FStream.Position:=FStream.Position+Count;
1736end;
1737
1738procedure TDelphiReader.SkipSetBody;
1739begin
1740  while ReadStr <> '' do ;
1741end;
1742
1743procedure TDelphiReader.SkipProperty;
1744begin
1745  ReadStr; { Skips property name }
1746  SkipValue;
1747end;
1748
1749constructor TDelphiReader.Create(Stream: TStream);
1750begin
1751  FStream:=Stream;
1752end;
1753
1754procedure TDelphiReader.ReadSignature;
1755var
1756  Signature: TFilerSignature;
1757begin
1758  Signature:='1234';
1759  Read(Signature[1], length(Signature));
1760  if Signature<>FilerSignature then
1761    ReadError(rsInvalidStreamFormat);
1762end;
1763
1764procedure TDelphiReader.Read(out Buf; Count: Longint);
1765begin
1766  FStream.Read(Buf,Count);
1767end;
1768
1769function TDelphiReader.ReadInteger: Longint;
1770var
1771  S: Shortint;
1772  I: Smallint;
1773begin
1774  case ReadValue of
1775    dvaInt8:
1776      begin
1777        Read(S, SizeOf(Shortint));
1778        Result := S;
1779      end;
1780    dvaInt16:
1781      begin
1782        Read(I, SizeOf(I));
1783        Result := I;
1784      end;
1785    dvaInt32:
1786      Read(Result, SizeOf(Result));
1787  else
1788    Result:=0;
1789    PropValueError;
1790  end;
1791end;
1792
1793function TDelphiReader.ReadValue: TDelphiValueType;
1794var b: byte;
1795begin
1796  Read(b,1);
1797  Result:=TDelphiValueType(b);
1798end;
1799
1800function TDelphiReader.NextValue: TDelphiValueType;
1801begin
1802  Result := ReadValue;
1803  FStream.Position:=FStream.Position-1;
1804end;
1805
1806function TDelphiReader.ReadStr: string;
1807var
1808  L: Byte;
1809begin
1810  Read(L, SizeOf(Byte));
1811  SetLength(Result, L);
1812  if L>0 then
1813    Read(Result[1], L);
1814end;
1815
1816function TDelphiReader.EndOfList: Boolean;
1817begin
1818  Result := (ReadValue = dvaNull);
1819  FStream.Position:=FStream.Position-1;
1820end;
1821
1822procedure TDelphiReader.SkipValue;
1823
1824  procedure SkipList;
1825  begin
1826    while not EndOfList do SkipValue;
1827    ReadListEnd;
1828  end;
1829
1830  procedure SkipBinary(BytesPerUnit: Integer);
1831  var
1832    Count: Longint;
1833  begin
1834    Read(Count, SizeOf(Count));
1835    SkipBytes(Count * BytesPerUnit);
1836  end;
1837
1838  procedure SkipCollection;
1839  begin
1840    while not EndOfList do
1841    begin
1842      if NextValue in [dvaInt8, dvaInt16, dvaInt32] then SkipValue;
1843      SkipBytes(1);
1844      while not EndOfList do SkipProperty;
1845      ReadListEnd;
1846    end;
1847    ReadListEnd;
1848  end;
1849
1850begin
1851  case ReadValue of
1852    dvaNull: { no value field, just an identifier };
1853    dvaList: SkipList;
1854    dvaInt8: SkipBytes(SizeOf(Byte));
1855    dvaInt16: SkipBytes(SizeOf(Word));
1856    dvaInt32: SkipBytes(SizeOf(LongInt));
1857    dvaExtended: SkipBytes(SizeOf(Extended));
1858    dvaString, dvaIdent: ReadStr;
1859    dvaFalse, dvaTrue: { no value field, just an identifier };
1860    dvaBinary: SkipBinary(1);
1861    dvaSet: SkipSetBody;
1862    dvaLString: SkipBinary(1);
1863    dvaCollection: SkipCollection;
1864    dvaSingle: SkipBytes(Sizeof(Single));
1865    dvaCurrency: SkipBytes(SizeOf(Currency));
1866    dvaDate: SkipBytes(Sizeof(TDateTime));
1867    dvaWString: SkipBinary(Sizeof(WideChar));
1868    dvaInt64: SkipBytes(Sizeof(Int64));
1869    dvaUTF8String: SkipBinary(1);
1870  end;
1871end;
1872
1873procedure TDelphiReader.CheckValue(Value: TDelphiValueType);
1874begin
1875  if ReadValue <> Value then
1876  begin
1877    FStream.Position:=FStream.Position-1;
1878    SkipValue;
1879    PropValueError;
1880  end;
1881end;
1882
1883procedure TDelphiReader.ReadListEnd;
1884begin
1885  CheckValue(dvaNull);
1886end;
1887
1888procedure TDelphiReader.ReadPrefix(var Flags: TFilerFlags;
1889  var AChildPos: Integer);
1890var
1891  Prefix: Byte;
1892begin
1893  Flags := [];
1894  if Byte(NextValue) and $F0 = $F0 then
1895  begin
1896    Prefix := Byte(ReadValue);
1897    if (Prefix and ObjStreamMaskInherited)>0 then
1898      Include(Flags,ffInherited);
1899    if (Prefix and ObjStreamMaskChildPos)>0 then
1900      Include(Flags,ffChildPos);
1901    if (Prefix and ObjStreamMaskInline)>0 then
1902      Include(Flags,ffInline);
1903    if ffChildPos in Flags then AChildPos := ReadInteger;
1904  end;
1905end;
1906
1907function TDelphiReader.ReadFloat: Extended;
1908begin
1909  if ReadValue = dvaExtended then
1910    Read(Result, SizeOf(Result))
1911  else begin
1912    FStream.Position:=FStream.Position-1;
1913    Result := ReadInteger;
1914  end;
1915end;
1916
1917function TDelphiReader.ReadSingle: Single;
1918begin
1919  if ReadValue = dvaSingle then
1920    Read(Result, SizeOf(Result))
1921  else begin
1922    FStream.Position:=FStream.Position-1;
1923    Result := ReadInteger;
1924  end;
1925end;
1926
1927function TDelphiReader.ReadCurrency: Currency;
1928begin
1929  if ReadValue = dvaCurrency then
1930    Read(Result, SizeOf(Result))
1931  else begin
1932    FStream.Position:=FStream.Position-1;
1933    Result := ReadInteger;
1934  end;
1935end;
1936
1937function TDelphiReader.ReadDate: TDateTime;
1938begin
1939  if ReadValue = dvaDate then
1940    Read(Result, SizeOf(Result))
1941  else begin
1942    FStream.Position:=FStream.Position-1;
1943    Result := ReadInteger;
1944  end;
1945end;
1946
1947function TDelphiReader.ReadString: string;
1948var
1949  L: Integer;
1950begin
1951  Result := '';
1952  if NextValue in [dvaWString, dvaUTF8String] then begin
1953    ReadError('TDelphiReader.ReadString: WideString and UTF8String are not implemented yet');
1954    //Result := ReadWideString;
1955  end else
1956  begin
1957    L := 0;
1958    case ReadValue of
1959      dvaString:
1960        Read(L, SizeOf(Byte));
1961      dvaLString:
1962        Read(L, SizeOf(Integer));
1963    else
1964      PropValueError;
1965    end;
1966    SetLength(Result, L);
1967    Read(Pointer(Result)^, L);
1968  end;
1969end;
1970
1971function TDelphiReader.ReadInt64: Int64;
1972begin
1973  if NextValue = dvaInt64 then
1974  begin
1975    ReadValue;
1976    Read(Result, Sizeof(Result));
1977  end
1978  else
1979    Result := ReadInteger;
1980end;
1981
1982function TDelphiReader.ReadIdent: string;
1983var
1984  L: Byte;
1985begin
1986  case ReadValue of
1987    dvaIdent:
1988      begin
1989        Read(L, SizeOf(Byte));
1990        SetLength(Result, L);
1991        Read(Result[1], L);
1992      end;
1993    dvaFalse:
1994      Result := 'False';
1995    dvaTrue:
1996      Result := 'True';
1997    dvaNil:
1998      Result := 'nil';
1999    dvaNull:
2000      Result := 'Null';
2001  else
2002    Result:='';
2003    PropValueError;
2004  end;
2005end;
2006
2007{ TDelphiWriter }
2008
2009{ MultiByte Character Set (MBCS) byte type }
2010type
2011  TMbcsByteType = (mbSingleByte, mbLeadByte, mbTrailByte);
2012
2013function ByteType(const S: string; Index: Integer): TMbcsByteType;
2014begin
2015  Result := mbSingleByte;
2016  { ToDo:
2017    if SysLocale.FarEast then
2018      Result := ByteTypeTest(PChar(S), Index-1);
2019  }
2020end;
2021
2022constructor TDelphiWriter.Create(Stream: TStream);
2023begin
2024  FStream:=Stream;
2025end;
2026
2027procedure TDelphiWriter.Write(const Buf; Count: Longint);
2028begin
2029  FStream.Write(Buf,Count);
2030end;
2031
2032procedure ReadLFMHeader(LFMStream: TStream;
2033  out LFMType, LFMComponentName, LFMClassName: String);
2034var
2035  c:char;
2036  Token: String;
2037begin
2038  { examples:
2039    object Form1: TForm1
2040    inherited AboutBox2: TAboutBox2
2041  }
2042  LFMComponentName:='';
2043  LFMClassName := '';
2044  LFMType := '';
2045  Token := '';
2046  while (LFMStream.Read(c,1)=1) and (LFMStream.Position<1000) do begin
2047    if c in ['a'..'z','A'..'Z','0'..'9','_'] then
2048      Token := Token + c
2049    else begin
2050      if Token<>'' then begin
2051        if LFMType = '' then
2052          LFMType := Token
2053        else if LFMComponentName='' then
2054          LFMComponentName:=Token
2055        else if LFMClassName = '' then
2056          LFMClassName := Token;
2057        Token := '';
2058      end;
2059      if c in [#10,#13] then break;
2060    end;
2061  end;
2062  LFMStream.Position:=0;
2063end;
2064
2065procedure ReadLFMHeader(const LFMSource: string;
2066  out LFMClassName: String; out LFMType: String);
2067var
2068  LFMComponentName: string;
2069begin
2070  ReadLFMHeader(LFMSource,LFMType,LFMComponentName,LFMClassName);
2071end;
2072
2073procedure ReadLFMHeader(const LFMSource: string; out LFMType, LFMComponentName,
2074  LFMClassName: String);
2075var
2076  p: Integer;
2077  StartPos: LongInt;
2078begin
2079  { examples:
2080    object Form1: TForm1
2081    inherited AboutBox2: TAboutBox2
2082
2083    - LFMType is the first word on the line
2084    - LFMComponentName is the second word
2085    - LFMClassName is the fourth token
2086  }
2087
2088  // read first word => LFMType
2089  p:=1;
2090  while (p<=length(LFMSource))
2091  and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
2092    inc(p);
2093  LFMType:=copy(LFMSource,1,p-1);
2094
2095  // read second word => LFMComponentName
2096  while (p<=length(LFMSource)) and (LFMSource[p] in [' ',#9]) do inc(p);
2097  StartPos:=p;
2098  while (p<=length(LFMSource))
2099  and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
2100    inc(p);
2101  LFMComponentName:=copy(LFMSource,StartPos,p-StartPos);
2102
2103  // read third word => LFMClassName
2104  while (p<=length(LFMSource)) and (LFMSource[p] in [' ',#9,':']) do inc(p);
2105  StartPos:=p;
2106  while (p<=length(LFMSource))
2107  and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
2108    inc(p);
2109  LFMClassName:=copy(LFMSource,StartPos,p-StartPos);
2110end;
2111
2112function ReadLFMHeaderFromFile(const Filename: string; out LFMType,
2113  LFMComponentName, LFMClassName: String): boolean;
2114var
2115  fs: TFileStreamUTF8;
2116  Header: string;
2117  Cnt: LongInt;
2118begin
2119  Result:=false;
2120  try
2121    fs:=TFileStreamUTF8.Create(Filename,fmOpenRead);
2122    try
2123      SetLength(Header,600);
2124      Cnt:=fs.Read(Header[1],length(Header));
2125      SetLength(Header,Cnt);
2126      ReadLFMHeader(Header,LFMType,LFMComponentName,LFMClassName);
2127      Result:=LFMClassName<>'';
2128    finally
2129      fs.Free;
2130    end;
2131  except
2132  end;
2133end;
2134
2135function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer;
2136// 0 = ok
2137// -1 = error while streaming AForm to binary stream
2138// -2 = error while streaming binary stream to text file
2139var
2140  BinStream: TMemoryStream;
2141  DestroyDriver: Boolean;
2142  Writer: TWriter;
2143begin
2144  Result:=0;
2145  BinStream:=TMemoryStream.Create;
2146  try
2147    try
2148      // write component to binary stream
2149      DestroyDriver:=false;
2150      Writer:=CreateLRSWriter(BinStream,DestroyDriver);
2151      try
2152        Writer.WriteDescendent(AComponent,nil);
2153      finally
2154        if DestroyDriver then Writer.Driver.Free;
2155        Writer.Free;
2156      end;
2157    except
2158      Result:=-1;
2159      exit;
2160    end;
2161    try
2162      // transform binary to text
2163      BinStream.Position:=0;
2164      LRSObjectBinaryToText(BinStream,LFMStream);
2165    except
2166      Result:=-2;
2167      exit;
2168    end;
2169  finally
2170    BinStream.Free;
2171  end;
2172end;
2173
2174procedure LRSObjectBinaryToText(Input, Output: TStream);
2175
2176  procedure OutStr(const s: String);
2177  {$IFDEF VerboseLRSObjectBinaryToText}
2178  var
2179    i: Integer;
2180  {$ENDIF}
2181  begin
2182    {$IFDEF VerboseLRSObjectBinaryToText}
2183    for i:=1 to length(s) do begin
2184      if (s[i] in [#0..#8,#11..#12,#14..#31]) then begin
2185        DbgOut('#'+IntToStr(ord(s[i])));
2186        RaiseGDBException('ObjectLRSToText: Invalid character');
2187      end else
2188        DbgOut(s[i]);
2189    end;
2190    {$ENDIF}
2191    if Length(s) > 0 then
2192      Output.Write(s[1], Length(s));
2193  end;
2194
2195  procedure OutLn(const s: String);
2196  begin
2197    OutStr(s + LineEnding);
2198  end;
2199
2200  procedure OutString(const s: String);
2201  var
2202    res, NewStr: String;
2203    i: Integer;
2204    InString, NewInString: Boolean;
2205  begin
2206    if s<>'' then begin
2207      res := '';
2208      InString := False;
2209      for i := 1 to Length(s) do begin
2210        NewInString := InString;
2211        case s[i] of
2212          #0..#31: begin
2213              NewInString := False;
2214              NewStr := '#' + IntToStr(Ord(s[i]));
2215            end;
2216          '''': begin
2217              NewInString := True;
2218              NewStr:=''''''; // write two ticks, so the reader will read one
2219            end;
2220          else begin
2221            NewInString := True;
2222            NewStr := s[i];
2223          end;
2224        end;
2225        if NewInString <> InString then begin
2226          NewStr := '''' + NewStr;
2227          InString := NewInString;
2228        end;
2229        res := res + NewStr;
2230      end;
2231      if InString then res := res + '''';
2232    end else begin
2233      res:='''''';
2234    end;
2235    OutStr(res);
2236  end;
2237
2238  procedure OutWideString(const s: WideString);
2239  // write as normal string
2240  var
2241    res, NewStr: String;
2242    i: Integer;
2243    InString, NewInString: Boolean;
2244  begin
2245    //debugln('OutWideString ',s);
2246    res := '';
2247    if s<>'' then begin
2248      InString := False;
2249      for i := 1 to Length(s) do begin
2250        NewInString := InString;
2251        if (ord(s[i])<ord(' ')) or (ord(s[i])>=127) then begin
2252          // special char
2253          NewInString := False;
2254          NewStr := '#' + IntToStr(Ord(s[i]));
2255        end
2256        else if s[i]='''' then begin
2257          // '
2258          if InString then
2259            NewStr := ''''''
2260          else
2261            NewStr := '''''''';
2262        end
2263        else begin
2264          // normal char
2265          NewInString := True;
2266          NewStr := AnsiString(s[i]);
2267        end;
2268        if NewInString <> InString then begin
2269          NewStr := '''' + NewStr;
2270          InString := NewInString;
2271        end;
2272        res := res + NewStr;
2273      end;
2274      if InString then res := res + '''';
2275    end else begin
2276      res:='''''';
2277    end;
2278    OutStr(res);
2279  end;
2280
2281  function ReadInt(ValueType: TValueType): LongInt;
2282  var
2283    w: Word;
2284  begin
2285    case ValueType of
2286      vaInt8: Result := ShortInt(Input.ReadByte);
2287      vaInt16: begin
2288          w:=ReadLRSWord(Input);
2289          //DebugLn('ReadInt vaInt16 w=',IntToStr(w));
2290          Result := SmallInt(w);
2291        end;
2292      vaInt32: Result := ReadLRSInteger(Input);
2293      else Result := 0;
2294    end;
2295  end;
2296
2297  function ReadInt: LongInt;
2298  begin
2299    Result := ReadInt(TValueType(Input.ReadByte));
2300  end;
2301
2302  function ReadShortString: String;
2303  var
2304    len: Byte;
2305  begin
2306    len := Input.ReadByte;
2307    SetLength(Result, len);
2308    if (Len > 0) then
2309      Input.Read(Result[1], len);
2310  end;
2311
2312  function ReadLongString: String;
2313  var
2314    len: integer;
2315  begin
2316    len := ReadLRSInteger(Input);
2317    SetLength(Result, len);
2318    if (Len > 0) then
2319      Input.Read(Result[1], len);
2320  end;
2321
2322  procedure ReadPropList(const indent: String);
2323
2324    procedure ProcessValue(ValueType: TValueType; const Indent: String);
2325
2326      procedure Stop(const s: String);
2327      begin
2328        RaiseGDBException('ObjectLRSToText '+s);
2329      end;
2330
2331      function ValueTypeAsString(ValueType: TValueType): string;
2332      begin
2333        case ValueType of
2334        vaNull: Result:='vaNull';
2335        vaList: Result:='vaList';
2336        vaInt8: Result:='vaInt8';
2337        vaInt16: Result:='vaInt16';
2338        vaInt32: Result:='vaInt32';
2339        vaExtended: Result:='vaExtended';
2340        vaString: Result:='vaString';
2341        vaIdent: Result:='vaIdent';
2342        vaFalse: Result:='vaFalse';
2343        vaTrue: Result:='vaTrue';
2344        vaBinary: Result:='vaBinary';
2345        vaSet: Result:='vaSet';
2346        vaLString: Result:='vaLString';
2347        vaNil: Result:='vaNil';
2348        vaCollection: Result:='vaCollection';
2349        vaSingle: Result:='vaSingle';
2350        vaCurrency: Result:='vaCurrency';
2351        vaDate: Result:='vaDate';
2352        vaWString: Result:='vaWString';
2353        vaInt64: Result:='vaInt64';
2354        vaUTF8String: Result:='vaUTF8String';
2355        vaUString: Result:='vaUString';
2356        vaQWord : Result:='vaQWord';
2357        else Result:='Unknown ValueType='+dbgs(Ord(ValueType));
2358        end;
2359      end;
2360
2361      procedure UnknownValueType;
2362      var
2363        s: String;
2364        {$IFNDEF DisableChecks}
2365        HintStr: string;
2366        HintLen: Int64;
2367        {$ENDIF}
2368      begin
2369        s:=ValueTypeAsString(ValueType);
2370        if s<>'' then
2371          s:='Unimplemented ValueType='+s;
2372        {$IFNDEF DisableChecks}
2373        HintLen:=Output.Position;
2374        if HintLen>50 then HintLen:=50;
2375        SetLength(HintStr,HintLen);
2376        if HintStr<>'' then begin
2377          try
2378            Output.Position:=Output.Position-length(HintStr);
2379            Output.Read(HintStr[1],length(HintStr));
2380            //debugln('ObjectLRSToText:');
2381            debugln(DbgStr(HintStr));
2382          except
2383          end;
2384        end;
2385        {$ENDIF}
2386        s:=s+' ';
2387        Stop(s);
2388      end;
2389
2390      procedure ProcessBinary;
2391      var
2392        ToDo, DoNow, StartPos, i: LongInt;
2393        lbuf: array[0..31] of Byte;
2394        s: String;
2395        p: pchar;
2396      const
2397        HexDigits: array[0..$F] of char = '0123456789ABCDEF';
2398      begin
2399        ToDo := ReadLRSCardinal(Input);
2400        OutLn('{');
2401        while ToDo > 0 do begin
2402          DoNow := ToDo;
2403          if DoNow > 32 then DoNow := 32;
2404          Dec(ToDo, DoNow);
2405          s := Indent + '  ';
2406          StartPos := length(s);
2407          Input.Read(lbuf, DoNow);
2408          setlength(s, StartPos+DoNow*2);
2409          p := @s[StartPos];
2410          for i := 0 to DoNow - 1 do begin
2411            inc(p);
2412            p^ := HexDigits[(lbuf[i] shr 4) and $F];
2413            inc(p);
2414            p^ := HexDigits[lbuf[i] and $F];
2415          end;
2416          OutLn(s);
2417        end;
2418        OutStr(indent);
2419        OutLn('}');
2420      end;
2421
2422    var
2423      s: String;
2424      IsFirst: Boolean;
2425      ext: Extended;
2426      ASingle: single;
2427      ADate: TDateTime;
2428      ACurrency: Currency;
2429      AWideString: WideString;
2430
2431    begin
2432      //DebugLn(['ProcessValue ',Indent,' ValueType="',ValueTypeAsString(ValueType),'"']);
2433      case ValueType of
2434        vaList: begin
2435            OutStr('(');
2436            IsFirst := True;
2437            while True do begin
2438              ValueType := TValueType(Input.ReadByte);
2439              if ValueType = vaNull then break;
2440              if IsFirst then begin
2441                OutLn('');
2442                IsFirst := False;
2443              end;
2444              OutStr(Indent + '  ');
2445              ProcessValue(ValueType, Indent + '  ');
2446            end;
2447            OutLn(Indent + ')');
2448          end;
2449        vaInt8: begin
2450            // MG: IntToStr has a bug with ShortInt, therefore these typecasts
2451            OutLn(IntToStr(Integer(ShortInt(Input.ReadByte))));
2452          end;
2453        vaInt16: OutLn(IntToStr(SmallInt(ReadLRSWord(Input))));
2454        vaInt32: OutLn(IntToStr(ReadLRSInteger(Input)));
2455        vaInt64: OutLn(IntToStr(ReadLRSInt64(Input)));
2456        vaExtended: begin
2457            ext:=ReadLRSExtended(Input);
2458            OutLn(FloatToStr(ext));
2459          end;
2460        vaString: begin
2461            OutString(ReadShortString);
2462            OutLn('');
2463          end;
2464        vaIdent: OutLn(ReadShortString);
2465        vaFalse: OutLn('False');
2466        vaTrue: OutLn('True');
2467        vaBinary: ProcessBinary;
2468        vaSet: begin
2469            OutStr('[');
2470            IsFirst := True;
2471            while True do begin
2472              s := ReadShortString;
2473              if Length(s) = 0 then break;
2474              if not IsFirst then OutStr(', ');
2475              IsFirst := False;
2476              OutStr(s);
2477            end;
2478            OutLn(']');
2479          end;
2480        vaLString: begin
2481            OutString(ReadLongString);
2482            OutLn('');
2483          end;
2484        vaNil:
2485          OutLn('nil');
2486        vaCollection: begin
2487            OutStr('<');
2488            while Input.ReadByte <> 0 do begin
2489              OutLn(Indent);
2490              Input.Seek(-1, soFromCurrent);
2491              OutStr(indent + '  item');
2492              ValueType := TValueType(Input.ReadByte);
2493              if ValueType <> vaList then
2494                OutStr('[' + IntToStr(ReadInt(ValueType)) + ']');
2495              OutLn('');
2496              ReadPropList(indent + '    ');
2497              OutStr(indent + '  end');
2498            end;
2499            OutLn('>');
2500          end;
2501        vaSingle: begin
2502            ASingle:=ReadLRSSingle(Input);
2503            OutLn(FloatToStr(ASingle) + 's');
2504          end;
2505        vaDate: begin
2506            ADate:=TDateTime(ReadLRSDouble(Input));
2507            OutLn(FloatToStr(ADate) + 'd');
2508          end;
2509        vaCurrency: begin
2510            ACurrency:=ReadLRSCurrency(Input);
2511            OutLn(FloatToStr(ACurrency * 10000) + 'c');
2512          end;
2513        vaWString,vaUString: begin
2514            AWideString:=ReadLRSWideString(Input);
2515            OutWideString(AWideString);
2516            OutLn('');
2517          end;
2518        else
2519          if ord(ValueType)=20 then begin
2520            // vaUTF8String
2521            // Delphi saves widestrings as UTF8 strings
2522            // The LCL does not use widestrings, but UTF8 directly
2523            // so, simply read and write the string
2524            OutString(ReadLongString);
2525            OutLn('');
2526          end else
2527            UnknownValueType;
2528      end;
2529    end;
2530
2531  var
2532    NextByte: Byte;
2533  begin
2534    while Input.ReadByte <> 0 do begin
2535      Input.Seek(-1, soFromCurrent);
2536      OutStr(indent + ReadShortString + ' = ');
2537      NextByte:=Input.ReadByte;
2538      if NextByte<>0 then
2539        ProcessValue(TValueType(NextByte), Indent)
2540      else
2541        OutLn('');
2542    end;
2543  end;
2544
2545  procedure ReadObject(const indent: String);
2546  var
2547    b: Byte;
2548    ObjClassName, ObjName: String;
2549    ChildPos: LongInt;
2550  begin
2551    ChildPos := 0;
2552    // Check for FilerFlags
2553    b := Input.ReadByte;
2554    if (b and $f0) = $f0 then begin
2555      if (b and ObjStreamMaskChildPos) <> 0 then
2556        ChildPos := ReadInt;
2557    end else begin
2558      b := 0;
2559      Input.Seek(-1, soFromCurrent);
2560    end;
2561
2562    ObjClassName := ReadShortString;
2563    ObjName := ReadShortString;
2564
2565    OutStr(Indent);
2566    if (b and ObjStreamMaskInherited) <> 0 then OutStr('inherited')
2567    else if (b and ObjStreamMaskInline) <> 0 then OutStr('inline')
2568    else OutStr('object');
2569    OutStr(' ');
2570    if ObjName <> '' then
2571      OutStr(ObjName + ': ');
2572    OutStr(ObjClassName);
2573    if (b and ObjStreamMaskChildPos) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']');
2574    OutLn('');
2575
2576    ReadPropList(indent + '  ');
2577
2578    while Input.ReadByte <> 0 do begin
2579      Input.Seek(-1, soFromCurrent);
2580      ReadObject(indent + '  ');
2581    end;
2582    OutLn(indent + 'end');
2583  end;
2584
2585var
2586  OldDecimalSeparator: Char;
2587  OldThousandSeparator: Char;
2588  Signature: TFilerSignature;
2589begin
2590  // Endian note: comparing 2 cardinals is endian independent
2591  Signature:='1234';
2592  Input.Read(Signature[1], length(Signature));
2593  if Signature<>FilerSignature then
2594    raise EReadError.Create('Illegal stream image' {###SInvalidImage});
2595  OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
2596  DefaultFormatSettings.DecimalSeparator:='.';
2597  OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
2598  DefaultFormatSettings.ThousandSeparator:=',';
2599  try
2600    ReadObject('');
2601  finally
2602    DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
2603    DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
2604  end;
2605end;
2606
2607function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat;
2608var
2609  Pos: TStreamSeekType;
2610  Signature: TFilerSignature;
2611begin
2612  Pos := Stream.Position;
2613  Signature[1] := #0; // initialize, in case the stream is at its end
2614  Stream.Read(Signature, length(Signature));
2615  Stream.Position := Pos;
2616  if (Signature[1] = #$FF) or (Signature = FilerSignature) then
2617    Result := sofBinary
2618    // text format may begin with "object", "inherited", or whitespace
2619  else if Signature[1] in ['o','O','i','I',' ',#13,#11,#9] then
2620    Result := sofText
2621  else
2622    Result := sofUnknown;
2623end;
2624
2625type
2626  TObjectTextConvertProc = procedure (Input, Output: TStream);
2627
2628procedure InternalLRSBinaryToText(Input, Output: TStream;
2629  var OriginalFormat: TLRSStreamOriginalFormat;
2630  ConvertProc: TObjectTextConvertProc;
2631  BinarySignature: TFilerSignature);
2632var
2633  Pos: TStreamSeekType;
2634  Signature: TFilerSignature;
2635begin
2636  Pos := Input.Position;
2637  Signature := BinarySignature;
2638  Signature[1]:=#0;
2639  Input.Read(Signature[1], length(Signature));
2640  Input.Position := Pos;
2641  if Signature = BinarySignature then
2642  begin     // definitely binary format
2643    if OriginalFormat = sofBinary then begin
2644      if Output is TMemoryStream then
2645        TMemoryStream(Output).SetSize(Output.Position+(Input.Size-Input.Position));
2646      Output.CopyFrom(Input, Input.Size - Input.Position)
2647    end else
2648    begin
2649      if OriginalFormat = sofUnknown then
2650        Originalformat := sofBinary;
2651      ConvertProc(Input, Output);
2652    end;
2653  end
2654  else  // might be text format
2655  begin
2656    if OriginalFormat = sofBinary then
2657      ConvertProc(Input, Output)
2658    else
2659    begin
2660      if OriginalFormat = sofUnknown then
2661      begin   // text format may begin with "object", "inherited", or whitespace
2662        if Signature[1] in ['o','O','i','I',' ',#13,#11,#9] then
2663          OriginalFormat := sofText
2664        else    // not binary, not text... let it raise the exception
2665        begin
2666          ConvertProc(Input, Output);
2667          Exit;
2668        end;
2669      end;
2670      if OriginalFormat = sofText then begin
2671        if Output is TMemoryStream then
2672          TMemoryStream(Output).SetSize(Output.Position
2673                                        +(Input.Size - Input.Position));
2674        Output.CopyFrom(Input, Input.Size - Input.Position);
2675      end;
2676    end;
2677  end;
2678end;
2679
2680procedure LRSObjectTextToBinary(Input, Output: TStream; Links: TLRPositionLinks);
2681var
2682  parser: {$IFDEF DisableWindowsUnicodeSupport}TParser{$ELSE}TUTF8Parser{$ENDIF};
2683  OldDecimalSeparator: Char;
2684  OldThousandSeparator: Char;
2685  TokenStartPos: LongInt;
2686
2687  procedure WriteShortString(const s: String);
2688  var
2689    Size: Integer;
2690  begin
2691    Size:=length(s);
2692    if Size>255 then Size:=255;
2693    Output.WriteByte(byte(Size));
2694    if Size > 0 then
2695      Output.Write(s[1], Size);
2696  end;
2697
2698  procedure WriteLongString(const s: String);
2699  begin
2700    WriteLRSInteger(Output,Length(s));
2701    if Length(s) > 0 then
2702      Output.Write(s[1], Length(s));
2703  end;
2704
2705  procedure WriteWideString(const s: WideString);
2706  begin
2707    WriteLRSInteger(Output,Length(s));
2708    if Length(s) > 0 then
2709      Output.Write(s[1], Length(s)*2);
2710  end;
2711
2712  procedure WriteInteger(value: LongInt);
2713  begin
2714    if (value >= -128) and (value <= 127) then begin
2715      Output.WriteByte(Ord(vaInt8));
2716      Output.WriteByte(Byte(value));
2717    end else if (value >= -32768) and (value <= 32767) then begin
2718      Output.WriteByte(Ord(vaInt16));
2719      WriteLRSWord(Output,Word(value));
2720    end else begin
2721      Output.WriteByte(ord(vaInt32));
2722      WriteLRSInteger(Output,value);
2723    end;
2724  end;
2725
2726  procedure WriteInt64(const Value: Int64);
2727  begin
2728    if (Value >= -$80000000) and (Value <= $7fffffff) then
2729      WriteInteger(Integer(Value))
2730    else begin
2731      Output.WriteByte(ord(vaInt64));
2732      WriteLRSInt64(Output,Value);
2733    end;
2734  end;
2735
2736  procedure WriteIntegerStr(const s: string);
2737  begin
2738    if length(s)>7 then
2739      WriteInt64(StrToInt64(s))
2740    else
2741      WriteInteger(StrToInt(s));
2742  end;
2743
2744  {$IFDEF DisableWindowsUnicodeSupport}
2745  function WideStringNeeded(const s: widestring): Boolean;
2746  var
2747    i: Integer;
2748  begin
2749    i:=length(s);
2750    while (i>=1) and (ord(s[i])<256) do dec(i);
2751    Result:=i>=1;
2752  end;
2753
2754  function WideStrToAnsiStrWithoutConversion(const s: widestring): string;
2755  var
2756    i: Integer;
2757  begin
2758    SetLength(Result,Length(s){$IFDEF WideStringLenDoubled} div 2{$ENDIF});
2759    for i:=1 to length(Result) do
2760      Result[i]:=chr(ord(s[i]));
2761  end;
2762
2763  function WideStrToShortStrWithoutConversion(const s: widestring): shortstring;
2764  var
2765    i: Integer;
2766  begin
2767    SetLength(Result,Length(s){$IFDEF WideStringLenDoubled} div 2{$ENDIF});
2768    for i:=1 to length(Result) do
2769      Result[i]:=chr(ord(s[i]));
2770  end;
2771  {$ENDIF}
2772
2773  function ParserNextToken: Char;
2774  begin
2775    TokenStartPos:=Parser.SourcePos;
2776    Result:=Parser.NextToken;
2777    if Links<>nil then
2778      Links.SetPosition(TokenStartPos,Parser.SourcePos,Output.Position,true);
2779  end;
2780
2781  procedure ProcessProperty; forward;
2782
2783  {$if not declared(toWString)}
2784    const toWString = char(5);
2785  {$endif}
2786
2787  procedure ProcessValue;
2788
2789    procedure RaiseValueExpected;
2790    begin
2791      parser.Error('Value expected, but '+parser.TokenString+' found');
2792    end;
2793
2794  var
2795    flt: Extended;
2796    stream: TMemoryStream;
2797    BinDataSize: LongInt;
2798    toStringBuf: String;
2799  begin
2800    if parser.TokenSymbolIs('END') then exit;
2801    if parser.TokenSymbolIs('OBJECT') then
2802      RaiseValueExpected;
2803    case parser.Token of
2804      toInteger:
2805        begin
2806          WriteIntegerStr(parser.TokenString);
2807          ParserNextToken;
2808        end;
2809      toFloat:
2810        begin
2811          flt := Parser.TokenFloat;
2812          case parser.FloatType of
2813            's': begin
2814              Output.WriteByte(Ord(vaSingle));
2815              WriteLRSSingle(Output,flt);
2816            end;
2817            'd': begin
2818              Output.WriteByte(Ord(vaDate));
2819              WriteLRSDouble(Output,flt);
2820            end;
2821            'c': begin
2822              Output.WriteByte(Ord(vaCurrency));
2823              WriteLRSCurrency(Output,flt/10000);
2824            end;
2825            else
2826            begin
2827              Output.WriteByte(Ord(vaExtended));
2828              WriteLRSExtended(Output,flt);
2829            end;
2830          end;
2831          ParserNextToken;
2832        end;
2833      toString:
2834        begin
2835          toStringBuf := parser.TokenString;
2836          //DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
2837          while ParserNextToken = '+' do
2838          begin
2839            ParserNextToken;   // Get next string fragment
2840            if not (parser.Token in [toString,toWString]) then
2841              parser.CheckToken(toString);
2842            toStringBuf := toStringBuf + parser.TokenString;
2843          end;
2844          if length(toStringBuf)<256 then begin
2845            //debugln('LRSObjectTextToBinary.ProcessValue WriteShortString');
2846            Output.WriteByte(Ord(vaString));
2847            WriteShortString(toStringBuf);
2848          end else begin
2849            //debugln('LRSObjectTextToBinary.ProcessValue WriteLongString');
2850            Output.WriteByte(Ord(vaLString));
2851            WriteLongString(toStringBuf);
2852          end;
2853        end;
2854      toWString:
2855        begin
2856          toStringBuf := parser.TokenString;
2857          //DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
2858          while ParserNextToken = '+' do
2859          begin
2860            ParserNextToken;   // Get next string fragment
2861            if not (parser.Token in [toString,toWString]) then
2862              parser.CheckToken(toString);
2863            toStringBuf := toStringBuf + parser.TokenString;
2864          end;
2865          Output.WriteByte(Ord(vaWString));
2866          WriteWideString(UTF8Decode(toStringBuf));
2867        end;
2868      toSymbol:
2869        begin
2870          if CompareText(parser.TokenString, 'True') = 0 then
2871            Output.WriteByte(Ord(vaTrue))
2872          else if CompareText(parser.TokenString, 'False') = 0 then
2873            Output.WriteByte(Ord(vaFalse))
2874          else if CompareText(parser.TokenString, 'nil') = 0 then
2875            Output.WriteByte(Ord(vaNil))
2876          else
2877          begin
2878            Output.WriteByte(Ord(vaIdent));
2879            WriteShortString(parser.TokenComponentIdent);
2880          end;
2881          ParserNextToken;
2882        end;
2883      // Set
2884      '[':
2885        begin
2886          ParserNextToken;
2887          Output.WriteByte(Ord(vaSet));
2888          if parser.Token <> ']' then
2889            while True do
2890            begin
2891              parser.CheckToken(toSymbol);
2892              WriteShortString(parser.TokenString);
2893              ParserNextToken;
2894              if parser.Token = ']' then
2895                break;
2896              parser.CheckToken(',');
2897              ParserNextToken;
2898            end;
2899          Output.WriteByte(0);
2900          ParserNextToken;
2901        end;
2902      // List
2903      '(':
2904        begin
2905          Output.WriteByte(Ord(vaList));
2906          ParserNextToken;
2907          while parser.Token <> ')' do
2908            ProcessValue;
2909          Output.WriteByte(0);
2910          ParserNextToken;
2911        end;
2912      // Collection
2913      '<':
2914        begin
2915          ParserNextToken;
2916          Output.WriteByte(Ord(vaCollection));
2917          while parser.Token <> '>' do
2918          begin
2919            parser.CheckTokenSymbol('item');
2920            ParserNextToken;
2921            // ConvertOrder
2922            Output.WriteByte(Ord(vaList));
2923            while not parser.TokenSymbolIs('end') do
2924              ProcessProperty;
2925            ParserNextToken;   // Skip 'end'
2926            Output.WriteByte(0);
2927          end;
2928          Output.WriteByte(0);
2929          ParserNextToken;
2930        end;
2931      // Binary data
2932      '{':
2933        begin
2934          Output.WriteByte(Ord(vaBinary));
2935          stream := TMemoryStream.Create;
2936          try
2937            parser.HexToBinary(stream);
2938            BinDataSize:=integer(stream.Size);
2939            WriteLRSInteger(Output,BinDataSize);
2940            Output.Write(Stream.Memory^, BinDataSize);
2941            Stream.Position:=0;
2942            //debugln('LRSObjectTextToBinary binary data "',dbgMemStream(Stream,30),'"');
2943          finally
2944            stream.Free;
2945          end;
2946          ParserNextToken;
2947        end;
2948      else
2949        parser.Error('Invalid Property');
2950    end;
2951  end;
2952
2953  procedure ProcessProperty;
2954  var
2955    name: String;
2956  begin
2957    // Get name of property
2958    parser.CheckToken(toSymbol);
2959    name := parser.TokenString;
2960    while True do begin
2961      ParserNextToken;
2962      if parser.Token <> '.' then break;
2963      ParserNextToken;
2964      parser.CheckToken(toSymbol);
2965      name := name + '.' + parser.TokenString;
2966    end;
2967    WriteShortString(name);
2968    parser.CheckToken('=');
2969    ParserNextToken;
2970    ProcessValue;
2971  end;
2972
2973  procedure ProcessObject;
2974  var
2975    Flags: Byte;
2976    ChildPos: Integer;
2977    ObjectName, ObjectType: String;
2978  begin
2979    if parser.TokenSymbolIs('OBJECT') then
2980      Flags :=0  { IsInherited := False }
2981    else if parser.TokenSymbolIs('INHERITED') then
2982      Flags := 1 { IsInherited := True; }
2983    else begin
2984      parser.CheckTokenSymbol('INLINE');
2985      Flags := 4;
2986    end;
2987    ParserNextToken;
2988    parser.CheckToken(toSymbol);
2989    if parser.TokenSymbolIs('END') then begin
2990      // 'object end': no name, no content
2991      // this is normally invalid, but Delphi can create this, so ignore it
2992      exit;
2993    end;
2994    ObjectName := '';
2995    ObjectType := parser.TokenString;
2996    ParserNextToken;
2997    ChildPos := 0;
2998    if parser.Token = ':' then begin
2999      ParserNextToken;
3000      parser.CheckToken(toSymbol);
3001      ObjectName := ObjectType;
3002      ObjectType := parser.TokenString;
3003      ParserNextToken;
3004      if parser.Token = '[' then begin
3005        ParserNextToken;
3006        ChildPos := parser.TokenInt;
3007        ParserNextToken;
3008        parser.CheckToken(']');
3009        ParserNextToken;
3010        Flags := Flags or 2;
3011      end;
3012    end;
3013    if Flags <> 0 then begin
3014      Output.WriteByte($f0 or Flags);
3015      if (Flags and ObjStreamMaskChildPos) <> 0 then
3016        WriteInteger(ChildPos);
3017    end;
3018    WriteShortString(ObjectType);
3019    WriteShortString(ObjectName);
3020
3021    // Convert property list
3022    while not (parser.TokenSymbolIs('END') or
3023      parser.TokenSymbolIs('OBJECT') or
3024      parser.TokenSymbolIs('INHERITED') or
3025      parser.TokenSymbolIs('INLINE'))
3026    do
3027      ProcessProperty;
3028    Output.WriteByte(0);        // Terminate property list
3029
3030    // Convert child objects
3031    while not parser.TokenSymbolIs('END') do ProcessObject;
3032    ParserNextToken;            // Skip end token
3033    Output.WriteByte(0);        // Terminate property list
3034  end;
3035
3036var
3037  Count: Integer;
3038begin
3039  if Links<>nil then begin
3040    // sort links for LFM positions
3041    Links.Sort(true);
3042  end;
3043  parser := {$IFDEF DisableWindowsUnicodeSupport}TParser{$ELSE}TUTF8Parser{$ENDIF}.Create(Input);
3044  OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
3045  DefaultFormatSettings.DecimalSeparator:='.';
3046  OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
3047  DefaultFormatSettings.ThousandSeparator:=',';
3048  try
3049    Count:=0;
3050    repeat
3051      Output.Write(FilerSignature[1], length(FilerSignature));
3052      ProcessObject;
3053      inc(Count);
3054    until parser.TokenString='';
3055    if Count>1 then
3056      Output.WriteByte(0);        // Terminate object list
3057  finally
3058    parser.Free;
3059    DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
3060    DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
3061  end;
3062end;
3063
3064procedure LRSObjectToText(Input, Output: TStream;
3065  var OriginalFormat: TLRSStreamOriginalFormat);
3066begin
3067  InternalLRSBinaryToText(Input, Output, OriginalFormat,
3068    @LRSObjectBinaryToText, FilerSignature);
3069end;
3070
3071procedure LRSObjectResToText(Input, Output: TStream;
3072  var OriginalFormat: TLRSStreamOriginalFormat);
3073begin
3074  InternalLRSBinaryToText(Input, Output, OriginalFormat,
3075    @LRSObjectResourceToText, #255);
3076end;
3077
3078procedure LRSObjectResourceToText(Input, Output: TStream);
3079begin
3080  Input.ReadResHeader;
3081  LRSObjectBinaryToText(Input, Output);
3082end;
3083
3084procedure FormDataToText(FormStream, TextStream: TStream; aFormat: TLRSStreamOriginalFormat);
3085begin
3086  if aFormat = sofUnknown then
3087    aFormat := TestFormStreamFormat(FormStream);
3088  case aFormat of
3089    sofBinary:
3090      LRSObjectResourceToText(FormStream, TextStream);
3091
3092    sofText:
3093      begin
3094        if TextStream is TMemoryStream then
3095          TMemoryStream(TextStream).SetSize(TextStream.Position+FormStream.Size);
3096        TextStream.CopyFrom(FormStream,FormStream.Size);
3097      end;
3098
3099    else
3100      raise Exception.Create(rsInvalidFormObjectStream);
3101  end;
3102end;
3103
3104function InitLazResourceComponent(Instance: TComponent;
3105  RootAncestor: TClass): Boolean;
3106
3107  function InitComponent(ClassType: TClass): Boolean;
3108  var
3109    {$ifdef UseLRS}
3110    LazResource: TLResource;
3111    {$endif}
3112    {$ifdef UseRES}
3113    FPResource: TFPResourceHandle;
3114    {$endif}
3115    ResName: String;
3116    Stream: TStream;
3117    Reader: TReader;
3118    DestroyDriver: Boolean;
3119    Driver: TAbstractObjectReader;
3120  begin
3121    //DebugLn(['[InitComponent] ClassType=',ClassType.Classname,' Instance=',DbgsName(Instance),' RootAncestor=',DbgsName(RootAncestor),' ClassType.ClassParent=',DbgsName(ClassType.ClassParent)]);
3122    Result := False;
3123    if (ClassType = TComponent) or (ClassType = RootAncestor) then
3124      Exit;
3125    if Assigned(ClassType.ClassParent) then
3126      Result := InitComponent(ClassType.ClassParent);
3127
3128    Stream := nil;
3129    ResName := ClassType.ClassName;
3130
3131    {$ifdef UseLRS}
3132    LazResource := LazarusResources.Find(ResName);
3133    if (LazResource <> nil) and (LazResource.Value <> '') then
3134      Stream := TLazarusResourceStream.CreateFromHandle(LazResource);
3135    //DebugLn('[InitComponent] CompResource found for ',ClassType.Classname);
3136    {$endif}
3137
3138    {$ifdef UseRES}
3139    if Stream = nil then
3140    begin
3141      FPResource := FindResourceLFM(ResName);
3142      if FPResource <> 0 then
3143        Stream := TLazarusResourceStream.CreateFromHandle(HInstance, FPResource);
3144    end;
3145    {$endif}
3146
3147    if Stream = nil then
3148      Exit;
3149
3150    try
3151      //DebugLn('Form Stream "',ClassType.ClassName,'"');
3152      //try
3153      DestroyDriver:=false;
3154      Reader := CreateLRSReader(Stream, DestroyDriver);
3155      try
3156        Reader.ReadRootComponent(Instance);
3157      finally
3158        Driver := Reader.Driver;
3159        Reader.Free;
3160        if DestroyDriver then
3161          Driver.Free;
3162      end;
3163      //except
3164      //  on E: Exception do begin
3165      //    DebugLn(Format(rsFormStreamingError,[ClassType.ClassName,E.Message]));
3166      //    exit;
3167      //  end;
3168      //end;
3169    finally
3170      Stream.Free;
3171    end;
3172    Result := True;
3173  end;
3174
3175begin
3176  if Instance.ComponentState * [csLoading, csInline] <> []
3177  then begin
3178    // global loading not needed
3179    Result := InitComponent(Instance.ClassType);
3180  end
3181  else try
3182    BeginGlobalLoading;
3183    Result := InitComponent(Instance.ClassType);
3184    NotifyGlobalLoading;
3185  finally
3186    EndGlobalLoading;
3187  end;
3188end;
3189
3190function CreateLRSReader(s: TStream; var DestroyDriver: boolean): TReader;
3191var
3192  p: Pointer;
3193  Driver: TAbstractObjectReader;
3194begin
3195  Result:=TReader.Create(s,4096);
3196  //If included Default translator LRSTranslator will be set
3197  if Assigned(LRSTranslator) then
3198    Result.OnReadStringProperty:=@(LRSTranslator.TranslateStringProperty);
3199
3200  Result.OnPropertyNotFound := @(PropertiesToSkip.DoPropertyNotFound);
3201
3202  DestroyDriver:=false;
3203  if Result.Driver.ClassType=LRSObjectReaderClass then
3204  begin
3205    TLRSObjectReader(Result.Driver).Reader:=Result;
3206    exit;
3207  end;
3208  // hack to set a write protected variable.
3209  // DestroyDriver:=true; TReader will free it
3210  Driver:=LRSObjectReaderClass.Create(s,4096);
3211  p:=@Result.Driver;
3212  Result.Driver.Free;
3213  TAbstractObjectReader(p^):=Driver;
3214  TLRSObjectReader(Driver).Reader:=Result;
3215end;
3216
3217function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;
3218var
3219  Driver: TAbstractObjectWriter;
3220begin
3221  Driver:=LRSObjectWriterClass.Create(s,4096);
3222  DestroyDriver:=true;
3223  Result:=TWriter.Create(Driver);
3224  TLRSObjectWriter(Driver).Writer:=Result;
3225end;
3226
3227{ LRS format converter functions }
3228
3229procedure ReverseBytes(p: Pointer; Count: integer);
3230var
3231  p1: PChar;
3232  p2: PChar;
3233  c: Char;
3234begin
3235  p1:=PChar(p);
3236  p2:=PChar(p)+Count-1;
3237  while p1<p2 do begin
3238    c:=p1^;
3239    p1^:=p2^;
3240    p2^:=c;
3241    inc(p1);
3242    dec(p2);
3243  end;
3244end;
3245
3246procedure ReverseByteOrderInWords(p: PWord; Count: integer);
3247var
3248  i: Integer;
3249  w: Word;
3250begin
3251  for i:=0 to Count-1 do begin
3252    w:=p[i];
3253    w:=(w shr 8) or ((w and $ff) shl 8);
3254    p[i]:=w;
3255  end;
3256end;
3257
3258function ConvertLRSExtendedToDouble(p: Pointer): Double;
3259type
3260  Ti386ExtendedReversed = packed record
3261    {$IFDEF FPC_BIG_ENDIAN}
3262    ExponentAndSign: word;
3263    Mantissa: qword;
3264    {$ELSE}
3265    Mantissa: qword;
3266    ExponentAndSign: word;
3267    {$ENDIF}
3268  end;
3269var
3270  e: Ti386ExtendedReversed;
3271  Exponent: word;
3272  ExponentAndSign: word;
3273  Mantissa: qword;
3274begin
3275  System.Move(p^,e,10);
3276  {$IFDEF FPC_BIG_ENDIAN}
3277  ReverseBytes(@e,10);
3278  {$ENDIF}
3279  // i386 extended
3280  Exponent:=(e.ExponentAndSign and $7fff);
3281  if (Exponent>$4000+$3ff) or (Exponent<$4000-$400) then begin
3282    // exponent out of bounds
3283    Result:=0;
3284    exit;
3285  end;
3286  dec(Exponent,$4000-$400);
3287  ExponentAndSign:=Exponent or ((e.ExponentAndSign and $8000) shr 4);
3288  // i386 extended has leading 1, double has not (shl 1)
3289  // i386 has 64 bit, double has 52 bit (shr 12)
3290  {$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
3291    {$IFDEF FPC_BIG_ENDIAN}
3292    // accessing Mantissa will couse trouble, copy it first
3293    System.Move(e.Mantissa, Mantissa, SizeOf(Mantissa));
3294    Mantissa := (Mantissa shl 1) shr 12;
3295    {$ELSE FPC_BIG_ENDIAN}
3296    Mantissa := (e.Mantissa shl 1) shr 12;
3297    {$ENDIF FPC_BIG_ENDIAN}
3298  {$ELSE FPC_REQUIRES_PROPER_ALIGNMENT}
3299  Mantissa := (e.Mantissa shl 1) shr 12;
3300  {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
3301  // put together
3302  QWord(Result):=Mantissa or (qword(ExponentAndSign) shl 52);
3303end;
3304
3305procedure ConvertEndianBigDoubleToLRSExtended(BigEndianDouble,
3306  LRSExtended: Pointer);
3307// Floats consists of a sign bit, some exponent bits and the mantissa bits
3308// A 0 is all bits 0
3309// not 0 has always a leading 1, which exponent is stored
3310// Single/Double does not save the leading 1, Extended does.
3311//
3312// Double is 8 bytes long, leftmost bit is sign,
3313// then 11 bit exponent based $400, then 52 bit mantissa without leading 1
3314//
3315// Extended is 10 bytes long, leftmost bit is sign,
3316// then 15 bit exponent based $4000, then 64 bit mantissa with leading 1
3317// EndianLittle means reversed byte order
3318var
3319  e: array[0..9] of byte;
3320  i: Integer;
3321  Exponent: Word;
3322  d: PByte;
3323begin
3324  d:=PByte(BigEndianDouble);
3325  // convert ppc double to i386 extended
3326  if (PCardinal(d)[0] or PCardinal(d)[1])=0 then begin
3327    // 0
3328    FillChar(LRSExtended^,10,#0);
3329  end else begin
3330    Exponent:=((d[0] and $7f) shl 4)+(d[1] shr 4);
3331    inc(Exponent,$4000-$400);
3332    if (d[0] and $80)>0 then
3333      // signed
3334      inc(Exponent,$8000);
3335    e[9]:=Exponent shr 8;
3336    e[8]:=Exponent and $ff;
3337    e[7]:=($80 or (d[1] shl 3) or (d[2] shr 5)) and $ff;
3338    for i:=3 to 7 do begin
3339      e[9-i]:=((d[i-1] shl 3) or (d[i] shr 5)) and $ff;
3340    end;
3341    e[1]:=(d[7] shl 3) and $ff;
3342    e[0]:=0;
3343    System.Move(e[0],LRSExtended^,10);
3344  end;
3345end;
3346
3347procedure ConvertLEDoubleToLRSExtended(LEDouble, LRSExtended: Pointer);
3348type
3349  TMantissaWrap = record
3350    case boolean of
3351      True: (Q: QWord);
3352      False: (B: array[0..7] of Byte);
3353  end;
3354
3355  TExpWrap = packed record
3356    Mantissa: TMantissaWrap;
3357    Exp: Word;
3358  end;
3359
3360var
3361  Q: PQWord absolute LEDouble;
3362  C: PCardinal absolute LEDouble;
3363  W: PWord absolute LEDouble;
3364  E: ^TExpWrap absolute LRSExtended;
3365  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
3366  Mantissa: TMantissaWrap;
3367  {$endif}
3368begin
3369  if W[3] and $7FF0 = $7FF0 // infinite or NaN
3370  then E^.Exp := $7FFF
3371  else E^.Exp := (W[3] and $7FFF) shr 4 - $3FF + $3FFF;
3372  E^.Exp := E^.Exp or (W[3] and $8000); // sign
3373  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
3374  Mantissa.Q := (Q^ shl 11);
3375  Mantissa.B[7] := Mantissa.B[7] or $80; // add ignored 1
3376  System.Move(Mantissa, E^.Mantissa, 8);
3377  {$else}
3378  E^.Mantissa.Q := (Q^ shl 11);
3379  E^.Mantissa.B[7] := E^.Mantissa.B[7] or $80; // add ignored 1
3380  {$endif}
3381end;
3382
3383function ReadLRSShortInt(s: TStream): shortint;
3384begin
3385  Result:=0;
3386  s.Read(Result,1);
3387end;
3388
3389function ReadLRSByte(s: TStream): byte;
3390begin
3391  Result:=0;
3392  s.Read(Result,1);
3393end;
3394
3395function ReadLRSWord(s: TStream): word;
3396begin
3397  Result:=0;
3398  s.Read(Result,2);
3399  {$IFDEF FPC_BIG_ENDIAN}
3400  Result:=((Result and $ff) shl 8) or (Result shr 8);
3401  {$ENDIF}
3402end;
3403
3404function ReadLRSSmallInt(s: TStream): smallint;
3405begin
3406  Result:=0;
3407  {$IFDEF FPC_BIG_ENDIAN}
3408  Result:=smallint(ReadLRSWord(s));
3409  {$ELSE}
3410  s.Read(Result,2);
3411  {$ENDIF}
3412end;
3413
3414function ReadLRSInteger(s: TStream): integer;
3415begin
3416  Result:=0;
3417  s.Read(Result,4);
3418  {$IFDEF FPC_BIG_ENDIAN}
3419  ReverseBytes(@Result,4);
3420  {$ENDIF}
3421end;
3422
3423function ReadLRSCardinal(s: TStream): cardinal;
3424begin
3425  Result:=0;
3426  s.Read(Result,4);
3427  {$IFDEF FPC_BIG_ENDIAN}
3428  ReverseBytes(@Result,4);
3429  {$ENDIF}
3430end;
3431
3432function ReadLRSInt64(s: TStream): int64;
3433begin
3434  Result:=0;
3435  s.Read(Result,8);
3436  {$IFDEF FPC_BIG_ENDIAN}
3437  ReverseBytes(@Result,8);
3438  {$ENDIF}
3439end;
3440
3441function ReadLRSSingle(s: TStream): Single;
3442begin
3443  Result:=0;
3444  s.Read(Result,4);
3445  {$IFDEF FPC_BIG_ENDIAN}
3446  ReverseBytes(@Result,4);
3447  {$ENDIF}
3448end;
3449
3450function ReadLRSDouble(s: TStream): Double;
3451begin
3452  Result:=0;
3453  s.Read(Result,8);
3454  {$IFDEF FPC_BIG_ENDIAN}
3455  ReverseBytes(@Result,8);
3456  {$ENDIF}
3457end;
3458
3459function ReadLRSExtended(s: TStream): Extended;
3460begin
3461  Result:=0;
3462  {$IFDEF FPC_HAS_TYPE_EXTENDED}
3463    s.Read(Result,10);
3464    {$IFDEF FPC_BIG_ENDIAN}
3465    ReverseBytes(@Result,10);
3466    {$ENDIF}
3467  {$ELSE}
3468    // possible endian conversion is handled in ConvertLRSExtendedToDouble
3469    Result:=ReadLRSEndianLittleExtendedAsDouble(s);
3470  {$ENDIF}
3471end;
3472
3473function ReadLRSCurrency(s: TStream): Currency;
3474begin
3475  Result:=0;
3476  s.Read(Result,8);
3477  {$IFDEF FPC_BIG_ENDIAN}
3478  ReverseBytes(@Result,8);
3479  {$ENDIF}
3480end;
3481
3482function ReadLRSWideString(s: TStream): WideString;
3483var
3484  Len: LongInt;
3485begin
3486  Len:=ReadLRSInteger(s);
3487  SetLength(Result,Len);
3488  if Len>0 then begin
3489    s.Read(Result[1],Len*2);
3490    {$IFDEF FPC_BIG_ENDIAN}
3491    ReverseByteOrderInWords(PWord(@Result[1]),Len);
3492    {$ENDIF}
3493  end;
3494end;
3495
3496function ReadLRSEndianLittleExtendedAsDouble(s: TStream): Double;
3497var
3498  e: array[1..10] of byte;
3499begin
3500  s.Read(e,10);
3501  Result:=ConvertLRSExtendedToDouble(@e);
3502end;
3503
3504function ReadLRSValueType(s: TStream): TValueType;
3505var
3506  b: byte;
3507begin
3508  s.Read(b,1);
3509  Result:=TValueType(b);
3510end;
3511
3512function ReadLRSInt64MB(s: TStream): int64;
3513var
3514  v: TValueType;
3515begin
3516  v:=ReadLRSValueType(s);
3517  case v of
3518  vaInt8: Result:=ReadLRSShortInt(s);
3519  vaInt16: Result:=ReadLRSSmallInt(s);
3520  vaInt32: Result:=ReadLRSInteger(s);
3521  vaInt64: Result:=ReadLRSInt64(s);
3522  else
3523    raise EInOutError.Create('ordinal valuetype missing');
3524  end;
3525end;
3526
3527procedure WriteLRSReversedWord(s: TStream; w: word);
3528begin
3529  w:=(w shr 8) or ((w and $ff) shl 8);
3530  s.Write(w,2);
3531end;
3532
3533procedure WriteLRS4BytesReversed(s: TStream; p: Pointer);
3534var
3535  a: array[0..3] of char;
3536  i: Integer;
3537begin
3538  for i:=0 to 3 do
3539    a[i]:=PChar(p)[3-i];
3540  s.Write(a[0],4);
3541end;
3542
3543procedure WriteLRS8BytesReversed(s: TStream; p: Pointer);
3544var
3545  a: array[0..7] of char;
3546  i: Integer;
3547begin
3548  for i:=0 to 7 do
3549    a[i]:=PChar(p)[7-i];
3550  s.Write(a[0],8);
3551end;
3552
3553procedure WriteLRS10BytesReversed(s: TStream; p: Pointer);
3554var
3555  a: array[0..9] of char;
3556  i: Integer;
3557begin
3558  for i:=0 to 9 do
3559    a[i]:=PChar(p)[9-i];
3560  s.Write(a[0],10);
3561end;
3562
3563procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer);
3564var
3565  w: Word;
3566  i: Integer;
3567begin
3568  for i:=0 to Count-1 do begin
3569    w:=PWord(P)[i];
3570    w:=(w shr 8) or ((w and $ff) shl 8);
3571    s.Write(w,2);
3572  end;
3573end;
3574
3575function FloatToLFMStr(const Value: extended; Precision, Digits: Integer): string;
3576var
3577  P: Integer;
3578  TooSmall, TooLarge: Boolean;
3579  DeletePos: LongInt;
3580begin
3581  Result:='';
3582  If (Precision = -1) or (Precision > 15) then Precision := 15;
3583
3584  TooSmall := (Abs(Value) < 0.00001) and (Value>0.0);
3585  if TooSmall then begin
3586    P := 0;
3587    TooLarge := False;
3588  end
3589  else begin
3590    Str(Value:digits:precision, Result);
3591    P := Pos('.', Result);
3592    TooLarge :=(P > Precision + 1) or (Pos('E', Result)<>0);
3593  End;
3594
3595  if TooSmall or TooLarge then begin
3596    // use exponential format
3597    Str(Value:Precision + 8, Result);
3598    P:=4;
3599    while (P>0) and (Digits < P) and (Result[Precision + 5] = '0') do begin
3600      if P<>1 then
3601        system.Delete(Result, Precision + 5, 1)
3602      else
3603        system.Delete(Result, Precision + 3, 3);
3604      Dec(P);
3605    end;
3606    if Result[1] = ' ' then
3607      System.Delete(Result, 1, 1);
3608    // Strip unneeded zeroes.
3609    P:=Pos('E',result)-1;
3610    If P>=0 then begin
3611      { delete superfluous +? }
3612      if result[p+2]='+' then
3613        system.Delete(Result,P+2,1);
3614      DeletePos:=p;
3615      while (DeletePos>1) and (Result[DeletePos]='0') do
3616        Dec(DeletePos);
3617      if (DeletePos>0) and (Result[DeletePos]=DefaultFormatSettings.DecimalSeparator) Then
3618        Dec(DeletePos);
3619      if (DeletePos<p) then
3620        system.Delete(Result,DeletePos,p-DeletePos);
3621    end;
3622  end
3623  else if (P<>0) then begin
3624    // we have a decimalseparator
3625    P := Length(Result);
3626    While (P>0) and (Result[P] = '0') Do
3627      Dec(P);
3628    If (P>0) and (Result[P]=DefaultFormatSettings.DecimalSeparator) Then
3629      Dec(P);
3630    SetLength(Result, P);
3631  end;
3632end;
3633
3634function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer;
3635var
3636  p1: Int64;
3637  p2: Int64;
3638begin
3639  p1:=PLRPositionLink(Item1)^.LFMPosition;
3640  p2:=PLRPositionLink(Item2)^.LFMPosition;
3641  if p1<p2 then
3642    Result:=1
3643  else if p1>p2 then
3644    Result:=-1
3645  else
3646    Result:=0;
3647end;
3648
3649function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer;
3650var
3651  p1: Int64;
3652  p2: Int64;
3653begin
3654  p1:=PLRPositionLink(Item1)^.LRSPosition;
3655  p2:=PLRPositionLink(Item2)^.LRSPosition;
3656  if p1<p2 then
3657    Result:=1
3658  else if p1>p2 then
3659    Result:=-1
3660  else
3661    Result:=0;
3662end;
3663
3664procedure RegisterPropertyToSkip(PersistentClass: TPersistentClass;
3665  const PropertyName, Note, HelpKeyWord: string);
3666begin
3667  PropertiesToSkip.Add(PersistentClass, PropertyName, Note, HelpKeyWord);
3668end;
3669
3670procedure Register;
3671begin
3672  RegisterComponents('System',[TLazComponentQueue]);
3673end;
3674
3675procedure WriteLRSNull(s: TStream; Count: integer);
3676var
3677  c: char;
3678  i: Integer;
3679begin
3680  c:=#0;
3681  for i:=0 to Count-1 do
3682    s.Write(c,1);
3683end;
3684
3685procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream;
3686  EndBigDouble: PByte);
3687var
3688  e: array[0..9] of byte;
3689begin
3690  ConvertEndianBigDoubleToLRSExtended(EndBigDouble,@e);
3691  s.Write(e[0],10);
3692end;
3693
3694procedure WriteLRSDoubleAsExtended(s: TStream; ADouble: PByte);
3695var
3696  e: array[0..9] of byte;
3697begin
3698  {$ifdef FPC_LITTLE_ENDIAN}
3699  ConvertLEDoubleToLRSExtended(ADouble,@e);
3700  {$else}
3701  ConvertEndianBigDoubleToLRSExtended(ADouble,@e);
3702  {$endif}
3703  s.Write(e[0],10);
3704end;
3705
3706
3707procedure WriteLRSSmallInt(s: TStream; const i: SmallInt);
3708begin
3709  {$IFDEF FPC_LITTLE_ENDIAN}
3710  s.Write(i,2);
3711  {$ELSE}
3712  WriteLRSReversedWord(s,Word(i));
3713  {$ENDIF}
3714end;
3715
3716procedure WriteLRSWord(s: TStream; const w: word);
3717begin
3718  {$IFDEF FPC_LITTLE_ENDIAN}
3719  s.Write(w,2);
3720  {$ELSE}
3721  WriteLRSReversedWord(s,w);
3722  {$ENDIF}
3723end;
3724
3725procedure WriteLRSInteger(s: TStream; const i: integer);
3726begin
3727  {$IFDEF FPC_LITTLE_ENDIAN}
3728  s.Write(i,4);
3729  {$ELSE}
3730  WriteLRS4BytesReversed(s,@i);
3731  {$ENDIF}
3732end;
3733
3734procedure WriteLRSCardinal(s: TStream; const c: cardinal);
3735begin
3736  {$IFDEF FPC_LITTLE_ENDIAN}
3737  s.Write(c,4);
3738  {$ELSE}
3739  WriteLRS4BytesReversed(s,@c);
3740  {$ENDIF}
3741end;
3742
3743procedure WriteLRSSingle(s: TStream; const si: Single);
3744begin
3745  {$IFDEF FPC_LITTLE_ENDIAN}
3746  s.Write(si,4);
3747  {$ELSE}
3748  WriteLRS4BytesReversed(s,@si);
3749  {$ENDIF}
3750end;
3751
3752procedure WriteLRSDouble(s: TStream; const d: Double);
3753begin
3754  {$IFDEF FPC_LITTLE_ENDIAN}
3755  s.Write(d,8);
3756  {$ELSE}
3757  WriteLRS8BytesReversed(s,@d);
3758  {$ENDIF}
3759end;
3760
3761procedure WriteLRSExtended(s: TStream; const e: extended);
3762begin
3763  {$IFDEF FPC_HAS_TYPE_EXTENDED}
3764    {$IFDEF FPC_BIG_ENDIAN}
3765      WriteLRS10BytesReversed(s, @e);
3766    {$ELSE}
3767      s.Write(e,10);
3768    {$ENDIF}
3769  {$ELSE}
3770    WriteLRSDoubleAsExtended(s,pbyte(@e))
3771  {$ENDIF}
3772end;
3773
3774procedure WriteLRSInt64(s: TStream; const i: int64);
3775begin
3776  {$IFDEF FPC_LITTLE_ENDIAN}
3777  s.Write(i,8);
3778  {$ELSE}
3779  WriteLRS8BytesReversed(s,@i);
3780  {$ENDIF}
3781end;
3782
3783procedure WriteLRSCurrency(s: TStream; const c: Currency);
3784begin
3785  {$IFDEF FPC_LITTLE_ENDIAN}
3786  s.Write(c,8);
3787  {$ELSE}
3788  WriteLRS8BytesReversed(s,@c);
3789  {$ENDIF}
3790end;
3791
3792procedure WriteLRSWideStringContent(s: TStream; const w: WideString);
3793var
3794  Size: Integer;
3795begin
3796  Size:=length(w);
3797  if Size=0 then exit;
3798  {$IFDEF FPC_LITTLE_ENDIAN}
3799  s.Write(w[1], Size * 2);
3800  {$ELSE}
3801  WriteLRSReversedWords(s,@w[1],Size);
3802  {$ENDIF}
3803end;
3804
3805procedure WriteLRSInt64MB(s: TStream; const Value: int64);
3806var
3807  w: Word;
3808  i: Integer;
3809  b: Byte;
3810begin
3811  // Use the smallest possible integer type for the given value:
3812  if (Value >= -128) and (Value <= 127) then
3813  begin
3814    b:=byte(vaInt8);
3815    s.Write(b, 1);
3816    b:=byte(Value);
3817    s.Write(b, 1);
3818  end else if (Value >= -32768) and (Value <= 32767) then
3819  begin
3820    b:=byte(vaInt16);
3821    s.Write(b, 1);
3822    w:=Word(Value);
3823    WriteLRSWord(s,w);
3824  end else if (Value >= -$80000000) and (Value <= $7fffffff) then
3825  begin
3826    b:=byte(vaInt32);
3827    s.Write(b, 1);
3828    i:=Integer(Value);
3829    WriteLRSInteger(s,i);
3830  end else
3831  begin
3832    b:=byte(vaInt64);
3833    s.Write(b, 1);
3834    WriteLRSInt64(s,Value);
3835  end;
3836end;
3837
3838{ TLRSObjectReader }
3839
3840procedure TLRSObjectReader.Read(var Buf; Count: LongInt);
3841var
3842  CopyNow: LongInt;
3843  Dest: Pointer;
3844begin
3845  Dest := @Buf;
3846  while Count > 0 do
3847  begin
3848    if FBufPos >= FBufEnd then
3849    begin
3850      FBufEnd := FStream.Read(FBuffer^, FBufSize);
3851      if FBufEnd = 0 then
3852        raise EReadError.Create('Read Error');
3853      FBufPos := 0;
3854    end;
3855    CopyNow := FBufEnd - FBufPos;
3856    if CopyNow > Count then
3857      CopyNow := Count;
3858    Move(PChar(FBuffer)[FBufPos], Dest^, CopyNow);
3859    Inc(FBufPos, CopyNow);
3860    Dest:=Dest+CopyNow;
3861    Dec(Count, CopyNow);
3862  end;
3863end;
3864
3865procedure TLRSObjectReader.SkipProperty;
3866begin
3867  { Skip property name, then the property value }
3868  ReadStr;
3869  SkipValue;
3870end;
3871
3872procedure TLRSObjectReader.SkipSetBody;
3873begin
3874  while Length(ReadStr) > 0 do;
3875end;
3876
3877procedure TLRSObjectReader.Push(ItemType: TLRSItemType; const AName: string;
3878                                Root: TComponent; PushCount: integer);
3879begin
3880  if FStackPointer=FStackCapacity then begin
3881    FStackCapacity:=FStackCapacity*2+10;
3882    ReAllocMem(FStack,SizeOf(TLRSORStackItem)*FStackCapacity);
3883    FillByte(FStack[FStackPointer],SizeOf(TLRSORStackItem)*(FStackCapacity-FStackPointer),0);
3884  end;
3885  //DebugLn(['TLRSObjectReader.Push AName=',AName,' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount]);
3886  FStack[FStackPointer].Name:=AName;
3887  FStack[FStackPointer].ItemType:=ItemType;
3888  FStack[FStackPointer].Root:=Root;
3889  FStack[FStackPointer].PushCount:=PushCount;
3890  FStack[FStackPointer].ItemNr:=-1;
3891  inc(FStackPointer);
3892end;
3893
3894procedure TLRSObjectReader.Pop;
3895var
3896  Item: PLRSORStackItem;
3897begin
3898  if FStackPointer=0 then
3899    raise Exception.Create('Error: TLRSObjectReader.Pop stack is empty');
3900  Item:=@FStack[FStackPointer-1];
3901  //DebugLn(['TLRSObjectReader.Pop AName=',Item^.Name,
3902  //        ' Type=',GetEnumName(TypeInfo(TLRSItemType), Integer(item^.ItemType)),
3903  //        ' PushCount=',item^.PushCount,' StackPtr=', FStackPointer]);
3904  if Item^.PushCount>1 then begin
3905    // stack item still needs more EndList
3906    dec(Item^.PushCount);
3907  end else begin
3908    // stack item is complete
3909    dec(FStackPointer);
3910  end;
3911end;
3912
3913procedure TLRSObjectReader.ClearStack;
3914var
3915  i: Integer;
3916begin
3917  for i:=0 to FStackCapacity-1 do begin
3918    FStack[i].Name:='';
3919  end;
3920  ReAllocMem(FStack,0);
3921end;
3922
3923function TLRSObjectReader.InternalReadValue: TValueType;
3924var
3925  b: byte;
3926begin
3927  Result := vaNull; { Necessary in FPC as TValueType is larger than 1 byte! }
3928  Read(b,1);
3929  Result:=TValueType(b);
3930end;
3931
3932function TLRSObjectReader.ReadIntegerContent: integer;
3933begin
3934  Result:=0;
3935  Read(Result,4);
3936  {$ifdef FPC_BIG_ENDIAN}
3937  ReverseBytes(@Result,4);
3938  {$endif}
3939end;
3940
3941constructor TLRSObjectReader.Create(AStream: TStream; BufSize: Integer);
3942begin
3943  inherited Create;
3944  FStream := AStream;
3945  FBufSize := BufSize;
3946  GetMem(FBuffer, BufSize);
3947end;
3948
3949destructor TLRSObjectReader.Destroy;
3950begin
3951  { Seek back the amount of bytes that we didn't process until now: }
3952  if Assigned(FStream) then
3953    FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), soFromCurrent);
3954
3955  if Assigned(FBuffer) then
3956    FreeMem(FBuffer, FBufSize);
3957
3958  ClearStack;
3959
3960  inherited Destroy;
3961end;
3962
3963function TLRSObjectReader.ReadValue: TValueType;
3964begin
3965  Result := InternalReadValue;
3966  case Result of
3967    vaNull:
3968      begin
3969        EndPropertyIfOpen;
3970        // End previous element collection, list or component.
3971        if FStackPointer > 0 then
3972          Pop;
3973      end;
3974    vaCollection:
3975      begin
3976        Push(lrsitCollection);
3977      end;
3978    vaList:
3979      begin
3980        // Increase counter for next collection item.
3981        if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
3982          Inc(FStack[FStackPointer-1].ItemNr);
3983        Push(lrsitList);
3984      end;
3985  end;
3986end;
3987
3988function TLRSObjectReader.NextValue: TValueType;
3989begin
3990  Result := InternalReadValue;
3991  { We only 'peek' at the next value, so seek back to unget the read value: }
3992  Dec(FBufPos);
3993end;
3994
3995procedure TLRSObjectReader.BeginRootComponent;
3996var
3997  Signature: TFilerSignature;
3998begin
3999  { Read filer signature }
4000  Signature:='1234';
4001  Read(Signature[1],length(Signature));
4002  if Signature <> FilerSignature then
4003    raise EReadError.Create('Invalid Filer Signature');
4004end;
4005
4006procedure TLRSObjectReader.BeginComponent(var Flags: TFilerFlags;
4007  var AChildPos: Integer; var CompClassName, CompName: String);
4008var
4009  Prefix: Byte;
4010  ValueType: TValueType;
4011  ItemName: String;
4012  ItemRoot: TComponent;
4013begin
4014  { Every component can start with a special prefix: }
4015  Flags := [];
4016  if (Byte(NextValue) and $f0) = $f0 then
4017  begin
4018    Prefix := Byte(ReadValue);
4019    if (ObjStreamMaskInherited and Prefix)<>0 then
4020      Include(Flags,ffInherited);
4021    if (ObjStreamMaskInline and Prefix)<>0 then
4022      Include(Flags,ffInline);
4023    if (ObjStreamMaskChildPos and Prefix)<>0 then
4024    begin
4025      Include(Flags,ffChildPos);
4026      ValueType := ReadValue;
4027      case ValueType of
4028        vaInt8:
4029          AChildPos := ReadInt8;
4030        vaInt16:
4031          AChildPos := ReadInt16;
4032        vaInt32:
4033          AChildPos := ReadInt32;
4034        else
4035          PropValueError;
4036      end;
4037    end;
4038  end;
4039
4040  CompClassName := ReadStr;
4041  CompName := ReadStr;
4042
4043  // Top component is addressed by ClassName.
4044  if FStackPointer = 0 then
4045  begin
4046    ItemName := CompClassName;
4047    ItemRoot := nil;
4048  end
4049  else
4050  begin
4051    ItemName := CompName;
4052    if Assigned(Reader) then
4053      // Reader.LookupRoot is the current Root component.
4054      ItemRoot := Reader.LookupRoot
4055    else
4056      ItemRoot := nil;
4057  end;
4058
4059  // A component has two lists: properties and childs, hence PopCount=2.
4060  Push(lrsitComponent, ItemName, ItemRoot, 2);
4061end;
4062
4063function TLRSObjectReader.BeginProperty: String;
4064begin
4065  EndPropertyIfOpen;
4066  Result := ReadStr;
4067  Push(lrsitProperty, Result);
4068end;
4069
4070procedure TLRSObjectReader.EndPropertyIfOpen;
4071begin
4072  // End previous property.
4073  if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitProperty) then
4074    Pop;
4075end;
4076
4077function TLRSObjectReader.GetStackPath: string;
4078var
4079  i: Integer;
4080  CurName: string;
4081  Item: PLRSORStackItem;
4082begin
4083  Result:='';
4084
4085  for i:=0 to FStackPointer-1 do
4086  begin
4087    Item := @FStack[i];
4088
4089    // Reader.Root is the top component in the module.
4090    if Assigned(Reader) and
4091       (Item^.ItemType = lrsitComponent) and
4092       (Item^.Root = Reader.Root) and
4093       (Item^.Root <> nil) then
4094    begin
4095      // Restart path from top component.
4096      Result := Item^.Root.ClassName;
4097    end;
4098
4099    CurName:=Item^.Name;
4100    if CurName<>'' then begin
4101      if Result<>'' then Result:=Result+'.';
4102      Result:=Result+CurName;
4103    end;
4104    if Item^.ItemNr >= 0 then
4105      Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
4106  end;
4107end;
4108
4109procedure TLRSObjectReader.ReadBinary(const DestData: TMemoryStream);
4110var
4111  BinSize: LongInt;
4112begin
4113  BinSize:=ReadIntegerContent;
4114  DestData.Size := BinSize;
4115  Read(DestData.Memory^, BinSize);
4116end;
4117
4118function TLRSObjectReader.ReadFloat: Extended;
4119{$ifndef FPC_HAS_TYPE_EXTENDED}
4120var
4121  e: array[1..10] of byte;
4122{$endif}
4123begin
4124  Result:=0;
4125  {$ifdef FPC_HAS_TYPE_EXTENDED}
4126    Read(Result, 10);
4127    {$ifdef FPC_BIG_ENDIAN}
4128      ReverseBytes(@Result, 10);
4129    {$endif FPC_BIG_ENDIAN}
4130  {$else FPC_HAS_TYPE_EXTENDED}
4131    Read(e, 10);
4132    Result := ConvertLRSExtendedToDouble(@e);
4133  {$endif FPC_HAS_TYPE_EXTENDED}
4134end;
4135
4136function TLRSObjectReader.ReadSingle: Single;
4137begin
4138  Result:=0;
4139  Read(Result, 4);
4140  {$ifdef FPC_BIG_ENDIAN}
4141  ReverseBytes(@Result,4);
4142  {$endif}
4143end;
4144
4145function TLRSObjectReader.ReadCurrency: Currency;
4146begin
4147  Result:=0;
4148  Read(Result, 8);
4149  {$ifdef FPC_BIG_ENDIAN}
4150  ReverseBytes(@Result,8);
4151  {$endif}
4152end;
4153
4154function TLRSObjectReader.ReadDate: TDateTime;
4155begin
4156  Result:=0;
4157  Read(Result, 8);
4158  {$ifdef FPC_BIG_ENDIAN}
4159  ReverseBytes(@Result,8);
4160  {$endif}
4161end;
4162
4163function TLRSObjectReader.ReadIdent(ValueType: TValueType): String;
4164var
4165  b: Byte;
4166begin
4167  case ValueType of
4168    vaIdent:
4169      begin
4170        Read(b, 1);
4171        SetLength(Result, b);
4172        if ( b > 0 ) then
4173          Read(Result[1], b);
4174      end;
4175    vaNil:
4176      Result := 'nil';
4177    vaFalse:
4178      Result := 'False';
4179    vaTrue:
4180      Result := 'True';
4181    vaNull:
4182      Result := 'Null';
4183  else
4184    Result:='';
4185    RaiseGDBException('');
4186  end;
4187end;
4188
4189function TLRSObjectReader.ReadInt8: ShortInt;
4190begin
4191  Result:=0;
4192  Read(Result, 1);
4193end;
4194
4195function TLRSObjectReader.ReadInt16: SmallInt;
4196begin
4197  Result:=0;
4198  Read(Result, 2);
4199  {$ifdef FPC_BIG_ENDIAN}
4200  ReverseBytes(@Result,2);
4201  {$endif}
4202end;
4203
4204function TLRSObjectReader.ReadInt32: LongInt;
4205begin
4206  Result:=0;
4207  Read(Result, 4);
4208  {$ifdef FPC_BIG_ENDIAN}
4209  ReverseBytes(@Result,4);
4210  {$endif}
4211end;
4212
4213function TLRSObjectReader.ReadInt64: Int64;
4214begin
4215  Result:=0;
4216  Read(Result, 8);
4217  {$ifdef FPC_BIG_ENDIAN}
4218  ReverseBytes(@Result,8);
4219  {$endif}
4220end;
4221
4222function TLRSObjectReader.ReadSet(EnumType: Pointer): Integer;
4223type
4224  tset = set of 0..31;
4225var
4226  OName: String;
4227  OValue: Integer;
4228begin
4229  try
4230    Result := 0;
4231    while True do
4232    begin
4233      OName := ReadStr;
4234      if Length(OName) = 0 then
4235        break;
4236      OValue := GetEnumValue(PTypeInfo(EnumType), OName);
4237      // Eg. "Options" is a set and can give an error when changing component type.
4238      // Do nothing on error (OValue = -1), was PropValueError;  (JuMa)
4239      if OValue >= 0 then
4240        include(tset(result),OValue);
4241    end;
4242  except
4243    SkipSetBody;
4244    raise;
4245  end;
4246end;
4247
4248{$IF FPC_FULLVERSION >= 30000}
4249procedure TLRSObjectReader.ReadSignature;
4250begin
4251end;
4252{$ENDIF}
4253
4254function TLRSObjectReader.ReadStr: String;
4255var
4256  b: Byte;
4257begin
4258  Read(b, 1);
4259  SetLength(Result, b);
4260  if b > 0 then
4261    Read(Result[1], b);
4262end;
4263
4264function TLRSObjectReader.ReadString(StringType: TValueType): String;
4265var
4266  i: Integer;
4267  b: byte;
4268begin
4269  case StringType of
4270    vaString:
4271      begin
4272        Read(b, 1);
4273        i:=b;
4274      end;
4275    vaLString:
4276      i:=ReadIntegerContent;
4277  else
4278    raise Exception.Create('TLRSObjectReader.ReadString invalid StringType');
4279  end;
4280  SetLength(Result, i);
4281  if i > 0 then
4282    Read(Pointer(@Result[1])^, i);
4283end;
4284
4285function TLRSObjectReader.ReadWideString: WideString;
4286var
4287  i: Integer;
4288begin
4289  i:=ReadIntegerContent;
4290  SetLength(Result, i);
4291  if i > 0 then
4292    Read(Pointer(@Result[1])^, i*2);
4293  //debugln('TLRSObjectReader.ReadWideString ',Result);
4294end;
4295
4296function TLRSObjectReader.ReadUnicodeString: UnicodeString;
4297var
4298  i: Integer;
4299begin
4300  i:=ReadIntegerContent;
4301  SetLength(Result, i);
4302  if i > 0 then
4303    Read(Pointer(@Result[1])^, i*2);
4304  //debugln('TLRSObjectReader.ReadWideString ',Result);
4305end;
4306
4307procedure TLRSObjectReader.SkipComponent(SkipComponentInfos: Boolean);
4308var
4309  Flags: TFilerFlags;
4310  Dummy: Integer;
4311  CompClassName, CompName: String;
4312begin
4313  if SkipComponentInfos then
4314    { Skip prefix, component class name and component object name }
4315    BeginComponent(Flags, Dummy, CompClassName, CompName);
4316
4317  { Skip properties }
4318  while NextValue <> vaNull do
4319    SkipProperty;
4320  ReadValue;
4321
4322  { Skip children }
4323  while NextValue <> vaNull do
4324    SkipComponent(True);
4325  ReadValue;
4326end;
4327
4328procedure TLRSObjectReader.SkipValue;
4329
4330  procedure SkipBytes(Count: LongInt);
4331  var
4332    Dummy: array[0..1023] of Byte;
4333    SkipNow: Integer;
4334  begin
4335    while Count > 0 do
4336    begin
4337      if Count > 1024 then
4338        SkipNow := 1024
4339      else
4340        SkipNow := Count;
4341      Read(Dummy, SkipNow);
4342      Dec(Count, SkipNow);
4343    end;
4344  end;
4345
4346var
4347  Count: LongInt;
4348begin
4349  case ReadValue of
4350    vaNull, vaFalse, vaTrue, vaNil: ;
4351    vaList:
4352      begin
4353        while NextValue <> vaNull do
4354          SkipValue;
4355        ReadValue;
4356      end;
4357    vaInt8:
4358      SkipBytes(1);
4359    vaInt16:
4360      SkipBytes(2);
4361    vaInt32:
4362      SkipBytes(4);
4363    vaExtended:
4364      SkipBytes(10);
4365    vaString, vaIdent:
4366      ReadStr;
4367    vaBinary, vaLString:
4368      begin
4369        Count:=ReadIntegerContent;
4370        SkipBytes(Count);
4371      end;
4372    vaWString, vaUString:
4373      begin
4374        Count:=ReadIntegerContent;
4375        SkipBytes(Count*2);
4376      end;
4377    vaSet:
4378      SkipSetBody;
4379    vaCollection:
4380      begin
4381        while NextValue <> vaNull do
4382        begin
4383          { Skip the order value if present }
4384          if NextValue in [vaInt8, vaInt16, vaInt32] then
4385            SkipValue;
4386          SkipBytes(1);
4387          while NextValue <> vaNull do
4388            SkipProperty;
4389          ReadValue;
4390        end;
4391        ReadValue;
4392      end;
4393    vaSingle:
4394      SkipBytes(4);
4395    vaCurrency:
4396      SkipBytes(SizeOf(Currency));
4397    vaDate:
4398      SkipBytes(8);
4399    vaInt64:
4400      SkipBytes(8);
4401  else
4402    RaiseGDBException('TLRSObjectReader.SkipValue unknown valuetype');
4403  end;
4404end;
4405
4406{ TLRSObjectWriter }
4407
4408procedure TLRSObjectWriter.Push(ItemType: TLRSItemType; const AName: string;
4409                                Root: TComponent; PushCount: integer;
4410                                SkipIfEmpty: boolean);
4411begin
4412  if FStackPointer=FStackCapacity then begin
4413    FStackCapacity:=FStackCapacity*2+10;
4414    ReAllocMem(FStack,SizeOf(TLRSOWStackItem)*FStackCapacity);
4415    FillByte(FStack[FStackPointer],SizeOf(TLRSOWStackItem)*(FStackCapacity-FStackPointer),0);
4416  end;
4417  //if AName<>'' then DebugLn(['TLRSObjectWriter.Push AName=',AName, ' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount,' SkipIfEmpty=',SkipIfEmpty]);
4418  FStack[FStackPointer].Name:=AName;
4419  FStack[FStackPointer].ItemType:=ItemType;
4420  FStack[FStackPointer].Root:=Root;
4421  FStack[FStackPointer].PushCount:=PushCount;
4422  FStack[FStackPointer].ItemNr:=-1;
4423  FStack[FStackPointer].SkipIfEmpty:=SkipIfEmpty;
4424  FStack[FStackPointer].BufCount:=0;
4425  if SkipIfEmpty then
4426    FStack[FStackPointer].State:=lrsowsisStarted
4427  else begin
4428    FlushStackToStream;
4429    FStack[FStackPointer].State:=lrsowsisDataWritten;
4430  end;
4431  inc(FStackPointer);
4432end;
4433
4434procedure TLRSObjectWriter.EndHeader;
4435var
4436  Item: PLRSOWStackItem;
4437begin
4438  Item:=@FStack[FStackPointer-1];
4439  if Item^.State=lrsowsisStarted then
4440    Item^.State:=lrsowsisHeaderWritten;
4441end;
4442
4443procedure TLRSObjectWriter.Pop(WriteNull: boolean);
4444var
4445  Item: PLRSOWStackItem;
4446begin
4447  if FStackPointer=0 then
4448    raise Exception.Create('Error: TLRSObjectWriter.Pop stack is empty');
4449  Item:=@FStack[FStackPointer-1];
4450  if Item^.PushCount>1 then begin
4451    // stack item still needs more EndList
4452    dec(Item^.PushCount);
4453    if WriteNull then begin
4454      if Item^.State=lrsowsisHeaderWritten then begin
4455        // no data yet, append EndList to header
4456        Item^.State:=lrsowsisStarted;
4457        WriteValue(vaNull);
4458        // wait again for data
4459        Item^.State:=lrsowsisHeaderWritten;
4460      end else begin
4461        // write EndList to stream
4462        WriteValue(vaNull);
4463      end;
4464    end;
4465  end else begin
4466    // stack item is complete
4467    dec(FStackPointer);
4468    //if Item^.BufCount>0 then DebugLn(['TLRSObjectWriter.Pop SKIPPED: ',Item^.Name]);
4469    if (Item^.State=lrsowsisDataWritten) and WriteNull then
4470      WriteValue(vaNull);
4471  end;
4472end;
4473
4474procedure TLRSObjectWriter.ClearStack;
4475var
4476  i: Integer;
4477begin
4478  for i:=0 to FStackCapacity-1 do begin
4479    FStack[i].Name:='';
4480    ReAllocMem(FStack[i].Buffer,0);
4481  end;
4482  ReAllocMem(FStack,0);
4483end;
4484
4485procedure TLRSObjectWriter.FlushStackToStream;
4486var
4487  i: Integer;
4488  Item: PLRSOWStackItem;
4489begin
4490  for i:=0 to FStackPointer-1 do begin
4491    Item:=@FStack[i];
4492    if Item^.State<>lrsowsisDataWritten then begin
4493      //DebugLn(['TLRSObjectWriter.Write FLUSH from stack to stream']);
4494      Item^.State:=lrsowsisDataWritten;
4495      WriteToStream(Item^.Buffer^,Item^.BufCount);
4496      Item^.BufCount:=0;
4497    end;
4498  end;
4499end;
4500
4501procedure TLRSObjectWriter.WriteToStream(const Buffer; Count: Longint);
4502var
4503  CopyNow: LongInt;
4504  SourceBuf: PChar;
4505begin
4506  //DebugLn(['TLRSObjectWriter.WriteToStream ',dbgMemRange(@Buffer,Count,80)]);
4507  if Count<2*FBufSize then begin
4508    // write a small amount of data
4509    SourceBuf:=@Buffer;
4510    while Count > 0 do
4511    begin
4512      CopyNow := Count;
4513      if CopyNow > FBufSize - FBufPos then
4514        CopyNow := FBufSize - FBufPos;
4515      Move(SourceBuf^, PChar(FBuffer)[FBufPos], CopyNow);
4516      Dec(Count, CopyNow);
4517      Inc(FBufPos, CopyNow);
4518      SourceBuf:=SourceBuf+CopyNow;
4519      if FBufPos = FBufSize then
4520        FlushBuffer;
4521    end;
4522  end else begin
4523    // write a big amount of data
4524    if FBufPos>0 then
4525      FlushBuffer;
4526    FStream.WriteBuffer(Buffer, Count);
4527  end;
4528end;
4529
4530procedure TLRSObjectWriter.FlushBuffer;
4531begin
4532  FStream.WriteBuffer(FBuffer^, FBufPos);
4533  FBufPos := 0;
4534end;
4535
4536procedure TLRSObjectWriter.Write(const Buffer; Count: Longint);
4537var
4538  Item: PLRSOWStackItem;
4539begin
4540  if Count=0 then exit;
4541  if (FStackPointer>0) then
4542  begin
4543    Item:=@FStack[FStackPointer-1];
4544    case Item^.State of
4545    lrsowsisStarted:
4546      begin
4547        // store data on stack
4548        //DebugLn(['TLRSObjectWriter.Write STORE data on stack']);
4549        if Item^.BufCount+Count>Item^.BufCapacity then
4550        begin
4551          Item^.BufCapacity:=Item^.BufCount+Count+10;
4552          ReAllocMem(Item^.Buffer,Item^.BufCapacity);
4553        end;
4554        System.Move(Buffer,PByte(Item^.Buffer)[Item^.BufCount],Count);
4555        inc(Item^.BufCount,Count);
4556        exit;
4557      end;
4558    lrsowsisHeaderWritten:
4559      begin
4560        // flush header(s) from stack to stream
4561        FlushStackToStream;
4562      end;
4563    end;
4564  end;
4565  // write data to stream
4566  WriteToStream(Buffer,Count);
4567end;
4568
4569procedure TLRSObjectWriter.WriteValue(Value: TValueType);
4570var
4571  b: byte;
4572begin
4573  b:=byte(Value);
4574  Write(b, 1);
4575end;
4576
4577procedure TLRSObjectWriter.WriteStr(const Value: String);
4578var
4579  i: Integer;
4580  b: Byte;
4581begin
4582  i := Length(Value);
4583  if i > 255 then
4584    i := 255;
4585  b:=byte(i);
4586  Write(b,1);
4587  if i > 0 then
4588    Write(Value[1], i);
4589end;
4590
4591procedure TLRSObjectWriter.WriteIntegerContent(i: integer);
4592begin
4593  {$IFDEF FPC_BIG_ENDIAN}
4594  ReverseBytes(@i,4);
4595  {$ENDIF}
4596  Write(i,4);
4597end;
4598
4599procedure TLRSObjectWriter.WriteWordContent(w: word);
4600begin
4601  {$IFDEF FPC_BIG_ENDIAN}
4602  ReverseBytes(@w,2);
4603  {$ENDIF}
4604  Write(w,2);
4605end;
4606
4607procedure TLRSObjectWriter.WriteInt64Content(i: int64);
4608begin
4609  {$IFDEF FPC_BIG_ENDIAN}
4610  ReverseBytes(@i,8);
4611  {$ENDIF}
4612  Write(i,8);
4613end;
4614
4615procedure TLRSObjectWriter.WriteSingleContent(s: single);
4616begin
4617  {$IFDEF FPC_BIG_ENDIAN}
4618  ReverseBytes(@s,4);
4619  {$ENDIF}
4620  Write(s,4);
4621end;
4622
4623procedure TLRSObjectWriter.WriteDoubleContent(d: Double);
4624begin
4625  {$IFDEF FPC_BIG_ENDIAN}
4626  ReverseBytes(@d,8);
4627  {$ENDIF}
4628  Write(d,8);
4629end;
4630
4631procedure TLRSObjectWriter.WriteExtendedContent(e: Extended);
4632{$IFNDEF FPC_HAS_TYPE_EXTENDED}
4633var
4634  LRSExtended: array[1..10] of byte;
4635{$endif}
4636begin
4637  {$IFDEF FPC_HAS_TYPE_EXTENDED}
4638    {$IFDEF FPC_BIG_ENDIAN}
4639      ReverseBytes(@e,10);
4640    {$ENDIF}
4641      Write(e,10);
4642  {$ELSE}
4643    {$IFDEF FPC_BIG_ENDIAN}
4644      ConvertEndianBigDoubleToLRSExtended(@e,@LRSExtended);
4645    {$ELSE}
4646      ConvertLEDoubleToLRSExtended(@e,@LRSExtended);
4647    {$ENDIF}
4648      Write(LRSExtended,10);
4649  {$ENDIF}
4650end;
4651
4652procedure TLRSObjectWriter.WriteCurrencyContent(c: Currency);
4653begin
4654  {$IFDEF FPC_BIG_ENDIAN}
4655  ReverseBytes(@c,8);
4656  {$ENDIF}
4657  Write(c,8);
4658end;
4659
4660procedure TLRSObjectWriter.WriteWideStringContent(const ws: WideString);
4661begin
4662  if ws='' then exit;
4663  {$IFDEF FPC_BIG_ENDIAN}
4664  WriteWordsReversed(PWord(@ws[1]),length(ws));
4665  {$ELSE}
4666  Write(ws[1],length(ws)*2);
4667  {$ENDIF}
4668end;
4669
4670procedure TLRSObjectWriter.WriteWordsReversed(p: PWord; Count: integer);
4671var
4672  i: Integer;
4673  w: Word;
4674begin
4675  for i:=0 to Count-1 do begin
4676    w:=p[i];
4677    w:=((w and $ff) shl 8) or (w and $ff);
4678    Write(w,2);
4679  end;
4680end;
4681
4682procedure TLRSObjectWriter.WriteNulls(Count: integer);
4683var
4684  c: Char;
4685  i: Integer;
4686begin
4687  c:=#0;
4688  for i:=0 to Count-1 do Write(c,1);
4689end;
4690
4691constructor TLRSObjectWriter.Create(Stream: TStream; BufSize: Integer);
4692begin
4693  inherited Create;
4694  FStream := Stream;
4695  FBufSize := BufSize;
4696  GetMem(FBuffer, BufSize);
4697end;
4698
4699destructor TLRSObjectWriter.Destroy;
4700begin
4701  // Flush all data which hasn't been written yet
4702  if Assigned(FStream) then
4703    FlushBuffer;
4704
4705  if Assigned(FBuffer) then begin
4706    FreeMem(FBuffer, FBufSize);
4707    FBuffer:=nil;
4708  end;
4709
4710  ClearStack;
4711
4712  inherited Destroy;
4713end;
4714
4715procedure TLRSObjectWriter.BeginCollection;
4716begin
4717  //DebugLn(['TLRSObjectWriter.BeginCollection ',FStackPointer]);
4718  Push(lrsitCollection);
4719  WriteValue(vaCollection);
4720end;
4721
4722procedure TLRSObjectWriter.BeginComponent(Component: TComponent;
4723  Flags: TFilerFlags; ChildPos: Integer);
4724var
4725  Prefix: Byte;
4726  CanBeOmitted: boolean;
4727  ItemName: String;
4728  ItemRoot: TComponent;
4729begin
4730  //DebugLn(['TLRSObjectWriter.BeginComponent ',FStackPointer]);
4731  // an inherited child component can be omitted if empty
4732  CanBeOmitted:=(not WriteEmptyInheritedChilds)
4733            and (FStackPointer>0) and (ffInherited in Flags)
4734            and (not (ffChildPos in Flags));
4735
4736  // Top component is addressed by ClassName.
4737  if FStackPointer = 0 then
4738  begin
4739    ItemName := Component.ClassName;
4740    ItemRoot := nil;
4741  end
4742  else
4743  begin
4744    ItemName := Component.Name;
4745    if Assigned(Writer) then
4746      // Writer.Root is the current Root component.
4747      ItemRoot := Writer.Root
4748    else
4749      ItemRoot := nil;
4750  end;
4751
4752  // A component has two lists: properties and childs, hence PopCount=2.
4753  Push(lrsitComponent, ItemName, ItemRoot, 2, CanBeOmitted);
4754
4755  if not FSignatureWritten then
4756  begin
4757    Write(FilerSignature[1], length(FilerSignature));
4758    FSignatureWritten := True;
4759  end;
4760
4761  { Only write the flags if they are needed! }
4762  if Flags <> [] then
4763  begin
4764    Prefix := $f0;
4765    if ffInherited in Flags then
4766      inc(Prefix,ObjStreamMaskInherited);
4767    if ffInline in Flags then
4768      inc(Prefix,ObjStreamMaskInline);
4769    if ffChildPos in Flags then
4770      inc(Prefix,ObjStreamMaskChildPos);
4771    Write(Prefix, 1);
4772    if ffChildPos in Flags then
4773      WriteInteger(ChildPos);
4774  end;
4775
4776  WriteStr(Component.ClassName);
4777  WriteStr(Component.Name);
4778
4779  EndHeader;
4780end;
4781
4782{$IF FPC_FULLVERSION >= 30000}
4783procedure TLRSObjectWriter.WriteSignature;
4784begin
4785end;
4786{$ENDIF}
4787
4788procedure TLRSObjectWriter.BeginList;
4789begin
4790  // Increase counter for next collection item.
4791  if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
4792    Inc(FStack[FStackPointer-1].ItemNr);
4793  //DebugLn(['TLRSObjectWriter.BeginList ',FStackPointer]);
4794  Push(lrsitList);
4795  WriteValue(vaList);
4796end;
4797
4798procedure TLRSObjectWriter.EndList;
4799begin
4800  //DebugLn(['TLRSObjectWriter.EndList ',FStackPointer]);
4801  Pop(true);
4802end;
4803
4804procedure TLRSObjectWriter.BeginProperty(const PropName: String);
4805begin
4806  //DebugLn(['TLRSObjectWriter.BeginProperty ',FStackPointer,' ',PropName]);
4807  Push(lrsitProperty, PropName);
4808  WriteStr(PropName);
4809end;
4810
4811procedure TLRSObjectWriter.EndProperty;
4812begin
4813  //DebugLn(['TLRSObjectWriter.EndProperty ',FStackPointer]);
4814  Pop(false);
4815end;
4816
4817function TLRSObjectWriter.GetStackPath: string;
4818var
4819  i: Integer;
4820  CurName: string;
4821  Item: PLRSOWStackItem;
4822begin
4823  Result:='';
4824
4825  for i:=0 to FStackPointer-1 do
4826  begin
4827    Item := @FStack[i];
4828
4829    // Writer.LookupRoot is the top component in the module.
4830    if Assigned(Writer) and
4831       (Item^.ItemType = lrsitComponent) and
4832       (Item^.Root = Writer.LookupRoot) and
4833       (Item^.Root <> nil) then
4834    begin
4835      // Restart path from top component.
4836      Result := Item^.Root.ClassName;
4837    end;
4838
4839    CurName:=Item^.Name;
4840    if CurName<>'' then begin
4841      if Result<>'' then Result:=Result+'.';
4842      Result:=Result+CurName;
4843    end;
4844    if Item^.ItemNr >= 0 then
4845      Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
4846  end;
4847end;
4848
4849procedure TLRSObjectWriter.WriteBinary(const Buffer; Count: LongInt);
4850begin
4851  WriteValue(vaBinary);
4852  WriteIntegerContent(Count);
4853  Write(Buffer, Count);
4854end;
4855
4856procedure TLRSObjectWriter.WriteBoolean(Value: Boolean);
4857begin
4858  if Value then
4859    WriteValue(vaTrue)
4860  else
4861    WriteValue(vaFalse);
4862end;
4863
4864procedure TLRSObjectWriter.WriteFloat(const Value: Extended);
4865begin
4866  WriteValue(vaExtended);
4867  WriteExtendedContent(Value);
4868end;
4869
4870procedure TLRSObjectWriter.WriteSingle(const Value: Single);
4871begin
4872  WriteValue(vaSingle);
4873  WriteSingleContent(Value);
4874end;
4875
4876procedure TLRSObjectWriter.WriteCurrency(const Value: Currency);
4877begin
4878  WriteValue(vaCurrency);
4879  WriteCurrencyContent(Value);
4880end;
4881
4882procedure TLRSObjectWriter.WriteDate(const Value: TDateTime);
4883begin
4884  WriteValue(vaDate);
4885  WriteDoubleContent(Value);
4886end;
4887
4888procedure TLRSObjectWriter.WriteIdent(const Ident: string);
4889begin
4890  { Check if Ident is a special identifier before trying to just write
4891    Ident directly }
4892  if UpperCase(Ident) = 'NIL' then
4893    WriteValue(vaNil)
4894  else if UpperCase(Ident) = 'FALSE' then
4895    WriteValue(vaFalse)
4896  else if UpperCase(Ident) = 'TRUE' then
4897    WriteValue(vaTrue)
4898  else if UpperCase(Ident) = 'NULL' then
4899    WriteValue(vaNull) else
4900  begin
4901    WriteValue(vaIdent);
4902    WriteStr(Ident);
4903  end;
4904end;
4905
4906procedure TLRSObjectWriter.WriteInteger(Value: Int64);
4907var
4908  w: Word;
4909  i: Integer;
4910  b: Byte;
4911begin
4912  //debugln('TLRSObjectWriter.WriteInteger Value=',Value);
4913  // Use the smallest possible integer type for the given value:
4914  if (Value >= -128) and (Value <= 127) then
4915  begin
4916    WriteValue(vaInt8);
4917    b:=Byte(Value);
4918    Write(b, 1);
4919  end else if (Value >= -32768) and (Value <= 32767) then
4920  begin
4921    WriteValue(vaInt16);
4922    w:=Word(Value);
4923    WriteWordContent(w);
4924  end else if (Value >= -$80000000) and (Value <= $7fffffff) then
4925  begin
4926    WriteValue(vaInt32);
4927    i:=Integer(Value);
4928    WriteIntegerContent(i);
4929  end else
4930  begin
4931    WriteValue(vaInt64);
4932    WriteInt64Content(Value);
4933  end;
4934end;
4935
4936procedure TLRSObjectWriter.WriteMethodName(const Name: String);
4937begin
4938  if Length(Name) > 0 then
4939  begin
4940    WriteValue(vaIdent);
4941    WriteStr(Name);
4942  end else
4943    WriteValue(vaNil);
4944end;
4945
4946procedure TLRSObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
4947type
4948  tset = set of 0..31;
4949var
4950  i: Integer;
4951begin
4952  WriteValue(vaSet);
4953  for i := 0 to 31 do
4954  begin
4955    if (i in tset(Value)) then
4956      WriteStr(GetEnumName(PTypeInfo(SetType), i));
4957  end;
4958  WriteStr('');
4959end;
4960
4961procedure TLRSObjectWriter.WriteString(const Value: String);
4962var
4963  i: Integer;
4964  b: Byte;
4965begin
4966  i := Length(Value);
4967  if i <= 255 then
4968  begin
4969    WriteValue(vaString);
4970    b:=byte(i);
4971    Write(b, 1);
4972  end else
4973  begin
4974    WriteValue(vaLString);
4975    WriteIntegerContent(i);
4976  end;
4977  if i > 0 then
4978    Write(Value[1], i);
4979end;
4980
4981procedure TLRSObjectWriter.WriteWideString(const Value: WideString);
4982var
4983  i: Integer;
4984begin
4985  WriteValue(vaWString);
4986  i := Length(Value);
4987  WriteIntegerContent(i);
4988  WriteWideStringContent(Value);
4989end;
4990
4991procedure TLRSObjectWriter.WriteUnicodeString(const Value: UnicodeString);
4992var
4993  i: Integer;
4994begin
4995  WriteValue(vaUString);
4996  i := Length(Value);
4997  WriteIntegerContent(i);
4998  WriteWideStringContent(Value);
4999end;
5000
5001procedure TLRSObjectWriter.WriteVariant(const Value: Variant);
5002begin
5003  case VarType(Value) of
5004    varnull:
5005      WriteValue(vaNull);
5006    varsmallint, varinteger, varshortint, varint64, varbyte, varword, varlongword, varqword:
5007      WriteInteger(Value);
5008    varsingle:
5009      WriteSingle(Value);
5010    vardouble:
5011      WriteFloat(Value);
5012    vardate:
5013      WriteDate(Value);
5014    varcurrency:
5015      WriteCurrency(Value);
5016    varolestr, varstring:
5017      WriteString(Value);
5018    varboolean:
5019      WriteBoolean(Value);
5020    else
5021      WriteValue(vaNil);
5022  end;
5023end;
5024
5025{ TLRPositionLinks }
5026
5027function TLRPositionLinks.GetLFM(Index: integer): Int64;
5028begin
5029  Result:=PLRPositionLink(FItems[Index])^.LFMPosition;
5030end;
5031
5032function TLRPositionLinks.GetData(Index: integer): Pointer;
5033begin
5034  Result:=PLRPositionLink(FItems[Index])^.Data;
5035end;
5036
5037function TLRPositionLinks.GetLRS(Index: integer): Int64;
5038begin
5039  Result:=PLRPositionLink(FItems[Index])^.LRSPosition;
5040end;
5041
5042procedure TLRPositionLinks.SetCount(const AValue: integer);
5043var
5044  i: LongInt;
5045  Item: PLRPositionLink;
5046begin
5047  if FCount=AValue then exit;
5048  // free old items
5049  for i:=AValue to FCount-1 do begin
5050    Item:=PLRPositionLink(FItems[i]);
5051    Dispose(Item);
5052  end;
5053  // create new items
5054  FItems.Count:=AValue;
5055  for i:=FCount to AValue-1 do begin
5056    New(Item);
5057    Item^.LFMPosition:=-1;
5058    Item^.LRSPosition:=-1;
5059    Item^.Data:=nil;
5060    FItems[i]:=Item;
5061  end;
5062  FCount:=AValue;
5063end;
5064
5065procedure TLRPositionLinks.SetData(Index: integer; const AValue: Pointer);
5066begin
5067  PLRPositionLink(FItems[Index])^.Data:=AValue;
5068end;
5069
5070procedure TLRPositionLinks.SetLFM(Index: integer; const AValue: Int64);
5071begin
5072  PLRPositionLink(FItems[Index])^.LFMPosition:=AValue;
5073end;
5074
5075procedure TLRPositionLinks.SetLRS(Index: integer; const AValue: Int64);
5076begin
5077  PLRPositionLink(FItems[Index])^.LRSPosition:=AValue;
5078end;
5079
5080constructor TLRPositionLinks.Create;
5081begin
5082  FItems:=TFPList.Create;
5083end;
5084
5085destructor TLRPositionLinks.Destroy;
5086begin
5087  Count:=0;
5088  FItems.Free;
5089  inherited Destroy;
5090end;
5091
5092procedure TLRPositionLinks.Clear;
5093begin
5094  Count:=0;
5095end;
5096
5097procedure TLRPositionLinks.Sort(LFMPositions: Boolean);
5098begin
5099  if LFMPositions then
5100    FItems.Sort(@CompareLRPositionLinkWithLFMPosition)
5101  else
5102    FItems.Sort(@CompareLRPositionLinkWithLRSPosition)
5103end;
5104
5105function TLRPositionLinks.IndexOf(const Position: int64; LFMPositions: Boolean
5106  ): integer;
5107var
5108  l, r, m: integer;
5109  p: Int64;
5110begin
5111  // binary search for the line
5112  l:=0;
5113  r:=FCount-1;
5114  while r>=l do begin
5115    m:=(l+r) shr 1;
5116    if LFMPositions then
5117      p:=PLRPositionLink(FItems[m])^.LFMPosition
5118    else
5119      p:=PLRPositionLink(FItems[m])^.LRSPosition;
5120    if p>Position then begin
5121      // too high, search lower
5122      r:=m-1;
5123    end else if p<Position then begin
5124      // too low, search higher
5125      l:=m+1;
5126    end else begin
5127      // position found
5128      Result:=m;
5129      exit;
5130    end;
5131  end;
5132  Result:=-1;
5133end;
5134
5135function TLRPositionLinks.IndexOfRange(const FromPos, ToPos: int64;
5136  LFMPositions: Boolean): integer;
5137var
5138  l, r, m: integer;
5139  p: Int64;
5140  Item: PLRPositionLink;
5141begin
5142  // binary search for the line
5143  l:=0;
5144  r:=FCount-1;
5145  while r>=l do begin
5146    m:=(l+r) shr 1;
5147    Item:=PLRPositionLink(FItems[m]);
5148    if LFMPositions then
5149      p:=Item^.LFMPosition
5150    else
5151      p:=Item^.LRSPosition;
5152    if p>=ToPos then begin
5153      // too high, search lower
5154      r:=m-1;
5155    end else if p<FromPos then begin
5156      // too low, search higher
5157      l:=m+1;
5158    end else begin
5159      // position found
5160      Result:=m;
5161      exit;
5162    end;
5163  end;
5164  Result:=-1;
5165end;
5166
5167procedure TLRPositionLinks.SetPosition(const FromPos, ToPos, MappedPos: int64;
5168  LFMtoLRSPositions: Boolean);
5169var
5170  i: LongInt;
5171begin
5172  i:=IndexOfRange(FromPos,ToPos,LFMtoLRSPositions);
5173  if i>=0 then
5174    if LFMtoLRSPositions then
5175      PLRPositionLink(FItems[i])^.LRSPosition:=MappedPos
5176    else
5177      PLRPositionLink(FItems[i])^.LFMPosition:=MappedPos;
5178end;
5179
5180procedure TLRPositionLinks.Add(const LFMPos, LRSPos: Int64; AData: Pointer);
5181var
5182  Item: PLRPositionLink;
5183begin
5184  Count:=Count+1;
5185  Item:=PLRPositionLink(FItems[Count-1]);
5186  Item^.LFMPosition:=LFMPos;
5187  Item^.LRSPosition:=LRSPos;
5188  Item^.Data:=AData;
5189end;
5190
5191{ TCustomLazComponentQueue }
5192
5193function TCustomLazComponentQueue.ReadComponentSize(out ComponentSize,
5194  SizeLength: int64): Boolean;
5195// returns true if there are enough bytes to read the ComponentSize
5196//   and returns the ComponentSize
5197//   and returns the size (SizeLength) needed to store the ComponentSize
5198
5199  procedure ReadBytes(var p);
5200  var a: array[1..9] of byte;
5201  begin
5202    FQueue.Top(a[1],1+SizeLength);
5203    System.Move(a[2],p,SizeLength);
5204    {$IFDEF FPC_BIG_ENDIAN}
5205    ReverseBytes(@p,SizeLength);
5206    {$ENDIF}
5207  end;
5208
5209var
5210  v8: ShortInt;
5211  v16: SmallInt;
5212  v32: Integer;
5213  v64: int64;
5214  vt: TValueType;
5215begin
5216  Result:=false;
5217  // check if there are enough bytes
5218  if (FQueue.Size<2) then exit;
5219  FQueue.Top(vt,1);
5220  case vt of
5221  vaInt8: SizeLength:=1;
5222  vaInt16: SizeLength:=2;
5223  vaInt32: SizeLength:=4;
5224  vaInt64: SizeLength:=8;
5225  else
5226    raise EInOutError.Create('Invalid size type');
5227  end;
5228  if FQueue.Size<1+SizeLength then exit; // need more data
5229  // read the ComponentSize
5230  Result:=true;
5231  case vt of
5232  vaInt8:
5233    begin
5234      ReadBytes(v8);
5235      ComponentSize:=v8;
5236    end;
5237  vaInt16:
5238    begin
5239      ReadBytes(v16);
5240      ComponentSize:=v16;
5241    end;
5242  vaInt32:
5243    begin
5244      ReadBytes(v32);
5245      ComponentSize:=v32;
5246    end;
5247  vaInt64:
5248    begin
5249      ReadBytes(v64);
5250      ComponentSize:=v64;
5251    end;
5252  end;
5253  inc(SizeLength);
5254  if ComponentSize<0 then
5255    raise EInOutError.Create('Size of data in queue is negative');
5256end;
5257
5258constructor TCustomLazComponentQueue.Create(TheOwner: TComponent);
5259begin
5260  inherited Create(TheOwner);
5261  FQueue:=TDynamicDataQueue.Create;
5262end;
5263
5264destructor TCustomLazComponentQueue.Destroy;
5265begin
5266  FreeAndNil(FQueue);
5267  inherited Destroy;
5268end;
5269
5270procedure TCustomLazComponentQueue.Clear;
5271begin
5272  FQueue.Clear;
5273end;
5274
5275function TCustomLazComponentQueue.Write(const Buffer; Count: Longint): Longint;
5276begin
5277  Result:=FQueue.Push(Buffer,Count);
5278end;
5279
5280function TCustomLazComponentQueue.CopyFrom(AStream: TStream; Count: Longint
5281  ): Longint;
5282begin
5283  Result:=FQueue.Push(AStream,Count);
5284end;
5285
5286function TCustomLazComponentQueue.HasComponent: Boolean;
5287var
5288  ComponentSize, SizeLength: int64;
5289begin
5290  if not ReadComponentSize(ComponentSize,SizeLength) then exit(false);
5291  Result:=FQueue.Size-SizeLength>=ComponentSize;
5292end;
5293
5294function TCustomLazComponentQueue.ReadComponent(var AComponent: TComponent;
5295  NewOwner: TComponent): Boolean;
5296var
5297  ComponentSize, SizeLength: int64;
5298  AStream: TMemoryStream;
5299begin
5300  Result:=false;
5301  if not ReadComponentSize(ComponentSize,SizeLength) then exit;
5302  if (FQueue.Size-SizeLength<ComponentSize) then exit;
5303  // a complete component is in the buffer -> copy it to a stream
5304  AStream:=TMemoryStream.Create;
5305  try
5306    // copy component to stream
5307    AStream.Size:=SizeLength+ComponentSize;
5308    FQueue.Pop(AStream,SizeLength+ComponentSize);
5309    // create/read the component
5310    AStream.Position:=SizeLength;
5311    ReadComponentFromBinaryStream(AStream,AComponent,
5312                                  OnFindComponentClass,NewOwner);
5313  finally
5314    AStream.Free;
5315  end;
5316  Result:=true;
5317end;
5318
5319function TCustomLazComponentQueue.ConvertComponentAsString(AComponent: TComponent
5320  ): string;
5321var
5322  AStream: TMemoryStream;
5323  ComponentSize: Int64;
5324  LengthSize: Int64;
5325begin
5326  // write component to stream
5327  AStream:=TMemoryStream.Create;
5328  try
5329    WriteComponentAsBinaryToStream(AStream,AComponent);
5330
5331    ComponentSize:=AStream.Size;
5332    WriteLRSInt64MB(AStream,ComponentSize);
5333    LengthSize:=AStream.Size-ComponentSize;
5334    //debugln('TCustomLazComponentQueue.ConvertComponentAsString ComponentSize=',ComponentSize,' LengthSize=',LengthSize);
5335
5336    SetLength(Result,AStream.Size);
5337    // write size
5338    AStream.Position:=ComponentSize;
5339    AStream.Read(Result[1],LengthSize);
5340    //debugln('TCustomLazComponentQueue.ConvertComponentAsString ',hexstr(ord(Result[1]),2),' ',hexstr(ord(Result[2]),2),' ',hexstr(ord(Result[3]),2),' ',hexstr(ord(Result[4]),2));
5341    // write component
5342    AStream.Position:=0;
5343    AStream.Read(Result[LengthSize+1],ComponentSize);
5344  finally
5345    AStream.Free;
5346  end;
5347end;
5348
5349{ TLazarusResourceStream }
5350
5351procedure TLazarusResourceStream.Initialize(Name, ResType: PChar);
5352begin
5353  if ResType <> nil then
5354    FLRes := LazarusResources.Find(Name, ResType)
5355  else
5356    FLRes := LazarusResources.Find(Name);
5357
5358  if FLRes = nil then
5359    raise EResNotFound.CreateFmt(SResNotFound, [Name]);
5360  SetPointer(PChar(FLRes.Value), Length(FLRes.Value));
5361end;
5362
5363constructor TLazarusResourceStream.Create(const ResName: string; ResType: PChar);
5364begin
5365  inherited Create;
5366  Initialize(PChar(ResName), ResType);
5367end;
5368
5369constructor TLazarusResourceStream.CreateFromID(ResID: Integer; ResType: PChar);
5370begin
5371  inherited Create;
5372  Initialize(PChar(PtrInt(ResID)), ResType);
5373end;
5374
5375constructor TLazarusResourceStream.CreateFromHandle(AHandle: TLResource);
5376begin
5377  inherited Create;
5378  FLRes := AHandle;
5379  SetPointer(PChar(FLRes.Value), Length(FLRes.Value));
5380end;
5381
5382{$ifdef UseRes}
5383constructor TLazarusResourceStream.CreateFromHandle(Instance: TFPResourceHMODULE; AHandle: TFPResourceHandle);
5384begin
5385  FPRes := LoadResource(Instance, AHandle);
5386  if FPRes <> 0 then
5387    SetPointer(LockResource(FPRes), SizeOfResource(Instance, AHandle));
5388end;
5389{$endif}
5390
5391destructor TLazarusResourceStream.Destroy;
5392begin
5393{$ifdef UseRES}
5394  if FPRes <> 0 then
5395  begin
5396    UnlockResource(FPRes);
5397    FreeResource(FPRes);
5398  end;
5399{$endif}
5400  inherited Destroy;
5401end;
5402
5403function TLazarusResourceStream.Write(const Buffer; Count: Longint): Longint;
5404begin
5405  Result := 0;
5406  raise EStreamError.Create(SCantWriteResourceStreamError);
5407end;
5408
5409const
5410  ParseBufSize     = 4096;
5411  LastSpecialToken = 5;
5412
5413  TokNames : array[0..LastSpecialToken] of string =
5414  (
5415    'EOF',
5416    'Symbol',
5417    'String',
5418    'Integer',
5419    'Float',
5420    'WideString'
5421  );
5422
5423function TUTF8Parser.GetTokenName(aTok: char): string;
5424begin
5425  if ord(aTok) <= LastSpecialToken then
5426    Result:=TokNames[ord(aTok)]
5427  else Result:=aTok;
5428end;
5429
5430procedure TUTF8Parser.LoadBuffer;
5431var newread : integer;
5432begin
5433  newread:=fStream.Read(fBuf[0],ParseBufSize);
5434  fBuf[newread]:=#0;
5435  fLineStart:=fLineStart-fPos; // column = fPos - fLineStart + 1
5436  fPos:=0;
5437  fBufLen:=newread;
5438  fEofReached:=newread=0;
5439end;
5440
5441procedure TUTF8Parser.CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5442begin
5443  if fBuf[fPos]<>#0 then exit;
5444  if fPos<fBufLen then begin
5445    // skip #0
5446    repeat
5447      inc(fPos);
5448      if fBuf[fPos]<>#0 then exit;
5449    until (fPos=fBufLen);
5450  end;
5451  LoadBuffer;
5452end;
5453
5454procedure TUTF8Parser.ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5455begin
5456  fLastTokenStr:=fLastTokenStr+fBuf[fPos];
5457  inc(fPos);
5458  CheckLoadBuffer;
5459end;
5460
5461function TUTF8Parser.IsNumber: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5462begin
5463  Result:=fBuf[fPos] in ['0'..'9'];
5464end;
5465
5466function TUTF8Parser.IsHexNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5467begin
5468  Result:=fBuf[fPos] in ['0'..'9','A'..'F','a'..'f'];
5469end;
5470
5471function TUTF8Parser.IsAlpha: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5472begin
5473  Result:=fBuf[fPos] in ['_','A'..'Z','a'..'z'];
5474end;
5475
5476function TUTF8Parser.IsAlphaNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5477begin
5478  Result:=IsAlpha or IsNumber;
5479end;
5480
5481function TUTF8Parser.GetHexValue(c: char): byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
5482begin
5483  case c of
5484    '0'..'9' : Result:=ord(c)-$30;
5485    'A'..'F' : Result:=ord(c)-$37; //-$41+$0A
5486    'a'..'f' : Result:=ord(c)-$57; //-$61+$0A
5487  end;
5488end;
5489
5490function TUTF8Parser.GetAlphaNum: string;
5491begin
5492  if not IsAlpha then
5493    ErrorFmt(SParExpected,[GetTokenName(toSymbol)]);
5494  Result:='';
5495  while IsAlphaNum do
5496  begin
5497    Result:=Result+fBuf[fPos];
5498    inc(fPos);
5499    CheckLoadBuffer;
5500  end;
5501end;
5502
5503procedure TUTF8Parser.HandleNewLine;
5504begin
5505  if fBuf[fPos]=#13 then //CR
5506  begin
5507    inc(fPos);
5508    CheckLoadBuffer;
5509    if fBuf[fPos]=#10 then inc(fPos); //CR LF
5510  end
5511  else
5512    inc(fPos); //LF
5513  CheckLoadBuffer;
5514  inc(fSourceLine);
5515  fLineStart:=fPos;
5516end;
5517
5518procedure TUTF8Parser.SkipSpaces;
5519begin
5520  while fBuf[fPos] in [' ',#9] do begin
5521    inc(fPos);
5522    CheckLoadBuffer;
5523  end;
5524end;
5525
5526procedure TUTF8Parser.SkipWhitespace;
5527begin
5528  while true do
5529  begin
5530    case fBuf[fPos] of
5531      ' ',#9  : SkipSpaces;
5532      #10,#13 : HandleNewLine
5533      else break;
5534    end;
5535  end;
5536end;
5537
5538procedure TUTF8Parser.HandleEof;
5539begin
5540  fToken:=toEOF;
5541  fLastTokenStr:='';
5542end;
5543
5544procedure TUTF8Parser.HandleAlphaNum;
5545begin
5546  fLastTokenStr:=GetAlphaNum;
5547  fToken:=toSymbol;
5548end;
5549
5550procedure TUTF8Parser.HandleNumber;
5551type
5552  floatPunct = (fpDot,fpE);
5553  floatPuncts = set of floatPunct;
5554var
5555  allowed : floatPuncts;
5556begin
5557  fLastTokenStr:='';
5558  while IsNumber do
5559    ProcessChar;
5560  fToken:=toInteger;
5561  if (fBuf[fPos] in ['.','e','E']) then
5562  begin
5563    fToken:=toFloat;
5564    allowed:=[fpDot,fpE];
5565    while (fBuf[fPos] in ['.','e','E','0'..'9']) do
5566    begin
5567      case fBuf[fPos] of
5568        '.'     : if fpDot in allowed then Exclude(allowed,fpDot) else break;
5569        'E','e' : if fpE in allowed then
5570                  begin
5571                    allowed:=[];
5572                    ProcessChar;
5573                    if (fBuf[fPos] in ['+','-']) then ProcessChar;
5574                    if not (fBuf[fPos] in ['0'..'9']) then
5575                      ErrorFmt(SParInvalidFloat,[fLastTokenStr+fBuf[fPos]]);
5576                  end
5577                  else break;
5578      end;
5579      ProcessChar;
5580    end;
5581  end;
5582  if (fBuf[fPos] in ['s','S','d','D','c','C']) then //single, date, currency
5583  begin
5584    fFloatType:=fBuf[fPos];
5585    inc(fPos);
5586    CheckLoadBuffer;
5587    fToken:=toFloat;
5588  end
5589  else fFloatType:=#0;
5590end;
5591
5592procedure TUTF8Parser.HandleHexNumber;
5593var valid : boolean;
5594begin
5595  fLastTokenStr:='$';
5596  inc(fPos);
5597  CheckLoadBuffer;
5598  valid:=false;
5599  while IsHexNum do
5600  begin
5601    valid:=true;
5602    ProcessChar;
5603  end;
5604  if not valid then
5605    ErrorFmt(SParInvalidInteger,[fLastTokenStr]);
5606  fToken:=toInteger;
5607end;
5608
5609function TUTF8Parser.HandleQuotedString: string;
5610begin
5611  Result:='';
5612  inc(fPos);
5613  CheckLoadBuffer;
5614  while true do
5615  begin
5616    case fBuf[fPos] of
5617      #0     : ErrorStr(SParUnterminatedString);
5618      #13,#10 : ErrorStr(SParUnterminatedString);
5619      ''''   : begin
5620                 inc(fPos);
5621                 CheckLoadBuffer;
5622                 if fBuf[fPos]<>'''' then exit;
5623               end;
5624    end;
5625    Result:=Result+fBuf[fPos];
5626    inc(fPos);
5627    CheckLoadBuffer;
5628  end;
5629end;
5630
5631function TUTF8Parser.HandleDecimalString: string;
5632var
5633  i: integer;
5634begin
5635  Result:='';
5636  inc(fPos);
5637  CheckLoadBuffer;
5638  while IsNumber do
5639  begin
5640    Result:=Result+fBuf[fPos];
5641    inc(fPos);
5642    CheckLoadBuffer;
5643  end;
5644  if not TryStrToInt(Result,i) then
5645    i:=0;
5646  Result:=UnicodeToUTF8(i); // widestring
5647end;
5648
5649procedure TUTF8Parser.HandleString;
5650var
5651  IsWideString: Boolean;
5652begin
5653  fLastTokenStr:='';
5654  IsWideString := false;
5655  while true do begin
5656    case fBuf[fPos] of
5657      '''' : fLastTokenStr:=fLastTokenStr+HandleQuotedString;
5658      '#'  : begin
5659               fLastTokenStr:=fLastTokenStr+HandleDecimalString;
5660               IsWideString:=true;
5661             end;
5662      else break;
5663    end;
5664  end;
5665  if IsWideString then
5666    fToken:=Classes.toWString
5667  else
5668    fToken:=Classes.toString;
5669end;
5670
5671procedure TUTF8Parser.HandleMinus;
5672begin
5673  inc(fPos);
5674  CheckLoadBuffer;
5675  if IsNumber then
5676  begin
5677    HandleNumber;
5678    fLastTokenStr:='-'+fLastTokenStr;
5679  end
5680  else
5681  begin
5682    fToken:='-';
5683    fLastTokenStr:=fToken;
5684  end;
5685end;
5686
5687procedure TUTF8Parser.HandleUnknown;
5688begin
5689  fToken:=fBuf[fPos];
5690  fLastTokenStr:=fToken;
5691  inc(fPos);
5692  CheckLoadBuffer;
5693end;
5694
5695constructor TUTF8Parser.Create(Stream: TStream);
5696begin
5697  fStream:=Stream;
5698  fBuf:=GetMem(ParseBufSize+1);
5699  fBufLen:=0;
5700  fPos:=0;
5701  fLineStart:=0;
5702  fSourceLine:=1;
5703  fEofReached:=false;
5704  fLastTokenStr:='';
5705  fFloatType:=#0;
5706  fToken:=#0;
5707  LoadBuffer;
5708  NextToken;
5709end;
5710
5711destructor TUTF8Parser.Destroy;
5712begin
5713  fStream.Position:=SourcePos;
5714  FreeMem(fBuf);
5715end;
5716
5717procedure TUTF8Parser.CheckToken(T: Char);
5718begin
5719  if fToken<>T then
5720    ErrorFmt(SParWrongTokenType,[GetTokenName(T),GetTokenName(fToken)]);
5721end;
5722
5723procedure TUTF8Parser.CheckTokenSymbol(const S: string);
5724begin
5725  CheckToken(toSymbol);
5726  if CompareText(fLastTokenStr,S)<>0 then
5727    ErrorFmt(SParWrongTokenSymbol,[s,fLastTokenStr]);
5728end;
5729
5730procedure TUTF8Parser.Error(const Ident: string);
5731begin
5732  ErrorStr(Ident);
5733end;
5734
5735procedure TUTF8Parser.ErrorFmt(const Ident: string; const Args: array of const);
5736begin
5737  ErrorStr(Format(Ident,Args));
5738end;
5739
5740procedure TUTF8Parser.ErrorStr(const Message: string);
5741begin
5742  debugln(['TUTF8Parser.ErrorStr Message="',Message,'" at y=',SourceLine,',x=',SourceColumn]);
5743  raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,SourceColumn,SourcePos]);
5744end;
5745
5746procedure TUTF8Parser.HexToBinary(Stream: TStream);
5747var outbuf : array[0..ParseBufSize-1] of byte;
5748    b : byte;
5749    i : integer;
5750begin
5751  i:=0;
5752  SkipWhitespace;
5753  while IsHexNum do
5754  begin
5755    b:=(GetHexValue(fBuf[fPos]) shl 4);
5756    inc(fPos);
5757    CheckLoadBuffer;
5758    if not IsHexNum then
5759      Error(SParUnterminatedBinValue);
5760    b:=b or GetHexValue(fBuf[fPos]);
5761    inc(fPos);
5762    CheckLoadBuffer;
5763    outbuf[i]:=b;
5764    inc(i);
5765    if i>=ParseBufSize then
5766    begin
5767      Stream.WriteBuffer(outbuf[0],i);
5768      i:=0;
5769    end;
5770    SkipWhitespace;
5771  end;
5772  if i>0 then
5773    Stream.WriteBuffer(outbuf[0],i);
5774  NextToken;
5775end;
5776
5777function TUTF8Parser.NextToken: Char;
5778
5779begin
5780  SkipWhiteSpace;
5781  if fEofReached then
5782    HandleEof
5783  else
5784    case fBuf[fPos] of
5785      '_','A'..'Z','a'..'z' : HandleAlphaNum;
5786      '$'                   : HandleHexNumber;
5787      '-'                   : HandleMinus;
5788      '0'..'9'              : HandleNumber;
5789      '''','#'              : HandleString
5790      else
5791        HandleUnknown;
5792    end;
5793  Result:=fToken;
5794end;
5795
5796function TUTF8Parser.SourcePos: Longint;
5797begin
5798  Result:=fStream.Position-fBufLen+fPos;
5799end;
5800
5801function TUTF8Parser.TokenComponentIdent: string;
5802begin
5803  if fToken<>toSymbol then
5804    ErrorFmt(SParExpected,[GetTokenName(toSymbol)]);
5805  CheckLoadBuffer;
5806  while fBuf[fPos]='.' do
5807  begin
5808    ProcessChar;
5809    fLastTokenStr:=fLastTokenStr+GetAlphaNum;
5810  end;
5811  Result:=fLastTokenStr;
5812end;
5813
5814function TUTF8Parser.TokenFloat: Extended;
5815
5816var errcode : word;
5817
5818begin
5819  Val(fLastTokenStr,Result,errcode);
5820  if errcode<>0 then
5821    ErrorFmt(SParInvalidFloat,[fLastTokenStr]);
5822end;
5823
5824function TUTF8Parser.TokenInt: Int64;
5825begin
5826  if not TryStrToInt64(fLastTokenStr,Result) then
5827    Result:=Int64(StrToQWord(fLastTokenStr)); //second chance for malformed files
5828end;
5829
5830function TUTF8Parser.TokenString: string;
5831begin
5832  case fToken of
5833    toFloat : if fFloatType<>#0 then
5834                Result:=fLastTokenStr+fFloatType
5835              else Result:=fLastTokenStr
5836    else
5837      Result:=fLastTokenStr;
5838  end;
5839end;
5840
5841function TUTF8Parser.TokenSymbolIs(const S: string): Boolean;
5842begin
5843  Result:=(fToken=toSymbol) and (CompareText(fLastTokenStr,S)=0);
5844end;
5845
5846function TUTF8Parser.SourceColumn: integer;
5847begin
5848  Result:=fPos-fLineStart+1;
5849end;
5850
5851//------------------------------------------------------------------------------
5852procedure InternalInit;
5853begin
5854  LazarusResources := TLResourceList.Create;
5855  RegisterInitComponentHandler(TComponent, @InitResourceComponent);
5856  PropertiesToSkip := TPropertiesToSkip.Create;
5857end;
5858
5859initialization
5860  InternalInit;
5861
5862finalization
5863  FreeAndNil(LazarusResources);
5864  FreeAndNil(PropertiesToSkip);
5865
5866end.
5867
5868
5869
5870