{
  Author: Mattias Gaertner

 *****************************************************************************
  This file is part of the Lazarus Component Library (LCL)

  See the file COPYING.modifiedLGPL.txt, included in this distribution,
  for details about the license.
 *****************************************************************************

  Abstract:
    This unit maintains and stores all lazarus resources in the global list
    named LazarusResources and provides methods and types to stream components.

    A lazarus resource is an ansistring, with a name and a valuetype. Both, name
    and valuetype, are ansistrings as well.
    Lazarus resources are normally included via an include directive in the
    initialization part of a unit. To create such include files use the
    BinaryToLazarusResourceCode procedure.
    To create a LRS file from an LFM file use the LFMtoLRSfile function which
    transforms the LFM text to binary format and stores it as Lazarus resource
    include file.
}
unit LResources;

{$mode objfpc}{$H+}

{ $DEFINE WideStringLenDoubled}

interface

uses
  {$IFDEF Windows}
  Windows,
  {$ENDIF}
  Classes, SysUtils, Types, RtlConsts, TypInfo, Variants,
  // LCL
  LCLStrConsts,
  // LazUtils
  LazConfigStorage, FPCAdds, DynQueue, LazUTF8, LazLoggerBase, LazTracer, LazUtilities;

{$DEFINE UseLRS}
{$DEFINE UseRES}

const
  LRSComment =  // do not translate this!
    'This is an automatically generated lazarus resource file';
type
  TFilerSignature = array[1..4] of Char;


  { TLResourceList }

  TLResource = class
  public
    Name: AnsiString;
    ValueType: AnsiString;
    Value: AnsiString;
  end;

  TLResourceList = class(TObject)
  private
    FList: TList;  // main list with all resource pointers
    FMergeList: TList; // list needed for mergesort
    FSortedCount: integer; // 0 .. FSortedCount-1 resources are sorted
    function FindPosition(const Name: AnsiString):integer;
    function GetItems(Index: integer): TLResource;
    procedure Sort;
    procedure MergeSort(List, MergeList: TList; Pos1, Pos2: integer);
    procedure Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer);
  public
    constructor Create;
    destructor Destroy;  override;
    procedure Add(const Name, ValueType, Value: AnsiString);
    procedure Add(const Name, ValueType: AnsiString; const Values: array of string);
    function Find(const Name: AnsiString): TLResource; overload;
    function Find(const Name, ValueType: AnsiString): TLResource; overload;
    function Count: integer;
    property Items[Index: integer]: TLResource read GetItems;
  end;

  { TLazarusResourceStream }

  TLazarusResourceStream = class(TCustomMemoryStream)
  private
    FLRes: TLResource;
  {$ifdef UseRES}
    FPRes: TFPResourceHGLOBAL;
  {$endif}
    procedure Initialize(Name, ResType: PChar);
  public
    constructor Create(const ResName: string; ResType: PChar);
    constructor CreateFromID(ResID: Integer; ResType: PChar);
    constructor CreateFromHandle(AHandle: TLResource); overload;
  {$ifdef UseRES}
    // here from FP resource handle
    constructor CreateFromHandle(Instance: TFPResourceHMODULE; AHandle: TFPResourceHandle); overload;
  {$endif}
    destructor Destroy; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    property Res: TLResource read FLRes;
  end;

  { TAbstractTranslator}
  TAbstractTranslator = class(TObject)//Should it be somewhat more than TObject?
  public
    procedure TranslateStringProperty(Sender:TObject; const Instance: TPersistent; PropInfo: PPropInfo; var Content:string); virtual;abstract;
   //seems like we need nothing more here
  end;


var LRSTranslator: TAbstractTranslator;

type
  TLRSItemType = (
    lrsitCollection,
    lrsitComponent,
    lrsitList,
    lrsitProperty
  );

  TLRSORStackItem = record
    Name: string;
    ItemType: TLRSItemType;
    Root: TComponent;
    PushCount: integer; // waiting for this number of Pop
    ItemNr: integer; // nr in a collection or list
  end;
  PLRSORStackItem = ^TLRSORStackItem;

  { TLRSObjectReader }

  TLRSObjectReader = class(TAbstractObjectReader)
  private
    FStream: TStream;
    FBuffer: Pointer;
    FBufSize: Integer;
    FBufPos: Integer;
    FBufEnd: Integer;
    FStack: PLRSORStackItem;
    FStackPointer: integer;
    FStackCapacity: integer;
    FReader: TReader;
    procedure SkipProperty;
    procedure SkipSetBody;
    procedure Push(ItemType: TLRSItemType; const AName: string = '';
                   Root: TComponent = nil; PushCount: integer = 1);
    procedure Pop;
    procedure ClearStack;
    function InternalReadValue: TValueType;
    procedure EndPropertyIfOpen;
  protected
    function ReadIntegerContent: integer;
  public
    constructor Create(AStream: TStream; BufSize: Integer); virtual;
    destructor Destroy; override;

    function NextValue: TValueType; override;
    function ReadValue: TValueType; override;
    procedure BeginRootComponent; override;
    procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer;
      var CompClassName, CompName: String); override;
    function BeginProperty: String; override;
    function GetStackPath: string;

    procedure Read(var Buf; Count: LongInt); override;
    procedure ReadBinary(const DestData: TMemoryStream); override;
    function ReadFloat: Extended; override;
    function ReadSingle: Single; override;
    function ReadCurrency: Currency; override;
    function ReadDate: TDateTime; override;
    function ReadIdent(ValueType: TValueType): String; override;
    function ReadInt8: ShortInt; override;
    function ReadInt16: SmallInt; override;
    function ReadInt32: LongInt; override;
    function ReadInt64: Int64; override;
    function ReadSet(EnumType: Pointer): Integer; override;
    procedure ReadSignature; override;
    function ReadStr: String; override;
    function ReadString(StringType: TValueType): String; override;
    function ReadWideString: WideString; override;
    function ReadUnicodeString: UnicodeString; override;
    procedure SkipComponent(SkipComponentInfos: Boolean); override;
    procedure SkipValue; override;
  public
    property Stream: TStream read FStream;
    property Reader: TReader read FReader write FReader;
  end;
  TLRSObjectReaderClass = class of TLRSObjectReader;

  { TLRSOWStackItem
    The TLRSObjectWriter can find empty entries and omit writing them to stream.
    For example:
        inline ConditionalOptionsFrame: TCompOptsConditionalsFrame
          inherited COCTreeView: TTreeView
          end
          inherited COCPopupMenu: TPopupMenu
          end
        end

    The empty inherited child components will not be written if
      WriteEmptyInheritedChilds = false (default).

    Reason:
      This allows one to delete/rename controls in ancestors without the need
      to update all descendants.
  }

  TLRSOWStackItemState = (
    lrsowsisStarted,       // now writing header
    lrsowsisHeaderWritten, // header saved on stack, not yet written to stream, waiting for data
    lrsowsisDataWritten    // header written to stream, data written
    );

  TLRSOWStackItem = record
    Name: string;
    ItemType: TLRSItemType;
    Root: TComponent;
    PushCount: integer; // waiting for this number of Pop
    ItemNr: integer; // nr in a collection or list
    SkipIfEmpty: boolean;
    State: TLRSOWStackItemState;
    Buffer: Pointer;
    BufCount: PtrInt;
    BufCapacity: PtrInt;
  end;
  PLRSOWStackItem = ^TLRSOWStackItem;

  {$IF FPC_FULLVERSION>30300}
  TLazObjectWriterString = RawByteString;
  {$ELSE}
  TLazObjectWriterString = String;
  {$ENDIF}

  { TLRSObjectWriter }

  TLRSObjectWriter = class(TAbstractObjectWriter)
  private
    FStream: TStream;
    FBuffer: Pointer;
    FBufSize: Integer;
    FBufPos: Integer;
    FSignatureWritten: Boolean;
    FStack: PLRSOWStackItem;
    FStackPointer: integer;
    FStackCapacity: integer;
    FWriteEmptyInheritedChilds: boolean;
    FWriter: TWriter;
    procedure Push(ItemType: TLRSItemType; const AName: string = '';
                   Root: TComponent = nil; PushCount: integer = 1;
                   SkipIfEmpty: boolean = false);
    procedure EndHeader;
    procedure Pop(WriteNull: boolean);
    procedure ClearStack;
    procedure FlushStackToStream;
    procedure WriteToStream(const Buffer; Count: Longint);
  protected
    procedure FlushBuffer; override;
    procedure WriteValue(Value: TValueType);
    procedure WriteStr(const Value: String);
    procedure WriteIntegerContent(i: integer);
    procedure WriteWordContent(w: word);
    procedure WriteInt64Content(i: int64);
    procedure WriteSingleContent(s: single);
    procedure WriteDoubleContent(d: Double);
    procedure WriteExtendedContent(e: Extended);
    procedure WriteCurrencyContent(c: Currency);
    procedure WriteWideStringContent(const ws: WideString);
    procedure WriteWordsReversed(p: PWord; Count: integer);
    procedure WriteNulls(Count: integer);
  public
    constructor Create(Stream: TStream; BufSize: Integer); virtual;
    destructor Destroy; override;

    { Begin/End markers. Those ones who don't have an end indicator, use
      "EndList", after the occurrence named in the comment. Note that this
      only counts for "EndList" calls on the same level; each BeginXXX call
      increases the current level. }
    procedure BeginCollection; override;{ Ends with the next "EndList" }
    procedure BeginComponent(Component: TComponent; Flags: TFilerFlags;
      ChildPos: Integer); override; { Ends after the second "EndList" }
    procedure WriteSignature; override;
    procedure BeginList; override;
    procedure EndList; override;
    procedure BeginProperty(const PropName: String); override;
    procedure EndProperty; override;
    function GetStackPath: string;

    procedure Write(const Buffer; Count: Longint); override;
    procedure WriteBinary(const Buffer; Count: LongInt); override;
    procedure WriteBoolean(Value: Boolean); override;
    procedure WriteFloat(const Value: Extended); override;
    procedure WriteSingle(const Value: Single); override;
    procedure WriteCurrency(const Value: Currency); override;
    procedure WriteDate(const Value: TDateTime); override;
    procedure WriteIdent(const Ident: string); override;
    procedure WriteInteger(Value: Int64); override;
    procedure WriteMethodName(const Name: String); override;
    procedure WriteSet(Value: LongInt; SetType: Pointer); override;
    procedure WriteString(const Value: TLazObjectWriterString); override;
    procedure WriteWideString(const Value: WideString); override;
    procedure WriteUnicodeString(const Value: UnicodeString); override;
    procedure WriteVariant(const Value: Variant); override;

    property WriteEmptyInheritedChilds: boolean read FWriteEmptyInheritedChilds write FWriteEmptyInheritedChilds;
    property Writer: TWriter read FWriter write FWriter;
  end;
  TLRSObjectWriterClass = class of TLRSObjectWriter;

  TLRPositionLink = record
    LFMPosition: int64;
    LRSPosition: int64;
    Data: Pointer;
  end;
  PLRPositionLink = ^TLRPositionLink;
  
  { TLRPositionLinks }

  TLRPositionLinks = class
  private
    FItems: TFPList;
    FCount: integer;
    function GetData(Index: integer): Pointer;
    function GetLFM(Index: integer): Int64;
    function GetLRS(Index: integer): Int64;
    procedure SetCount(const AValue: integer);
    procedure SetData(Index: integer; const AValue: Pointer);
    procedure SetLFM(Index: integer; const AValue: Int64);
    procedure SetLRS(Index: integer; const AValue: Int64);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure Sort(LFMPositions: Boolean);
    function IndexOf(const Position: int64; LFMPositions: Boolean): integer;
    function IndexOfRange(const FromPos, ToPos: int64;
                          LFMPositions: Boolean): integer;
    procedure SetPosition(const FromPos, ToPos, MappedPos: int64;
                          LFMtoLRSPositions: Boolean);
    procedure Add(const LFMPos, LRSPos: Int64; AData: Pointer);
  public
    property LFM[Index: integer]: int64 read GetLFM write SetLFM;
    property LRS[Index: integer]: int64 read GetLRS write SetLRS;
    property Data[Index: integer]: Pointer read GetData write SetData;
    property Count: integer read FCount write SetCount;
  end;
  
  { TUTF8Parser }

  TUTF8Parser = class(TObject)
  private
    fStream : TStream;
    fBuf : pchar;
    fBufLen : integer; // read
    fPos : integer;
    fLineStart : integer; // column = fPos - fLineStart + 1
    fFloatType : char;
    fSourceLine : integer;
    fToken : char;
    fEofReached : boolean;
    fLastTokenStr : string;
    function GetTokenName(aTok : char) : string;
    procedure LoadBuffer;
    procedure CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
    procedure ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
    function IsNumber : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
    function IsHexNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
    function IsAlpha : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
    function IsAlphaNum : boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
    function GetHexValue(c : char) : byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
    function GetAlphaNum : string;
    procedure HandleNewLine;
    procedure SkipSpaces;
    procedure SkipWhitespace;
    procedure HandleEof;
    procedure HandleAlphaNum;
    procedure HandleNumber;
    procedure HandleHexNumber;
    function HandleQuotedString: string;
    function HandleDecimalString: string;
    procedure HandleString;
    procedure HandleMinus;
    procedure HandleUnknown;
  public
    constructor Create(Stream: TStream);
    destructor Destroy; override;
    procedure CheckToken(T: Char);
    procedure CheckTokenSymbol(const S: string);
    procedure Error(const Ident: string);
    procedure ErrorFmt(const Ident: string; const Args: array of const);
    procedure ErrorStr(const Message: string);
    procedure HexToBinary(Stream: TStream);
    function NextToken: Char;
    function SourcePos: Longint;
    function TokenComponentIdent: string;
    function TokenFloat: Extended;
    function TokenInt: Int64;
    function TokenString: string;
    function TokenSymbolIs(const S: string): Boolean;
    property FloatType: Char read fFloatType;
    property SourceLine: Integer read fSourceLine;
    function SourceColumn: integer;
    property Token: Char read fToken;
  end deprecated 'use Classes.TParser instead';

  { TCustomLazComponentQueue
    A queue to stream components, used for multithreading or network.
    The function ConvertComponentAsString converts a component to binary format
    with a leading size information (using WriteLRSInt64MB).
    When streaming components over network, they will arrive in chunks.
    TCustomLazComponentQueue tells you, if a whole component has arrived and if
    it has completely arrived. }
  TCustomLazComponentQueue = class(TComponent)
  private
    FOnFindComponentClass: TFindComponentClassEvent;
  protected
    FQueue: TDynamicDataQueue;
    function ReadComponentSize(out ComponentSize, SizeLength: int64): Boolean; virtual;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear;
    function Write(const Buffer; Count: Longint): Longint;
    function CopyFrom(AStream: TStream; Count: Longint): Longint;
    function HasComponent: Boolean; virtual;
    function ReadComponent(var AComponent: TComponent;
                           NewOwner: TComponent = nil): Boolean; virtual;
    function ConvertComponentAsString(AComponent: TComponent): string;
    property OnFindComponentClass: TFindComponentClassEvent
                         read FOnFindComponentClass write FOnFindComponentClass;
  end;
  
  { TLazComponentQueue }

  TLazComponentQueue = class(TCustomLazComponentQueue)
  published
    property Name;
    property OnFindComponentClass;
  end;

  TPropertyToSkip = record
    PersistentClass: TPersistentClass;
    PropertyName: String;
    Note: String;
    HelpKeyword: String;
  end;
  PRemovedProperty = ^TPropertyToSkip;

  { TPropertyToSkipList }

  TPropertiesToSkip = class(TList)
  private
    function GetItem(AIndex: Integer): PRemovedProperty;
    procedure SetItem(AIndex: Integer; const AValue: PRemovedProperty);
  protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
    procedure DoPropertyNotFound(Reader: TReader; Instance: TPersistent;
      var PropName: string; IsPath: boolean; var Handled, Skip: Boolean);
  public
    function IndexOf(AInstance: TPersistent; const APropertyName: String): Integer; overload;
    function IndexOf(AClass: TPersistentClass; APropertyName: String): Integer; overload;
    function Add(APersistentClass: TPersistentClass; const APropertyName, ANote,
      AHelpKeyWord: string): Integer; reintroduce;
    property Items[AIndex: Integer]: PRemovedProperty read GetItem write SetItem;
  end;

const
  ObjStreamMaskInherited = 1;
  ObjStreamMaskChildPos  = 2;
  ObjStreamMaskInline    = 4;

var
  LazarusResources: TLResourceList;
  PropertiesToSkip: TPropertiesToSkip = nil;

  LRSObjectReaderClass: TLRSObjectReaderClass=TLRSObjectReader;
  LRSObjectWriterClass: TLRSObjectWriterClass=TLRSObjectWriter;

function InitResourceComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
function InitLazResourceComponent(Instance: TComponent;
                                  RootAncestor: TClass): Boolean;
function CreateLRSReader(s: TStream; var DestroyDriver: boolean): TReader;
function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;

function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean): shortstring;
procedure GetComponentInfoFromLRSStream(s: TStream;
                                  out ComponentName, ComponentClassName: string;
                                  out IsInherited: Boolean);
procedure WriteComponentAsBinaryToStream(AStream: TStream;
                                         AComponent: TComponent);
procedure ReadComponentFromBinaryStream(AStream: TStream;
                           var RootComponent: TComponent;
                           OnFindComponentClass: TFindComponentClassEvent;
                           TheOwner: TComponent = nil;
                           Parent: TComponent = nil;
                           ReaderRoot: TComponent = nil);
procedure WriteComponentAsTextToStream(AStream: TStream;
                                       AComponent: TComponent);
procedure ReadComponentFromTextStream(AStream: TStream;
                           var RootComponent: TComponent;
                           OnFindComponentClass: TFindComponentClassEvent;
                           TheOwner: TComponent = nil;
                           Parent: TComponent = nil);
procedure SaveComponentToConfig(Config: TConfigStorage; const Path: string;
                                AComponent: TComponent);
procedure LoadComponentFromConfig(Config: TConfigStorage; const Path: string;
                                 var RootComponent: TComponent;
                                 OnFindComponentClass: TFindComponentClassEvent;
                                 TheOwner: TComponent = nil;
                                 Parent: TComponent = nil);


function CompareComponents(Component1, Component2: TComponent): boolean;
function CompareMemStreams(Stream1, Stream2: TCustomMemoryStream): boolean;

procedure BinaryToLazarusResourceCode(BinStream, ResStream: TStream;
  const ResourceName, ResourceType: String);
function LFMtoLRSfile(const LFMfilename: string): boolean;// true on success
function LFMtoLRSstream(LFMStream, LRSStream: TStream): boolean;// true on success
function FindLFMClassName(LFMStream: TStream):AnsiString;
procedure ReadLFMHeader(LFMStream: TStream;
                        out LFMType, LFMComponentName, LFMClassName: String);
procedure ReadLFMHeader(const LFMSource: string;
                        out LFMClassName: String; out LFMType: String);
procedure ReadLFMHeader(const LFMSource: string;
                        out LFMType, LFMComponentName, LFMClassName: String);
function ReadLFMHeaderFromFile(const Filename: string;
                  out LFMType, LFMComponentName, LFMClassName: String): boolean;
function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer;
function SameLFMTypeName(aUnitname, aTypename, LFMTypename: string): boolean;

type
  TLRSStreamOriginalFormat = (sofUnknown, sofBinary, sofText);
  
procedure LRSObjectBinaryToText(Input, Output: TStream); // binary to lfm
procedure LRSObjectTextToBinary(Input, Output: TStream;  // lfm to binary
                                Links: TLRPositionLinks = nil);
procedure LRSObjectToText(Input, Output: TStream;
  var OriginalFormat: TLRSStreamOriginalFormat);

procedure LRSObjectResourceToText(Input, Output: TStream); // lrs to lfm
procedure LRSObjectResToText(Input, Output: TStream;
  var OriginalFormat: TLRSStreamOriginalFormat);
  
function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat;
procedure FormDataToText(FormStream, TextStream: TStream;
  aFormat: TLRSStreamOriginalFormat = sofUnknown);

function FindResourceLFM(ResName: string): HRSRC;

procedure DefineRectProperty(Filer: TFiler; const Name: string;
                             ARect, DefaultRect: PRect);

procedure ReverseBytes(p: Pointer; Count: integer);
procedure ReverseByteOrderInWords(p: PWord; Count: integer);
function ConvertLRSExtendedToDouble(p: Pointer): Double;
procedure ConvertEndianBigDoubleToLRSExtended(BigEndianDouble,
                                              LRSExtended: Pointer);
                                              
procedure ConvertLEDoubleToLRSExtended(LEDouble, LRSExtended: Pointer);


function ReadLRSShortInt(s: TStream): shortint;
function ReadLRSByte(s: TStream): byte;
function ReadLRSSmallInt(s: TStream): smallint;
function ReadLRSWord(s: TStream): word;
function ReadLRSInteger(s: TStream): integer;
function ReadLRSCardinal(s: TStream): cardinal;
function ReadLRSInt64(s: TStream): int64;
function ReadLRSSingle(s: TStream): Single;
function ReadLRSDouble(s: TStream): Double;
function ReadLRSExtended(s: TStream): Extended;
function ReadLRSCurrency(s: TStream): Currency;
function ReadLRSWideString(s: TStream): WideString;
function ReadLRSEndianLittleExtendedAsDouble(s: TStream): Double;
function ReadLRSValueType(s: TStream): TValueType;
function ReadLRSInt64MB(s: TStream): int64;// multibyte

procedure WriteLRSSmallInt(s: TStream; const i: smallint);
procedure WriteLRSWord(s: TStream; const w: word);
procedure WriteLRSInteger(s: TStream; const i: integer);
procedure WriteLRSCardinal(s: TStream; const c: cardinal);
procedure WriteLRSSingle(s: TStream; const si: Single);
procedure WriteLRSDouble(s: TStream; const d: Double);
procedure WriteLRSExtended(s: TStream; const e: extended);
procedure WriteLRSInt64(s: TStream; const i: int64);
procedure WriteLRSCurrency(s: TStream; const c: Currency);
procedure WriteLRSWideStringContent(s: TStream; const w: WideString);
procedure WriteLRSInt64MB(s: TStream; const Value: int64);// multibyte

procedure WriteLRSReversedWord(s: TStream; w: word);
procedure WriteLRS4BytesReversed(s: TStream; p: Pointer);
procedure WriteLRS8BytesReversed(s: TStream; p: Pointer);
procedure WriteLRS10BytesReversed(s: TStream; p: Pointer);
procedure WriteLRSNull(s: TStream; Count: integer);
procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream;
  EndBigDouble: PByte);
procedure WriteLRSDoubleAsExtended(s: TStream; ADouble: PByte);
procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer);

function FloatToLFMStr(const Value: extended; Precision, Digits: Integer
                       ): string;

function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer;
function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer;

procedure RegisterPropertyToSkip(PersistentClass: TPersistentClass;
  const PropertyName, Note, HelpKeyWord: string);

procedure Register;

implementation

const
  LineEnd: ShortString = LineEnding;

var
  ByteToStr: array[char] of shortstring;
  ByteToStrValid: boolean=false;
  
type

  { TDefineRectPropertyClass }

  TDefineRectPropertyClass = class
  public
    Value: PRect;
    DefaultValue: PRect;
    constructor Create(AValue, ADefaultRect: PRect);
    procedure ReadData(Reader: TReader);
    procedure WriteData(Writer: TWriter);
    function HasData: Boolean;
  end;
  
  { TReaderUniqueNamer - dummy class, used by the reader functions to rename
    components, that are read from a stream, on the fly. }

  TReaderUniqueNamer = class
    procedure OnSetName(Reader: TReader; Component: TComponent;
                        var Name: string);
  end;

{ TPropertiesToSkip }

function TPropertiesToSkip.GetItem(AIndex: Integer): PRemovedProperty;
begin
  Result := inherited Get(AIndex);
end;

procedure TPropertiesToSkip.SetItem(AIndex: Integer;
  const AValue: PRemovedProperty);
begin
  inherited Put(AIndex, AValue);
end;

procedure TPropertiesToSkip.Notify(Ptr: Pointer; Action: TListNotification);
begin
  if Action = lnDeleted then
    Dispose(PRemovedProperty(Ptr))
  else
    inherited Notify(Ptr, Action);
end;

procedure TPropertiesToSkip.DoPropertyNotFound(Reader: TReader; Instance: TPersistent;
  var PropName: string; IsPath: boolean; var Handled, Skip: Boolean);
begin
  Skip := IndexOf(Instance, PropName) >= 0;
  Handled := Skip;
end;

function TPropertiesToSkip.IndexOf(AInstance: TPersistent;
  const APropertyName: String): Integer;
begin
  if AInstance <> nil then
    Result := IndexOf(TPersistentClass(AInstance.ClassType), APropertyName)
  else
    Result := -1;
end;

function TPropertiesToSkip.IndexOf(AClass: TPersistentClass;
  APropertyName: String): Integer;
var
  PropertyInfo: PRemovedProperty;
begin
  APropertyName := LowerCase(APropertyName);
  Result := Count - 1;
  while Result >= 0 do
  begin
    PropertyInfo := Items[Result];
    if AClass.InheritsFrom(PropertyInfo^.PersistentClass) and
       (APropertyName = PropertyInfo^.PropertyName) then
    begin
      Exit;
    end;
    Dec(Result);
  end;
  Result := -1;
end;

function TPropertiesToSkip.Add(APersistentClass: TPersistentClass;
  const APropertyName, ANote, AHelpKeyWord: string): Integer;
var
  Item: PRemovedProperty;
begin
  Result := IndexOf(APersistentClass, APropertyName);
  if Result = -1 then
  begin
    New(Item);
    Item^.PersistentClass := APersistentClass;
    Item^.PropertyName := LowerCase(APropertyName);
    Item^.Note := ANote;
    Item^.HelpKeyword := AHelpKeyWord;
    Result := inherited Add(Item);
  end;
end;

{ TReaderUniqueNamer }

procedure TReaderUniqueNamer.OnSetName(Reader: TReader; Component: TComponent;
  var Name: string);
  
  procedure MakeValidIdentifier;
  var
    i: Integer;
  begin
    for i:=length(Name) downto 1 do
      if not (Name[i] in ['0'..'9','_','a'..'z','A'..'Z']) then
        System.Delete(Name,i,1);
    if (Name<>'') and (Name[1] in ['0'..'9']) then
      Name:='_'+Name;
  end;

  function NameIsUnique: Boolean;
  var
    Owner: TComponent;
    i: Integer;
    CurComponent: TComponent;
  begin
    Result:=true;
    if Name='' then exit;
    Owner:=Component.Owner;
    if Owner=nil then exit;
    for i:=0 to Owner.ComponentCount-1 do begin
      CurComponent:=Owner.Components[i];
      if CurComponent=Component then continue;
      if CompareText(CurComponent.Name,Name)=0 then exit(false);
    end;
  end;
  
begin
  MakeValidIdentifier;
  while not NameIsUnique do
    Name:=CreateNextIdentifier(Name);
end;
  
{ TDefineRectPropertyClass }

constructor TDefineRectPropertyClass.Create(AValue, ADefaultRect: PRect);
begin
  Value:=AValue;
  DefaultValue:=ADefaultRect;
end;

procedure TDefineRectPropertyClass.ReadData(Reader: TReader);
begin
  with Reader do begin
    ReadListBegin;
    Value^.Left:=ReadInteger;
    Value^.Top:=ReadInteger;
    Value^.Right:=ReadInteger;
    Value^.Bottom:=ReadInteger;
    ReadListEnd;
  end;
end;

procedure TDefineRectPropertyClass.WriteData(Writer: TWriter);
begin
  with Writer do begin
    WriteListBegin;
    WriteInteger(Value^.Left);
    WriteInteger(Value^.Top);
    WriteInteger(Value^.Right);
    WriteInteger(Value^.Bottom);
    WriteListEnd;
  end;
end;

function TDefineRectPropertyClass.HasData: Boolean;
begin
  if DefaultValue<>nil then begin
    Result:=(DefaultValue^.Left<>Value^.Left)
         or (DefaultValue^.Top<>Value^.Top)
         or (DefaultValue^.Right<>Value^.Right)
         or (DefaultValue^.Bottom<>Value^.Bottom);
  end else begin
    Result:=(Value^.Left<>0)
         or (Value^.Top<>0)
         or (Value^.Right<>0)
         or (Value^.Bottom<>0);
  end;
end;

function InitResourceComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
begin
  Result := InitLazResourceComponent(Instance, RootAncestor);
end;

function FindResourceLFM(ResName: string): HRSRC;
{$if defined(WinCE)}
var
  u: UnicodeString;
begin
  u:=ResName;
  Result := FindResource(HInstance,PWideChar(u),Windows.RT_RCDATA);
end;
{$else}
begin
  Result := FindResource(HInstance,PChar(ResName),
    {$ifdef Windows}Windows.{$endif}RT_RCDATA);
end;
{$endif}

procedure DefineRectProperty(Filer: TFiler; const Name: string; ARect,
  DefaultRect: PRect);
var
  PropDef: TDefineRectPropertyClass;
begin
  PropDef := TDefineRectPropertyClass.Create(ARect, DefaultRect);
  try
    Filer.DefineProperty(Name,@PropDef.ReadData,@PropDef.WriteData,PropDef.HasData);
  finally
    PropDef.Free;
  end;
end;

procedure InitByteToStr;
var
  c: Char;
begin
  if ByteToStrValid then exit;
  for c:=Low(char) to High(char) do
    ByteToStr[c]:=IntToStr(ord(c));
  ByteToStrValid:=true;
end;

function GetClassNameFromLRSStream(s: TStream; out IsInherited: Boolean
  ): shortstring;
var
  Signature: TFilerSignature;
  NameLen: byte;
  OldPosition: Int64;
begin
  Result:='';
  OldPosition:=s.Position;
  // read signature
  Signature:='1234';
  s.Read(Signature[1],length(Signature));
  if Signature<>FilerSignature then exit;
  // read classname length
  NameLen:=0;
  s.Read(NameLen,1);
  if (NameLen and $f0) = $f0 then begin
    // this was the Flag Byte
    IsInherited := (NameLen and ObjStreamMaskInherited) <> 0;
    // read namelen
    s.Read(NameLen,1);
  end else
    IsInherited := False;
  // read classname
  if NameLen>0 then begin
    SetLength(Result,NameLen);
    s.Read(Result[1],NameLen);
  end;
  s.Position:=OldPosition;
end;

procedure GetComponentInfoFromLRSStream(s: TStream; out ComponentName,
  ComponentClassName: string; out IsInherited: Boolean);
var
  Signature: TFilerSignature;
  NameLen: byte;
  OldPosition: Int64;
  Flag: Byte;
begin
  ComponentName:='';
  ComponentClassName:='';
  OldPosition:=s.Position;
  // read signature
  Signature:='1234';
  s.Read(Signature[1],length(Signature));
  if Signature<>FilerSignature then exit;
  // read classname length
  NameLen:=0;
  s.Read(NameLen,1);
  if (NameLen and $f0) = $f0 then begin
    // Read Flag Byte
    Flag:=NameLen;
    IsInherited := (Flag and ObjStreamMaskInherited) <> 0;
    s.Read(NameLen,1);
  end else
    IsInherited := False;
  // read classname
  if NameLen>0 then begin
    SetLength(ComponentClassName,NameLen);
    s.Read(ComponentClassName[1],NameLen);
  end;
  // read component name length
  NameLen:=0;
  s.Read(NameLen,1);
  // read componentname
  if NameLen>0 then begin
    SetLength(ComponentName,NameLen);
    s.Read(ComponentName[1],NameLen);
  end;
  s.Position:=OldPosition;
end;

procedure WriteComponentAsBinaryToStream(AStream: TStream;
  AComponent: TComponent);
var
  Writer: TWriter;
  DestroyDriver: Boolean;
begin
  DestroyDriver:=false;
  Writer:=nil;
  try
    Writer:=CreateLRSWriter(AStream,DestroyDriver);
    Writer.WriteDescendent(AComponent,nil);
  finally
    if DestroyDriver then
      Writer.Driver.Free;
    Writer.Free;
  end;
end;

procedure ReadComponentFromBinaryStream(AStream: TStream;
  var RootComponent: TComponent;
  OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
  Parent: TComponent; ReaderRoot: TComponent);
var
  DestroyDriver: Boolean;
  Reader: TReader;
  IsInherited: Boolean;
  AClassName: String;
  AClass: TComponentClass;
  UniqueNamer: TReaderUniqueNamer;
begin
  // get root class
  AClassName:=GetClassNameFromLRSStream(AStream,IsInherited);
  if IsInherited then begin
    // inherited is not supported by this simple function
    {$IFNDEF DisableChecks}
    DebugLn('ReadComponentFromBinaryStream WARNING: "inherited" is not supported by this simple function');
    {$ENDIF}
  end;
  AClass:=nil;
  OnFindComponentClass(nil,AClassName,AClass);
  if AClass=nil then
    raise EClassNotFound.CreateFmt('Class "%s" not found', [AClassName]);

  if RootComponent=nil then begin
    // create root component
    // first create the new instance and set the variable ...
    RootComponent:=AClass.NewInstance as TComponent;
    // then call the constructor
    RootComponent.Create(TheOwner);
  end else begin
    // there is a root component, check if class is compatible
    if not RootComponent.InheritsFrom(AClass) then begin
      raise EComponentError.CreateFmt('Cannot assign a %s to a %s.',
                                      [AClassName,RootComponent.ClassName]);
    end;
  end;

  // read the root component
  DestroyDriver:=false;
  Reader:=nil;
  UniqueNamer:=nil;
  try
    UniqueNamer:=TReaderUniqueNamer.Create;
    Reader:=CreateLRSReader(AStream,DestroyDriver);
    if ReaderRoot = nil then
      Reader.Root:=RootComponent
    else
      Reader.Root:=ReaderRoot;
    Reader.Owner:=TheOwner;
    Reader.Parent:=Parent;
    Reader.OnFindComponentClass:=OnFindComponentClass;
    Reader.OnSetName:=@UniqueNamer.OnSetName;
    Reader.BeginReferences;
    try
      Reader.Driver.BeginRootComponent;
      RootComponent:=Reader.ReadComponent(RootComponent);
      Reader.FixupReferences;
    finally
      Reader.EndReferences;
    end;
  finally
    if DestroyDriver then
      Reader.Driver.Free;
    UniqueNamer.Free;
    Reader.Free;
  end;
end;

procedure WriteComponentAsTextToStream(AStream: TStream; AComponent: TComponent);
var
  BinStream: TMemoryStream;
begin
  BinStream:=nil;
  try
    BinStream:=TMemoryStream.Create;
    WriteComponentAsBinaryToStream(BinStream,AComponent);
    BinStream.Position:=0;
    LRSObjectBinaryToText(BinStream,AStream);
  finally
    BinStream.Free;
  end;
end;

procedure ReadComponentFromTextStream(AStream: TStream;
  var RootComponent: TComponent;
  OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
  Parent: TComponent);
var
  BinStream: TMemoryStream;
begin
  BinStream:=nil;
  try
    BinStream:=TMemoryStream.Create;
    LRSObjectTextToBinary(AStream,BinStream);
    BinStream.Position:=0;
    ReadComponentFromBinaryStream(BinStream,RootComponent,OnFindComponentClass,
                                  TheOwner,Parent);
  finally
    BinStream.Free;
  end;
end;

procedure SaveComponentToConfig(Config: TConfigStorage; const Path: string;
  AComponent: TComponent);
var
  BinStream: TMemoryStream;
  TxtStream: TMemoryStream;
  s: string;
begin
  BinStream:=nil;
  TxtStream:=nil;
  try
    // write component to stream
    BinStream:=TMemoryStream.Create;
    WriteComponentAsBinaryToStream(BinStream,AComponent);
    // convert it to human readable text format
    BinStream.Position:=0;
    TxtStream:=TMemoryStream.Create;
    LRSObjectBinaryToText(BinStream,TxtStream);
    // convert stream to string
    SetLength(s,TxtStream.Size);
    TxtStream.Position:=0;
    if s<>'' then
      TxtStream.Read(s[1],length(s));
    // write to config
    Config.SetDeleteValue(Path,s,'');
  finally
    BinStream.Free;
    TxtStream.Free;
  end;
end;

procedure LoadComponentFromConfig(Config: TConfigStorage; const Path: string;
  var RootComponent: TComponent;
  OnFindComponentClass: TFindComponentClassEvent; TheOwner: TComponent;
  Parent: TComponent);
var
  s: String;
  TxtStream: TMemoryStream;
begin
  // read from config
  s:=Config.GetValue(Path,'');
  TxtStream:=nil;
  try
    TxtStream:=TMemoryStream.Create;
    if s<>'' then
      TxtStream.Write(s[1],length(s));
    TxtStream.Position:=0;
    // create component from stream
    ReadComponentFromTextStream(TxtStream,RootComponent,OnFindComponentClass,
                                TheOwner,Parent);
  finally
    TxtStream.Free;
  end;
end;

function CompareComponents(Component1, Component2: TComponent): boolean;
var
  Stream1: TMemoryStream;
  Stream2: TMemoryStream;
  i: Integer;
begin
  if Component1=Component2 then exit(true);
  Result:=false;
  // quick checks
  if (Component1=nil) or (Component2=nil) then exit;
  if (Component1.ClassType<>Component2.ClassType) then exit;
  if Component1.ComponentCount<>Component2.ComponentCount then exit;
  for i:=0 to Component1.ComponentCount-1 do begin
    if Component1.Components[i].ClassType<>Component2.Components[i].ClassType
    then exit;
  end;
  // expensive streaming test
  try
    Stream1:=nil;
    Stream2:=nil;
    try
      Stream1:=TMemoryStream.Create;
      WriteComponentAsBinaryToStream(Stream1,Component1);
      Stream2:=TMemoryStream.Create;
      WriteComponentAsBinaryToStream(Stream2,Component2);
      Result:=CompareMemStreams(Stream1,Stream2);
    finally
      Stream1.Free;
      Stream2.Free;
    end;
  except
  end;
end;

function CompareMemStreams(Stream1, Stream2: TCustomMemoryStream
  ): boolean;
var
  p1: Pointer;
  p2: Pointer;
  Cnt: Int64;
  CurCnt: cardinal;
begin
  if Stream1=Stream2 then exit(true);
  Result:=false;
  if (Stream1=nil) or (Stream2=nil) then exit;
  if Stream1.Size<>Stream2.Size then exit;
  Cnt:=Stream1.Size;
  p1:=Stream1.Memory;
  p2:=Stream2.Memory;
  while Cnt>0 do begin
    CurCnt:=Cnt;
    if CurCnt>=High(Cardinal) then CurCnt:=High(Cardinal);
    if not CompareMem(p1,p2,CurCnt) then exit;
    inc(p1,CurCnt);
    inc(p2,CurCnt);
    dec(Cnt,CurCnt);
  end;
  Result:=true;
end;

procedure BinaryToLazarusResourceCode(BinStream,ResStream:TStream;
  const ResourceName, ResourceType: String);
{ example ResStream:
  LazarusResources.Add('ResourceName','ResourceType',
    #123#45#34#78#18#72#45#34#78#18#72#72##45#34#78#45#34#78#184#34#78#145#34#78
    +#83#187#6#78#83
  );
}
const
  ReadBufSize = 4096;
  WriteBufSize = 4096;
var
  s, Indent: string;
  x: integer;
  c: char;
  RangeString, NewRangeString: boolean;
  RightMargin, CurLine: integer;
  WriteBufStart, Writebuf: PChar;
  WriteBufPos: Integer;
  ReadBufStart, ReadBuf: PChar;
  ReadBufPos, ReadBufLen: integer;
  MinCharCount: Integer;
  
  procedure FillReadBuf;
  begin
    ReadBuf:=ReadBufStart;
    ReadBufPos:=0;
    ReadBufLen:=BinStream.Read(ReadBuf^,ReadBufSize);
  end;
  
  procedure InitReadBuf;
  begin
    GetMem(ReadBufStart,ReadBufSize);
    FillReadBuf;
  end;

  function ReadChar(var c: char): boolean;
  begin
    if ReadBufPos>=ReadBufLen then begin
      FillReadBuf;
      if ReadBufLen=0 then begin
        Result:=false;
        exit;
      end;
    end;
    c:=ReadBuf^;
    inc(ReadBuf);
    inc(ReadBufPos);
    Result:=true;
  end;

  procedure InitWriteBuf;
  begin
    GetMem(WriteBufStart,WriteBufSize);
    WriteBuf:=WriteBufStart;
    WriteBufPos:=0;
  end;

  procedure FlushWriteBuf;
  begin
    if WriteBufPos>0 then begin
      ResStream.Write(WriteBufStart^,WriteBufPos);
      WriteBuf:=WriteBufStart;
      WriteBufPos:=0;
    end;
  end;
  
  procedure WriteChar(c: char);
  begin
    WriteBuf^:=c;
    inc(WriteBufPos);
    inc(WriteBuf);
    if WriteBufPos>=WriteBufSize then
      FlushWriteBuf;
  end;
  
  procedure WriteString(const s: string);
  var
    i: Integer;
  begin
    for i:=1 to length(s) do WriteChar(s[i]);
  end;

  procedure WriteShortString(const s: string);
  var
    i: Integer;
  begin
    for i:=1 to length(s) do WriteChar(s[i]);
  end;

begin
  // fpc is not optimized for building a constant string out of thousands of
  // lines. It needs huge amounts of memory and becomes very slow. Therefore big
  // files are split into several strings.

  InitReadBuf;
  InitWriteBuf;
  InitByteToStr;

  Indent:='';
  s:=Indent+'LazarusResources.Add('''+ResourceName+''','''+ResourceType+''',['+LineEnd;
  WriteString(s);
  Indent:='  '+Indent;
  WriteString(Indent);
  x:=length(Indent);
  RangeString:=false;
  CurLine:=1;
  RightMargin:=80;
  if ReadBufLen>0 then begin
    while ReadChar(c) do begin
      NewRangeString:=(ord(c)>=32) and (ord(c)<127);
      // check if new char fits into line or if a new line must be started
      if NewRangeString then begin
        if RangeString then
          MinCharCount:=2 // char plus '
        else
          MinCharCount:=3; // ' plus char plus '
        if c='''' then inc(MinCharCount);
      end else begin
        MinCharCount:=1+length(ByteToStr[c]); // # plus number
        if RangeString then
          inc(MinCharCount); // plus ' for ending last string constant
      end;
      if x+MinCharCount>RightMargin then begin
        // break line
        if RangeString then begin
          // end string constant
          WriteChar('''');
        end;
        // write line ending
        WriteShortString(LineEnd);
        x:=0;
        inc(CurLine);
        // write indention
        WriteString(Indent);
        inc(x,length(Indent));
        // write operator
        if (CurLine and 63)<>1 then
          WriteChar('+')
        else
          WriteChar(',');
        inc(x);
        RangeString:=false;
      end;
      // write converted byte
      if RangeString<>NewRangeString then begin
        WriteChar('''');
        inc(x);
      end;
      if NewRangeString then begin
        WriteChar(c);
        inc(x);
        if c='''' then begin
          WriteChar(c);
          inc(x);
        end;
      end else begin
        WriteChar('#');
        inc(x);
        WriteShortString(ByteToStr[c]);
        inc(x,length(ByteToStr[c]));
      end;
      // next
      RangeString:=NewRangeString;
    end;
    if RangeString then begin
      WriteChar('''');
    end;
  end else begin
    WriteShortString('''''');
  end;
  Indent:=copy(Indent,3,length(Indent)-2);
  s:=LineEnd+Indent+']);'+LineEnd;
  WriteString(s);
  FlushWriteBuf;
  FreeMem(ReadBufStart);
  FreeMem(WriteBufStart);
end;

function FindLFMClassName(LFMStream:TStream):ansistring;
{ examples:
  object Form1: TForm1
  inherited AboutBox2: TAboutBox2

  -> the classname is the last word of the first line
}
var c:char;
  StartPos, EndPos: Int64;
begin
  Result:='';
  StartPos:=-1;
  c:=' ';
  // read till end of line
  repeat
    // remember last non identifier char position
    if (not (c in ['a'..'z','A'..'Z','0'..'9','_'])) then
      StartPos:=LFMStream.Position;
    if LFMStream.Read(c,1)<>1 then exit;
    if LFMStream.Position>1000 then exit;
  until c in [#10,#13];
  if StartPos<0 then exit;
  EndPos:=LFMStream.Position-1;
  if EndPos-StartPos>255 then exit;
  SetLength(Result,EndPos-StartPos);
  LFMStream.Position:=StartPos;
  if Length(Result) > 0 then
    LFMStream.Read(Result[1],length(Result));
  LFMStream.Position:=0;
  if not IsValidIdent(Result) then
    Result:='';
end;

function LFMtoLRSfile(const LFMfilename: string):boolean;
// returns true if successful
var
  LFMFileStream, LRSFileStream: TFileStream;
  LFMMemStream, LRSMemStream: TMemoryStream;
  LRSfilename: string;
begin
  Result:=true;
  try
    LFMFileStream:=TFileStream.Create(LFMfilename,fmOpenRead);
    LFMMemStream:=TMemoryStream.Create;
    LRSMemStream:=TMemoryStream.Create;
    try
      LFMMemStream.SetSize(LFMFileStream.Size);
      LFMMemStream.CopyFrom(LFMFileStream,LFMFileStream.Size);
      LFMMemStream.Position:=0;
      LRSfilename:=ChangeFileExt(LFMfilename,'.lrs');
      Result:=LFMtoLRSstream(LFMMemStream,LRSMemStream);
      if not Result then exit;
      LRSMemStream.Position:=0;
      LRSFileStream:=TFileStream.Create(LRSfilename,fmCreate);
      try
        LRSFileStream.CopyFrom(LRSMemStream,LRSMemStream.Size);
      finally
        LRSFileStream.Free;
      end;
    finally
      LFMMemStream.Free;
      LRSMemStream.Free;
      LFMFileStream.Free;
    end;
  except
    on E: Exception do begin
      {$IFNDEF DisableChecks}
      DebugLn('LFMtoLRSfile ',E.Message);
      {$ENDIF}
      Result:=false;
    end;
  end;
end;

function LFMtoLRSstream(LFMStream, LRSStream: TStream):boolean;
// returns true if successful
var FormClassName:ansistring;
  BinStream:TMemoryStream;
begin
  Result:=true;
  try
    FormClassName:=FindLFMClassName(LFMStream);
    BinStream:=TMemoryStream.Create;
    try
      LRSObjectTextToBinary(LFMStream,BinStream);
      BinStream.Position:=0;
      BinaryToLazarusResourceCode(BinStream,LRSStream,FormClassName,'FORMDATA');
    finally
      BinStream.Free;
    end;
  except
    on E: Exception do begin
      {$IFNDEF DisableChecks}
      DebugLn('LFMtoLRSstream ',E.Message);
      {$ENDIF}
      Result:=false;
    end;
  end;
end;

//==============================================================================

{ TLResourceList }

constructor TLResourceList.Create;
begin
  FList := TList.Create;
  FMergeList := TList.Create;
  FSortedCount := 0;
end;

destructor TLResourceList.Destroy;
var
  a: integer;
begin
  for a := 0 to FList.Count - 1 do
    TLResource(FList[a]).Free;
  FList.Free;
  FMergeList.Free;
end;

function TLResourceList.Count: integer;
begin
  if (Self<>nil) and (FList<>nil) then
    Result:=FList.Count
  else
    Result:=0;
end;

procedure TLResourceList.Add(const Name, ValueType: AnsiString;
  const Values: array of string);
var
  NewLResource: TLResource;
  i, TotalLen, ValueCount, p: integer;
begin
  NewLResource := TLResource.Create;
  NewLResource.Name := Name;
  NewLResource.ValueType := uppercase(ValueType);
  
  ValueCount := High(Values) - Low(Values) + 1;
  case ValueCount of
    0:
      begin
        NewLResource.Free;
        exit;
      end;
    1:
      NewLResource.Value:=Values[0];
  else
    TotalLen := 0;
    for i := Low(Values) to High(Values) do
      inc(TotalLen, length(Values[i]));
    SetLength(NewLResource.Value, TotalLen);
    p := 1;
    for i := Low(Values) to High(Values) do
    begin
      if length(Values[i]) > 0 then
      begin
        Move(Values[i][1], NewLResource.Value[p], length(Values[i]));
        inc(p, length(Values[i]));
      end;
    end;
  end;
  
  FList.Add(NewLResource);
end;

function TLResourceList.Find(const Name: AnsiString):TLResource;
var
  P: Integer;
begin
  P := FindPosition(Name);
  if P >= 0 then
    Result := TLResource(FList[P])
  else
    Result := nil;
end;

function TLResourceList.Find(const Name, ValueType: AnsiString): TLResource;
var
  P, I: Integer;
begin
  P := FindPosition(Name);
  if P >= 0 then
  begin
    // Since we can have many resources that have the same name but different type
    // we should look before and after found position (do not forget that we are searching
    // them by dividing intervals)
  
    // look before position
    for I := P - 1 downto 0 do
    begin
      Result := TLResource(FList[I]);
      if SysUtils.CompareText(Result.Name,Name)<>0 then
        break;
      if Result.ValueType = ValueType then
        Exit;
    end;
    // look behind position
    for I := P to FList.Count - 1 do
    begin
      Result := TLResource(FList[I]);
      if SysUtils.CompareText(Result.Name,Name)<>0 then
        break;
      if Result.ValueType = ValueType then
        Exit;
    end;
  end;
  Result := nil;
end;

function TLResourceList.FindPosition(const Name: AnsiString): Integer;
var
  L, R, C: Integer;
begin
  if FSortedCount < FList.Count then
    Sort;
  L := 0;
  R := FList.Count-1;
  while (L <= R) do
  begin
    Result := (L + R) shr 1;
    C := SysUtils.CompareText(Name, TLResource(FList[Result]).Name);
    if C < 0 then
      R := Result - 1
    else
    if C > 0 then
      L := Result + 1
    else
      Exit;
  end;
  Result := -1;
end;

function TLResourceList.GetItems(Index: integer): TLResource;
begin
  Result := TLResource(FList[Index]);
end;

procedure TLResourceList.Sort;
{$IFNDEF DisableChecks}
var
  i: Integer;
  r1: TLResource;
  r2: TLResource;
{$ENDIF}
begin
  if FSortedCount = FList.Count then
    exit;
  // sort the unsorted elements
  FMergeList.Count := FList.Count;
  MergeSort(FList, FMergeList, FSortedCount, FList.Count - 1);
  // merge both
  Merge(FList, FMergeList, 0, FSortedCount, FList.Count - 1);
  FSortedCount := FList.Count;
  // check for doubles
  {$IFNDEF DisableChecks}
  for i:=0 to FList.Count-2 do
  begin
    r1:=TLResource(FList[i]);
    r2:=TLResource(FList[i+1]);
    if (SysUtils.CompareText(r1.Name,r2.Name)=0) and (r1.ValueType=r2.ValueType) then
    begin
      DebugLn(['TLResourceList.Sort ',i,' DUPLICATE RESOURCE FOUND: ',r1.Name,':',r1.ValueType]);
      //DumpStack;
    end;
  end;
  {$ENDIF}
end;

procedure TLResourceList.MergeSort(List, MergeList: TList; Pos1, Pos2: integer);
var
  cmp, mid: integer;
begin
  if Pos1 = Pos2 then
  begin
  end else
  if Pos1 + 1 = Pos2 then
  begin
    cmp := SysUtils.CompareText(TLResource(List[Pos1]).Name, TLResource(List[Pos2]).Name);
    if cmp > 0 then
    begin
      MergeList[Pos1] := List[Pos1];
      List[Pos1] := List[Pos2];
      List[Pos2] := MergeList[Pos1];
    end;
  end else
  begin
    if Pos2 > Pos1 then
    begin
      mid := (Pos1 + Pos2) shr 1;
      MergeSort(List, MergeList, Pos1, mid);
      MergeSort(List, MergeList, mid + 1, Pos2);
      Merge(List, MergeList, Pos1, mid + 1, Pos2);
    end;
  end;
end;

procedure TLResourceList.Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer);
// merge two sorted arrays
// the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3
var
  Src1Pos, Src2Pos, DestPos, cmp, a: integer;
begin
  if (Pos1 >= Pos2) or (Pos2 > Pos3) then
    exit;
  Src1Pos := Pos2 - 1;
  Src2Pos := Pos3;
  DestPos := Pos3;
  while (Src2Pos >= Pos2) and (Src1Pos >= Pos1) do
  begin
    cmp:=SysUtils.CompareText(TLResource(List[Src1Pos]).Name, TLResource(List[Src2Pos]).Name);
    if cmp > 0 then
    begin
      MergeList[DestPos] := List[Src1Pos];
      dec(Src1Pos);
    end else
    begin
      MergeList[DestPos] := List[Src2Pos];
      dec(Src2Pos);
    end;
    dec(DestPos);
  end;
  while Src2Pos >= Pos2 do
  begin
    MergeList[DestPos] := List[Src2Pos];
    dec(Src2Pos);
    dec(DestPos);
  end;
  for a := DestPos + 1 to Pos3 do
    List[a] := MergeList[a];
end;

procedure TLResourceList.Add(const Name, ValueType, Value: AnsiString);
begin
  Add(Name, ValueType, [Value]);
end;

//------------------------------------------------------------------------------
// Delphi object streams

type
  TDelphiValueType = (dvaNull, dvaList, dvaInt8, dvaInt16, dvaInt32, dvaExtended,
    dvaString, dvaIdent, dvaFalse, dvaTrue, dvaBinary, dvaSet, dvaLString,
    dvaNil, dvaCollection, dvaSingle, dvaCurrency, dvaDate, dvaWString,
    dvaInt64, dvaUTF8String);
    
  TDelphiReader = class
  private
    FStream: TStream;
  protected
    procedure SkipBytes(Count: Integer);
    procedure SkipSetBody;
    procedure SkipProperty;
  public
    constructor Create(Stream: TStream);
    procedure ReadSignature;
    procedure Read(out Buf; Count: Longint);
    function ReadInteger: Longint;
    function ReadValue: TDelphiValueType;
    function NextValue: TDelphiValueType;
    function ReadStr: string;
    function EndOfList: Boolean;
    procedure SkipValue;
    procedure CheckValue(Value: TDelphiValueType);
    procedure ReadListEnd;
    procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); virtual;
    function ReadFloat: Extended;
    function ReadSingle: Single;
    function ReadCurrency: Currency;
    function ReadDate: TDateTime;
    function ReadString: string;
    //function ReadWideString: WideString;
    function ReadInt64: Int64;
    function ReadIdent: string;
  end;

  TDelphiWriter = class
  private
    FStream: TStream;
  public
    constructor Create(Stream: TStream);
    procedure Write(const Buf; Count: Longint);
  end;
  
{ TDelphiReader }

procedure ReadError(Msg: string);
begin
  raise EReadError.Create(Msg);
end;

procedure PropValueError;
begin
  ReadError(rsInvalidPropertyValue);
end;

procedure TDelphiReader.SkipBytes(Count: Integer);
begin
  FStream.Position:=FStream.Position+Count;
end;

procedure TDelphiReader.SkipSetBody;
begin
  while ReadStr <> '' do ;
end;

procedure TDelphiReader.SkipProperty;
begin
  ReadStr; { Skips property name }
  SkipValue;
end;

constructor TDelphiReader.Create(Stream: TStream);
begin
  FStream:=Stream;
end;

procedure TDelphiReader.ReadSignature;
var
  Signature: TFilerSignature;
begin
  Signature:='1234';
  Read(Signature[1], length(Signature));
  if Signature<>FilerSignature then
    ReadError(rsInvalidStreamFormat);
end;

procedure TDelphiReader.Read(out Buf; Count: Longint);
begin
  FStream.Read(Buf,Count);
end;

function TDelphiReader.ReadInteger: Longint;
var
  S: Shortint;
  I: Smallint;
begin
  case ReadValue of
    dvaInt8:
      begin
        Read(S, SizeOf(Shortint));
        Result := S;
      end;
    dvaInt16:
      begin
        Read(I, SizeOf(I));
        Result := I;
      end;
    dvaInt32:
      Read(Result, SizeOf(Result));
  else
    Result:=0;
    PropValueError;
  end;
end;

function TDelphiReader.ReadValue: TDelphiValueType;
var b: byte;
begin
  Read(b,1);
  Result:=TDelphiValueType(b);
end;

function TDelphiReader.NextValue: TDelphiValueType;
begin
  Result := ReadValue;
  FStream.Position:=FStream.Position-1;
end;

function TDelphiReader.ReadStr: string;
var
  L: Byte;
begin
  Read(L, SizeOf(Byte));
  SetLength(Result, L);
  if L>0 then
    Read(Result[1], L);
end;

function TDelphiReader.EndOfList: Boolean;
begin
  Result := (ReadValue = dvaNull);
  FStream.Position:=FStream.Position-1;
end;

procedure TDelphiReader.SkipValue;

  procedure SkipList;
  begin
    while not EndOfList do SkipValue;
    ReadListEnd;
  end;

  procedure SkipBinary(BytesPerUnit: Integer);
  var
    Count: Longint;
  begin
    Read(Count, SizeOf(Count));
    SkipBytes(Count * BytesPerUnit);
  end;

  procedure SkipCollection;
  begin
    while not EndOfList do
    begin
      if NextValue in [dvaInt8, dvaInt16, dvaInt32] then SkipValue;
      SkipBytes(1);
      while not EndOfList do SkipProperty;
      ReadListEnd;
    end;
    ReadListEnd;
  end;

begin
  case ReadValue of
    dvaNull: { no value field, just an identifier };
    dvaList: SkipList;
    dvaInt8: SkipBytes(SizeOf(Byte));
    dvaInt16: SkipBytes(SizeOf(Word));
    dvaInt32: SkipBytes(SizeOf(LongInt));
    dvaExtended: SkipBytes(SizeOf(Extended));
    dvaString, dvaIdent: ReadStr;
    dvaFalse, dvaTrue: { no value field, just an identifier };
    dvaBinary: SkipBinary(1);
    dvaSet: SkipSetBody;
    dvaLString: SkipBinary(1);
    dvaCollection: SkipCollection;
    dvaSingle: SkipBytes(Sizeof(Single));
    dvaCurrency: SkipBytes(SizeOf(Currency));
    dvaDate: SkipBytes(Sizeof(TDateTime));
    dvaWString: SkipBinary(Sizeof(WideChar));
    dvaInt64: SkipBytes(Sizeof(Int64));
    dvaUTF8String: SkipBinary(1);
  end;
end;

procedure TDelphiReader.CheckValue(Value: TDelphiValueType);
begin
  if ReadValue <> Value then
  begin
    FStream.Position:=FStream.Position-1;
    SkipValue;
    PropValueError;
  end;
end;

procedure TDelphiReader.ReadListEnd;
begin
  CheckValue(dvaNull);
end;

procedure TDelphiReader.ReadPrefix(var Flags: TFilerFlags;
  var AChildPos: Integer);
var
  Prefix: Byte;
begin
  Flags := [];
  if Byte(NextValue) and $F0 = $F0 then
  begin
    Prefix := Byte(ReadValue);
    if (Prefix and ObjStreamMaskInherited)>0 then
      Include(Flags,ffInherited);
    if (Prefix and ObjStreamMaskChildPos)>0 then
      Include(Flags,ffChildPos);
    if (Prefix and ObjStreamMaskInline)>0 then
      Include(Flags,ffInline);
    if ffChildPos in Flags then AChildPos := ReadInteger;
  end;
end;

function TDelphiReader.ReadFloat: Extended;
begin
  if ReadValue = dvaExtended then
    Read(Result, SizeOf(Result))
  else begin
    FStream.Position:=FStream.Position-1;
    Result := ReadInteger;
  end;
end;

function TDelphiReader.ReadSingle: Single;
begin
  if ReadValue = dvaSingle then
    Read(Result, SizeOf(Result))
  else begin
    FStream.Position:=FStream.Position-1;
    Result := ReadInteger;
  end;
end;

function TDelphiReader.ReadCurrency: Currency;
begin
  if ReadValue = dvaCurrency then
    Read(Result, SizeOf(Result))
  else begin
    FStream.Position:=FStream.Position-1;
    Result := ReadInteger;
  end;
end;

function TDelphiReader.ReadDate: TDateTime;
begin
  if ReadValue = dvaDate then
    Read(Result, SizeOf(Result))
  else begin
    FStream.Position:=FStream.Position-1;
    Result := ReadInteger;
  end;
end;

function TDelphiReader.ReadString: string;
var
  L: Integer;
begin
  Result := '';
  if NextValue in [dvaWString, dvaUTF8String] then begin
    ReadError('TDelphiReader.ReadString: WideString and UTF8String are not implemented yet');
    //Result := ReadWideString;
  end else
  begin
    L := 0;
    case ReadValue of
      dvaString:
        Read(L, SizeOf(Byte));
      dvaLString:
        Read(L, SizeOf(Integer));
    else
      PropValueError;
    end;
    SetLength(Result, L);
    Read(Pointer(Result)^, L);
  end;
end;

function TDelphiReader.ReadInt64: Int64;
begin
  if NextValue = dvaInt64 then
  begin
    ReadValue;
    Read(Result, Sizeof(Result));
  end
  else
    Result := ReadInteger;
end;

function TDelphiReader.ReadIdent: string;
var
  L: Byte;
begin
  case ReadValue of
    dvaIdent:
      begin
        Read(L, SizeOf(Byte));
        SetLength(Result, L);
        Read(Result[1], L);
      end;
    dvaFalse:
      Result := 'False';
    dvaTrue:
      Result := 'True';
    dvaNil:
      Result := 'nil';
    dvaNull:
      Result := 'Null';
  else
    Result:='';
    PropValueError;
  end;
end;

{ TDelphiWriter }

{ MultiByte Character Set (MBCS) byte type }
type
  TMbcsByteType = (mbSingleByte, mbLeadByte, mbTrailByte);

function ByteType(const S: string; Index: Integer): TMbcsByteType;
begin
  Result := mbSingleByte;
  { ToDo:
    if SysLocale.FarEast then
      Result := ByteTypeTest(PChar(S), Index-1);
  }
end;

constructor TDelphiWriter.Create(Stream: TStream);
begin
  FStream:=Stream;
end;

procedure TDelphiWriter.Write(const Buf; Count: Longint);
begin
  FStream.Write(Buf,Count);
end;

procedure ReadLFMHeader(LFMStream: TStream;
  out LFMType, LFMComponentName, LFMClassName: String);
var
  c:char;
  Token: String;
begin
  { examples:
    object Form1: TForm1
    inherited AboutBox2: ns.unit2/TAboutBox2
  }
  LFMComponentName:='';
  LFMClassName := '';
  LFMType := '';
  Token := '';
  while (LFMStream.Read(c,1)=1) and (LFMStream.Position<1000) do begin
    case c of
    ' ',#9,':':
      begin
        if Token<>'' then begin
          if LFMType = '' then
            LFMType := Token
          else if LFMComponentName='' then
            LFMComponentName:=Token
          else if LFMClassName = '' then
          begin
            LFMClassName := Token;
            exit;
          end;
          Token := '';
        end;
      end;
    'a'..'z','A'..'Z','0'..'9','_','.','/':
      Token:=Token+c;
    else
      break;
    end;
  end;
  LFMStream.Position:=0;
end;

procedure ReadLFMHeader(const LFMSource: string;
  out LFMClassName: String; out LFMType: String);
var
  LFMComponentName: string;
begin
  ReadLFMHeader(LFMSource,LFMType,LFMComponentName,LFMClassName);
end;

procedure ReadLFMHeader(const LFMSource: string; out LFMType, LFMComponentName,
  LFMClassName: String);
var
  p: Integer;
  StartPos: LongInt;
begin
  { examples:
    object Form1: TForm1
    inherited AboutBox2: ns.unit1/TAboutBox2

    - LFMType is the first word on the line, e.g. object or inherited
    - LFMComponentName is the second word
    - LFMClassName is the third
  }

  // read LFMType
  p:=1;
  while (p<=length(LFMSource))
  and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
    inc(p);
  LFMType:=copy(LFMSource,1,p-1);

  // read LFMComponentName
  while (p<=length(LFMSource)) and (LFMSource[p] in [' ',#9]) do inc(p);
  StartPos:=p;
  while (p<=length(LFMSource))
  and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
    inc(p);
  LFMComponentName:=copy(LFMSource,StartPos,p-StartPos);

  // read LFMClassName
  while (p<=length(LFMSource)) and (LFMSource[p] in [' ',#9,':']) do inc(p);
  StartPos:=p;
  while (p<=length(LFMSource))
  and (LFMSource[p] in ['a'..'z','A'..'Z','0'..'9','_','.','/']) do
    inc(p);
  LFMClassName:=copy(LFMSource,StartPos,p-StartPos);
end;

function ReadLFMHeaderFromFile(const Filename: string; out LFMType,
  LFMComponentName, LFMClassName: String): boolean;
var
  fs: TFileStream;
  Header: string;
  Cnt: LongInt;
begin
  Result:=false;
  try
    fs:=TFileStream.Create(Filename,fmOpenRead);
    try
      SetLength(Header,600);
      Cnt:=fs.Read(Header[1],length(Header));
      SetLength(Header,Cnt);
      ReadLFMHeader(Header,LFMType,LFMComponentName,LFMClassName);
      Result:=LFMClassName<>'';
    finally
      fs.Free;
    end;
  except
  end;
end;

function CreateLFMFile(AComponent: TComponent; LFMStream: TStream): integer;
// 0 = ok
// -1 = error while streaming AForm to binary stream
// -2 = error while streaming binary stream to text file
var
  BinStream: TMemoryStream;
  DestroyDriver: Boolean;
  Writer: TWriter;
begin
  Result:=0;
  BinStream:=TMemoryStream.Create;
  try
    try
      // write component to binary stream
      DestroyDriver:=false;
      Writer:=CreateLRSWriter(BinStream,DestroyDriver);
      try
        Writer.WriteDescendent(AComponent,nil);
      finally
        if DestroyDriver then Writer.Driver.Free;
        Writer.Free;
      end;
    except
      Result:=-1;
      exit;
    end;
    try
      // transform binary to text
      BinStream.Position:=0;
      LRSObjectBinaryToText(BinStream,LFMStream);
    except
      Result:=-2;
      exit;
    end;
  finally
    BinStream.Free;
  end;
end;

function SameLFMTypeName(aUnitname, aTypename, LFMTypename: string): boolean;
var
  p: SizeInt;
begin
  p:=Pos('/',LFMTypename);
  if p>0 then
  begin
    if aUnitname<>'' then
      Result:=CompareText(aUnitname+'/'+aTypename,LFMTypename)=0
    else
      Result:=CompareText(aTypename,copy(LFMTypename,p+1,length(LFMTypename)))=0;
  end else begin
    Result:=CompareText(aTypename,LFMTypename)=0;
  end;
end;

procedure LRSObjectBinaryToText(Input, Output: TStream);

  procedure OutStr(const s: String);
  {$IFDEF VerboseLRSObjectBinaryToText}
  var
    i: Integer;
  {$ENDIF}
  begin
    {$IFDEF VerboseLRSObjectBinaryToText}
    for i:=1 to length(s) do begin
      if (s[i] in [#0..#8,#11..#12,#14..#31]) then begin
        DbgOut('#'+IntToStr(ord(s[i])));
        RaiseGDBException('ObjectLRSToText: Invalid character');
      end else
        DbgOut(s[i]);
    end;
    {$ENDIF}
    if Length(s) > 0 then
      Output.Write(s[1], Length(s));
  end;

  procedure OutLn(const s: String);
  begin
    OutStr(s + LineEnding);
  end;

  procedure OutString(const s: String);
  var
    res, NewStr: String;
    i: Integer;
    InString, NewInString: Boolean;
  begin
    if s<>'' then begin
      res := '';
      InString := False;
      for i := 1 to Length(s) do begin
        NewInString := InString;
        case s[i] of
          #0..#31: begin
              NewInString := False;
              NewStr := '#' + IntToStr(Ord(s[i]));
            end;
          '''': begin
              NewInString := True;
              NewStr:=''''''; // write two ticks, so the reader will read one
            end;
          else begin
            NewInString := True;
            NewStr := s[i];
          end;
        end;
        if NewInString <> InString then begin
          NewStr := '''' + NewStr;
          InString := NewInString;
        end;
        res := res + NewStr;
      end;
      if InString then res := res + '''';
    end else begin
      res:='''''';
    end;
    OutStr(res);
  end;

  procedure OutWideString(const s: WideString);
  // write as normal string
  var
    res, NewStr: String;
    i: Integer;
    InString, NewInString: Boolean;
  begin
    //debugln('OutWideString ',s);
    res := '';
    if s<>'' then begin
      InString := False;
      for i := 1 to Length(s) do begin
        NewInString := InString;
        if (ord(s[i])<ord(' ')) or (ord(s[i])>=127) then begin
          // special char
          NewInString := False;
          NewStr := '#' + IntToStr(Ord(s[i]));
        end
        else if s[i]='''' then begin
          // '
          if InString then
            NewStr := ''''''
          else
            NewStr := '''''''';
        end
        else begin
          // normal char
          NewInString := True;
          NewStr := AnsiString(s[i]);
        end;
        if NewInString <> InString then begin
          NewStr := '''' + NewStr;
          InString := NewInString;
        end;
        res := res + NewStr;
      end;
      if InString then res := res + '''';
    end else begin
      res:='''''';
    end;
    OutStr(res);
  end;

  function ReadInt(ValueType: TValueType): LongInt;
  var
    w: Word;
  begin
    case ValueType of
      vaInt8: Result := ShortInt(Input.ReadByte);
      vaInt16: begin
          w:=ReadLRSWord(Input);
          //DebugLn('ReadInt vaInt16 w=',IntToStr(w));
          Result := SmallInt(w);
        end;
      vaInt32: Result := ReadLRSInteger(Input);
      else Result := 0;
    end;
  end;

  function ReadInt: LongInt;
  begin
    Result := ReadInt(TValueType(Input.ReadByte));
  end;

  function ReadShortString: String;
  var
    len: Byte;
  begin
    len := Input.ReadByte;
    SetLength(Result, len);
    if (Len > 0) then
      Input.Read(Result[1], len);
  end;

  function ReadLongString: String;
  var
    len: integer;
  begin
    len := ReadLRSInteger(Input);
    SetLength(Result, len);
    if (Len > 0) then
      Input.Read(Result[1], len);
  end;

  procedure ReadPropList(const indent: String);

    procedure ProcessValue(ValueType: TValueType; const Indent: String);

      procedure Stop(const s: String);
      begin
        RaiseGDBException('ObjectLRSToText '+s);
      end;
      
      function ValueTypeAsString(ValueType: TValueType): string;
      begin
        case ValueType of
        vaNull: Result:='vaNull';
        vaList: Result:='vaList';
        vaInt8: Result:='vaInt8';
        vaInt16: Result:='vaInt16';
        vaInt32: Result:='vaInt32';
        vaExtended: Result:='vaExtended';
        vaString: Result:='vaString';
        vaIdent: Result:='vaIdent';
        vaFalse: Result:='vaFalse';
        vaTrue: Result:='vaTrue';
        vaBinary: Result:='vaBinary';
        vaSet: Result:='vaSet';
        vaLString: Result:='vaLString';
        vaNil: Result:='vaNil';
        vaCollection: Result:='vaCollection';
        vaSingle: Result:='vaSingle';
        vaCurrency: Result:='vaCurrency';
        vaDate: Result:='vaDate';
        vaWString: Result:='vaWString';
        vaInt64: Result:='vaInt64';
        vaUTF8String: Result:='vaUTF8String';
        vaUString: Result:='vaUString';
        vaQWord : Result:='vaQWord';
        else Result:='Unknown ValueType='+dbgs(Ord(ValueType));
        end;
      end;
      
      procedure UnknownValueType;
      var
        s: String;
        {$IFNDEF DisableChecks}
        HintStr: string;
        HintLen: Int64;
        {$ENDIF}
      begin
        s:=ValueTypeAsString(ValueType);
        if s<>'' then
          s:='Unimplemented ValueType='+s;
        {$IFNDEF DisableChecks}
        HintLen:=Output.Position;
        if HintLen>50 then HintLen:=50;
        SetLength(HintStr,HintLen);
        if HintStr<>'' then begin
          try
            Output.Position:=Output.Position-length(HintStr);
            Output.Read(HintStr[1],length(HintStr));
            //debugln('ObjectLRSToText:');
            debugln(DbgStr(HintStr));
          except
          end;
        end;
        {$ENDIF}
        s:=s+' ';
        Stop(s);
      end;

      procedure ProcessBinary;
      var
        ToDo, DoNow, StartPos, i: LongInt;
        lbuf: array[0..31] of Byte;
        s: String;
        p: pchar;
      const
        HexDigits: array[0..$F] of char = '0123456789ABCDEF';
      begin
        ToDo := ReadLRSCardinal(Input);
        OutLn('{');
        while ToDo > 0 do begin
          DoNow := ToDo;
          if DoNow > 32 then DoNow := 32;
          Dec(ToDo, DoNow);
          s := Indent + '  ';
          StartPos := length(s);
          Input.Read(lbuf, DoNow);
          setlength(s, StartPos+DoNow*2);
          p := @s[StartPos];
          for i := 0 to DoNow - 1 do begin
            inc(p);
            p^ := HexDigits[(lbuf[i] shr 4) and $F];
            inc(p);
            p^ := HexDigits[lbuf[i] and $F];
          end;
          OutLn(s);
        end;
        OutStr(indent);
        OutLn('}');
      end;

    var
      s: String;
      IsFirst: Boolean;
      ext: Extended;
      ASingle: single;
      ADate: TDateTime;
      ACurrency: Currency;
      AWideString: WideString;

    begin
      //DebugLn(['ProcessValue ',Indent,' ValueType="',ValueTypeAsString(ValueType),'"']);
      case ValueType of
        vaList: begin
            OutStr('(');
            IsFirst := True;
            while True do begin
              ValueType := TValueType(Input.ReadByte);
              if ValueType = vaNull then break;
              if IsFirst then begin
                OutLn('');
                IsFirst := False;
              end;
              OutStr(Indent + '  ');
              ProcessValue(ValueType, Indent + '  ');
            end;
            OutLn(Indent + ')');
          end;
        vaInt8: begin
            // MG: IntToStr has a bug with ShortInt, therefore these typecasts
            OutLn(IntToStr(Integer(ShortInt(Input.ReadByte))));
          end;
        vaInt16: OutLn(IntToStr(SmallInt(ReadLRSWord(Input))));
        vaInt32: OutLn(IntToStr(ReadLRSInteger(Input)));
        vaInt64: OutLn(IntToStr(ReadLRSInt64(Input)));
        vaExtended: begin
            ext:=ReadLRSExtended(Input);
            OutLn(FloatToStr(ext));
          end;
        vaString: begin
            OutString(ReadShortString);
            OutLn('');
          end;
        vaIdent: OutLn(ReadShortString);
        vaFalse: OutLn('False');
        vaTrue: OutLn('True');
        vaBinary: ProcessBinary;
        vaSet: begin
            OutStr('[');
            IsFirst := True;
            while True do begin
              s := ReadShortString;
              if Length(s) = 0 then break;
              if not IsFirst then OutStr(', ');
              IsFirst := False;
              OutStr(s);
            end;
            OutLn(']');
          end;
        vaLString: begin
            OutString(ReadLongString);
            OutLn('');
          end;
        vaNil:
          OutLn('nil');
        vaCollection: begin
            OutStr('<');
            while Input.ReadByte <> 0 do begin
              OutLn(Indent);
              Input.Seek(-1, soFromCurrent);
              OutStr(indent + '  item');
              ValueType := TValueType(Input.ReadByte);
              if ValueType <> vaList then
                OutStr('[' + IntToStr(ReadInt(ValueType)) + ']');
              OutLn('');
              ReadPropList(indent + '    ');
              OutStr(indent + '  end');
            end;
            OutLn('>');
          end;
        vaSingle: begin
            ASingle:=ReadLRSSingle(Input);
            OutLn(FloatToStr(ASingle) + 's');
          end;
        vaDate: begin
            ADate:=TDateTime(ReadLRSDouble(Input));
            OutLn(FloatToStr(ADate) + 'd');
          end;
        vaCurrency: begin
            ACurrency:=ReadLRSCurrency(Input);
            OutLn(FloatToStr(ACurrency * 10000) + 'c');
          end;
        vaWString,vaUString: begin
            AWideString:=ReadLRSWideString(Input);
            OutWideString(AWideString);
            OutLn('');
          end;
        else
          if ord(ValueType)=20 then begin
            // vaUTF8String
            // Delphi saves widestrings as UTF8 strings
            // The LCL does not use widestrings, but UTF8 directly
            // so, simply read and write the string
            OutString(ReadLongString);
            OutLn('');
          end else
            UnknownValueType;
      end;
    end;

  var
    NextByte: Byte;
  begin
    while Input.ReadByte <> 0 do begin
      Input.Seek(-1, soFromCurrent);
      OutStr(indent + ReadShortString + ' = ');
      NextByte:=Input.ReadByte;
      if NextByte<>0 then
        ProcessValue(TValueType(NextByte), Indent)
      else
        OutLn('');
    end;
  end;

  procedure ReadObject(const indent: String);
  var
    b: Byte;
    ObjClassName, ObjName: String;
    ChildPos: LongInt;
  begin
    ChildPos := 0;
    // Check for FilerFlags
    b := Input.ReadByte;
    if (b and $f0) = $f0 then begin
      if (b and ObjStreamMaskChildPos) <> 0 then
        ChildPos := ReadInt;
    end else begin
      b := 0;
      Input.Seek(-1, soFromCurrent);
    end;

    ObjClassName := ReadShortString;
    ObjName := ReadShortString;

    OutStr(Indent);
    if (b and ObjStreamMaskInherited) <> 0 then OutStr('inherited')
    else if (b and ObjStreamMaskInline) <> 0 then OutStr('inline')
    else OutStr('object');
    OutStr(' ');
    if ObjName <> '' then
      OutStr(ObjName + ': ');
    OutStr(ObjClassName);
    if (b and ObjStreamMaskChildPos) <> 0 then OutStr('[' + IntToStr(ChildPos) + ']');
    OutLn('');

    ReadPropList(indent + '  ');

    while Input.ReadByte <> 0 do begin
      Input.Seek(-1, soFromCurrent);
      ReadObject(indent + '  ');
    end;
    OutLn(indent + 'end');
  end;

var
  OldDecimalSeparator: Char;
  OldThousandSeparator: Char;
  Signature: TFilerSignature;
begin
  // Endian note: comparing 2 cardinals is endian independent
  Signature:='1234';
  Input.Read(Signature[1], length(Signature));
  if Signature<>FilerSignature then
    raise EReadError.Create('Illegal stream image' {###SInvalidImage});
  OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
  DefaultFormatSettings.DecimalSeparator:='.';
  OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
  DefaultFormatSettings.ThousandSeparator:=',';
  try
    ReadObject('');
  finally
    DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
    DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
  end;
end;

function TestFormStreamFormat(Stream: TStream): TLRSStreamOriginalFormat;
var
  Pos: TStreamSeekType;
  Signature: TFilerSignature;
begin
  Pos := Stream.Position;
  Signature[1] := #0; // initialize, in case the stream is at its end
  Stream.Read(Signature, length(Signature));
  Stream.Position := Pos;
  if (Signature[1] = #$FF) or (Signature = FilerSignature) then
    Result := sofBinary
    // text format may begin with "object", "inherited", or whitespace
  else if Signature[1] in ['o','O','i','I',' ',#13,#11,#9] then
    Result := sofText
  else
    Result := sofUnknown;
end;

type
  TObjectTextConvertProc = procedure (Input, Output: TStream);

procedure InternalLRSBinaryToText(Input, Output: TStream;
  var OriginalFormat: TLRSStreamOriginalFormat;
  ConvertProc: TObjectTextConvertProc;
  BinarySignature: TFilerSignature);
var
  Pos: TStreamSeekType;
  Signature: TFilerSignature;
begin
  Pos := Input.Position;
  Signature := BinarySignature;
  Signature[1]:=#0;
  Input.Read(Signature[1], length(Signature));
  Input.Position := Pos;
  if Signature = BinarySignature then
  begin     // definitely binary format
    if OriginalFormat = sofBinary then begin
      if Output is TMemoryStream then
        TMemoryStream(Output).SetSize(Output.Position+(Input.Size-Input.Position));
      Output.CopyFrom(Input, Input.Size - Input.Position)
    end else
    begin
      if OriginalFormat = sofUnknown then
        Originalformat := sofBinary;
      ConvertProc(Input, Output);
    end;
  end
  else  // might be text format
  begin
    if OriginalFormat = sofBinary then
      ConvertProc(Input, Output)
    else
    begin
      if OriginalFormat = sofUnknown then
      begin   // text format may begin with "object", "inherited", or whitespace
        if Signature[1] in ['o','O','i','I',' ',#13,#11,#9] then
          OriginalFormat := sofText
        else    // not binary, not text... let it raise the exception
        begin
          ConvertProc(Input, Output);
          Exit;
        end;
      end;
      if OriginalFormat = sofText then begin
        if Output is TMemoryStream then
          TMemoryStream(Output).SetSize(Output.Position
                                        +(Input.Size - Input.Position));
        Output.CopyFrom(Input, Input.Size - Input.Position);
      end;
    end;
  end;
end;

procedure LRSObjectTextToBinary(Input, Output: TStream; Links: TLRPositionLinks);
var
  parser: TParser;
  OldDecimalSeparator: Char;
  OldThousandSeparator: Char;
  TokenStartPos: LongInt;

  procedure WriteShortString(const s: String);
  var
    Size: Integer;
  begin
    Size:=length(s);
    if Size>255 then Size:=255;
    Output.WriteByte(byte(Size));
    if Size > 0 then
      Output.Write(s[1], Size);
  end;

  procedure WriteLongString(const s: String);
  begin
    WriteLRSInteger(Output,Length(s));
    if Length(s) > 0 then
      Output.Write(s[1], Length(s));
  end;

  procedure WriteWideString(const s: WideString);
  begin
    WriteLRSInteger(Output,Length(s));
    if Length(s) > 0 then
      Output.Write(s[1], Length(s)*2);
  end;

  procedure WriteInteger(value: LongInt);
  begin
    if (value >= -128) and (value <= 127) then begin
      Output.WriteByte(Ord(vaInt8));
      Output.WriteByte(Byte(value));
    end else if (value >= -32768) and (value <= 32767) then begin
      Output.WriteByte(Ord(vaInt16));
      WriteLRSWord(Output,Word(value));
    end else begin
      Output.WriteByte(ord(vaInt32));
      WriteLRSInteger(Output,value);
    end;
  end;

  procedure WriteInt64(const Value: Int64);
  begin
    if (Value >= -$80000000) and (Value <= $7fffffff) then
      WriteInteger(Integer(Value))
    else begin
      Output.WriteByte(ord(vaInt64));
      WriteLRSInt64(Output,Value);
    end;
  end;

  procedure WriteIntegerStr(const s: string);
  begin
    if length(s)>7 then
      WriteInt64(StrToInt64(s))
    else
      WriteInteger(StrToInt(s));
  end;

  function ParserNextToken: Char;
  begin
    TokenStartPos:=Parser.SourcePos;
    Result:=Parser.NextToken;
    if Links<>nil then
      Links.SetPosition(TokenStartPos,Parser.SourcePos,Output.Position,true);
  end;
  
  procedure ProcessProperty; forward;

  {$if not declared(toWString)}
    const toWString = char(5);
  {$endif}

  procedure ProcessValue;
  
    procedure RaiseValueExpected;
    begin
      parser.Error('Value expected, but '+parser.TokenString+' found');
    end;
  
  var
    flt: Extended;
    stream: TMemoryStream;
    BinDataSize: LongInt;
    toStringBuf: String;
  begin
    if parser.TokenSymbolIs('END') then exit;
    if parser.TokenSymbolIs('OBJECT') then
      RaiseValueExpected;
    case parser.Token of
      toInteger:
        begin
          WriteIntegerStr(parser.TokenString);
          ParserNextToken;
        end;
      toFloat:
        begin
          flt := Parser.TokenFloat;
          case parser.FloatType of
            's': begin
              Output.WriteByte(Ord(vaSingle));
              WriteLRSSingle(Output,flt);
            end;
            'd': begin
              Output.WriteByte(Ord(vaDate));
              WriteLRSDouble(Output,flt);
            end;
            'c': begin
              Output.WriteByte(Ord(vaCurrency));
              WriteLRSCurrency(Output,flt/10000);
            end;
            else
            begin
              Output.WriteByte(Ord(vaExtended));
              WriteLRSExtended(Output,flt);
            end;
          end;
          ParserNextToken;
        end;
      toString:
        begin
          toStringBuf := parser.TokenString;
          //DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
          while ParserNextToken = '+' do
          begin
            ParserNextToken;   // Get next string fragment
            if not (parser.Token in [toString,toWString]) then
              parser.CheckToken(toString);
            toStringBuf := toStringBuf + parser.TokenString;
          end;
          if length(toStringBuf)<256 then begin
            //debugln('LRSObjectTextToBinary.ProcessValue WriteShortString');
            Output.WriteByte(Ord(vaString));
            WriteShortString(toStringBuf);
          end else begin
            //debugln('LRSObjectTextToBinary.ProcessValue WriteLongString');
            Output.WriteByte(Ord(vaLString));
            WriteLongString(toStringBuf);
          end;
        end;
      toWString:
        begin
          toStringBuf := parser.TokenString;
          //DebugLn(['ProcessValue toStringBuf="',toStringBuf,'" ',dbgstr(toStringBuf)]);
          while ParserNextToken = '+' do
          begin
            ParserNextToken;   // Get next string fragment
            if not (parser.Token in [toString,toWString]) then
              parser.CheckToken(toString);
            toStringBuf := toStringBuf + parser.TokenString;
          end;
          Output.WriteByte(Ord(vaWString));
          WriteWideString(UTF8Decode(toStringBuf));
        end;
      toSymbol:
        begin
          if CompareText(parser.TokenString, 'True') = 0 then
            Output.WriteByte(Ord(vaTrue))
          else if CompareText(parser.TokenString, 'False') = 0 then
            Output.WriteByte(Ord(vaFalse))
          else if CompareText(parser.TokenString, 'nil') = 0 then
            Output.WriteByte(Ord(vaNil))
          else
          begin
            Output.WriteByte(Ord(vaIdent));
            WriteShortString(parser.TokenComponentIdent);
          end;
          ParserNextToken;
        end;
      // Set
      '[':
        begin
          ParserNextToken;
          Output.WriteByte(Ord(vaSet));
          if parser.Token <> ']' then
            while True do
            begin
              parser.CheckToken(toSymbol);
              WriteShortString(parser.TokenString);
              ParserNextToken;
              if parser.Token = ']' then
                break;
              parser.CheckToken(',');
              ParserNextToken;
            end;
          Output.WriteByte(0);
          ParserNextToken;
        end;
      // List
      '(':
        begin
          Output.WriteByte(Ord(vaList));
          ParserNextToken;
          while parser.Token <> ')' do
            ProcessValue;
          Output.WriteByte(0);
          ParserNextToken;
        end;
      // Collection
      '<':
        begin
          ParserNextToken;
          Output.WriteByte(Ord(vaCollection));
          while parser.Token <> '>' do
          begin
            parser.CheckTokenSymbol('item');
            ParserNextToken;
            // ConvertOrder
            Output.WriteByte(Ord(vaList));
            while not parser.TokenSymbolIs('end') do
              ProcessProperty;
            ParserNextToken;   // Skip 'end'
            Output.WriteByte(0);
          end;
          Output.WriteByte(0);
          ParserNextToken;
        end;
      // Binary data
      '{':
        begin
          Output.WriteByte(Ord(vaBinary));
          stream := TMemoryStream.Create;
          try
            parser.HexToBinary(stream);
            BinDataSize:=integer(stream.Size);
            WriteLRSInteger(Output,BinDataSize);
            Output.Write(Stream.Memory^, BinDataSize);
            Stream.Position:=0;
            //debugln('LRSObjectTextToBinary binary data "',dbgMemStream(Stream,30),'"');
          finally
            stream.Free;
          end;
          ParserNextToken;
        end;
      else
        parser.Error('Invalid Property');
    end;
  end;

  procedure ProcessProperty;
  var
    name: String;
  begin
    // Get name of property
    parser.CheckToken(toSymbol);
    name := parser.TokenString;
    while True do begin
      ParserNextToken;
      if parser.Token <> '.' then break;
      ParserNextToken;
      parser.CheckToken(toSymbol);
      name := name + '.' + parser.TokenString;
    end;
    WriteShortString(name);
    parser.CheckToken('=');
    ParserNextToken;
    ProcessValue;
  end;

  procedure ProcessObject;
  var
    Flags: Byte;
    ChildPos: Integer;
    ObjectName, ObjectType: String;
  begin
    if parser.TokenSymbolIs('OBJECT') then
      Flags :=0  { IsInherited := False }
    else if parser.TokenSymbolIs('INHERITED') then
      Flags := 1 { IsInherited := True; }
    else begin
      parser.CheckTokenSymbol('INLINE');
      Flags := 4;
    end;
    ParserNextToken;
    parser.CheckToken(toSymbol);
    if parser.TokenSymbolIs('END') then begin
      // 'object end': no name, no content
      // this is normally invalid, but Delphi can create this, so ignore it
      exit;
    end;
    ObjectName := '';
    ObjectType := parser.TokenString;
    ParserNextToken;
    ChildPos := 0;
    if parser.Token = ':' then begin
      ParserNextToken;
      parser.CheckToken(toSymbol);
      ObjectName := ObjectType;
      ObjectType := parser.TokenString;
      ParserNextToken;
      if parser.Token = '[' then begin
        ParserNextToken;
        ChildPos := parser.TokenInt;
        ParserNextToken;
        parser.CheckToken(']');
        ParserNextToken;
        Flags := Flags or 2;
      end;
    end;
    if Flags <> 0 then begin
      Output.WriteByte($f0 or Flags);
      if (Flags and ObjStreamMaskChildPos) <> 0 then
        WriteInteger(ChildPos);
    end;
    WriteShortString(ObjectType);
    WriteShortString(ObjectName);

    // Convert property list
    while not (parser.TokenSymbolIs('END') or
      parser.TokenSymbolIs('OBJECT') or
      parser.TokenSymbolIs('INHERITED') or
      parser.TokenSymbolIs('INLINE'))
    do
      ProcessProperty;
    Output.WriteByte(0);        // Terminate property list

    // Convert child objects
    while not parser.TokenSymbolIs('END') do ProcessObject;
    ParserNextToken;            // Skip end token
    Output.WriteByte(0);        // Terminate property list
  end;

var
  Count: Integer;
begin
  if Links<>nil then begin
    // sort links for LFM positions
    Links.Sort(true);
  end;
  parser := TParser.Create(Input);
  OldDecimalSeparator:=DefaultFormatSettings.DecimalSeparator;
  DefaultFormatSettings.DecimalSeparator:='.';
  OldThousandSeparator:=DefaultFormatSettings.ThousandSeparator;
  DefaultFormatSettings.ThousandSeparator:=',';
  try
    Count:=0;
    repeat
      Output.Write(FilerSignature[1], length(FilerSignature));
      ProcessObject;
      inc(Count);
    until parser.TokenString='';
    if Count>1 then
      Output.WriteByte(0);        // Terminate object list
  finally
    parser.Free;
    DefaultFormatSettings.DecimalSeparator:=OldDecimalSeparator;
    DefaultFormatSettings.ThousandSeparator:=OldThousandSeparator;
  end;
end;

procedure LRSObjectToText(Input, Output: TStream;
  var OriginalFormat: TLRSStreamOriginalFormat);
begin
  InternalLRSBinaryToText(Input, Output, OriginalFormat,
    @LRSObjectBinaryToText, FilerSignature);
end;

procedure LRSObjectResToText(Input, Output: TStream;
  var OriginalFormat: TLRSStreamOriginalFormat);
begin
  InternalLRSBinaryToText(Input, Output, OriginalFormat,
    @LRSObjectResourceToText, #255);
end;

procedure LRSObjectResourceToText(Input, Output: TStream);
begin
  Input.ReadResHeader;
  LRSObjectBinaryToText(Input, Output);
end;

procedure FormDataToText(FormStream, TextStream: TStream; aFormat: TLRSStreamOriginalFormat);
begin
  if aFormat = sofUnknown then
    aFormat := TestFormStreamFormat(FormStream);
  case aFormat of
    sofBinary:
      LRSObjectResourceToText(FormStream, TextStream);

    sofText:
      begin
        if TextStream is TMemoryStream then
          TMemoryStream(TextStream).SetSize(TextStream.Position+FormStream.Size);
        TextStream.CopyFrom(FormStream,FormStream.Size);
      end;

    else
      raise Exception.Create(rsInvalidFormObjectStream);
  end;
end;

function InitLazResourceComponent(Instance: TComponent;
                                  RootAncestor: TClass): Boolean;

  function InitComponent(ClassType: TClass): Boolean;
  var
    {$ifdef UseLRS}
    LazResource: TLResource;
    {$endif}
    {$ifdef UseRES}
    FPResource: TFPResourceHandle;
    {$endif}
    ResName: String;
    GenericInd: Integer;
    Stream: TStream;
    Reader: TReader;
    DestroyDriver: Boolean;
    Driver: TAbstractObjectReader;
  begin
    //DebugLn(['[InitComponent] ClassType=',ClassType.Classname,' Instance=',DbgsName(Instance),' RootAncestor=',DbgsName(RootAncestor),' ClassType.ClassParent=',DbgsName(ClassType.ClassParent)]);
    Result := False;
    if (ClassType = TComponent) or (ClassType = RootAncestor) then
      Exit;
    if Assigned(ClassType.ClassParent) then
      Result := InitComponent(ClassType.ClassParent);
      
    Stream := nil;
    ResName := ClassType.ClassName;
    // Generics class name can contain <> and resource files do not support it
    GenericInd := ResName.IndexOf('<');
    if GenericInd > 0 then
      SetLength(ResName, GenericInd);

    {$ifdef UseLRS}
    LazResource := LazarusResources.Find(ResName);
    if (LazResource <> nil) and (LazResource.Value <> '') then
      Stream := TLazarusResourceStream.CreateFromHandle(LazResource);
    //DebugLn('[InitComponent] CompResource found for ',ClassType.Classname);
    {$endif}

    {$ifdef UseRES}
    if Stream = nil then
    begin
      FPResource := FindResourceLFM(ResName);
      if FPResource <> 0 then
        Stream := TLazarusResourceStream.CreateFromHandle(HInstance, FPResource);
    end;
    {$endif}
    
    if Stream = nil then
      Exit;
      
    try
      //DebugLn('Form Stream "',ClassType.ClassName,'"');
      //try
      DestroyDriver:=false;
      Reader := CreateLRSReader(Stream, DestroyDriver);
      try
        Reader.ReadRootComponent(Instance);
      finally
        Driver := Reader.Driver;
        Reader.Free;
        if DestroyDriver then
          Driver.Free;
      end;
      //except
      //  on E: Exception do begin
      //    DebugLn(Format(rsFormStreamingError,[ClassType.ClassName,E.Message]));
      //    exit;
      //  end;
      //end;
    finally
      Stream.Free;
    end;
    Result := True;
  end;

begin
  if Instance.ComponentState * [csLoading, csInline] <> []
  then begin
    // global loading not needed
    Result := InitComponent(Instance.ClassType);
  end
  else try
    BeginGlobalLoading;
    Result := InitComponent(Instance.ClassType);
    NotifyGlobalLoading;
  finally
    EndGlobalLoading;
  end;
end;

function CreateLRSReader(s: TStream; var DestroyDriver: boolean): TReader;
var
  p: Pointer;
  Driver: TAbstractObjectReader;
begin
  Result:=TReader.Create(s,4096);
  //If included Default translator LRSTranslator will be set
  if Assigned(LRSTranslator) then
    Result.OnReadStringProperty:=@(LRSTranslator.TranslateStringProperty);

  Result.OnPropertyNotFound := @(PropertiesToSkip.DoPropertyNotFound);

  DestroyDriver:=false;
  if Result.Driver.ClassType=LRSObjectReaderClass then
  begin
    TLRSObjectReader(Result.Driver).Reader:=Result;
    exit;
  end;
  // hack to set a write protected variable.
  // DestroyDriver:=true; TReader will free it
  Driver:=LRSObjectReaderClass.Create(s,4096);
  p:=@Result.Driver;
  Result.Driver.Free;
  TAbstractObjectReader(p^):=Driver;
  TLRSObjectReader(Driver).Reader:=Result;
end;

function CreateLRSWriter(s: TStream; var DestroyDriver: boolean): TWriter;
var
  Driver: TAbstractObjectWriter;
begin
  Driver:=LRSObjectWriterClass.Create(s,4096);
  DestroyDriver:=true;
  Result:=TWriter.Create(Driver);
  TLRSObjectWriter(Driver).Writer:=Result;
end;

{ LRS format converter functions }

procedure ReverseBytes(p: Pointer; Count: integer);
var
  p1: PChar;
  p2: PChar;
  c: Char;
begin
  p1:=PChar(p);
  p2:=PChar(p)+Count-1;
  while p1<p2 do begin
    c:=p1^;
    p1^:=p2^;
    p2^:=c;
    inc(p1);
    dec(p2);
  end;
end;

procedure ReverseByteOrderInWords(p: PWord; Count: integer);
var
  i: Integer;
  w: Word;
begin
  for i:=0 to Count-1 do begin
    w:=p[i];
    w:=(w shr 8) or ((w and $ff) shl 8);
    p[i]:=w;
  end;
end;

function ConvertLRSExtendedToDouble(p: Pointer): Double;
type
  Ti386ExtendedReversed = packed record
    {$IFDEF FPC_BIG_ENDIAN}
    ExponentAndSign: word;
    Mantissa: qword;
    {$ELSE}
    Mantissa: qword;
    ExponentAndSign: word;
    {$ENDIF}
  end;
var
  e: Ti386ExtendedReversed;
  Exponent: word;
  ExponentAndSign: word;
  Mantissa: qword;
begin
  System.Move(p^,e,10);
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@e,10);
  {$ENDIF}
  // i386 extended
  Exponent:=(e.ExponentAndSign and $7fff);
  if (Exponent>$4000+$3ff) or (Exponent<$4000-$400) then begin
    // exponent out of bounds
    Result:=0;
    exit;
  end;
  dec(Exponent,$4000-$400);
  ExponentAndSign:=Exponent or ((e.ExponentAndSign and $8000) shr 4);
  // i386 extended has leading 1, double has not (shl 1)
  // i386 has 64 bit, double has 52 bit (shr 12)
  {$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
    {$IFDEF FPC_BIG_ENDIAN}
    // accessing Mantissa will couse trouble, copy it first
    System.Move(e.Mantissa, Mantissa, SizeOf(Mantissa));
    Mantissa := (Mantissa shl 1) shr 12;
    {$ELSE FPC_BIG_ENDIAN}
    Mantissa := (e.Mantissa shl 1) shr 12;
    {$ENDIF FPC_BIG_ENDIAN}
  {$ELSE FPC_REQUIRES_PROPER_ALIGNMENT}
  Mantissa := (e.Mantissa shl 1) shr 12;
  {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
  // put together
  QWord(Result):=Mantissa or (qword(ExponentAndSign) shl 52);
end;

procedure ConvertEndianBigDoubleToLRSExtended(BigEndianDouble, LRSExtended: Pointer);
// Floats consists of a sign bit, some exponent bits and the mantissa bits
// A 0 is all bits 0
// not 0 has always a leading 1, which exponent is stored
// Single/Double does not save the leading 1, Extended does.
//
// Double is 8 bytes long, leftmost bit is sign,
// then 11 bit exponent based $400, then 52 bit mantissa without leading 1
//
// Extended is 10 bytes long, leftmost bit is sign,
// then 15 bit exponent based $4000, then 64 bit mantissa with leading 1
// EndianLittle means reversed byte order
var
  e: array[0..9] of byte;
  i: Integer;
  Exponent: Word;
  d: PByte;
begin
  d:=PByte(BigEndianDouble);
  // convert ppc double to i386 extended
  if (PCardinal(d)[0] or PCardinal(d)[1])=0 then begin
    // 0
    FillChar(LRSExtended^,10,#0);
  end else begin
    Exponent:=((d[0] and $7f) shl 4)+(d[1] shr 4);
    inc(Exponent,$4000-$400);
    if (d[0] and $80)>0 then
      // signed
      inc(Exponent,$8000);
    e[9]:=Exponent shr 8;
    e[8]:=Exponent and $ff;
    e[7]:=($80 or (d[1] shl 3) or (d[2] shr 5)) and $ff;
    for i:=3 to 7 do begin
      e[9-i]:=((d[i-1] shl 3) or (d[i] shr 5)) and $ff;
    end;
    e[1]:=(d[7] shl 3) and $ff;
    e[0]:=0;
    System.Move(e[0],LRSExtended^,10);
  end;
end;

procedure ConvertLEDoubleToLRSExtended(LEDouble, LRSExtended: Pointer);
type
  TMantissaWrap = record
    case boolean of
      True: (Q: QWord);
      False: (B: array[0..7] of Byte);
  end;

  TExpWrap = packed record
    Mantissa: TMantissaWrap;
    Exp: Word;
  end;

var
  Q: PQWord absolute LEDouble;
  C: PCardinal absolute LEDouble;
  W: PWord absolute LEDouble;
  E: ^TExpWrap absolute LRSExtended;
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  Mantissa: TMantissaWrap;
  {$endif}
begin
  if W[3] and $7FF0 = $7FF0 // infinite or NaN
  then E^.Exp := $7FFF
  else E^.Exp := (W[3] and $7FFF) shr 4 - $3FF + $3FFF;
  E^.Exp := E^.Exp or (W[3] and $8000); // sign
  {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  Mantissa.Q := (Q^ shl 11);
  Mantissa.B[7] := Mantissa.B[7] or $80; // add ignored 1
  System.Move(Mantissa, E^.Mantissa, 8);
  {$else}
  E^.Mantissa.Q := (Q^ shl 11);
  E^.Mantissa.B[7] := E^.Mantissa.B[7] or $80; // add ignored 1
  {$endif}
end;

function ReadLRSShortInt(s: TStream): shortint;
begin
  Result:=0;
  s.Read(Result,1);
end;

function ReadLRSByte(s: TStream): byte;
begin
  Result:=0;
  s.Read(Result,1);
end;

function ReadLRSWord(s: TStream): word;
begin
  Result:=0;
  s.Read(Result,2);
  {$IFDEF FPC_BIG_ENDIAN}
  Result:=((Result and $ff) shl 8) or (Result shr 8);
  {$ENDIF}
end;

function ReadLRSSmallInt(s: TStream): smallint;
begin
  Result:=0;
  {$IFDEF FPC_BIG_ENDIAN}
  Result:=smallint(ReadLRSWord(s));
  {$ELSE}
  s.Read(Result,2);
  {$ENDIF}
end;

function ReadLRSInteger(s: TStream): integer;
begin
  Result:=0;
  s.Read(Result,4);
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@Result,4);
  {$ENDIF}
end;

function ReadLRSCardinal(s: TStream): cardinal;
begin
  Result:=0;
  s.Read(Result,4);
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@Result,4);
  {$ENDIF}
end;

function ReadLRSInt64(s: TStream): int64;
begin
  Result:=0;
  s.Read(Result,8);
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@Result,8);
  {$ENDIF}
end;

function ReadLRSSingle(s: TStream): Single;
begin
  Result:=0;
  s.Read(Result,4);
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@Result,4);
  {$ENDIF}
end;

function ReadLRSDouble(s: TStream): Double;
begin
  Result:=0;
  s.Read(Result,8);
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@Result,8);
  {$ENDIF}
end;

function ReadLRSExtended(s: TStream): Extended;
begin
  Result:=0;
  {$IFDEF FPC_HAS_TYPE_EXTENDED}
    s.Read(Result,10);
    {$IFDEF FPC_BIG_ENDIAN}
    ReverseBytes(@Result,10);
    {$ENDIF}
  {$ELSE}
    // possible endian conversion is handled in ConvertLRSExtendedToDouble
    Result:=ReadLRSEndianLittleExtendedAsDouble(s);
  {$ENDIF}
end;

function ReadLRSCurrency(s: TStream): Currency;
begin
  Result:=0;
  s.Read(Result,8);
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@Result,8);
  {$ENDIF}
end;

function ReadLRSWideString(s: TStream): WideString;
var
  Len: LongInt;
begin
  Len:=ReadLRSInteger(s);
  SetLength(Result,Len);
  if Len>0 then begin
    s.Read(Result[1],Len*2);
    {$IFDEF FPC_BIG_ENDIAN}
    ReverseByteOrderInWords(PWord(@Result[1]),Len);
    {$ENDIF}
  end;
end;

function ReadLRSEndianLittleExtendedAsDouble(s: TStream): Double;
var
  e: array[1..10] of byte;
begin
  s.Read(e,10);
  Result:=ConvertLRSExtendedToDouble(@e);
end;

function ReadLRSValueType(s: TStream): TValueType;
var
  b: byte;
begin
  s.Read(b,1);
  Result:=TValueType(b);
end;

function ReadLRSInt64MB(s: TStream): int64;
var
  v: TValueType;
begin
  v:=ReadLRSValueType(s);
  case v of
  vaInt8: Result:=ReadLRSShortInt(s);
  vaInt16: Result:=ReadLRSSmallInt(s);
  vaInt32: Result:=ReadLRSInteger(s);
  vaInt64: Result:=ReadLRSInt64(s);
  else
    raise EInOutError.Create('ordinal valuetype missing');
  end;
end;

procedure WriteLRSReversedWord(s: TStream; w: word);
begin
  w:=(w shr 8) or ((w and $ff) shl 8);
  s.Write(w,2);
end;

procedure WriteLRS4BytesReversed(s: TStream; p: Pointer);
var
  a: array[0..3] of char;
  i: Integer;
begin
  for i:=0 to 3 do
    a[i]:=PChar(p)[3-i];
  s.Write(a[0],4);
end;

procedure WriteLRS8BytesReversed(s: TStream; p: Pointer);
var
  a: array[0..7] of char;
  i: Integer;
begin
  for i:=0 to 7 do
    a[i]:=PChar(p)[7-i];
  s.Write(a[0],8);
end;

procedure WriteLRS10BytesReversed(s: TStream; p: Pointer);
var
  a: array[0..9] of char;
  i: Integer;
begin
  for i:=0 to 9 do
    a[i]:=PChar(p)[9-i];
  s.Write(a[0],10);
end;

procedure WriteLRSReversedWords(s: TStream; p: Pointer; Count: integer);
var
  w: Word;
  i: Integer;
begin
  for i:=0 to Count-1 do begin
    w:=PWord(P)[i];
    w:=(w shr 8) or ((w and $ff) shl 8);
    s.Write(w,2);
  end;
end;

function FloatToLFMStr(const Value: extended; Precision, Digits: Integer): string;
var
  P: Integer;
  TooSmall, TooLarge: Boolean;
  DeletePos: LongInt;
begin
  Result:='';
  If (Precision = -1) or (Precision > 15) then Precision := 15;

  TooSmall := (Abs(Value) < 0.00001) and (Value>0.0);
  if TooSmall then begin
    P := 0;
    TooLarge := False;
  end
  else begin
    Str(Value:digits:precision, Result);
    P := Pos('.', Result);
    TooLarge :=(P > Precision + 1) or (Pos('E', Result)<>0);
  End;

  if TooSmall or TooLarge then begin
    // use exponential format
    Str(Value:Precision + 8, Result);
    P:=4;
    while (P>0) and (Digits < P) and (Result[Precision + 5] = '0') do begin
      if P<>1 then
        system.Delete(Result, Precision + 5, 1)
      else
        system.Delete(Result, Precision + 3, 3);
      Dec(P);
    end;
    if Result[1] = ' ' then
      System.Delete(Result, 1, 1);
    // Strip unneeded zeroes.
    P:=Pos('E',result)-1;
    If P>=0 then begin
      { delete superfluous +? }
      if result[p+2]='+' then
        system.Delete(Result,P+2,1);
      DeletePos:=p;
      while (DeletePos>1) and (Result[DeletePos]='0') do
        Dec(DeletePos);
      if (DeletePos>0) and (Result[DeletePos]=DefaultFormatSettings.DecimalSeparator) Then
        Dec(DeletePos);
      if (DeletePos<p) then
        system.Delete(Result,DeletePos,p-DeletePos);
    end;
  end
  else if (P<>0) then begin
    // we have a decimalseparator
    P := Length(Result);
    While (P>0) and (Result[P] = '0') Do
      Dec(P);
    If (P>0) and (Result[P]=DefaultFormatSettings.DecimalSeparator) Then
      Dec(P);
    SetLength(Result, P);
  end;
end;

function CompareLRPositionLinkWithLFMPosition(Item1, Item2: Pointer): integer;
var
  p1: Int64;
  p2: Int64;
begin
  p1:=PLRPositionLink(Item1)^.LFMPosition;
  p2:=PLRPositionLink(Item2)^.LFMPosition;
  if p1<p2 then
    Result:=1
  else if p1>p2 then
    Result:=-1
  else
    Result:=0;
end;

function CompareLRPositionLinkWithLRSPosition(Item1, Item2: Pointer): integer;
var
  p1: Int64;
  p2: Int64;
begin
  p1:=PLRPositionLink(Item1)^.LRSPosition;
  p2:=PLRPositionLink(Item2)^.LRSPosition;
  if p1<p2 then
    Result:=1
  else if p1>p2 then
    Result:=-1
  else
    Result:=0;
end;

procedure RegisterPropertyToSkip(PersistentClass: TPersistentClass;
  const PropertyName, Note, HelpKeyWord: string);
begin
  PropertiesToSkip.Add(PersistentClass, PropertyName, Note, HelpKeyWord);
end;

procedure Register;
begin
  RegisterComponents('System',[TLazComponentQueue]);
end;

procedure WriteLRSNull(s: TStream; Count: integer);
var
  c: char;
  i: Integer;
begin
  c:=#0;
  for i:=0 to Count-1 do
    s.Write(c,1);
end;

procedure WriteLRSEndianBigDoubleAsEndianLittleExtended(s: TStream;
  EndBigDouble: PByte);
var
  e: array[0..9] of byte;
begin
  ConvertEndianBigDoubleToLRSExtended(EndBigDouble,@e);
  s.Write(e[0],10);
end;

procedure WriteLRSDoubleAsExtended(s: TStream; ADouble: PByte);
var
  e: array[0..9] of byte;
begin
  {$ifdef FPC_LITTLE_ENDIAN}
  ConvertLEDoubleToLRSExtended(ADouble,@e);
  {$else}
  ConvertEndianBigDoubleToLRSExtended(ADouble,@e);
  {$endif}
  s.Write(e[0],10);
end;


procedure WriteLRSSmallInt(s: TStream; const i: SmallInt);
begin
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(i,2);
  {$ELSE}
  WriteLRSReversedWord(s,Word(i));
  {$ENDIF}
end;

procedure WriteLRSWord(s: TStream; const w: word);
begin
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(w,2);
  {$ELSE}
  WriteLRSReversedWord(s,w);
  {$ENDIF}
end;

procedure WriteLRSInteger(s: TStream; const i: integer);
begin
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(i,4);
  {$ELSE}
  WriteLRS4BytesReversed(s,@i);
  {$ENDIF}
end;

procedure WriteLRSCardinal(s: TStream; const c: cardinal);
begin
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(c,4);
  {$ELSE}
  WriteLRS4BytesReversed(s,@c);
  {$ENDIF}
end;

procedure WriteLRSSingle(s: TStream; const si: Single);
begin
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(si,4);
  {$ELSE}
  WriteLRS4BytesReversed(s,@si);
  {$ENDIF}
end;

procedure WriteLRSDouble(s: TStream; const d: Double);
begin
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(d,8);
  {$ELSE}
  WriteLRS8BytesReversed(s,@d);
  {$ENDIF}
end;

procedure WriteLRSExtended(s: TStream; const e: extended);
begin
  {$IFDEF FPC_HAS_TYPE_EXTENDED}
    {$IFDEF FPC_BIG_ENDIAN}
      WriteLRS10BytesReversed(s, @e);
    {$ELSE}
      s.Write(e,10);
    {$ENDIF}
  {$ELSE}
    WriteLRSDoubleAsExtended(s,pbyte(@e))
  {$ENDIF}
end;

procedure WriteLRSInt64(s: TStream; const i: int64);
begin
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(i,8);
  {$ELSE}
  WriteLRS8BytesReversed(s,@i);
  {$ENDIF}
end;

procedure WriteLRSCurrency(s: TStream; const c: Currency);
begin
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(c,8);
  {$ELSE}
  WriteLRS8BytesReversed(s,@c);
  {$ENDIF}
end;

procedure WriteLRSWideStringContent(s: TStream; const w: WideString);
var
  Size: Integer;
begin
  Size:=length(w);
  if Size=0 then exit;
  {$IFDEF FPC_LITTLE_ENDIAN}
  s.Write(w[1], Size * 2);
  {$ELSE}
  WriteLRSReversedWords(s,@w[1],Size);
  {$ENDIF}
end;

procedure WriteLRSInt64MB(s: TStream; const Value: int64);
var
  w: Word;
  i: Integer;
  b: Byte;
begin
  // Use the smallest possible integer type for the given value:
  if (Value >= -128) and (Value <= 127) then
  begin
    b:=byte(vaInt8);
    s.Write(b, 1);
    b:=byte(Value);
    s.Write(b, 1);
  end else if (Value >= -32768) and (Value <= 32767) then
  begin
    b:=byte(vaInt16);
    s.Write(b, 1);
    w:=Word(Value);
    WriteLRSWord(s,w);
  end else if (Value >= -$80000000) and (Value <= $7fffffff) then
  begin
    b:=byte(vaInt32);
    s.Write(b, 1);
    i:=Integer(Value);
    WriteLRSInteger(s,i);
  end else
  begin
    b:=byte(vaInt64);
    s.Write(b, 1);
    WriteLRSInt64(s,Value);
  end;
end;

{ TLRSObjectReader }

procedure TLRSObjectReader.Read(var Buf; Count: LongInt);
var
  CopyNow: LongInt;
  Dest: Pointer;
begin
  Dest := @Buf;
  while Count > 0 do
  begin
    if FBufPos >= FBufEnd then
    begin
      FBufEnd := FStream.Read(FBuffer^, FBufSize);
      if FBufEnd = 0 then
        raise EReadError.Create('Read Error');
      FBufPos := 0;
    end;
    CopyNow := FBufEnd - FBufPos;
    if CopyNow > Count then
      CopyNow := Count;
    Move(PChar(FBuffer)[FBufPos], Dest^, CopyNow);
    Inc(FBufPos, CopyNow);
    Dest:=Dest+CopyNow;
    Dec(Count, CopyNow);
  end;
end;

procedure TLRSObjectReader.SkipProperty;
begin
  { Skip property name, then the property value }
  ReadStr;
  SkipValue;
end;

procedure TLRSObjectReader.SkipSetBody;
begin
  while Length(ReadStr) > 0 do;
end;

procedure TLRSObjectReader.Push(ItemType: TLRSItemType; const AName: string;
                                Root: TComponent; PushCount: integer);
begin
  if FStackPointer=FStackCapacity then begin
    FStackCapacity:=FStackCapacity*2+10;
    ReAllocMem(FStack,SizeOf(TLRSORStackItem)*FStackCapacity);
    FillByte(FStack[FStackPointer],SizeOf(TLRSORStackItem)*(FStackCapacity-FStackPointer),0);
  end;
  //DebugLn(['TLRSObjectReader.Push AName=',AName,' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount]);
  FStack[FStackPointer].Name:=AName;
  FStack[FStackPointer].ItemType:=ItemType;
  FStack[FStackPointer].Root:=Root;
  FStack[FStackPointer].PushCount:=PushCount;
  FStack[FStackPointer].ItemNr:=-1;
  inc(FStackPointer);
end;

procedure TLRSObjectReader.Pop;
var
  Item: PLRSORStackItem;
begin
  if FStackPointer=0 then
    raise Exception.Create('Error: TLRSObjectReader.Pop stack is empty');
  Item:=@FStack[FStackPointer-1];
  //DebugLn(['TLRSObjectReader.Pop AName=',Item^.Name,
  //        ' Type=',GetEnumName(TypeInfo(TLRSItemType), Integer(item^.ItemType)),
  //        ' PushCount=',item^.PushCount,' StackPtr=', FStackPointer]);
  if Item^.PushCount>1 then begin
    // stack item still needs more EndList
    dec(Item^.PushCount);
  end else begin
    // stack item is complete
    dec(FStackPointer);
  end;
end;

procedure TLRSObjectReader.ClearStack;
var
  i: Integer;
begin
  for i:=0 to FStackCapacity-1 do begin
    FStack[i].Name:='';
  end;
  ReAllocMem(FStack,0);
end;

function TLRSObjectReader.InternalReadValue: TValueType;
var
  b: byte;
begin
  Result := vaNull; { Necessary in FPC as TValueType is larger than 1 byte! }
  Read(b,1);
  Result:=TValueType(b);
end;

function TLRSObjectReader.ReadIntegerContent: integer;
begin
  Result:=0;
  Read(Result,4);
  {$ifdef FPC_BIG_ENDIAN}
  ReverseBytes(@Result,4);
  {$endif}
end;

constructor TLRSObjectReader.Create(AStream: TStream; BufSize: Integer);
begin
  inherited Create;
  FStream := AStream;
  FBufSize := BufSize;
  GetMem(FBuffer, BufSize);
end;

destructor TLRSObjectReader.Destroy;
begin
  { Seek back the amount of bytes that we didn't process until now: }
  if Assigned(FStream) then
    FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), soFromCurrent);

  if Assigned(FBuffer) then
    FreeMem(FBuffer, FBufSize);

  ClearStack;

  inherited Destroy;
end;

function TLRSObjectReader.ReadValue: TValueType;
begin
  Result := InternalReadValue;
  case Result of
    vaNull:
      begin
        EndPropertyIfOpen;
        // End previous element collection, list or component.
        if FStackPointer > 0 then
          Pop;
      end;
    vaCollection:
      begin
        Push(lrsitCollection);
      end;
    vaList:
      begin
        // Increase counter for next collection item.
        if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
          Inc(FStack[FStackPointer-1].ItemNr);
        Push(lrsitList);
      end;
  end;
end;

function TLRSObjectReader.NextValue: TValueType;
begin
  Result := InternalReadValue;
  { We only 'peek' at the next value, so seek back to unget the read value: }
  Dec(FBufPos);
end;

procedure TLRSObjectReader.BeginRootComponent;
var
  Signature: TFilerSignature;
begin
  { Read filer signature }
  Signature:='1234';
  Read(Signature[1],length(Signature));
  if Signature <> FilerSignature then
    raise EReadError.Create('Invalid Filer Signature');
end;

procedure TLRSObjectReader.BeginComponent(var Flags: TFilerFlags;
  var AChildPos: Integer; var CompClassName, CompName: String);
var
  Prefix: Byte;
  ValueType: TValueType;
  ItemName: String;
  ItemRoot: TComponent;
begin
  { Every component can start with a special prefix: }
  Flags := [];
  if (Byte(NextValue) and $f0) = $f0 then
  begin
    Prefix := Byte(ReadValue);
    if (ObjStreamMaskInherited and Prefix)<>0 then
      Include(Flags,ffInherited);
    if (ObjStreamMaskInline and Prefix)<>0 then
      Include(Flags,ffInline);
    if (ObjStreamMaskChildPos and Prefix)<>0 then
    begin
      Include(Flags,ffChildPos);
      ValueType := ReadValue;
      case ValueType of
        vaInt8:
          AChildPos := ReadInt8;
        vaInt16:
          AChildPos := ReadInt16;
        vaInt32:
          AChildPos := ReadInt32;
        else
          PropValueError;
      end;
    end;
  end;

  CompClassName := ReadStr;
  CompName := ReadStr;

  // Top component is addressed by ClassName.
  if FStackPointer = 0 then
  begin
    ItemName := CompClassName;
    ItemRoot := nil;
  end
  else
  begin
    ItemName := CompName;
    if Assigned(Reader) then
      // Reader.LookupRoot is the current Root component.
      ItemRoot := Reader.LookupRoot
    else
      ItemRoot := nil;
  end;

  // A component has two lists: properties and childs, hence PopCount=2.
  Push(lrsitComponent, ItemName, ItemRoot, 2);
end;

function TLRSObjectReader.BeginProperty: String;
begin
  EndPropertyIfOpen;
  Result := ReadStr;
  Push(lrsitProperty, Result);
end;

procedure TLRSObjectReader.EndPropertyIfOpen;
begin
  // End previous property.
  if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitProperty) then
    Pop;
end;

function TLRSObjectReader.GetStackPath: string;
var
  i: Integer;
  CurName: string;
  Item: PLRSORStackItem;
begin
  Result:='';

  for i:=0 to FStackPointer-1 do
  begin
    Item := @FStack[i];

    // Reader.Root is the top component in the module.
    if Assigned(Reader) and
       (Item^.ItemType = lrsitComponent) and
       (Item^.Root = Reader.Root) and
       (Item^.Root <> nil) then
    begin
      // Restart path from top component.
      Result := Item^.Root.ClassName;
    end;

    CurName:=Item^.Name;
    if CurName<>'' then begin
      if Result<>'' then Result:=Result+'.';
      Result:=Result+CurName;
    end;
    if Item^.ItemNr >= 0 then
      Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
  end;
end;

procedure TLRSObjectReader.ReadBinary(const DestData: TMemoryStream);
var
  BinSize: LongInt;
begin
  BinSize:=ReadIntegerContent;
  DestData.Size := BinSize;
  Read(DestData.Memory^, BinSize);
end;

function TLRSObjectReader.ReadFloat: Extended;
{$ifndef FPC_HAS_TYPE_EXTENDED}
var
  e: array[1..10] of byte;
{$endif}
begin
  Result:=0;
  {$ifdef FPC_HAS_TYPE_EXTENDED}
    Read(Result, 10);
    {$ifdef FPC_BIG_ENDIAN}
      ReverseBytes(@Result, 10);
    {$endif FPC_BIG_ENDIAN}
  {$else FPC_HAS_TYPE_EXTENDED}
    Read(e, 10);
    Result := ConvertLRSExtendedToDouble(@e);
  {$endif FPC_HAS_TYPE_EXTENDED}
end;

function TLRSObjectReader.ReadSingle: Single;
begin
  Result:=0;
  Read(Result, 4);
  {$ifdef FPC_BIG_ENDIAN}
  ReverseBytes(@Result,4);
  {$endif}
end;

function TLRSObjectReader.ReadCurrency: Currency;
begin
  Result:=0;
  Read(Result, 8);
  {$ifdef FPC_BIG_ENDIAN}
  ReverseBytes(@Result,8);
  {$endif}
end;

function TLRSObjectReader.ReadDate: TDateTime;
begin
  Result:=0;
  Read(Result, 8);
  {$ifdef FPC_BIG_ENDIAN}
  ReverseBytes(@Result,8);
  {$endif}
end;

function TLRSObjectReader.ReadIdent(ValueType: TValueType): String;
var
  b: Byte;
begin
  case ValueType of
    vaIdent:
      begin
        Read(b, 1);
        SetLength(Result, b);
        if ( b > 0 ) then
          Read(Result[1], b);
      end;
    vaNil:
      Result := 'nil';
    vaFalse:
      Result := 'False';
    vaTrue:
      Result := 'True';
    vaNull:
      Result := 'Null';
  else
    Result:='';
    RaiseGDBException('');
  end;
end;

function TLRSObjectReader.ReadInt8: ShortInt;
begin
  Result:=0;
  Read(Result, 1);
end;

function TLRSObjectReader.ReadInt16: SmallInt;
begin
  Result:=0;
  Read(Result, 2);
  {$ifdef FPC_BIG_ENDIAN}
  ReverseBytes(@Result,2);
  {$endif}
end;

function TLRSObjectReader.ReadInt32: LongInt;
begin
  Result:=0;
  Read(Result, 4);
  {$ifdef FPC_BIG_ENDIAN}
  ReverseBytes(@Result,4);
  {$endif}
end;

function TLRSObjectReader.ReadInt64: Int64;
begin
  Result:=0;
  Read(Result, 8);
  {$ifdef FPC_BIG_ENDIAN}
  ReverseBytes(@Result,8);
  {$endif}
end;

function TLRSObjectReader.ReadSet(EnumType: Pointer): Integer;
type
  tset = set of 0..31;
var
  OName: String;
  OValue: Integer;
begin
  try
    Result := 0;
    while True do
    begin
      OName := ReadStr;
      if Length(OName) = 0 then
        break;
      OValue := GetEnumValue(PTypeInfo(EnumType), OName);
      // Eg. "Options" is a set and can give an error when changing component type.
      // Do nothing on error (OValue = -1), was PropValueError;  (JuMa)
      if OValue >= 0 then
        include(tset(result),OValue);
    end;
  except
    SkipSetBody;
    raise;
  end;
end;

procedure TLRSObjectReader.ReadSignature;
begin
end;

function TLRSObjectReader.ReadStr: String;
var
  b: Byte;
begin
  Read(b, 1);
  SetLength(Result, b);
  if b > 0 then
    Read(Result[1], b);
end;

function TLRSObjectReader.ReadString(StringType: TValueType): String;
var
  i: Integer;
  b: byte;
begin
  case StringType of
    vaString:
      begin
        Read(b, 1);
        i:=b;
      end;
    vaLString:
      i:=ReadIntegerContent;
  else
    raise Exception.Create('TLRSObjectReader.ReadString invalid StringType');
  end;
  SetLength(Result, i);
  if i > 0 then
    Read(Pointer(@Result[1])^, i);
end;

function TLRSObjectReader.ReadWideString: WideString;
var
  i: Integer;
begin
  i:=ReadIntegerContent;
  SetLength(Result, i);
  if i > 0 then
    Read(Pointer(@Result[1])^, i*2);
  //debugln('TLRSObjectReader.ReadWideString ',Result);
end;

function TLRSObjectReader.ReadUnicodeString: UnicodeString;
var
  i: Integer;
begin
  i:=ReadIntegerContent;
  SetLength(Result, i);
  if i > 0 then
    Read(Pointer(@Result[1])^, i*2);
  //debugln('TLRSObjectReader.ReadWideString ',Result);
end;

procedure TLRSObjectReader.SkipComponent(SkipComponentInfos: Boolean);
var
  Flags: TFilerFlags;
  Dummy: Integer;
  CompClassName, CompName: String;
begin
  if SkipComponentInfos then
    { Skip prefix, component class name and component object name }
    BeginComponent(Flags, Dummy, CompClassName, CompName);

  { Skip properties }
  while NextValue <> vaNull do
    SkipProperty;
  ReadValue;

  { Skip children }
  while NextValue <> vaNull do
    SkipComponent(True);
  ReadValue;
end;

procedure TLRSObjectReader.SkipValue;

  procedure SkipBytes(Count: LongInt);
  var
    Dummy: array[0..1023] of Byte;
    SkipNow: Integer;
  begin
    while Count > 0 do
    begin
      if Count > 1024 then
        SkipNow := 1024
      else
        SkipNow := Count;
      Read(Dummy, SkipNow);
      Dec(Count, SkipNow);
    end;
  end;

var
  Count: LongInt;
begin
  case ReadValue of
    vaNull, vaFalse, vaTrue, vaNil: ;
    vaList:
      begin
        while NextValue <> vaNull do
          SkipValue;
        ReadValue;
      end;
    vaInt8:
      SkipBytes(1);
    vaInt16:
      SkipBytes(2);
    vaInt32:
      SkipBytes(4);
    vaExtended:
      SkipBytes(10);
    vaString, vaIdent:
      ReadStr;
    vaBinary, vaLString:
      begin
        Count:=ReadIntegerContent;
        SkipBytes(Count);
      end;
    vaWString, vaUString:
      begin
        Count:=ReadIntegerContent;
        SkipBytes(Count*2);
      end;
    vaSet:
      SkipSetBody;
    vaCollection:
      begin
        while NextValue <> vaNull do
        begin
          { Skip the order value if present }
          if NextValue in [vaInt8, vaInt16, vaInt32] then
            SkipValue;
          SkipBytes(1);
          while NextValue <> vaNull do
            SkipProperty;
          ReadValue;
        end;
        ReadValue;
      end;
    vaSingle:
      SkipBytes(4);
    vaCurrency:
      SkipBytes(SizeOf(Currency));
    vaDate:
      SkipBytes(8);
    vaInt64:
      SkipBytes(8);
  else
    RaiseGDBException('TLRSObjectReader.SkipValue unknown valuetype');
  end;
end;

{ TLRSObjectWriter }

procedure TLRSObjectWriter.Push(ItemType: TLRSItemType; const AName: string;
                                Root: TComponent; PushCount: integer;
                                SkipIfEmpty: boolean);
begin
  if FStackPointer=FStackCapacity then begin
    FStackCapacity:=FStackCapacity*2+10;
    ReAllocMem(FStack,SizeOf(TLRSOWStackItem)*FStackCapacity);
    FillByte(FStack[FStackPointer],SizeOf(TLRSOWStackItem)*(FStackCapacity-FStackPointer),0);
  end;
  //if AName<>'' then DebugLn(['TLRSObjectWriter.Push AName=',AName, ' Type=', GetEnumName(TypeInfo(TLRSItemType), Integer(ItemType)),' PushCount=',PushCount,' SkipIfEmpty=',SkipIfEmpty]);
  FStack[FStackPointer].Name:=AName;
  FStack[FStackPointer].ItemType:=ItemType;
  FStack[FStackPointer].Root:=Root;
  FStack[FStackPointer].PushCount:=PushCount;
  FStack[FStackPointer].ItemNr:=-1;
  FStack[FStackPointer].SkipIfEmpty:=SkipIfEmpty;
  FStack[FStackPointer].BufCount:=0;
  if SkipIfEmpty then
    FStack[FStackPointer].State:=lrsowsisStarted
  else begin
    FlushStackToStream;
    FStack[FStackPointer].State:=lrsowsisDataWritten;
  end;
  inc(FStackPointer);
end;

procedure TLRSObjectWriter.EndHeader;
var
  Item: PLRSOWStackItem;
begin
  Item:=@FStack[FStackPointer-1];
  if Item^.State=lrsowsisStarted then
    Item^.State:=lrsowsisHeaderWritten;
end;

procedure TLRSObjectWriter.Pop(WriteNull: boolean);
var
  Item: PLRSOWStackItem;
begin
  if FStackPointer=0 then
    raise Exception.Create('Error: TLRSObjectWriter.Pop stack is empty');
  Item:=@FStack[FStackPointer-1];
  if Item^.PushCount>1 then begin
    // stack item still needs more EndList
    dec(Item^.PushCount);
    if WriteNull then begin
      if Item^.State=lrsowsisHeaderWritten then begin
        // no data yet, append EndList to header
        Item^.State:=lrsowsisStarted;
        WriteValue(vaNull);
        // wait again for data
        Item^.State:=lrsowsisHeaderWritten;
      end else begin
        // write EndList to stream
        WriteValue(vaNull);
      end;
    end;
  end else begin
    // stack item is complete
    dec(FStackPointer);
    //if Item^.BufCount>0 then DebugLn(['TLRSObjectWriter.Pop SKIPPED: ',Item^.Name]);
    if (Item^.State=lrsowsisDataWritten) and WriteNull then
      WriteValue(vaNull);
  end;
end;

procedure TLRSObjectWriter.ClearStack;
var
  i: Integer;
begin
  for i:=0 to FStackCapacity-1 do begin
    FStack[i].Name:='';
    ReAllocMem(FStack[i].Buffer,0);
  end;
  ReAllocMem(FStack,0);
end;

procedure TLRSObjectWriter.FlushStackToStream;
var
  i: Integer;
  Item: PLRSOWStackItem;
begin
  for i:=0 to FStackPointer-1 do begin
    Item:=@FStack[i];
    if Item^.State<>lrsowsisDataWritten then begin
      //DebugLn(['TLRSObjectWriter.Write FLUSH from stack to stream']);
      Item^.State:=lrsowsisDataWritten;
      WriteToStream(Item^.Buffer^,Item^.BufCount);
      Item^.BufCount:=0;
    end;
  end;
end;

procedure TLRSObjectWriter.WriteToStream(const Buffer; Count: Longint);
var
  CopyNow: LongInt;
  SourceBuf: PChar;
begin
  //DebugLn(['TLRSObjectWriter.WriteToStream ',dbgMemRange(@Buffer,Count,80)]);
  if Count<2*FBufSize then begin
    // write a small amount of data
    SourceBuf:=@Buffer;
    while Count > 0 do
    begin
      CopyNow := Count;
      if CopyNow > FBufSize - FBufPos then
        CopyNow := FBufSize - FBufPos;
      Move(SourceBuf^, PChar(FBuffer)[FBufPos], CopyNow);
      Dec(Count, CopyNow);
      Inc(FBufPos, CopyNow);
      SourceBuf:=SourceBuf+CopyNow;
      if FBufPos = FBufSize then
        FlushBuffer;
    end;
  end else begin
    // write a big amount of data
    if FBufPos>0 then
      FlushBuffer;
    FStream.WriteBuffer(Buffer, Count);
  end;
end;

procedure TLRSObjectWriter.FlushBuffer;
begin
  FStream.WriteBuffer(FBuffer^, FBufPos);
  FBufPos := 0;
end;

procedure TLRSObjectWriter.Write(const Buffer; Count: Longint);
var
  Item: PLRSOWStackItem;
begin
  if Count=0 then exit;
  if (FStackPointer>0) then
  begin
    Item:=@FStack[FStackPointer-1];
    case Item^.State of
    lrsowsisStarted:
      begin
        // store data on stack
        //DebugLn(['TLRSObjectWriter.Write STORE data on stack']);
        if Item^.BufCount+Count>Item^.BufCapacity then
        begin
          Item^.BufCapacity:=Item^.BufCount+Count+10;
          ReAllocMem(Item^.Buffer,Item^.BufCapacity);
        end;
        System.Move(Buffer,PByte(Item^.Buffer)[Item^.BufCount],Count);
        inc(Item^.BufCount,Count);
        exit;
      end;
    lrsowsisHeaderWritten:
      begin
        // flush header(s) from stack to stream
        FlushStackToStream;
      end;
    end;
  end;
  // write data to stream
  WriteToStream(Buffer,Count);
end;

procedure TLRSObjectWriter.WriteValue(Value: TValueType);
var
  b: byte;
begin
  b:=byte(Value);
  Write(b, 1);
end;

procedure TLRSObjectWriter.WriteStr(const Value: String);
var
  i: Integer;
  b: Byte;
begin
  i := Length(Value);
  if i > 255 then
    i := 255;
  b:=byte(i);
  Write(b,1);
  if i > 0 then
    Write(Value[1], i);
end;

procedure TLRSObjectWriter.WriteIntegerContent(i: integer);
begin
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@i,4);
  {$ENDIF}
  Write(i,4);
end;

procedure TLRSObjectWriter.WriteWordContent(w: word);
begin
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@w,2);
  {$ENDIF}
  Write(w,2);
end;

procedure TLRSObjectWriter.WriteInt64Content(i: int64);
begin
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@i,8);
  {$ENDIF}
  Write(i,8);
end;

procedure TLRSObjectWriter.WriteSingleContent(s: single);
begin
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@s,4);
  {$ENDIF}
  Write(s,4);
end;

procedure TLRSObjectWriter.WriteDoubleContent(d: Double);
begin
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@d,8);
  {$ENDIF}
  Write(d,8);
end;

procedure TLRSObjectWriter.WriteExtendedContent(e: Extended);
{$IFNDEF FPC_HAS_TYPE_EXTENDED}
var
  LRSExtended: array[1..10] of byte;
{$endif}
begin
  {$IFDEF FPC_HAS_TYPE_EXTENDED}
    {$IFDEF FPC_BIG_ENDIAN}
      ReverseBytes(@e,10);
    {$ENDIF}
      Write(e,10);
  {$ELSE}
    {$IFDEF FPC_BIG_ENDIAN}
      ConvertEndianBigDoubleToLRSExtended(@e,@LRSExtended);
    {$ELSE}
      ConvertLEDoubleToLRSExtended(@e,@LRSExtended);
    {$ENDIF}
      Write(LRSExtended,10);
  {$ENDIF}
end;

procedure TLRSObjectWriter.WriteCurrencyContent(c: Currency);
begin
  {$IFDEF FPC_BIG_ENDIAN}
  ReverseBytes(@c,8);
  {$ENDIF}
  Write(c,8);
end;

procedure TLRSObjectWriter.WriteWideStringContent(const ws: WideString);
begin
  if ws='' then exit;
  {$IFDEF FPC_BIG_ENDIAN}
  WriteWordsReversed(PWord(@ws[1]),length(ws));
  {$ELSE}
  Write(ws[1],length(ws)*2);
  {$ENDIF}
end;

procedure TLRSObjectWriter.WriteWordsReversed(p: PWord; Count: integer);
var
  i: Integer;
  w: Word;
begin
  for i:=0 to Count-1 do begin
    w:=p[i];
    w:=((w and $ff) shl 8) or (w and $ff);
    Write(w,2);
  end;
end;

procedure TLRSObjectWriter.WriteNulls(Count: integer);
var
  c: Char;
  i: Integer;
begin
  c:=#0;
  for i:=0 to Count-1 do Write(c,1);
end;

constructor TLRSObjectWriter.Create(Stream: TStream; BufSize: Integer);
begin
  inherited Create;
  FStream := Stream;
  FBufSize := BufSize;
  GetMem(FBuffer, BufSize);
end;

destructor TLRSObjectWriter.Destroy;
begin
  // Flush all data which hasn't been written yet
  if Assigned(FStream) then
    FlushBuffer;

  if Assigned(FBuffer) then begin
    FreeMem(FBuffer, FBufSize);
    FBuffer:=nil;
  end;

  ClearStack;

  inherited Destroy;
end;

procedure TLRSObjectWriter.BeginCollection;
begin
  //DebugLn(['TLRSObjectWriter.BeginCollection ',FStackPointer]);
  Push(lrsitCollection);
  WriteValue(vaCollection);
end;

procedure TLRSObjectWriter.BeginComponent(Component: TComponent;
  Flags: TFilerFlags; ChildPos: Integer);
var
  Prefix: Byte;
  CanBeOmitted: boolean;
  ItemName: String;
  ItemRoot: TComponent;
begin
  //DebugLn(['TLRSObjectWriter.BeginComponent ',FStackPointer]);
  // an inherited child component can be omitted if empty
  CanBeOmitted:=(not WriteEmptyInheritedChilds)
            and (FStackPointer>0) and (ffInherited in Flags)
            and (not (ffChildPos in Flags));

  // Top component is addressed by ClassName.
  if FStackPointer = 0 then
  begin
    ItemName := Component.ClassName;
    ItemRoot := nil;
  end
  else
  begin
    ItemName := Component.Name;
    if Assigned(Writer) then
      // Writer.Root is the current Root component.
      ItemRoot := Writer.Root
    else
      ItemRoot := nil;
  end;

  // A component has two lists: properties and childs, hence PopCount=2.
  Push(lrsitComponent, ItemName, ItemRoot, 2, CanBeOmitted);

  if not FSignatureWritten then
  begin
    Write(FilerSignature[1], length(FilerSignature));
    FSignatureWritten := True;
  end;

  { Only write the flags if they are needed! }
  if Flags <> [] then
  begin
    Prefix := $f0;
    if ffInherited in Flags then
      inc(Prefix,ObjStreamMaskInherited);
    if ffInline in Flags then
      inc(Prefix,ObjStreamMaskInline);
    if ffChildPos in Flags then
      inc(Prefix,ObjStreamMaskChildPos);
    Write(Prefix, 1);
    if ffChildPos in Flags then
      WriteInteger(ChildPos);
  end;

  WriteStr(Component.ClassName);
  WriteStr(Component.Name);

  EndHeader;
end;

procedure TLRSObjectWriter.WriteSignature;
begin
end;

procedure TLRSObjectWriter.BeginList;
begin
  // Increase counter for next collection item.
  if (FStackPointer > 0) and (FStack[FStackPointer-1].ItemType = lrsitCollection) then
    Inc(FStack[FStackPointer-1].ItemNr);
  //DebugLn(['TLRSObjectWriter.BeginList ',FStackPointer]);
  Push(lrsitList);
  WriteValue(vaList);
end;

procedure TLRSObjectWriter.EndList;
begin
  //DebugLn(['TLRSObjectWriter.EndList ',FStackPointer]);
  Pop(true);
end;

procedure TLRSObjectWriter.BeginProperty(const PropName: String);
begin
  //DebugLn(['TLRSObjectWriter.BeginProperty ',FStackPointer,' ',PropName]);
  Push(lrsitProperty, PropName);
  WriteStr(PropName);
end;

procedure TLRSObjectWriter.EndProperty;
begin
  //DebugLn(['TLRSObjectWriter.EndProperty ',FStackPointer]);
  Pop(false);
end;

function TLRSObjectWriter.GetStackPath: string;
var
  i: Integer;
  CurName: string;
  Item: PLRSOWStackItem;
begin
  Result:='';

  for i:=0 to FStackPointer-1 do
  begin
    Item := @FStack[i];

    // Writer.LookupRoot is the top component in the module.
    if Assigned(Writer) and
       (Item^.ItemType = lrsitComponent) and
       (Item^.Root = Writer.LookupRoot) and
       (Item^.Root <> nil) then
    begin
      // Restart path from top component.
      Result := Item^.Root.ClassName;
    end;

    CurName:=Item^.Name;
    if CurName<>'' then begin
      if Result<>'' then Result:=Result+'.';
      Result:=Result+CurName;
    end;
    if Item^.ItemNr >= 0 then
      Result := Result + '[' + IntToStr(Item^.ItemNr) + ']';
  end;
end;

procedure TLRSObjectWriter.WriteBinary(const Buffer; Count: LongInt);
begin
  WriteValue(vaBinary);
  WriteIntegerContent(Count);
  Write(Buffer, Count);
end;

procedure TLRSObjectWriter.WriteBoolean(Value: Boolean);
begin
  if Value then
    WriteValue(vaTrue)
  else
    WriteValue(vaFalse);
end;

procedure TLRSObjectWriter.WriteFloat(const Value: Extended);
begin
  WriteValue(vaExtended);
  WriteExtendedContent(Value);
end;

procedure TLRSObjectWriter.WriteSingle(const Value: Single);
begin
  WriteValue(vaSingle);
  WriteSingleContent(Value);
end;

procedure TLRSObjectWriter.WriteCurrency(const Value: Currency);
begin
  WriteValue(vaCurrency);
  WriteCurrencyContent(Value);
end;

procedure TLRSObjectWriter.WriteDate(const Value: TDateTime);
begin
  WriteValue(vaDate);
  WriteDoubleContent(Value);
end;

procedure TLRSObjectWriter.WriteIdent(const Ident: string);
begin
  { Check if Ident is a special identifier before trying to just write
    Ident directly }
  if UpperCase(Ident) = 'NIL' then
    WriteValue(vaNil)
  else if UpperCase(Ident) = 'FALSE' then
    WriteValue(vaFalse)
  else if UpperCase(Ident) = 'TRUE' then
    WriteValue(vaTrue)
  else if UpperCase(Ident) = 'NULL' then
    WriteValue(vaNull) else
  begin
    WriteValue(vaIdent);
    WriteStr(Ident);
  end;
end;

procedure TLRSObjectWriter.WriteInteger(Value: Int64);
var
  w: Word;
  i: Integer;
  b: Byte;
begin
  //debugln('TLRSObjectWriter.WriteInteger Value=',Value);
  // Use the smallest possible integer type for the given value:
  if (Value >= -128) and (Value <= 127) then
  begin
    WriteValue(vaInt8);
    b:=Byte(Value);
    Write(b, 1);
  end else if (Value >= -32768) and (Value <= 32767) then
  begin
    WriteValue(vaInt16);
    w:=Word(Value);
    WriteWordContent(w);
  end else if (Value >= -$80000000) and (Value <= $7fffffff) then
  begin
    WriteValue(vaInt32);
    i:=Integer(Value);
    WriteIntegerContent(i);
  end else
  begin
    WriteValue(vaInt64);
    WriteInt64Content(Value);
  end;
end;

procedure TLRSObjectWriter.WriteMethodName(const Name: String);
begin
  if Length(Name) > 0 then
  begin
    WriteValue(vaIdent);
    WriteStr(Name);
  end else
    WriteValue(vaNil);
end;

procedure TLRSObjectWriter.WriteSet(Value: LongInt; SetType: Pointer);
type
  tset = set of 0..31;
var
  i: Integer;
begin
  WriteValue(vaSet);
  for i := 0 to 31 do
  begin
    if (i in tset(Value)) then
      WriteStr(GetEnumName(PTypeInfo(SetType), i));
  end;
  WriteStr('');
end;

procedure TLRSObjectWriter.WriteString(const Value: TLazObjectWriterString);
var
  i: Integer;
  b: Byte;
begin
  i := Length(Value);
  if i <= 255 then
  begin
    WriteValue(vaString);
    b:=byte(i);
    Write(b, 1);
  end else
  begin
    WriteValue(vaLString);
    WriteIntegerContent(i);
  end;
  if i > 0 then
    Write(Value[1], i);
end;

procedure TLRSObjectWriter.WriteWideString(const Value: WideString);
var
  i: Integer;
begin
  WriteValue(vaWString);
  i := Length(Value);
  WriteIntegerContent(i);
  WriteWideStringContent(Value);
end;

procedure TLRSObjectWriter.WriteUnicodeString(const Value: UnicodeString);
var
  i: Integer;
begin
  WriteValue(vaUString);
  i := Length(Value);
  WriteIntegerContent(i);
  WriteWideStringContent(Value);
end;

procedure TLRSObjectWriter.WriteVariant(const Value: Variant);
begin
  case VarType(Value) of
    varnull:
      WriteValue(vaNull);
    varsmallint, varinteger, varshortint, varint64, varbyte, varword, varlongword, varqword:
      WriteInteger(Value);
    varsingle:
      WriteSingle(Value);
    vardouble:
      WriteFloat(Value);
    vardate:
      WriteDate(Value);
    varcurrency:
      WriteCurrency(Value);
    varolestr, varstring:
      WriteString(String(Value));
    varboolean:
      WriteBoolean(Value);
    else
      WriteValue(vaNil);
  end;
end;

{ TLRPositionLinks }

function TLRPositionLinks.GetLFM(Index: integer): Int64;
begin
  Result:=PLRPositionLink(FItems[Index])^.LFMPosition;
end;

function TLRPositionLinks.GetData(Index: integer): Pointer;
begin
  Result:=PLRPositionLink(FItems[Index])^.Data;
end;

function TLRPositionLinks.GetLRS(Index: integer): Int64;
begin
  Result:=PLRPositionLink(FItems[Index])^.LRSPosition;
end;

procedure TLRPositionLinks.SetCount(const AValue: integer);
var
  i: LongInt;
  Item: PLRPositionLink;
begin
  if FCount=AValue then exit;
  // free old items
  for i:=AValue to FCount-1 do begin
    Item:=PLRPositionLink(FItems[i]);
    Dispose(Item);
  end;
  // create new items
  FItems.Count:=AValue;
  for i:=FCount to AValue-1 do begin
    New(Item);
    Item^.LFMPosition:=-1;
    Item^.LRSPosition:=-1;
    Item^.Data:=nil;
    FItems[i]:=Item;
  end;
  FCount:=AValue;
end;

procedure TLRPositionLinks.SetData(Index: integer; const AValue: Pointer);
begin
  PLRPositionLink(FItems[Index])^.Data:=AValue;
end;

procedure TLRPositionLinks.SetLFM(Index: integer; const AValue: Int64);
begin
  PLRPositionLink(FItems[Index])^.LFMPosition:=AValue;
end;

procedure TLRPositionLinks.SetLRS(Index: integer; const AValue: Int64);
begin
  PLRPositionLink(FItems[Index])^.LRSPosition:=AValue;
end;

constructor TLRPositionLinks.Create;
begin
  FItems:=TFPList.Create;
end;

destructor TLRPositionLinks.Destroy;
begin
  Count:=0;
  FItems.Free;
  inherited Destroy;
end;

procedure TLRPositionLinks.Clear;
begin
  Count:=0;
end;

procedure TLRPositionLinks.Sort(LFMPositions: Boolean);
begin
  if LFMPositions then
    FItems.Sort(@CompareLRPositionLinkWithLFMPosition)
  else
    FItems.Sort(@CompareLRPositionLinkWithLRSPosition)
end;

function TLRPositionLinks.IndexOf(const Position: int64; LFMPositions: Boolean
  ): integer;
var
  l, r, m: integer;
  p: Int64;
begin
  // binary search for the line
  l:=0;
  r:=FCount-1;
  while r>=l do begin
    m:=(l+r) shr 1;
    if LFMPositions then
      p:=PLRPositionLink(FItems[m])^.LFMPosition
    else
      p:=PLRPositionLink(FItems[m])^.LRSPosition;
    if p>Position then begin
      // too high, search lower
      r:=m-1;
    end else if p<Position then begin
      // too low, search higher
      l:=m+1;
    end else begin
      // position found
      Result:=m;
      exit;
    end;
  end;
  Result:=-1;
end;

function TLRPositionLinks.IndexOfRange(const FromPos, ToPos: int64;
  LFMPositions: Boolean): integer;
var
  l, r, m: integer;
  p: Int64;
  Item: PLRPositionLink;
begin
  // binary search for the line
  l:=0;
  r:=FCount-1;
  while r>=l do begin
    m:=(l+r) shr 1;
    Item:=PLRPositionLink(FItems[m]);
    if LFMPositions then
      p:=Item^.LFMPosition
    else
      p:=Item^.LRSPosition;
    if p>=ToPos then begin
      // too high, search lower
      r:=m-1;
    end else if p<FromPos then begin
      // too low, search higher
      l:=m+1;
    end else begin
      // position found
      Result:=m;
      exit;
    end;
  end;
  Result:=-1;
end;

procedure TLRPositionLinks.SetPosition(const FromPos, ToPos, MappedPos: int64;
  LFMtoLRSPositions: Boolean);
var
  i: LongInt;
begin
  i:=IndexOfRange(FromPos,ToPos,LFMtoLRSPositions);
  if i>=0 then
    if LFMtoLRSPositions then
      PLRPositionLink(FItems[i])^.LRSPosition:=MappedPos
    else
      PLRPositionLink(FItems[i])^.LFMPosition:=MappedPos;
end;

procedure TLRPositionLinks.Add(const LFMPos, LRSPos: Int64; AData: Pointer);
var
  Item: PLRPositionLink;
begin
  Count:=Count+1;
  Item:=PLRPositionLink(FItems[Count-1]);
  Item^.LFMPosition:=LFMPos;
  Item^.LRSPosition:=LRSPos;
  Item^.Data:=AData;
end;

{ TCustomLazComponentQueue }

function TCustomLazComponentQueue.ReadComponentSize(out ComponentSize,
  SizeLength: int64): Boolean;
// returns true if there are enough bytes to read the ComponentSize
//   and returns the ComponentSize
//   and returns the size (SizeLength) needed to store the ComponentSize

  procedure ReadBytes(var p);
  var a: array[1..9] of byte;
  begin
    FQueue.Top(a[1],1+SizeLength);
    System.Move(a[2],p,SizeLength);
    {$IFDEF FPC_BIG_ENDIAN}
    ReverseBytes(@p,SizeLength);
    {$ENDIF}
  end;

var
  v8: ShortInt;
  v16: SmallInt;
  v32: Integer;
  v64: int64;
  vt: TValueType;
begin
  Result:=false;
  // check if there are enough bytes
  if (FQueue.Size<2) then exit;
  FQueue.Top(vt,1);
  case vt of
  vaInt8: SizeLength:=1;
  vaInt16: SizeLength:=2;
  vaInt32: SizeLength:=4;
  vaInt64: SizeLength:=8;
  else
    raise EInOutError.Create('Invalid size type');
  end;
  if FQueue.Size<1+SizeLength then exit; // need more data
  // read the ComponentSize
  Result:=true;
  case vt of
  vaInt8:
    begin
      ReadBytes(v8);
      ComponentSize:=v8;
    end;
  vaInt16:
    begin
      ReadBytes(v16);
      ComponentSize:=v16;
    end;
  vaInt32:
    begin
      ReadBytes(v32);
      ComponentSize:=v32;
    end;
  vaInt64:
    begin
      ReadBytes(v64);
      ComponentSize:=v64;
    end;
  end;
  inc(SizeLength);
  if ComponentSize<0 then
    raise EInOutError.Create('Size of data in queue is negative');
end;

constructor TCustomLazComponentQueue.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);
  FQueue:=TDynamicDataQueue.Create;
end;

destructor TCustomLazComponentQueue.Destroy;
begin
  FreeAndNil(FQueue);
  inherited Destroy;
end;

procedure TCustomLazComponentQueue.Clear;
begin
  FQueue.Clear;
end;

function TCustomLazComponentQueue.Write(const Buffer; Count: Longint): Longint;
begin
  Result:=FQueue.Push(Buffer,Count);
end;

function TCustomLazComponentQueue.CopyFrom(AStream: TStream; Count: Longint
  ): Longint;
begin
  Result:=FQueue.Push(AStream,Count);
end;

function TCustomLazComponentQueue.HasComponent: Boolean;
var
  ComponentSize, SizeLength: int64;
begin
  if not ReadComponentSize(ComponentSize,SizeLength) then exit(false);
  Result:=FQueue.Size-SizeLength>=ComponentSize;
end;

function TCustomLazComponentQueue.ReadComponent(var AComponent: TComponent;
  NewOwner: TComponent): Boolean;
var
  ComponentSize, SizeLength: int64;
  AStream: TMemoryStream;
begin
  Result:=false;
  if not ReadComponentSize(ComponentSize,SizeLength) then exit;
  if (FQueue.Size-SizeLength<ComponentSize) then exit;
  // a complete component is in the buffer -> copy it to a stream
  AStream:=TMemoryStream.Create;
  try
    // copy component to stream
    AStream.Size:=SizeLength+ComponentSize;
    FQueue.Pop(AStream,SizeLength+ComponentSize);
    // create/read the component
    AStream.Position:=SizeLength;
    ReadComponentFromBinaryStream(AStream,AComponent,
                                  OnFindComponentClass,NewOwner);
  finally
    AStream.Free;
  end;
  Result:=true;
end;

function TCustomLazComponentQueue.ConvertComponentAsString(AComponent: TComponent
  ): string;
var
  AStream: TMemoryStream;
  ComponentSize: Int64;
  LengthSize: Int64;
begin
  // write component to stream
  AStream:=TMemoryStream.Create;
  try
    WriteComponentAsBinaryToStream(AStream,AComponent);

    ComponentSize:=AStream.Size;
    WriteLRSInt64MB(AStream,ComponentSize);
    LengthSize:=AStream.Size-ComponentSize;
    //debugln('TCustomLazComponentQueue.ConvertComponentAsString ComponentSize=',ComponentSize,' LengthSize=',LengthSize);

    SetLength(Result,AStream.Size);
    // write size
    AStream.Position:=ComponentSize;
    AStream.Read(Result[1],LengthSize);
    //debugln('TCustomLazComponentQueue.ConvertComponentAsString ',hexstr(ord(Result[1]),2),' ',hexstr(ord(Result[2]),2),' ',hexstr(ord(Result[3]),2),' ',hexstr(ord(Result[4]),2));
    // write component
    AStream.Position:=0;
    AStream.Read(Result[LengthSize+1],ComponentSize);
  finally
    AStream.Free;
  end;
end;

{ TLazarusResourceStream }

procedure TLazarusResourceStream.Initialize(Name, ResType: PChar);
begin
  if ResType <> nil then
    FLRes := LazarusResources.Find(Name, ResType)
  else
    FLRes := LazarusResources.Find(Name);
    
  if FLRes = nil then
    raise EResNotFound.CreateFmt(SResNotFound, [Name]);
  SetPointer(PChar(FLRes.Value), Length(FLRes.Value));
end;

constructor TLazarusResourceStream.Create(const ResName: string; ResType: PChar);
begin
  inherited Create;
  Initialize(PChar(ResName), ResType);
end;

constructor TLazarusResourceStream.CreateFromID(ResID: Integer; ResType: PChar);
begin
  inherited Create;
  Initialize(PChar(PtrInt(ResID)), ResType);
end;

constructor TLazarusResourceStream.CreateFromHandle(AHandle: TLResource);
begin
  inherited Create;
  FLRes := AHandle;
  SetPointer(PChar(FLRes.Value), Length(FLRes.Value));
end;

{$ifdef UseRes}
constructor TLazarusResourceStream.CreateFromHandle(Instance: TFPResourceHMODULE; AHandle: TFPResourceHandle);
begin
  FPRes := LoadResource(Instance, AHandle);
  if FPRes <> 0 then
    SetPointer(LockResource(FPRes), SizeOfResource(Instance, AHandle));
end;
{$endif}

destructor TLazarusResourceStream.Destroy;
begin
{$ifdef UseRES}
  if FPRes <> 0 then
  begin
    UnlockResource(FPRes);
    FreeResource(FPRes);
  end;
{$endif}
  inherited Destroy;
end;

function TLazarusResourceStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result := 0;
  raise EStreamError.Create(SCantWriteResourceStreamError);
end;

const
  ParseBufSize     = 4096;
  LastSpecialToken = 5;

  TokNames : array[0..LastSpecialToken] of string =
  (
    'EOF',
    'Symbol',
    'String',
    'Integer',
    'Float',
    'WideString'
  );

function TUTF8Parser.GetTokenName(aTok: char): string;
begin
  if ord(aTok) <= LastSpecialToken then
    Result:=TokNames[ord(aTok)]
  else Result:=aTok;
end;

procedure TUTF8Parser.LoadBuffer;
var newread : integer;
begin
  newread:=fStream.Read(fBuf[0],ParseBufSize);
  fBuf[newread]:=#0;
  fLineStart:=fLineStart-fPos; // column = fPos - fLineStart + 1
  fPos:=0;
  fBufLen:=newread;
  fEofReached:=newread=0;
end;

procedure TUTF8Parser.CheckLoadBuffer; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
  if fBuf[fPos]<>#0 then exit;
  if fPos<fBufLen then begin
    // skip #0
    repeat
      inc(fPos);
      if fBuf[fPos]<>#0 then exit;
    until (fPos=fBufLen);
  end;
  LoadBuffer;
end;

procedure TUTF8Parser.ProcessChar; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
  fLastTokenStr:=fLastTokenStr+fBuf[fPos];
  inc(fPos);
  CheckLoadBuffer;
end;

function TUTF8Parser.IsNumber: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
  Result:=fBuf[fPos] in ['0'..'9'];
end;

function TUTF8Parser.IsHexNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
  Result:=fBuf[fPos] in ['0'..'9','A'..'F','a'..'f'];
end;

function TUTF8Parser.IsAlpha: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
  Result:=fBuf[fPos] in ['_','A'..'Z','a'..'z'];
end;

function TUTF8Parser.IsAlphaNum: boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
  Result:=IsAlpha or IsNumber;
end;

function TUTF8Parser.GetHexValue(c: char): byte; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE}
begin
  case c of
    '0'..'9' : Result:=ord(c)-$30;
    'A'..'F' : Result:=ord(c)-$37; //-$41+$0A
    'a'..'f' : Result:=ord(c)-$57; //-$61+$0A
  end;
end;

function TUTF8Parser.GetAlphaNum: string;
begin
  if not IsAlpha then
    ErrorFmt(SParExpected,[GetTokenName(toSymbol)]);
  Result:='';
  while IsAlphaNum do
  begin
    Result:=Result+fBuf[fPos];
    inc(fPos);
    CheckLoadBuffer;
  end;
end;

procedure TUTF8Parser.HandleNewLine;
begin
  if fBuf[fPos]=#13 then //CR
  begin
    inc(fPos);
    CheckLoadBuffer;
    if fBuf[fPos]=#10 then inc(fPos); //CR LF
  end
  else
    inc(fPos); //LF
  CheckLoadBuffer;
  inc(fSourceLine);
  fLineStart:=fPos;
end;

procedure TUTF8Parser.SkipSpaces;
begin
  while fBuf[fPos] in [' ',#9] do begin
    inc(fPos);
    CheckLoadBuffer;
  end;
end;

procedure TUTF8Parser.SkipWhitespace;
begin
  while true do
  begin
    case fBuf[fPos] of
      ' ',#9  : SkipSpaces;
      #10,#13 : HandleNewLine
      else break;
    end;
  end;
end;

procedure TUTF8Parser.HandleEof;
begin
  fToken:=toEOF;
  fLastTokenStr:='';
end;

procedure TUTF8Parser.HandleAlphaNum;
begin
  fLastTokenStr:=GetAlphaNum;
  fToken:=toSymbol;
end;

procedure TUTF8Parser.HandleNumber;
type
  floatPunct = (fpDot,fpE);
  floatPuncts = set of floatPunct;
var
  allowed : floatPuncts;
begin
  fLastTokenStr:='';
  while IsNumber do
    ProcessChar;
  fToken:=toInteger;
  if (fBuf[fPos] in ['.','e','E']) then
  begin
    fToken:=toFloat;
    allowed:=[fpDot,fpE];
    while (fBuf[fPos] in ['.','e','E','0'..'9']) do
    begin
      case fBuf[fPos] of
        '.'     : if fpDot in allowed then Exclude(allowed,fpDot) else break;
        'E','e' : if fpE in allowed then
                  begin
                    allowed:=[];
                    ProcessChar;
                    if (fBuf[fPos] in ['+','-']) then ProcessChar;
                    if not (fBuf[fPos] in ['0'..'9']) then
                      ErrorFmt(SParInvalidFloat,[fLastTokenStr+fBuf[fPos]]);
                  end
                  else break;
      end;
      ProcessChar;
    end;
  end;
  if (fBuf[fPos] in ['s','S','d','D','c','C']) then //single, date, currency
  begin
    fFloatType:=fBuf[fPos];
    inc(fPos);
    CheckLoadBuffer;
    fToken:=toFloat;
  end
  else fFloatType:=#0;
end;

procedure TUTF8Parser.HandleHexNumber;
var valid : boolean;
begin
  fLastTokenStr:='$';
  inc(fPos);
  CheckLoadBuffer;
  valid:=false;
  while IsHexNum do
  begin
    valid:=true;
    ProcessChar;
  end;
  if not valid then
    ErrorFmt(SParInvalidInteger,[fLastTokenStr]);
  fToken:=toInteger;
end;

function TUTF8Parser.HandleQuotedString: string;
begin
  Result:='';
  inc(fPos);
  CheckLoadBuffer;
  while true do
  begin
    case fBuf[fPos] of
      #0     : ErrorStr(SParUnterminatedString);
      #13,#10 : ErrorStr(SParUnterminatedString);
      ''''   : begin
                 inc(fPos);
                 CheckLoadBuffer;
                 if fBuf[fPos]<>'''' then exit;
               end;
    end;
    Result:=Result+fBuf[fPos];
    inc(fPos);
    CheckLoadBuffer;
  end;
end;

function TUTF8Parser.HandleDecimalString: string;
var
  i: integer;
begin
  Result:='';
  inc(fPos);
  CheckLoadBuffer;
  while IsNumber do
  begin
    Result:=Result+fBuf[fPos];
    inc(fPos);
    CheckLoadBuffer;
  end;
  if not TryStrToInt(Result,i) then
    i:=0;
  Result:=UnicodeToUTF8(i); // widestring
end;

procedure TUTF8Parser.HandleString;
var
  IsWideString: Boolean;
begin
  fLastTokenStr:='';
  IsWideString := false;
  while true do begin
    case fBuf[fPos] of
      '''' : fLastTokenStr:=fLastTokenStr+HandleQuotedString;
      '#'  : begin
               fLastTokenStr:=fLastTokenStr+HandleDecimalString;
               IsWideString:=true;
             end;
      else break;
    end;
  end;
  if IsWideString then
    fToken:=Classes.toWString
  else
    fToken:=Classes.toString;
end;

procedure TUTF8Parser.HandleMinus;
begin
  inc(fPos);
  CheckLoadBuffer;
  if IsNumber then
  begin
    HandleNumber;
    fLastTokenStr:='-'+fLastTokenStr;
  end
  else
  begin
    fToken:='-';
    fLastTokenStr:=fToken;
  end;
end;

procedure TUTF8Parser.HandleUnknown;
begin
  fToken:=fBuf[fPos];
  fLastTokenStr:=fToken;
  inc(fPos);
  CheckLoadBuffer;
end;

constructor TUTF8Parser.Create(Stream: TStream);
begin
  fStream:=Stream;
  fBuf:=GetMem(ParseBufSize+1);
  fBufLen:=0;
  fPos:=0;
  fLineStart:=0;
  fSourceLine:=1;
  fEofReached:=false;
  fLastTokenStr:='';
  fFloatType:=#0;
  fToken:=#0;
  LoadBuffer;
  NextToken;
end;

destructor TUTF8Parser.Destroy;
begin
  fStream.Position:=SourcePos;
  FreeMem(fBuf);
end;

procedure TUTF8Parser.CheckToken(T: Char);
begin
  if fToken<>T then
    ErrorFmt(SParWrongTokenType,[GetTokenName(T),GetTokenName(fToken)]);
end;

procedure TUTF8Parser.CheckTokenSymbol(const S: string);
begin
  CheckToken(toSymbol);
  if CompareText(fLastTokenStr,S)<>0 then
    ErrorFmt(SParWrongTokenSymbol,[s,fLastTokenStr]);
end;

procedure TUTF8Parser.Error(const Ident: string);
begin
  ErrorStr(Ident);
end;

procedure TUTF8Parser.ErrorFmt(const Ident: string; const Args: array of const);
begin
  ErrorStr(Format(Ident,Args));
end;

procedure TUTF8Parser.ErrorStr(const Message: string);
begin
  debugln(['TUTF8Parser.ErrorStr Message="',Message,'" at y=',SourceLine,',x=',SourceColumn]);
  raise EParserError.CreateFmt(Message+SParLocInfo,[SourceLine,SourceColumn,SourcePos]);
end;

procedure TUTF8Parser.HexToBinary(Stream: TStream);
var outbuf : array[0..ParseBufSize-1] of byte;
    b : byte;
    i : integer;
begin
  i:=0;
  SkipWhitespace;
  while IsHexNum do
  begin
    b:=(GetHexValue(fBuf[fPos]) shl 4);
    inc(fPos);
    CheckLoadBuffer;
    if not IsHexNum then
      Error(SParUnterminatedBinValue);
    b:=b or GetHexValue(fBuf[fPos]);
    inc(fPos);
    CheckLoadBuffer;
    outbuf[i]:=b;
    inc(i);
    if i>=ParseBufSize then
    begin
      Stream.WriteBuffer(outbuf[0],i);
      i:=0;
    end;
    SkipWhitespace;
  end;
  if i>0 then
    Stream.WriteBuffer(outbuf[0],i);
  NextToken;
end;

function TUTF8Parser.NextToken: Char;

begin
  SkipWhiteSpace;
  if fEofReached then
    HandleEof
  else
    case fBuf[fPos] of
      '_','A'..'Z','a'..'z' : HandleAlphaNum;
      '$'                   : HandleHexNumber;
      '-'                   : HandleMinus;
      '0'..'9'              : HandleNumber;
      '''','#'              : HandleString
      else
        HandleUnknown;
    end;
  Result:=fToken;
end;

function TUTF8Parser.SourcePos: Longint;
begin
  Result:=fStream.Position-fBufLen+fPos;
end;

function TUTF8Parser.TokenComponentIdent: string;
begin
  if fToken<>toSymbol then
    ErrorFmt(SParExpected,[GetTokenName(toSymbol)]);
  CheckLoadBuffer;
  while fBuf[fPos]='.' do
  begin
    ProcessChar;
    fLastTokenStr:=fLastTokenStr+GetAlphaNum;
  end;
  Result:=fLastTokenStr;
end;

function TUTF8Parser.TokenFloat: Extended;

var errcode : word;

begin
  Val(fLastTokenStr,Result,errcode);
  if errcode<>0 then
    ErrorFmt(SParInvalidFloat,[fLastTokenStr]);
end;

function TUTF8Parser.TokenInt: Int64;
begin
  if not TryStrToInt64(fLastTokenStr,Result) then
    Result:=Int64(StrToQWord(fLastTokenStr)); //second chance for malformed files
end;

function TUTF8Parser.TokenString: string;
begin
  case fToken of
    toFloat : if fFloatType<>#0 then
                Result:=fLastTokenStr+fFloatType
              else Result:=fLastTokenStr
    else
      Result:=fLastTokenStr;
  end;
end;

function TUTF8Parser.TokenSymbolIs(const S: string): Boolean;
begin
  Result:=(fToken=toSymbol) and (CompareText(fLastTokenStr,S)=0);
end;

function TUTF8Parser.SourceColumn: integer;
begin
  Result:=fPos-fLineStart+1;
end;

//------------------------------------------------------------------------------
procedure InternalInit;
begin
  LazarusResources := TLResourceList.Create;
  RegisterInitComponentHandler(TComponent, @InitResourceComponent);
  PropertiesToSkip := TPropertiesToSkip.Create;
end;

initialization
  InternalInit;

finalization
  FreeAndNil(LazarusResources);
  FreeAndNil(PropertiesToSkip);

end.