{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 1995-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.Classes;

interface

uses
  System.Collections, System.ComponentModel, System.IO, System.Threading, System.Text,
  ActiveX, Windows, SysUtils, Types, Variants, TypInfo,
  System.ComponentModel.Design.Serialization, System.Reflection;

type
{ TStream seek origins }
  TSeekOrigin = (soBeginning, soCurrent, soEnd);

const
  { Maximum TList size }

  MaxListSize = Maxint div 16;

  { TStream seek origins compatibility aliases }

  soFromBeginning = soBeginning deprecated;
  soFromCurrent = soCurrent deprecated;
  soFromEnd = soEnd deprecated;

const
{ TFileStream create mode }

  fmCreate = $FFFF;

{ TParser special tokens }

  toEOF     = Char(0);
  toSymbol  = Char(1);
  toString  = Char(2);
  toInteger = Char(3);
  toFloat   = Char(4);
  toWString = Char(5);

  {+ ! Moved here from menus.pas !!}
  { TShortCut special values }

  scShift = $2000;
  scCtrl = $4000;
  scAlt = $8000;
  scNone = 0;

type

{ Text alignment types }

  TAlignment = (taLeftJustify, taRightJustify, taCenter);
  TLeftRight = taLeftJustify..taRightJustify;
  TBiDiMode = (bdLeftToRight, bdRightToLeft, bdRightToLeftNoAlign,
    bdRightToLeftReadingOnly);
  TVerticalAlignment = (taAlignTop, taAlignBottom, taVerticalCenter);
  TTopBottom = taAlignTop..taAlignBottom;

{ Types used by standard events }

  TShiftState = set of (ssShift, ssAlt, ssCtrl,
    ssLeft, ssRight, ssMiddle, ssDouble);

  THelpContext = -MaxLongint..MaxLongint;
  THelpType = (htKeyword, htContext);

  {+ ! Moved here from menus.pas !!}
  TShortCut = Low(Word)..High(Word);

{ Standard events }

  TNotifyEvent = procedure(Sender: TObject) of object;
  TGetStrProc = procedure(const S: string) of object;

{ Exception classes }

  EStreamError = class(Exception);
  EFileStreamError = class(EStreamError);

  EFCreateError = class(EFileStreamError);
  EFOpenError = class(EFileStreamError);
  EFilerError = class(EStreamError);
  EReadError = class(EFilerError);
  EWriteError = class(EFilerError);
  EClassNotFound = class(EFilerError);
  EMethodNotFound = class(EFilerError);
  EInvalidImage = class(EFilerError);
  EResNotFound = class(Exception);
  EListError = class(Exception);
  EBitsError = class(Exception);
  EStringListError = class(Exception);
  EComponentError = class(Exception);
  EParserError = class(Exception);
  EOutOfResources = class(Exception);
  EInvalidOperation = class(Exception);

{ Duplicate management }

  TDuplicates = (dupIgnore, dupAccept, dupError);

{ Forward class declarations }

  TStream = class;
  TFiler = class;
  TReader = class;
  TWriter = class;
  TComponent = System.ComponentModel.Component;

                                                                                                           
  // corbin note: You have to pepper it, or add the attribute to a base class.
  [ToolboxItem(False)]
  TBasicAction = class;

{ TList class }

  TListSortCompare = function (Item1, Item2: TObject): Integer;
  TListNotification = (lnAdded, lnExtracted, lnDeleted);

  // these operators are used in Assign and go beyond simply copying
  //   laCopy = dest becomes a copy of the source
  //   laAnd  = intersection of the two lists
  //   laOr   = union of the two lists
  //   laXor  = only those not in both lists
  // the last two operators can actually be thought of as binary operators but
  // their implementation has been optimized over their binary equivalent.
  //   laSrcUnique  = only those unique to source (same as laAnd followed by laXor)
  //   laDestUnique = only those unique to dest   (same as laOr followed by laXor)
  TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique);

  TList = class(TObject)
  private
    FList: System.Collections.ArrayList;
  protected
    function Get(Index: Integer): TObject;
    function GetCount: Integer;
    function GetCapacity: Integer;
    procedure Grow; virtual;
    procedure Put(Index: Integer; Item: TObject);
    procedure Notify(Instance: TObject; Action: TListNotification); virtual;
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    constructor Create;
    function Add(Item: TObject): Integer;
    procedure Clear; virtual;
    procedure Delete(Index: Integer);
                                      
    class procedure Error(const Msg: string; Data: Integer); overload; //virtual;
    procedure Exchange(Index1, Index2: Integer);
    function Expand: TList;
    function Extract(Item: TObject): TObject;
    function First: TObject;
    function IndexOf(Item: TObject): Integer;
    procedure Insert(Index: Integer; Item: TObject);
    function Last: TObject;
    procedure Move(CurIndex, NewIndex: Integer);
    function Remove(Item: TObject): Integer;
    procedure Pack;
    procedure Sort(Compare: TListSortCompare);
    procedure Assign(ListA: TList; AOperator: TListAssignOp = laCopy; ListB: TList = nil);
    property Capacity: Integer read GetCapacity write SetCapacity;
    property Count: Integer read GetCount write SetCount;
    property Items[Index: Integer]: TObject read Get write Put; default;
    property List: System.Collections.ArrayList read FList;
  end;

{ TThreadList class }

  TThreadList = class
  private
    FList: TList;
    FDuplicates: TDuplicates;
  public
    constructor Create;
    procedure Add(Item: TObject);
    procedure Clear;
    function  LockList: TList;
    procedure Remove(Item: TObject);
    procedure UnlockList;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  end;

{ IInterfaceList interface }

  IInterfaceList = interface
    ['{285DEA8A-B865-11D1-AAA7-00C04FB17A72}']
    function Get(Index: Integer): IInterface;
    function GetCapacity: Integer;
    function GetCount: Integer;
    procedure Put(Index: Integer; const Item: IInterface);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);

    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Exchange(Index1, Index2: Integer);
    function First: IInterface;
    function IndexOf(const Item: IInterface): Integer;
    function Add(const Item: IInterface): Integer;
    procedure Insert(Index: Integer; const Item: IInterface);
    function Last: IInterface;
    function Remove(const Item: IInterface): Integer;
    procedure Lock;
    procedure Unlock;
    property Capacity: Integer read GetCapacity write SetCapacity;
    property Count: Integer read GetCount write SetCount;
    property Items[Index: Integer]: IInterface read Get write Put; default;
  end;

{ TInterfaceList class }

  TInterfaceList = class(TObject, IInterfaceList)
  private
    FList: TThreadList;
  protected
    { IInterfaceList }
    function Get(Index: Integer): IInterface;
    function GetCapacity: Integer;
    function GetCount: Integer;
    procedure Put(Index: Integer; const Item: IInterface);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetCount(NewCount: Integer);
  public
    constructor Create;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Exchange(Index1, Index2: Integer);
    function Expand: TInterfaceList;
    function First: IInterface;
    function IndexOf(const Item: IInterface): Integer;
    function Add(const Item: IInterface): Integer;
    procedure Insert(Index: Integer; const Item: IInterface);
    function Last: IInterface;
    function Remove(const Item: IInterface): Integer;
    procedure Lock;
    procedure Unlock;
    property Capacity: Integer read GetCapacity write SetCapacity;
    property Count: Integer read GetCount write SetCount;
    property Items[Index: Integer]: IInterface read Get write Put; default;
  end;

{ TBits class }

  TBits = class
  private
    FSize: Integer;
    FBits: array of Integer;
    procedure Error;
    procedure SetSize(Value: Integer);
    procedure SetBit(Index: Integer; Value: Boolean);
    function GetBit(Index: Integer): Boolean;
  public
    function OpenBit: Integer;
    property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
    property Size: Integer read FSize write SetSize;
  end;

{ TAtomicValues }

  TAtomicValues = class
  private
    Table: Hashtable;
  public
    constructor Create;
    function GetAtomicValueOf(Value: TObject): TObject;
  end;

  { TPersistent class }

  TPersistent = System.MarshalByRefObject;

  TOperation = (opInsert, opRemove);

  IDesignerNotify = interface
    ['{B971E807-E3A6-11D1-AAB1-00C04FB16FBC}']
    procedure Modified;
    procedure Notification(AnObject: TPersistent; Operation: TOperation);
  end;

  TPersistentHelper = class helper (TObjectHelper) for TPersistent
  private
    procedure AssignError(Source: TPersistent);
  protected
    procedure AssignTo(Dest: TPersistent); virtual;
    procedure DefineProperties(Filer: TFiler); virtual;
    function GetOwner: TPersistent; virtual;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); virtual;
    function GetNamePath: string; virtual;
    function GetRootDesigner: IDesignerNotify; virtual;
  end;

{ TPersistent class reference type }

  TPersistentClass = class of TPersistent;

{ TInterfaced Persistent }

  TInterfacedPersistent = TPersistent;

{ TRecall class }

  TRecall = class(TObject)
  private
    FStorage, FReference: TPersistent;
  public
    constructor Create(AStorage, AReference: TPersistent);
    destructor Destroy; override;
    procedure Store;
    procedure Forget;
    property Reference: TPersistent read FReference;
  end;

{ TCollection class }

  TCollection = class;

  { Interface used by the designer to access the protected fields of TCollectionItem }
  IDesignCollectionItem = interface
    function GetOwner: TPersistent;
  end;

  TCollectionItem = class(TPersistent, IDesignCollectionItem)
  private
    FCollection: TCollection;
    FID: Integer;
    function GetIndex: Integer;
  protected
    procedure Changed(AllItems: Boolean);
    function GetOwner: TPersistent; override;
    function GetDisplayName: string; virtual;
    procedure SetCollection(Value: TCollection); virtual;
    procedure SetIndex(Value: Integer); virtual;
    procedure SetDisplayName(const Value: string); virtual;
  public
    constructor Create(Collection: TCollection); virtual;
    destructor Destroy; override;
    function GetNamePath: string; override;
    property Collection: TCollection read FCollection write SetCollection;
    property ID: Integer read FID;
    property Index: Integer read GetIndex write SetIndex;
    property DisplayName: string read GetDisplayName write SetDisplayName;
  end;

  TCollectionItemClass = class of TCollectionItem;
  TCollectionNotification = (cnAdded, cnExtracting, cnDeleting);

  { Interface used by the designer to access the protected fields of TCollection }
  IDesignCollection = interface
    function GetAttrCount: Integer;
    function GetAttr(Index: Integer): string;
    function GetItemAttr(Index, ItemIndex: Integer): string;
  end;

  TCollection = class(TPersistent, IDesignCollection)
  private
    FItemClass: TCollectionItemClass;
    FItems: TList;
    FUpdateCount: Integer;
    FNextID: Integer;
    FPropName: string;
    function GetCount: Integer;
    function GetPropName: string;
    procedure InsertItem(Item: TCollectionItem);
    procedure RemoveItem(Item: TCollectionItem);
  protected
    procedure Added(var Item: TCollectionItem); virtual; deprecated;
    procedure Deleting(Item: TCollectionItem); virtual; deprecated;
    property NextID: Integer read FNextID;
    procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); virtual;
    { Design-time editor support }
    function GetAttrCount: Integer; dynamic;
    function GetAttr(Index: Integer): string; dynamic;
    function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
    procedure Changed;
    function GetItem(Index: Integer): TCollectionItem;
    procedure SetItem(Index: Integer; Value: TCollectionItem);
    procedure SetItemName(Item: TCollectionItem); virtual;
    procedure Update(Item: TCollectionItem); virtual;
    property PropName: string read GetPropName write FPropName;
    property UpdateCount: Integer read FUpdateCount;
  public
    constructor Create(ItemClass: TCollectionItemClass);
    destructor Destroy; override;
    function Owner: TPersistent;
    function Add: TCollectionItem;
    procedure Assign(Source: TPersistent); override;
    procedure BeginUpdate; virtual;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure EndUpdate; virtual;
    function FindItemID(ID: Integer): TCollectionItem;
    function GetNamePath: string; override;
    function Insert(Index: Integer): TCollectionItem;
    property Count: Integer read GetCount;
    property ItemClass: TCollectionItemClass read FItemClass;
    property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
  end;

{ Collection class that maintains an "Owner" in order to obtain property
  path information at design-time }

  TOwnedCollection = class(TCollection)
  private
    FOwner: TPersistent;
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
  end;

  TStrings = class;

{ TGetModuleProc }
{ Used in the TFormDesigner class to allow component/property editors access
  to project specific information }

  TGetModuleProc = procedure(const FileName, UnitName, FormName,
    DesignClass: string; CoClasses: TStrings) of object;

{ TStrings class }

  TStringsDefined = set of (sdDelimiter, sdQuoteChar, sdNameValueSeparator, sdLineBreak);

  TStrings = class(TPersistent)
  private
    FDefined: TStringsDefined;
    FDelimiter: Char;
    FLineBreak: string;
    FQuoteChar: Char;
    FNameValueSeparator: Char;
    FUpdateCount: Integer;
    function GetCommaText: string;
    function GetDelimitedText: string;
    function GetName(Index: Integer): string;
    function GetValue(const Name: string): string;
    procedure ReadData(Reader: TReader);
    procedure SetCommaText(const Value: string);
    procedure SetDelimitedText(const Value: string);
    procedure SetValue(const Name, Value: string);
    procedure WriteData(Writer: TWriter);
    function GetDelimiter: Char;
    procedure SetDelimiter(const Value: Char);
    function GetLineBreak: string;
    procedure SetLineBreak(const Value: string);
    function GetQuoteChar: Char;
    procedure SetQuoteChar(const Value: Char);
    function GetNameValueSeparator: Char;
    procedure SetNameValueSeparator(const Value: Char);
    function GetValueFromIndex(Index: Integer): string;
    procedure SetValueFromIndex(Index: Integer; const Value: string);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure Error(const Msg: string; Data: Integer); overload;
    //procedure Error(Msg: PResStringRec; Data: Integer); overload;
    function ExtractName(const S: string): string;
    function Get(Index: Integer): string; virtual; abstract;
    function GetCapacity: Integer; virtual;
    function GetCount: Integer; virtual; abstract;
    function GetObject(Index: Integer): TObject; virtual;
    function GetTextStr: string; virtual;
    procedure Put(Index: Integer; const S: string); virtual;
    procedure PutObject(Index: Integer; AObject: TObject); virtual;
    procedure SetCapacity(NewCapacity: Integer); virtual;
    procedure SetTextStr(const Value: string); virtual;
    procedure SetUpdateState(Updating: Boolean); virtual;
    property UpdateCount: Integer read FUpdateCount;
    function CompareStrings(const S1, S2: string): Integer; virtual;
  public
    function Add(const S: string): Integer; virtual;
    function AddObject(const S: string; AObject: TObject): Integer; virtual;
    procedure Append(const S: string);
    procedure AddStrings(Strings: TStrings); virtual;
    procedure Assign(Source: TPersistent); override;
    procedure BeginUpdate;
    procedure Clear; virtual; abstract;
    procedure Delete(Index: Integer); virtual; abstract;
    procedure EndUpdate;
    function Equals(Strings: TStrings): Boolean;
    procedure Exchange(Index1, Index2: Integer); virtual;
    function IndexOf(const S: string): Integer; virtual;
    function IndexOfName(const Name: string): Integer; virtual;
    function IndexOfObject(AObject: TObject): Integer; virtual;
    procedure Insert(Index: Integer; const S: string); virtual; abstract;
    procedure InsertObject(Index: Integer; const S: string;
      AObject: TObject); virtual;
    procedure LoadFromFile(const FileName: string); overload; virtual;
    procedure LoadFromFile(const FileName: string; Encoding: System.Text.Encoding); overload; virtual;
    procedure LoadFromStream(Stream: TStream); overload; virtual;
    procedure LoadFromStream(Stream: TStream; Encoding: System.Text.Encoding); overload; virtual;
    procedure Move(CurIndex, NewIndex: Integer); virtual;
    procedure SaveToFile(const FileName: string); overload; virtual;
    procedure SaveToFile(const FileName: string; Encoding: System.Text.Encoding); overload; virtual;
    procedure SaveToStream(Stream: TStream); overload; virtual; 
    procedure SaveToStream(Stream: TStream; Encoding: System.Text.Encoding); overload; virtual;
    property Capacity: Integer read GetCapacity write SetCapacity;
    property CommaText: string read GetCommaText write SetCommaText;
    property Count: Integer read GetCount;
    property Delimiter: Char read GetDelimiter write SetDelimiter;
    property DelimitedText: string read GetDelimitedText write SetDelimitedText;
    property LineBreak: string read GetLineBreak write SetLineBreak;
    property Names[Index: Integer]: string read GetName;
    property Objects[Index: Integer]: TObject read GetObject write PutObject;
    property QuoteChar: Char read GetQuoteChar write SetQuoteChar;
    property Values[const Name: string]: string read GetValue write SetValue;
    property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex;
    property NameValueSeparator: Char read GetNameValueSeparator write SetNameValueSeparator;
    property Strings[Index: Integer]: string read Get write Put; default;
    property Text: string read GetTextStr write SetTextStr;
  end;

{ TStringList class }

  TStringList = class;

  TStringItem = record
    FString: string;
    FObject: TObject;
  end;

  TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;

  TStringList = class(TStrings)
  private
    FList: array of TStringItem;
    FCount: Integer;
    FSorted: Boolean;
    FDuplicates: TDuplicates;
    FCaseSensitive: Boolean;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    procedure ExchangeItems(Index1, Index2: Integer);
    procedure Grow;
    procedure QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
    procedure SetSorted(Value: Boolean);
    procedure SetCaseSensitive(const Value: Boolean);
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;
    function Get(Index: Integer): string; override;
    function GetCapacity: Integer; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetCapacity(NewCapacity: Integer); override;
    procedure SetUpdateState(Updating: Boolean); override;
    function CompareStrings(const S1, S2: string): Integer; override;
    procedure InsertItem(Index: Integer; const S: string; AObject: TObject); virtual;
  public
    function Add(const S: string): Integer; override;
    function AddObject(const S: string; AObject: TObject): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Exchange(Index1, Index2: Integer); override;
    function Find(const S: string; var Index: Integer): Boolean; virtual;
    function IndexOf(const S: string): Integer; override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure InsertObject(Index: Integer; const S: string;
      AObject: TObject); override;
    procedure Sort; virtual;
    procedure CustomSort(Compare: TStringListSortCompare); virtual;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
    property Sorted: Boolean read FSorted write SetSorted;
    property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  end;

{ TStream abstract class }

  TStream = class(TObject)
  private
    function GetPosition: Int64;
    procedure SetPosition(const Pos: Int64);
    function GetSize: Int64;
    function Skip(Amount: Integer): Integer;
  protected
    procedure SetSize(NewSize: Int64); overload; virtual; abstract;
  public
    function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; overload; virtual; abstract;
    function Read(var Buffer: array of Byte; Count: Longint): Longint; overload;
    function Read(var Buffer: Byte): Longint; overload;
    function Read(var Buffer: Byte; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Boolean): Longint; overload;
    function Read(var Buffer: Boolean; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Char): Longint; overload;
    function Read(var Buffer: Char; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: AnsiChar): Longint; overload;
    function Read(var Buffer: AnsiChar; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: ShortInt): Longint; overload;
    function Read(var Buffer: ShortInt; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: SmallInt): Longint; overload;
    function Read(var Buffer: SmallInt; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Word): Longint; overload;
    function Read(var Buffer: Word; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Integer): Longint; overload;
    function Read(var Buffer: Integer; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Cardinal): Longint; overload;
    function Read(var Buffer: Cardinal; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Int64): Longint; overload;
    function Read(var Buffer: Int64; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: UInt64): Longint; overload;
    function Read(var Buffer: UInt64; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Single): Longint; overload;
    function Read(var Buffer: Single; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Double): Longint; overload;
    function Read(var Buffer: Double; Count: Longint): Longint; overload; platform;
    function Read(var Buffer: Extended): Longint; overload;
    function Read(var Buffer: Extended; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; overload; virtual; abstract;
    function Write(const Buffer: array of Byte; Count: Longint): Longint; overload;
    function Write(const Buffer: Byte): Longint; overload;
    function Write(const Buffer: Byte; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Boolean): Longint; overload;
    function Write(const Buffer: Boolean; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Char): Longint; overload;
    function Write(const Buffer: Char; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: AnsiChar): Longint; overload;
    function Write(const Buffer: AnsiChar; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: ShortInt): Longint; overload;
    function Write(const Buffer: ShortInt; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: SmallInt): Longint; overload;
    function Write(const Buffer: SmallInt; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Word): Longint; overload;
    function Write(const Buffer: Word; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Integer): Longint; overload;
    function Write(const Buffer: Integer; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Cardinal): Longint; overload;
    function Write(const Buffer: Cardinal; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Int64): Longint; overload;
    function Write(const Buffer: Int64; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: UInt64): Longint; overload;
    function Write(const Buffer: UInt64; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Single): Longint; overload;
    function Write(const Buffer: Single; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Double): Longint; overload;
    function Write(const Buffer: Double; Count: Longint): Longint; overload; platform;
    function Write(const Buffer: Extended): Longint; overload; platform;
    function Write(const Buffer: Extended; Count: Longint): Longint; overload; platform;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; virtual; abstract;
    procedure ReadBuffer(Buffer: array of Byte; Count: Longint); overload;
    procedure ReadBuffer(var Buffer: Byte); overload;
    procedure ReadBuffer(var Buffer: Byte; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Boolean); overload;
    procedure ReadBuffer(var Buffer: Boolean; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Char); overload;
    procedure ReadBuffer(var Buffer: Char; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: AnsiChar); overload;
    procedure ReadBuffer(var Buffer: AnsiChar; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: ShortInt); overload;
    procedure ReadBuffer(var Buffer: ShortInt; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: SmallInt); overload;
    procedure ReadBuffer(var Buffer: SmallInt; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Word); overload;
    procedure ReadBuffer(var Buffer: Word; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Integer); overload;
    procedure ReadBuffer(var Buffer: Integer; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Cardinal); overload;
    procedure ReadBuffer(var Buffer: Cardinal; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Int64); overload;
    procedure ReadBuffer(var Buffer: Int64; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: UInt64); overload;
    procedure ReadBuffer(var Buffer: UInt64; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Single); overload;
    procedure ReadBuffer(var Buffer: Single; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Double); overload;
    procedure ReadBuffer(var Buffer: Double; Count: Longint); overload; platform;
    procedure ReadBuffer(var Buffer: Extended); overload; platform;
    procedure ReadBuffer(var Buffer: Extended; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: array of Byte; Count: Longint); overload;
    procedure WriteBuffer(const Buffer: Byte); overload;
    procedure WriteBuffer(const Buffer: Byte; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: Boolean); overload;
    procedure WriteBuffer(const Buffer: Boolean; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: Char); overload;
    procedure WriteBuffer(const Buffer: Char; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: AnsiChar); overload;
    procedure WriteBuffer(const Buffer: AnsiChar; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: ShortInt); overload;
    procedure WriteBuffer(const Buffer: ShortInt; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: SmallInt); overload;
    procedure WriteBuffer(const Buffer: SmallInt; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: Word); overload;
    procedure WriteBuffer(const Buffer: Word; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: Integer); overload;
    procedure WriteBuffer(const Buffer: Integer; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: Cardinal); overload;
    procedure WriteBuffer(const Buffer: Cardinal; Count: Longint); overload; platform;
    procedure WriteBuffer(const Buffer: Int64); overload;
    procedure WriteBuffer(const Buffer: Int64; Count: Integer); overload; platform;
    procedure WriteBuffer(const Buffer: UInt64); overload;
    procedure WriteBuffer(const Buffer: UInt64; Count: Integer); overload; platform;
    procedure WriteBuffer(const Buffer: Single); overload;
    procedure WriteBuffer(const Buffer: Single; Count: Integer); overload; platform;
    procedure WriteBuffer(const Buffer: Double); overload;
    procedure WriteBuffer(const Buffer: Double; Count: Integer); overload; platform;
    procedure WriteBuffer(const Buffer: Extended); overload; platform;
    procedure WriteBuffer(const Buffer: Extended; Count: Integer); overload; platform;
    function CopyFrom(Source: TStream; Count: Int64): Int64;
    function ReadComponent(Instance: TComponent): TComponent;
    function ReadComponentRes(Instance: TComponent): TComponent;
    procedure WriteComponent(Instance: TComponent);
    procedure WriteComponentRes(const ResName: string; Instance: TComponent);
    procedure WriteDescendent(Instance, Ancestor: TComponent); virtual;
    procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
    procedure WriteResourceHeader(const ResName: string; out FixupInfo: Integer);
    procedure FixupResourceHeader(FixupInfo: Integer);
    procedure ReadResHeader;
    property Position: Int64 read GetPosition write SetPosition;
    property Size: Int64 read GetSize write SetSize;
  end;

  IStreamPersist = interface
    ['{B8CD12A3-267A-11D4-83DA-00C04F60B2DD}']
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
  end;

{ TCLRStreamWrapper class }

  TCLRStreamWrapper = class(TStream)
  protected
    FHandle: System.IO.Stream;
    procedure SetSize(NewSize: Int64); override;
  public
    constructor Create(AHandle: System.IO.Stream);
    destructor Destroy; override;
    function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; override;
    function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
    property Handle: System.IO.Stream read FHandle;
  end;

  THandleStream = TCLRStreamWrapper;

{ TFileStream class }

  TFileStream = class(TCLRStreamWrapper)
  public
    constructor Create(const FileName: string; Mode: Word); overload;
    constructor Create(const FileName: string; Mode: Word; Rights: Cardinal); overload;
  end;

{ TCustomMemoryStream abstract class }

  TCustomMemoryStream = class(TStream)
  private
    FSize, FPosition: Int64;
  protected
    FMemory: TBytes;
  public
    function Read(var Buffer: array of Byte; Offset, Count: Longint): Longint; override;
    function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
    procedure SaveToStream(Stream: TStream);
    procedure SaveToFile(const FileName: string);
    property Memory: TBytes read FMemory;
  end;

{ TMemoryStream }

  TMemoryStream = class(TCustomMemoryStream)
  private
    function GetCapacity: Longint;
    procedure SetCapacity(NewCapacity: Longint);
  protected
    function Realloc(var NewCapacity: Longint): TBytes; virtual;
    property Capacity: Longint read GetCapacity write SetCapacity;
  public
    procedure Clear;
    procedure LoadFromStream(Stream: TStream);
    procedure LoadFromFile(const FileName: string);
    procedure SetSize(NewSize: Int64); override;
    function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
  end;

{ TStringStream }

  TStringStream = class(TMemoryStream)
  protected
    function GetString: string;
  public
    constructor Create(const AString: string);
    procedure WriteString(const AString: string);
    property DataString: string read GetString;
  end;

{ TStreamToCLRStream }

  TStreamToCLRStream = class(System.IO.Stream)
  protected
    FStream: TStream;
    constructor Create(Stream: TStream);
  public
    { overridden methods of System.IO.Stream }
    procedure Close; override;
    procedure Flush; override;
    function get_CanRead: Boolean; override;
    function get_CanSeek: Boolean; override;
    function get_CanWrite: Boolean; override;
    function get_Length: Int64; override;
    function get_Position: Int64; override;
    function Read(Buffer: array of Byte; Offset: Integer; Count: Integer): Integer; override;
    function Seek(Offset: Int64; Origin: System.IO.SeekOrigin): Int64; override;
    procedure SetLength(Value: Int64); override;
    procedure set_Position(Value: Int64); override;
    procedure Write(Buffer: array of Byte; Offset: Integer; Count: Integer); override;
    property CanRead: Boolean read get_CanRead;
    property CanSeek: Boolean read get_CanSeek;
    property CanWrite: Boolean read get_CanWrite;
    property Length: Int64 read get_Length;
    property Position: Int64 read get_Position write set_Position;
  public
    destructor Destroy; override;
    class function GetStream(Stream: TStream): System.IO.Stream; static;
  end;

{ TResourceStream }

  TResourceStream = class(TCustomMemoryStream)
  private
    HResInfo: THandle;
    HGlobal: THandle;
    procedure Initialize(Instance, ResInfo: THandle; const Name: string);
  public
    constructor Create(Instance: THandle; const ResName: string; ResType: Integer); overload;
    constructor Create(Instance: THandle; const ResName, ResType: string); overload;
    constructor CreateFromID(Instance: THandle; ResID, ResType: Integer); overload;
    constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: string); overload;
    procedure SetSize(NewSize: Int64); override;
    function Write(const Buffer: array of Byte; Offset, Count: Longint): Longint; override;
  end;


{ TStreamAdapter }
{ Implements OLE IStream on VCL TStream }

  TStreamOwnership = (soReference, soOwned);

  TStreamAdapter = class(TInterfacedObject, IStream)
  private
    FStream: TStream;
    FOwnership: TStreamOwnership;
  public
    constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference);
    destructor Destroy; override;
    { IStream }
    procedure Read(pv: TBytes; cb: Longint; pcbRead: IntPtr); virtual;
    procedure Write(pv: TBytes; cb: Longint; pcbWritten: IntPtr); virtual;
    procedure Seek(dlibMove: Int64; dwOrigin: Longint; libNewPosition: IntPtr); virtual;
    procedure SetSize(libNewSize: Int64); virtual;
    procedure CopyTo(stm: IStream; cb: Int64; cbRead: IntPtr; cbWritten: IntPtr); virtual;
    procedure Commit(grfCommitFlags: Longint); virtual;
    procedure Revert; virtual;
    procedure LockRegion(libOffset: Int64; cb: Int64; dwLockType: Longint); virtual;
    procedure UnlockRegion(libOffset: Int64; cb: Int64; dwLockType: Longint); virtual;
    procedure Stat(out statstg: TStatStg; grfStatFlag: Longint); virtual;
    procedure Clone(out stm: IStream); virtual;
    property Stream: TStream read FStream;
    property StreamOwnership: TStreamOwnership read FOwnership write FOwnership;
  end platform;

{ TClassFinder }

  TGetClass = procedure (AClass: TPersistentClass) of object;

  TClassFinder = class
  private
    FGroups: TList;
  public
    constructor Create(AClass: TPersistentClass = nil;
      AIncludeActiveGroups: Boolean = False);
    function GetClass(const AClassName: string): TPersistentClass;
    procedure GetClasses(Proc: TGetClass);
  end;

{ TFiler }

  TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
    vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
    vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString,
    vaInt64, vaUTF8String, vaDouble);

  TFilerFlag = (ffInherited, ffChildPos, ffInline);
  TFilerFlags = set of TFilerFlag;

  TReaderProc = procedure(Reader: TReader) of object;
  TWriterProc = procedure(Writer: TWriter) of object;
  TStreamProc = procedure(Stream: TStream) of object;
  TGetChildProc = procedure (Child: TComponent) of object;

  TFiler = class(TObject)
  private
    FStream: TStream;
    FBuffer: TBytes;
    FBufPos: Integer;
    FBufCount: Integer;
    FRoot: TComponent;
    FLookupRoot: TComponent;
    FAncestor: TPersistent;
    FIgnoreChildren: Boolean;
  protected
    procedure SetRoot(Value: TComponent); virtual;
  public
    constructor Create(Stream: TStream; BufSize: Integer);
    procedure DefineProperty(const Name: string;
      ReadData: TReaderProc; WriteData: TWriterProc;
      HasData: Boolean); virtual; abstract;
    procedure DefineBinaryProperty(const Name: string;
      ReadData, WriteData: TStreamProc;
      HasData: Boolean); virtual; abstract;
    procedure FlushBuffer; virtual; abstract;
    property Root: TComponent read FRoot write SetRoot;
    property LookupRoot: TComponent read FLookupRoot;
    property Ancestor: TPersistent read FAncestor write FAncestor;
    property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
  end;

  TFilerAccess = class(TObject)
  private
    FPersistent: TPersistent;
  public
    constructor Create(APersistent: TPersistent);
    procedure DefineProperties(AFiler: TFiler);
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent);
    function GetChildOwner: TComponent;
    function GetChildParent: TComponent;
    procedure SetAncestor(Value: Boolean);
    procedure SetChildOrder(Child: TComponent; Order: Integer);
    procedure Updated;
    procedure Updating;
  end;

{ TComponent class reference type }

  TComponentClass = class of TComponent;

{ TReader }

  TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
    var Address: TMethodCode; var Error: Boolean) of object;
  TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
    var Name: string) of object;
  TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object;
  TAncestorNotFoundEvent = procedure(Reader: TReader; const ComponentName: string;
    ComponentClass: TPersistentClass; var Component: TComponent) of object;
  TReadComponentsProc = procedure(Component: TComponent) of object;
  TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;
  TFindComponentClassEvent = procedure(Reader: TReader; const ClassName: string;
    var ComponentClass: TComponentClass) of object;
  TCreateComponentEvent = procedure(Reader: TReader;
    ComponentClass: TComponentClass; var Component: TComponent) of object;
  TFindMethodInstanceEvent = procedure (Reader: TReader; const MethodName: string;
    var Method: TMethod; var Error: Boolean) of object;
  TFindComponentInstanceEvent = procedure (Reader: TReader; const Name: string;
    var Instance: TObject) of object;

  TReader = class(TFiler)
  private
    FOwner: TComponent;
    FParent: TComponent;
    FFixups: TList;
    FLoaded: TList;
    FOnFindMethod: TFindMethodEvent;
    FOnFindMethodInstance: TFindMethodInstanceEvent;
    FOnSetName: TSetNameEvent;
    FOnReferenceName: TReferenceNameEvent;
    FOnAncestorNotFound: TAncestorNotFoundEvent;
    FOnError: TReaderError;
    FOnFindComponentClass: TFindComponentClassEvent;
    FOnCreateComponent: TCreateComponentEvent;
    FOnFindComponentInstance: TFindComponentInstanceEvent;
    FPropName: string;
    FFinder: TClassFinder;
    FCanHandleExcepts: Boolean;
    function CreateComponentFromType(ComponentClass: TComponentClass;
      Owner: TComponent): TComponent;
    procedure DoFixupReferences;
    procedure EnsureAtLeast(NumBytes: Integer);
    procedure FreeFixups;
    function GetFieldClass(Instance: TObject; const AClassName: string): TPersistentClass;
    function GetPosition: Longint;
    procedure ReadBuffer(Keeping: Integer = 0);
    procedure ReadDataInner(Instance: TComponent);
    function FindComponentClass(const ClassName: string): TComponentClass;
  protected
    function Error(const Message: string): Boolean; virtual;
    function FindAncestorComponent(const Name: string;
      ComponentClass: TPersistentClass): TComponent; virtual;
    function FindMethodInstance(Root: TComponent; const MethodName: string): TMethod; virtual;
    function FindMethod(Root: TComponent; const MethodName: string): TMethodCode; virtual;
    procedure SetName(Component: TComponent; var Name: string); virtual;
    procedure ReadProperty(AInstance: TPersistent);
    procedure ReadPropValue(Instance: TPersistent; PropInfo: TPropInfo);
    procedure ReferenceName(var Name: string); virtual;
    procedure PropertyError(const Name: string);
    procedure ReadData(Instance: TComponent);
    function ReadSet(SetType: TTypeInfo): Integer; deprecated;
    function ReadSetAsText(SetType: TTypeInfo): string;
    procedure SetPosition(Value: Longint);
    procedure SkipBytes(Count: Integer);
    procedure SkipSetBody;
    procedure SkipProperty;
    procedure SkipComponent(SkipHeader: Boolean);
    property PropName: string read FPropName;
    property CanHandleExceptions: Boolean read FCanHandleExcepts;
  public
    destructor Destroy; override;
    procedure BeginReferences;
    procedure CheckValue(Value: TValueType);
    procedure DefineProperty(const Name: string;
      ReadData: TReaderProc; WriteData: TWriterProc;
      HasData: Boolean); override;
    procedure DefineBinaryProperty(const Name: string;
      ReadData, WriteData: TStreamProc;
      HasData: Boolean); override;
    function EndOfList: Boolean;
    procedure EndReferences;
    procedure FixupReferences;
    procedure FlushBuffer; override;
    function NextValue: TValueType;
    procedure Read(var Buffer: array of Byte; Offset, Count: Longint); overload;
    procedure Read(var Buffer: array of Byte; Count: Longint); overload;
    procedure Read(var Buffer: Byte; Count: Longint = SizeOf(Byte)); overload;
    procedure Read(var Buffer: Char; Count: Longint = SizeOf(Char)); overload;
    procedure Read(var Buffer: AnsiChar; Count: Longint = SizeOf(AnsiChar)); overload;
    procedure Read(var Buffer: ShortInt; Count: Longint = SizeOf(ShortInt)); overload;
    procedure Read(var Buffer: SmallInt; Count: Longint = SizeOf(SmallInt)); overload;
    procedure Read(var Buffer: Word; Count: Longint = SizeOf(Word)); overload;
    procedure Read(var Buffer: Integer; Count: Longint = SizeOf(Integer)); overload;
    procedure Read(var Buffer: Cardinal; Count: Longint = SizeOf(Cardinal)); overload;
    procedure Read(var Buffer: Int64; Count: Longint = SizeOf(Int64)); overload;
    procedure Read(var Buffer: UInt64; Count: Longint = SizeOf(UInt64)); overload;
    procedure Read(var Buffer: Single; Count: Longint = SizeOf(Single)); overload;
    procedure Read(var Buffer: Double; Count: Longint = SizeOf(Double)); overload;
    function ReadBoolean: Boolean;
    function ReadChar: Char;
    function ReadAnsiChar: AnsiChar;
    function ReadWideChar: WideChar;
    procedure ReadCollection(Collection: TCollection);
    function ReadComponent(Component: TComponent): TComponent;
    procedure ReadComponents(AOwner, AParent: TComponent;
      Proc: TReadComponentsProc);
    function ReadFloat: Extended;
    function ReadSingle: Single;
    function ReadDouble: Double;
    function ReadCurrency: Currency;
    function ReadDate: TDateTime;
    function ReadIdent: string;
    function ReadInteger: Longint;
    function ReadInt64: Int64;
    procedure ReadListBegin;
    procedure ReadListEnd;
    procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); virtual;
    function ReadRootComponent(Root: TComponent): TComponent;
    procedure ReadSignature;
    function ReadStr: string;
    function ReadString: string;
    function ReadWideString: WideString;
    function ReadValue: TValueType;
    function ReadVariant: Variant;
    procedure CopyValue(Writer: TWriter);
    procedure SkipValue;
    property Owner: TComponent read FOwner write FOwner;
    property Parent: TComponent read FParent write FParent;
    property Position: Longint read GetPosition write SetPosition;
    property OnError: TReaderError read FOnError write FOnError;
    property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
    property OnFindMethodInstance: TFindMethodInstanceEvent read FOnFindMethodInstance write FOnFindMethodInstance;
    property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
    property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName;
    property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound;
    property OnCreateComponent: TCreateComponentEvent read FOnCreateComponent write FOnCreateComponent;
    property OnFindComponentClass: TFindComponentClassEvent read FOnFindComponentClass write FOnFindComponentClass;
    property OnFindComponentInstance: TFindComponentInstanceEvent read FOnFindComponentInstance write FOnFindComponentInstance;
  end;

{ TWriter }

  TFindAncestorEvent = procedure (Writer: TWriter; Component: TComponent;
    const Name: string; var Ancestor, RootAncestor: TComponent) of object;
  TFindMethodNameEvent = procedure (Writer: TWriter; Method: TMethod;
    var MethodName: string) of object;
  TGetLookupInfoEvent = procedure(var Ancestor: TPersistent;
    var Root, LookupRoot, RootAncestor: TComponent) of object;

  TWriter = class(TFiler)
  private
    FRootAncestor: TComponent;
    FPropPath: string;
    FAncestorList: TList;
    FAncestorPos: Integer;
    FChildPos: Integer;
    FOnFindAncestor: TFindAncestorEvent;
    FOnFindMethodName: TFindMethodNameEvent;
    FUseQualifiedNames: Boolean;
    procedure AddAncestor(Component: TComponent);
    procedure EnsureAtLeast(Amount: Integer);
    function GetPosition: Longint;
    procedure SetPosition(Value: Longint);
    procedure WriteBuffer;
    procedure WriteData(Instance: TComponent); virtual; // linker optimization
    procedure WriteMinStr(const Value: string);
    procedure GetLookupInfo(var Ancestor: TPersistent;
      var Root, LookupRoot, RootAncestor: TComponent);
  protected
    function FindMethodName(Method: TMethod): string; virtual;
    procedure SetRoot(Value: TComponent); override;
    procedure WriteBinary(WriteData: TStreamProc);
    procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
    procedure WriteProperty(Instance: TPersistent; PropInfo: TPropInfo);
    procedure WriteProperties(Instance: TPersistent);
    procedure WritePropName(const PropName: string);
    procedure WriteValue(Value: TValueType);
  public
    destructor Destroy; override;
    procedure DefineProperty(const Name: string;
      ReadData: TReaderProc; WriteData: TWriterProc;
      HasData: Boolean); override;
    procedure DefineBinaryProperty(const Name: string;
      ReadData, WriteData: TStreamProc;
      HasData: Boolean); override;
    procedure FlushBuffer; override;
    procedure Write(const Buffer: array of Byte; Offset, Count: Longint); overload;
    procedure Write(const Buffer: array of Byte; Count: Longint); overload;
    procedure Write(const Buffer: Integer; Count: Longint); overload;
                                                           
    procedure Write(const Buffer: Byte; Count: Longint); overload;
    procedure Write(const Buffer: Cardinal; Count: Longint); overload;
    procedure Write(const Buffer: Int64; Count: Longint); overload;
    procedure Write(const Buffer: Extended; Count: Longint); overload;
    procedure WriteBoolean(Value: Boolean);
    procedure WriteCollection(Value: TCollection);
    procedure WriteComponent(Component: TComponent);
    procedure WriteChar(Value: AnsiChar); overload;
    procedure WriteChar(Value: WideChar); overload;
    procedure WriteDescendent(Root: TComponent; AAncestor: TComponent);
    procedure WriteFloat(const Value: Extended);
    procedure WriteSingle(const Value: Single);
    procedure WriteDouble(const Value: Double);
    procedure WriteCurrency(const Value: Currency);
    procedure WriteDate(const Value: TDateTime);
    procedure WriteIdent(const Ident: string);
    procedure WriteInteger(Value: Longint); overload;
    procedure WriteInteger(const Value: Int64); overload;
    procedure WriteInt64(const Value: Int64);
    procedure WriteListBegin;
    procedure WriteListEnd;
    procedure WriteRootComponent(Root: TComponent);
    procedure WriteSignature;
    procedure WriteStr(const Value: string);
    procedure WriteString(const Value: string);
    procedure WriteWideString(const Value: WideString);
    procedure WriteVariant(const Value: Variant);
    property Position: Longint read GetPosition write SetPosition;
    property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
    property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor;
    property OnFindMethodName: TFindMethodNameEvent read FOnFindMethodName write FOnFindMethodName;
    property UseQualifiedNames: Boolean read FUseQualifiedNames write FUseQualifiedNames;
  end;

{ TParser }

  TParser = class(TObject)
  private
    FStream: TStream;
    FOrigin: Longint;
    FBuffer: TBytes;
    FBufPtr: Integer;
    FBufEnd: Integer;
    FSourcePtr: Integer;
    FSourceEnd: Integer;
    FTokenPtr: Integer;
    FStringPtr: Integer;
    FSourceLine: Integer;
    FSaveChar: Byte;
    FToken: Char;
    FFloatType: Char;
    FWideStr: WideString;
    procedure ReadBuffer;
    procedure SkipBlanks;
  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 TokenWideString: WideString;
    function TokenSymbolIs(const S: string): Boolean;
    property FloatType: Char read FFloatType;
    property SourceLine: Integer read FSourceLine;
    property Token: Char read FToken;
  end;

{ TThread }

  EThread = class(Exception);

  TThreadMethod = procedure of object;

  TThreadPriority = (tpLowest, tpLower, tpNormal, tpHigher, tpHighest);

  TSynchronizeRecord = record
    FThread: TObject;
    FMethod: TThreadMethod;
    FSynchronizeException: TObject;
  end;

  TThread = class
  private
    FHandle: System.Threading.Thread;
    FCreateSuspended: Boolean;
    FStarted: Boolean;
    FSuspendCount: Integer;
    FTerminated: Boolean;
    FSuspended: Boolean;
    FFreeOnTerminate: Boolean;
    FFinished: Boolean;
    FReturnValue: Integer;
    FOnTerminate: TNotifyEvent;
    FSynchronize: TSynchronizeRecord;
    FFatalException: TObject;
    procedure ThreadError(O: TObject);
    procedure CallOnTerminate;
    function GetPriority: TThreadPriority;
    procedure SetPriority(Value: TThreadPriority);
    procedure SetSuspended(Value: Boolean);
    class procedure Synchronize(ASyncRec: TSynchronizeRecord; QueueEvent: Boolean = False); overload;
  protected
    procedure Initialize; virtual;
    procedure DoTerminate; virtual;
    procedure Execute; virtual; abstract;
    procedure Queue(AMethod: TThreadMethod); overload;
    procedure Synchronize(Method: TThreadMethod); overload;
    property ReturnValue: Integer read FReturnValue write FReturnValue;
    property Terminated: Boolean read FTerminated;
  public
    constructor Create(CreateSuspended: Boolean);
    destructor Destroy; override;
    procedure Resume;
    procedure Suspend;
    procedure Terminate;
    function WaitFor: LongWord; overload;
    function WaitFor(TimeOut: Integer; var ReturnValue: LongWord): Boolean; overload;
    class procedure Queue(AThread: TThread; AMethod: TThreadMethod); overload;
    class procedure RemoveQueuedEvents(AThread: TThread; AMethod: TThreadMethod);
    class procedure StaticQueue(AThread: TThread; AMethod: TThreadMethod);
    property FatalException: TObject read FFatalException;
    property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
    property Handle: System.Threading.Thread read FHandle;
    property Priority: TThreadPriority read GetPriority write SetPriority;
    property Suspended: Boolean read FSuspended write SetSuspended;
    property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
  end;

  { TWin32Thread, unlike TThread, has a ThreadID (a Win32 concept) }

  TWin32Thread = class(TThread)
  private
    FThreadID: Integer;
  protected
    procedure Initialize; override;
  public
    property ThreadID: Integer read FThreadID;
  end platform;

{ TComponent class }

  TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
    csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification,
    csInline, csDesignInstance, csNotificationSent);
  TComponentStyle = set of (csInheritable, csCheckPropAvail, csSubComponent,
    csTransient);

  TComponentName = type string;

  TTag = Variant;

                                                                      
                                                                 
                                                                                 
  //TComponentSite = class(TObject, ISite, IContainer)
  TComponentSite = class(TObject, ISite, IServiceProvider)
  private
    FDesignMode: Boolean;
    FComponent: IComponent;
    FName: string;

    FTag: TTag;
    FComponents: TList;
    FFreeNotifies: TList;
    FDesignInfo: Longint;
    FComponentStyle: TComponentStyle;
    FComponentState: TComponentState;
    FOwner: TComponent;
    function get_Container: IContainer;

  protected

    { ISite }
    property Component: IComponent read FComponent;
    property Container: IContainer read get_Container;
    property DesignMode: Boolean read FDesignMode;
    property Name: string read FName write FName;
    { IServiceProvider }
    function GetService(serviceType: System.Type): TObject;
    { IContainer }
    procedure Add(Component: IComponent); overload;
    procedure Add(Component: IComponent; Name: string); overload;
    procedure Remove(Component: IComponent);
    function Get_Components: ComponentCollection;
  public
    { TComponent instance holders }
    constructor Create(AInstance, AOwner: TComponent);
  end;

  TComponentHelper = class helper (TPersistentHelper) for TComponent
  private
    function GetComponents(Index: Integer): TComponent;
    function GetComponentCount: Integer;
    function GetComponentIndex: Integer;
    function GetComponentState: TComponentState;
    function GetComponentStyle: TComponentStyle;
    function GetDesignInfo: Integer;
    function GetFFreeNotifies: TList;
    function GetSelfOwner: TComponent;
    procedure Insert(AComponent: TComponent);
    procedure ReadLeft(Reader: TReader);
    procedure ReadTop(Reader: TReader);
    procedure Remove(AComponent: TComponent);
    procedure RemoveNotification(AComponent: TComponent);
    procedure SetComponentStyle(Value: TComponentStyle);
    procedure SetComponentState(Value: TComponentState);
    procedure SetComponentIndex(Value: Integer);
    procedure SetFFreeNotifies(Value: TList);
    procedure SetDesignInfo(Value: Integer);
    procedure SetReference(Enable: Boolean);
    procedure WriteLeft(Writer: TWriter);
    procedure WriteTop(Writer: TWriter);
    property FComponentState: TComponentState read GetComponentState write SetComponentState;
    property FFreeNotifies: TList read GetFFreeNotifies write SetFFreeNotifies;
  protected
    property FComponentStyle: TComponentStyle read GetComponentStyle write SetComponentStyle;
    procedure ChangeName(const NewName: TComponentName);
    procedure DefineProperties(Filer: TFiler); override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); virtual;
    function GetChildOwner: TComponent; virtual;
    function GetChildParent: TComponent; virtual;
    function GetName: TComponentName;
    function GetOwner: TPersistent; override;
    function GetSiteObject: TComponentSite;
    function GetTag: TTag;
    procedure HandleDisposed(Sender: TObject; Args: EventArgs);
    procedure Loaded; virtual;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); virtual;
    procedure PaletteCreated; virtual;
    procedure ReadState(Reader: TReader); virtual;
    procedure SetAncestor(Value: Boolean);
    procedure SetDesigning(Value: Boolean; SetChildren: Boolean = True);
    procedure SetInline(Value: Boolean);
    procedure SetDesignInstance(Value: Boolean);
    procedure SetName(const NewName: TComponentName); virtual;
    procedure SetChildOrder(Child: TComponent; Order: Integer); virtual;
    procedure SetTag(Value: TTag);
    procedure Updating; virtual;
    procedure Updated; virtual;
    class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); virtual;
    procedure ValidateRename(AComponent: TComponent;
      const CurName, NewName: string); virtual;
    procedure ValidateContainer(AComponent: TComponent); virtual;
    procedure ValidateInsert(AComponent: TComponent); virtual;
    procedure WriteState(Writer: TWriter); virtual;
  public
    constructor Create(AOwner: TComponent); overload; virtual;
    procedure DestroyComponents;
    procedure Destroying;
    function ExecuteAction(Action: TBasicAction): Boolean; virtual;
    function FindComponent(const AName: string): TComponent;
    procedure FreeNotification(AComponent: TComponent);
    procedure RemoveFreeNotification(AComponent: TComponent);
    function GetParentComponent: TComponent; virtual;
    function GetNamePath: string; override;
    function HasParent: Boolean;  virtual;
    procedure InsertComponent(AComponent: TComponent);
    procedure RemoveComponent(AComponent: TComponent);
    procedure SetParentComponent(Value: TComponent); virtual;
    procedure SetSubComponent(IsSubComponent: Boolean);
    function UpdateAction(Action: TBasicAction): Boolean; virtual;
    function IsImplementorOf(const I: IInterface): Boolean;
    function ReferenceInterface(const I: IInterface; Operation: TOperation): Boolean;
    class procedure ChangeComponentName(Instance: TComponent; const NewName: string); static;
    class procedure SetComponentParent(Instance: TComponent; Parent: TComponent); static;
    property Components[Index: Integer]: TComponent read GetComponents;
    property ComponentCount: Integer read GetComponentCount;
    property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
    property ComponentState: TComponentState read GetComponentState;
    property ComponentStyle: TComponentStyle read GetComponentStyle;
    property DesignInfo: Longint read GetDesignInfo write SetDesignInfo;
    property Owner: TComponent read GetSelfOwner;
  published
    property Name: TComponentName read GetName write SetName stored False;
    property Tag: TTag read GetTag write SetTag;
  end;

{ TBasicActionLink }

  TBasicActionLink = class(TObject)
  private
    FOnChange: TNotifyEvent;
  protected
    FAction: TBasicAction;
    procedure AssignClient(AClient: TObject); virtual;
    procedure Change; virtual;
    function IsOnExecuteLinked: Boolean; virtual;
    procedure SetAction(Value: TBasicAction); virtual;
    procedure SetOnExecute(Value: TNotifyEvent); virtual;
  public
    constructor Create(AClient: TObject); virtual;
    destructor Destroy; override;
    function Execute(AComponent: TComponent = nil): Boolean; virtual;
    function Update: Boolean; virtual;
    property Action: TBasicAction read FAction write SetAction;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TBasicActionLinkClass = class of TBasicActionLink;

{ TBasicAction }

  [RootDesignerSerializerAttribute('', '', False)]
  TBasicAction = class(TComponent)
  private
    FActionComponent: TComponent;
    FOnChange: TNotifyEvent;
    FOnExecute: TNotifyEvent;
    FOnUpdate: TNotifyEvent;
    procedure SetActionComponent(const Value: TComponent);
  protected
    FClients: TList;
    procedure Change; virtual;
    procedure SetOnExecute(Value: TNotifyEvent); virtual;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property Clients: TList read FClients write FClients;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function HandlesTarget(Target: TObject): Boolean; virtual;
    procedure UpdateTarget(Target: TObject); virtual;
    procedure ExecuteTarget(Target: TObject); virtual;
    function Execute: Boolean; dynamic;
    procedure RegisterChanges(Value: TBasicActionLink);
    procedure UnRegisterChanges(Value: TBasicActionLink);
    function Update: Boolean; virtual;
    property ActionComponent: TComponent read FActionComponent write SetActionComponent;
    property OnExecute: TNotifyEvent read FOnExecute write SetOnExecute;
    property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;
  end;

{ TBasicAction class reference type }

  TBasicActionClass = class of TBasicAction;     

{ TDataModule }

  [ToolboxItem(False)]
  [RootDesignerSerializerAttribute('', '', False)]
  TDataModule = class(TComponent)
  private
    FDesignSize: TPoint;
    FDesignOffset: TPoint;
    FOnCreate: TNotifyEvent;
    FOnDestroy: TNotifyEvent;
    procedure IgnoreIdent(Reader: TReader);
    procedure ReadHeight(Reader: TReader);
    procedure ReadHorizontalOffset(Reader: TReader);
    procedure ReadVerticalOffset(Reader: TReader);
    procedure ReadWidth(Reader: TReader);
    procedure WriteWidth(Writer: TWriter);
    procedure WriteHorizontalOffset(Writer: TWriter);
    procedure WriteVerticalOffset(Writer: TWriter);
    procedure WriteHeight(Writer: TWriter);
  protected
    procedure DoCreate; virtual;
    procedure DoDestroy; virtual;
    procedure DefineProperties(Filer: TFiler); override;
    function HandleCreateException: Boolean; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); virtual;
    destructor Destroy; override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    property DesignOffset: TPoint read FDesignOffset write FDesignOffset;
    property DesignSize: TPoint read FDesignSize write FDesignSize;
  published
    property OnCreate: TNotifyEvent read FOnCreate write FOnCreate;
    property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
  end;

var
  AddDataModule: procedure (DataModule: TDataModule) of object;
  RemoveDataModule: procedure (DataModule: TDataModule) of object;
  ApplicationHandleException: procedure (Sender: TObject) of object;
  ApplicationShowException: procedure (E: Exception) of object;

{ Component registration handlers }

  RegisterComponentsProc: procedure(const Page: string;
    const ComponentClasses: array of TComponentClass);
  RegisterNoIconProc: procedure(const ComponentClasses: array of TComponentClass);
  CurrentGroup: Integer = -1; { Current design group }

{ Point and rectangle constructors }

/// Point and rectangle constructors have been moved to Borland.Vcl.Types

{function Point(AX, AY: Integer): TPoint; deprecated;
function SmallPoint(AX, AY: SmallInt): TSmallPoint; deprecated;
function PointsEqual(const P1, P2: TPoint): Boolean; overload; deprecated;
function PointsEqual(const P1, P2: TSmallPoint): Boolean; overload; deprecated;
function InvalidPoint(X, Y: Integer): Boolean; overload; deprecated;
function InvalidPoint(const At: TPoint): Boolean; overload; deprecated;
function InvalidPoint(const At: TSmallPoint): Boolean; overload; deprecated;

function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect; overload; deprecated;
function Rect(const ATopLeft, ABottomRight: TPoint): TRect; overload; deprecated;
function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect; deprecated;}

{ Class registration routines }

procedure RegisterClass(AClass: TPersistentClass);
procedure RegisterClasses(AClasses: array of TPersistentClass);
procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
procedure UnRegisterClass(AClass: TPersistentClass);
procedure UnRegisterClasses(AClasses: array of TPersistentClass);
function FindClass(const AClassName: string): TPersistentClass;
function GetClass(const AClassName: string): TPersistentClass;
procedure StartClassGroup(AClass: TPersistentClass);
procedure GroupDescendentsWith(AClass, AClassGroup: TPersistentClass);
function ActivateClassGroup(AClass: TPersistentClass): TPersistentClass;
function ClassGroupOf(AClass: TPersistentClass): TPersistentClass; overload;
function ClassGroupOf(Instance: TPersistent): TPersistentClass; overload;
function OwnedBy(AComponent, AOwner: TComponent): Boolean;

{ Component registration routines }

procedure RegisterComponents(const Page: string;
  const ComponentClasses: array of TComponentClass);
procedure RegisterNoIcon(const ComponentClasses: array of TComponentClass);

var
  GlobalNameSpace: ReaderWriterLock;

{ Object filing routines }

type
  TIdentMapEntry = record
    Value: Integer;
    Name: string;
  end;

  TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
  TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
  TFindGlobalComponent = function(const Name: string): TComponent;
  TIsUniqueGlobalComponentName = function(const Name: string): Boolean;

var
  IsUniqueGlobalComponentNameProc: TIsUniqueGlobalComponentName;

procedure RegisterIntegerConsts(AIntegerType: TTypeInfo; AIdentToInt: TIdentToInt;
  AIntToIdent: TIntToIdent);
procedure UnregisterIntegerConsts(AIntegerType: TTypeInfo; AIdentToInt: TIdentToInt;
  AIntToIdent: TIntToIdent);
function FindIntToIdent(AIntegerType: TTypeInfo): TIntToIdent;
function FindIdentToInt(AIntegerType: TTypeInfo): TIdentToInt;
procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
function FindGlobalComponent(const Name: string): TComponent;
function IsUniqueGlobalComponentName(const Name: string): Boolean;
function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
function InitComponentRes(const ResName: string; Instance: TComponent): Boolean; overload;
function InitComponentRes(const ResName, BaseName: string; Instance: TComponent): Boolean; overload;
function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent; overload;
function ReadComponentRes(const ResName, BaseName: string; Instance: TComponent): TComponent; overload;
function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
procedure WriteComponentResFile(const FileName: string; Instance: TComponent);

procedure GlobalFixupReferences;
procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
procedure GetFixupInstanceNames(Root: TComponent;
  const ReferenceRootName: string; Names: TStrings);
procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  NewRootName: string);
procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
procedure RemoveFixups(Instance: TPersistent);
function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent;
function SendNotification(ASender, AComponent: TComponent; Operation: TOperation): Boolean;

procedure BeginGlobalLoading;
procedure NotifyGlobalLoading;
procedure EndGlobalLoading;

function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean;

{ find the ultimate owner of a collection or item (or persistent for that matter) }
function GetUltimateOwner(ACollectionItem: TCollectionItem): TPersistent; overload;
function GetUltimateOwner(ACollection: TCollection): TPersistent; overload;
function GetUltimateOwner(APersistent: TPersistent): TPersistent; overload;

{ Object conversion routines }

type
  TStreamOriginalFormat = (sofUnknown, sofBinary, sofText);

procedure ObjectBinaryToText(Input, Output: TStream); overload;
procedure ObjectBinaryToText(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat); overload;
procedure ObjectTextToBinary(Input, Output: TStream); overload;
procedure ObjectTextToBinary(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat); overload;

procedure ObjectResourceToText(Input, Output: TStream); overload;
procedure ObjectResourceToText(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat); overload;
procedure ObjectTextToResource(Input, Output: TStream); overload;
procedure ObjectTextToResource(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat); overload;

function TestStreamFormat(Stream: TStream): TStreamOriginalFormat;

{ Utility routines }

function LineStart(Buffer: array of Byte; BufPos: Integer): Integer;

function ExtractStrings(Separators, WhiteSpace: TSysCharSet;
  const Content: string; Strings: TStrings): Integer;

procedure BinToHex(const Buffer: array of Byte; BufOffset: Integer;
  var Text: array of Byte; TextOffset: Integer; Count: Integer);
function HexToBin(const Text: array of Byte; TextOffset: Integer;
  Buffer: array of Byte; BufOffset: Integer; Count: Integer): Integer;

{ FindRootDesigner is now deprecated. Use GetRootDesigner from
  TPersistent. }
function FindRootDesigner(Obj: TPersistent): IDesignerNotify; deprecated;
function DelegatesEqual(A, B: Delegate): Boolean;

{ CountGenerations:  Use this helper function to calculate the distance
  between two related classes.  Returns -1 if Descendent is not a descendent of
  Ancestor. }

function CountGenerations(Ancestor, Descendent: TClass): Integer;

{  Call CheckSynchronize periodically within the main thread in order for
   background threads to synchronize execution with the main thread.  This
   is mainly for applications that have an event driven UI such as Windows.
   The best place this can be called is during Idle processing.  This
   guarantees that the main thread is in a known "good" state so that method
   calls can be safely made.  Returns True if a method
   was synchronized.  Returns False if there was nothing done.
}

 function CheckSynchronize(Timeout: Integer = 0): Boolean;

{ Assign a method to WakeMainThread in order to properly force an event into
  the GUI thread's queue.  This will make sure that non-GUI threads can quickly
  synchronize with the GUI thread even if no events are being processed due to
  an idle state }
var
  WakeMainThread: TNotifyEvent;

{ SyncEvent is an Event signal that is set every time a thread wishes to
  synchronize with the main thread or is terminating.  When this object is
  signaled, CheckSynchronize *must* be called in order to reset the event.
  Do not call this object's Reset method, or background threads may hang
  waiting for Synchronize to return.
}
  SyncEvent: System.Threading.ManualResetEvent;

function AncestorIsValid(Ancestor: TPersistent; Root,
  RootAncestor: TComponent): Boolean;
function IsDefaultPropertyValue(Instance: TObject; PropInfo: TPropInfo;
  OnGetLookupInfo: TGetLookupInfoEvent; Writer: TWriter = nil;
  OnFindMethodName: TFindMethodNameEvent = nil): Boolean;

function CreateDesignComponent(ComponentClass: TComponentClass;
  AOwner: TComponent = nil; ADesigning: Boolean = True;
  ADesignInstance: Boolean = False; AInline: Boolean = False): TComponent;

procedure SetComponentDesigning(Component: TComponent; Value: Boolean;
  SetChildren: Boolean = True);

procedure SetComponentTransient(Component: TComponent; IsTransient: Boolean);

implementation

uses
  System.Runtime.InteropServices, System.Resources, System.Globalization,
  StrUtils, SysConst, RTLConsts, WinUtils;

// Obscure System.Reflection.Pointer
type
  Pointer = Borland.Delphi.System.Pointer;

const
  FilerSignature = Cardinal($30465054); // TPF0

var
  IntConstList: TThreadList;

{ Class registration groups }

type
  TRegClassEntry = class
  strict private
    FQualifiedName: string;
    FClassRef: TPersistentClass;
  public
    constructor Create(AClassRef: TPersistentClass); overload;
    function ClassRefValid: Boolean;
    function GetClassRef: TPersistentClass;
    procedure SetClassRef(Value: TPersistentClass);
  end;

  TRegGroup = class
  private
    // FClassList is a hashtable where the ClassName is the key, and the
    // value is a TRegClassEntry, which contains the fully QualifiedName and
    // the cached ClassRef. If the ClassRef is nil, it can be dynamically
    // loaded.
    FClassList: Hashtable;
    FAliasList: Hashtable;
    FGroupClasses: TList;
    FActive: Boolean;
    function BestClass(AClass: TPersistentClass): TPersistentClass;
  public
    constructor Create(AClass: TPersistentClass);
    class function BestGroup(Group1, Group2: TRegGroup; AClass: TPersistentClass): TRegGroup;
    procedure AddClass(AClass: TPersistentClass);
    function GetClass(const AClassName: string): TPersistentClass;
    procedure GetClasses(Proc: TGetClass);
    function InGroup(AClass: TPersistentClass): Boolean;
    procedure RegisterClass(AClass: TPersistentClass);
    procedure UnregisterClass(AClass: TPersistentClass);
    procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
    function Registered(AClass: TPersistentClass): Boolean;
    property Active: Boolean read FActive write FActive;
  end;

  TRegGroups = class
  private
    FGroups: TList;
    FActiveClass: TPersistentClass;
    function FindGroup(AClass: TPersistentClass): TRegGroup;
  public
    constructor Create;
    procedure Activate(AClass: TPersistentClass);
    function GetClass(const AClassName: string): TPersistentClass;
    function GroupedWith(AClass: TPersistentClass): TPersistentClass;
    procedure GroupWith(AClass, AGroupClass: TPersistentClass);
    procedure Lock;
    procedure RegisterClass(AClass: TPersistentClass);
    procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
    procedure UnregisterClass(AClass: TPersistentClass);
    function Registered(AClass: TPersistentClass): Boolean;
    procedure StartGroup(AClass: TPersistentClass);
    procedure Unlock;
    property ActiveClass: TPersistentClass read FActiveClass;
  end;

{ TRegClassEntry }

constructor TRegClassEntry.Create(AClassRef: TPersistentClass);
begin
  inherited Create;
  FClassRef := AClassRef;
  FQualifiedName := TypeOf(FClassRef).FullName;
end;

function TRegClassEntry.GetClassRef: TPersistentClass;
begin
  if FClassRef = nil then
  begin
    { This GetType call will attempt to load the assembly that the type
      resides in. The act of loading it may call RegisterClass for us, which
      won't be a big deal. }
    FClassRef := TPersistentClass(System.Type.GetType(FQualifiedName, False));
  end;
  Result := FClassRef;
end;

procedure TRegClassEntry.SetClassRef(Value: TPersistentClass);
begin
  if (Value <> nil) and (FClassRef <> nil) then
    raise EFilerError.CreateFmt(SDuplicateClass, [Value.ClassName]);
  FClassRef := Value;
end;

function TRegClassEntry.ClassRefValid: Boolean;
begin
  Result := FClassRef <> nil;
end;

var
  RegGroups: TRegGroups;

{ TRegGroup }

procedure TRegGroup.AddClass(AClass: TPersistentClass);
begin
  FGroupClasses.Add(TObject(AClass));
end;

function TRegGroup.BestClass(AClass: TPersistentClass): TPersistentClass;
var
  I: Integer;
  Current: TPersistentClass;
begin
  Result := nil;
  for I := 0 to FGroupClasses.Count - 1 do
  begin
    Current := TPersistentClass(FGroupClasses[I]);
    if AClass.InheritsFrom(Current) then
      if (Result = nil) or Current.InheritsFrom(Result) then
        Result := Current;
  end;
end;

class function TRegGroup.BestGroup(Group1, Group2: TRegGroup;
  AClass: TPersistentClass): TRegGroup;
var
  Group1Class: TPersistentClass;
  Group2Class: TPersistentClass;
begin
  if Group1 <> nil then
    Group1Class := Group1.BestClass(AClass)
  else
    Group1Class := nil;
  if Group2 <> nil then
    Group2Class := Group2.BestClass(AClass)
  else
    Group2Class := nil;
  if Group1Class = nil then
    if Group2Class = nil then
      // AClass is not in either group, no best group
      Result := nil
    else
      // AClass is in Group2 but not Group1, Group2 is best
      Result := Group2
  else
    if Group2Class = nil then
      // AClass is in Group1 but not Group2, Group1 is best
      Result := Group1
    else
      // AClass is in both groups, select the group with the closest ancestor
      if Group1Class.InheritsFrom(Group2Class) then
        Result := Group1
      else
        Result := Group2;
end;

constructor TRegGroup.Create(AClass: TPersistentClass);
begin
  inherited Create;
  FClassList := Hashtable.Create(CaseInsensitiveHashCodeProvider.Default, CaseInsensitiveComparer.Default);
  FAliasList := Hashtable.Create(CaseInsensitiveHashCodeProvider.Default, CaseInsensitiveComparer.Default);
  FGroupClasses := TList.Create;
  FGroupClasses.Add(TObject(AClass));
end;

function TRegGroup.GetClass(const AClassName: string): TPersistentClass;
var
  ClassRegEntry: TRegClassEntry;
begin
  ClassRegEntry := TRegClassEntry(FClassList[AClassName]);
  if ClassRegEntry <> nil then
  begin
    Result := ClassRegEntry.GetClassRef;
    if Result = nil then
    begin
      { Failed type load; The type must no longer exist, so remove the entry. }
      FClassList.Remove(AClassName);
    end;
  end
  else
    Result := nil;
end;

procedure TRegGroup.GetClasses(Proc: TGetClass);
var
  E: IEnumerator;
  ClassRegEntry: TRegClassEntry;
  ClassRef: TPersistentClass;
begin
  if FClassList.Count > 0 then
  begin
    E := FClassList.Values.GetEnumerator;
    while E.MoveNext do
    begin
      ClassRegEntry := TRegClassEntry(E.Current);
      ClassRef := ClassRegEntry.GetClassRef;
      if ClassRef <> nil then
        Proc(ClassRef);      
    end;
  end;
end;

function TRegGroup.InGroup(AClass: TPersistentClass): Boolean;
var
  I: Integer;
begin
  Result := True;
  for I := 0 to FGroupClasses.Count - 1 do
    if AClass.InheritsFrom(TPersistentClass(FGroupClasses[I])) then
      Exit;
  Result := False;
end;

procedure TRegGroup.RegisterClass(AClass: TPersistentClass);
var
  ClassRegEntry: TRegClassEntry;
  ClassName: string;
begin
  ClassName := AClass.ClassName;
  ClassRegEntry := TRegClassEntry(FClassList[ClassName]);
  if ClassRegEntry = nil then
    FClassList[ClassName] := TRegClassEntry.Create(AClass)
  else
    ClassRegEntry.SetClassRef(AClass);
end;

procedure TRegGroup.RegisterClassAlias(AClass: TPersistentClass;
  const Alias: string);
var
  ClassRegEntry: TRegClassEntry;
begin
  RegisterClass(AClass);
  ClassRegEntry := TRegClassEntry(FClassList[AClass.ClassName]);
  if ClassRegEntry <> nil then
  begin
    FClassList[Alias] := ClassRegEntry;
    FAliasList[Alias] := ClassRegEntry;
  end;
end;

function TRegGroup.Registered(AClass: TPersistentClass): Boolean;
begin
  Result := FClassList.Contains(AClass.ClassName);
end;

procedure TRegGroup.UnregisterClass(AClass: TPersistentClass);
var
  ClassRegEntry: TRegClassEntry;
  Aliases: array of string;
  I: Integer;
begin
  ClassRegEntry := TRegClassEntry(FClassList[AClass.ClassName]);
  if ClassRegEntry <> nil then
  begin
    ClassRegEntry.SetClassRef(nil); { Remove references }
    FClassList.Remove(AClass.ClassName);
    { Remove aliases. }
    if FAliasList.Count > 0 then
    begin
      SetLength(Aliases, FAliasList.Count);
      FAliasList.Keys.CopyTo(Aliases, 0);
      for I := 0 to Length(Aliases) - 1 do
      begin
        if FAliasList[Aliases[I]] = ClassRegEntry then
        begin
          FClassList.Remove(Aliases[I]);
          FAliasList.Remove(Aliases[I]);
        end;
      end;
    end;
  end;
  { Now, make sure it isn't in our group class }
  I := FGroupClasses.IndexOf(TObject(AClass));
  if I <> -1 then
    FGroupClasses.Delete(I);
end;

{ TRegGroups }

procedure TRegGroups.Activate(AClass: TPersistentClass);
var
  I: Integer;
begin
  if FActiveClass <> AClass then
  begin
    FActiveClass := AClass;
    for I := 0 to FGroups.Count - 1 do
      with TRegGroup(FGroups[I]) do
        Active := InGroup(AClass);
  end;
end;

constructor TRegGroups.Create;
var
  Group: TRegGroup;
begin
  inherited Create;
  FGroups := TList.Create;
  // Initialize default group
  Group := TRegGroup.Create(TPersistent);
  FGroups.Add(Group);
  Group.Active := True;
end;

function TRegGroups.FindGroup(AClass: TPersistentClass): TRegGroup;
var
  I: Integer;
  Current: TRegGroup;
begin
  Result := nil;
  for I := 0 to FGroups.Count - 1 do
  begin
    Current := TRegGroup(FGroups[I]);
    Result := TRegGroup.BestGroup(Current, Result, AClass);
  end;
end;

function TRegGroups.GetClass(const AClassName: string): TPersistentClass;
var
  I: Integer;
begin
  Result := nil;
  for I := 0 to FGroups.Count - 1 do
    with TRegGroup(FGroups[I]) do
    begin
      if Active then
        Result := GetClass(AClassName);
      if Result <> nil then
        Exit;
    end;
end;

function TRegGroups.GroupedWith(AClass: TPersistentClass): TPersistentClass;
var
  Group: TRegGroup;
begin
  Result := nil;
  Group := FindGroup(AClass);
  if Group <> nil then
    Result := TPersistentClass(Group.FGroupClasses[0]);
end;

procedure TRegGroups.GroupWith(AClass, AGroupClass: TPersistentClass);

  procedure Error;
  begin
    raise EFilerError.CreateFmt(SUnknownGroup, [AGroupClass.ClassName]);
  end;

var
  Group: TRegGroup;
  CurrentGroup: TRegGroup;
  CurrentClass: TPersistentClass;
  I, J: Integer;
  ClassRefs: array of TRegClassEntry;
begin
  Group := FindGroup(AGroupClass);
  if Group = nil then
  begin
    StartGroup(AGroupClass);
    Group := FindGroup(AGroupClass);
    if Group = nil then
      Error;
  end;
  Group.AddClass(AClass);

  // The group criterion has changed. We need to recalculate which groups the
  // classes that have already been registered belong to. We can skip
  // Group since we would just be moving a class to a group it already belongs
  // to. We also only need to find the new group of classes that descend from
  // AClass since that is the only criterion being changed. In other words,
  // we only need to move classes that descend from AClass to Group if they
  // are in another group.
  for I := 0 to FGroups.Count - 1 do
  begin
    CurrentGroup := TRegGroup(FGroups[I]);
    if CurrentGroup <> Group then
    begin
      SetLength(ClassRefs, CurrentGroup.FClassList.Count);
      CurrentGroup.FClassList.Values.CopyTo(ClassRefs, 0);
      for J := Length(ClassRefs) - 1 downto 0 do
      begin
        { Ignore delay loads }
        if not ClassRefs[J].ClassRefValid then
          Continue;
        CurrentClass := ClassRefs[J].GetClassRef;
        if CurrentClass.InheritsFrom(AClass) then
        begin
          // Check CurrentClass should be put into Group based on the new
          // criterion. Their might be a descendent of AClass registered that
          // overrides Group's criterion.
          if FindGroup(CurrentClass) = Group then
          begin
            CurrentGroup.FClassList.Remove(AClass.ClassName);
            Group.FClassList[AClass.ClassName] := ClassRefs[J];
          end;
        end;
      end;
    end;
  end;
end;

procedure TRegGroups.Lock;
begin
  System.Threading.Monitor.Enter(Self);
end;

procedure TRegGroups.RegisterClass(AClass: TPersistentClass);
var
  Group: TRegGroup;
begin
  Group := FindGroup(AClass);
  if Group <> nil then
    Group.RegisterClass(AClass);
end;

procedure TRegGroups.RegisterClassAlias(AClass: TPersistentClass;
  const Alias: string);
var
  Group: TRegGroup;
begin
  Group := FindGroup(AClass);
  if Group <> nil then
    Group.RegisterClassAlias(AClass, Alias);
end;

function TRegGroups.Registered(AClass: TPersistentClass): Boolean;
var
  I: Integer;
begin
  Result := True;
  for I := 0 to FGroups.Count - 1 do
  begin
    if TRegGroup(FGroups[I]).Registered(AClass) then
      Exit;
  end;
  Result := False;
end;

procedure TRegGroups.UnregisterClass(AClass: TPersistentClass);
var
  I: Integer;
  Group: TRegGroup;
begin
  for I := FGroups.Count - 1 downto 0 do
  begin
    Group := TRegGroup(FGroups[I]);
    Group.UnregisterClass(AClass);
    { Was this the last class made just for that group? }
    if Group.FGroupClasses.Count = 0 then
      FGroups.Delete(I);
  end;
end;

procedure TRegGroups.StartGroup(AClass: TPersistentClass);
var
  I: Integer;
begin
  // Do not start a group that already exists
  for I := 0 to FGroups.Count - 1 do
  begin
    if TRegGroup(FGroups[I]).FGroupClasses.IndexOf(TObject(AClass)) >= 0 then
      Exit;
  end;
  // Create the group
  FGroups.Add(TRegGroup.Create(AClass));
end;

procedure TRegGroups.Unlock;
begin
  System.Threading.Monitor.Exit(Self);
end;

{ TClassFinder }

constructor TClassFinder.Create(AClass: TPersistentClass;
  AIncludeActiveGroups: Boolean);
var
  I: Integer;
  Group: TRegGroup;
begin
  inherited Create;
  FGroups := TList.Create;
  RegGroups.Lock;
  try
    if AClass = nil then
      AClass := RegGroups.ActiveClass;
    for I := 0 to RegGroups.FGroups.Count - 1 do
    begin
      Group := TRegGroup(RegGroups.FGroups[I]);
      if Group.InGroup(AClass) then
        FGroups.Add(Group);
    end;
    if AIncludeActiveGroups then
      for I := 0 to RegGroups.FGroups.Count - 1 do
      begin
        Group := TRegGroup(RegGroups.FGroups[I]);
        if Group.Active then
          FGroups.Add(Group);
      end;
  finally
    RegGroups.Unlock;
  end;
end;

function TClassFinder.GetClass(const AClassName: string): TPersistentClass;
var
  I: Integer;
begin
  Result := nil;
  RegGroups.Lock;
  try
    for I := 0 to FGroups.Count - 1 do
      with TRegGroup(FGroups[I]) do
      begin
        Result := GetClass(AClassName);
        if Result <> nil then
          Exit;
      end;
  finally
    RegGroups.Unlock;
  end;
end;

procedure TClassFinder.GetClasses(Proc: TGetClass);
var
  I: Integer;
begin
  RegGroups.Lock;
  try
    for I := 0 to FGroups.Count - 1 do
      TRegGroup(FGroups[I]).GetClasses(Proc);
  finally
    RegGroups.Unlock;
  end;
end;

{ Class registration routines }

procedure ClassNotFound(const ClassName: string);
begin
  raise EClassNotFound.CreateFmt(SClassNotFound, [ClassName]);
end;

function GetClass(const AClassName: string): TPersistentClass;
begin
  RegGroups.Lock;
  try
    Result := RegGroups.GetClass(AClassName);
  finally
    RegGroups.Unlock;
  end;
end;

function FindClass(const AClassName: string): TPersistentClass;
begin
  Result := GetClass(AClassName);
  if Result = nil then
    ClassNotFound(AClassName);
end;

procedure RegisterClass(AClass: TPersistentClass);
begin
  RegGroups.Lock;
  try
    while not RegGroups.Registered(AClass) do
    begin
      RegGroups.RegisterClass(AClass);
      if AClass = TPersistent then
        Break;
      AClass := TPersistentClass(AClass.ClassParent);
    end;
  finally
    RegGroups.Unlock;
  end;
end;

procedure RegisterClasses(AClasses: array of TPersistentClass);
var
  I: Integer;
begin
  for I := Low(AClasses) to High(AClasses) do RegisterClass(AClasses[I]);
end;

procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
begin
  RegGroups.Lock;
  try
    RegGroups.RegisterClassAlias(AClass, Alias);
  finally
    RegGroups.Unlock;
  end;
end;

procedure UnRegisterClass(AClass: TPersistentClass);
begin
  RegGroups.Lock;
  try
    RegGroups.UnregisterClass(AClass);
  finally
    RegGroups.Unlock;
  end;
end;

procedure UnRegisterClasses(AClasses: array of TPersistentClass);
var
  I: Integer;
begin
  for I := Low(AClasses) to High(AClasses) do
    UnRegisterClass(AClasses[I]);
end;

procedure StartClassGroup(AClass: TPersistentClass);
begin
  RegGroups.Lock;
  try
    RegGroups.StartGroup(AClass);
  finally
    RegGroups.Unlock;
  end;
end;

procedure GroupDescendentsWith(AClass, AClassGroup: TPersistentClass);
begin
  RegGroups.Lock;
  try
    RegGroups.GroupWith(AClass, AClassGroup);
  finally
    RegGroups.Unlock;
  end;
end;

function ActivateClassGroup(AClass: TPersistentClass): TPersistentClass;
begin
  RegGroups.Lock;
  try
    Result := RegGroups.ActiveClass;
    RegGroups.Activate(AClass);
  finally
    RegGroups.Unlock;
  end;
end;

function ClassGroupOf(AClass: TPersistentClass): TPersistentClass;
begin
  RegGroups.Lock;
  try
    Result := RegGroups.GroupedWith(AClass);
  finally
    RegGroups.Unlock;
  end;
end;

function ClassGroupOf(Instance: TPersistent): TPersistentClass;
begin
  RegGroups.Lock;
  try
    Result := nil;
    while Instance <> nil do
    begin
      Result := RegGroups.GroupedWith(TPersistentClass(Instance.ClassType));
      if Result <> nil then
        Exit
      else
        Instance := Instance.GetOwner;
    end;
  finally
    RegGroups.Unlock;
  end;
end;

function OwnedBy(AComponent, AOwner: TComponent): Boolean;
begin
  Result := True;
  while AComponent <> nil do
    if AComponent = AOwner then
      Exit
    else
      AComponent := AComponent.Owner;
  Result := False;
end;

{ Component registration routines }

procedure RegisterComponents(const Page: string;
  const ComponentClasses: array of TComponentClass);
begin
  if Assigned(RegisterComponentsProc) then
    RegisterComponentsProc(Page, ComponentClasses)
  else
    raise EComponentError.Create(SRegisterError);
end;

procedure RegisterNoIcon(const ComponentClasses: array of TComponentClass);
begin
  if Assigned(RegisterNoIconProc) then
    RegisterNoIconProc(ComponentClasses)
  else
    raise EComponentError.Create(SRegisterError);
end;

{ Component filing }

type
  TIntConst = class
    IntegerType: TTypeInfo;
    IdentToInt: TIdentToInt;
    IntToIdent: TIntToIdent;
    constructor Create(AIntegerType: TTypeInfo; AIdentToInt: TIdentToInt;
      AIntToIdent: TIntToIdent);
  end;

constructor TIntConst.Create(AIntegerType: TTypeInfo; AIdentToInt: TIdentToInt;
  AIntToIdent: TIntToIdent);
begin
  inherited Create;
  IntegerType := AIntegerType;
  IdentToInt := AIdentToInt;
  IntToIdent := AIntToIdent;
end;

procedure RegisterIntegerConsts(AIntegerType: TTypeInfo; AIdentToInt: TIdentToInt;
  AIntToIdent: TIntToIdent);
begin
  if not Assigned(IntConstList) then
    IntConstList := TThreadList.Create;
  IntConstList.Add(TIntConst.Create(AIntegerType, AIdentToInt, AIntToIdent));
end;

procedure UnregisterIntegerConsts(AIntegerType: TTypeInfo; AIdentToInt: TIdentToInt;
  AIntToIdent: TIntToIdent);
var
  I: Integer;
begin
  if Assigned(IntConstList) then
    with IntConstList.LockList do
    try
      for I := Count - 1 downto 0 do
        with TIntConst(Items[I]) do
          if AIntegerType.Equals(IntegerType) and
             TObject(@AIdentToInt).Equals(TObject(@IdentToInt)) and
             TObject(@AIntToIdent).Equals(TObject(@IntToIdent)) then
            Delete(I);
    finally
      IntConstList.UnlockList;
    end;
end;

function FindIntToIdent(AIntegerType: TTypeInfo): TIntToIdent;
var
  I: Integer;
begin
  Result := nil;
  if Assigned(IntConstList) then
    with IntConstList.LockList do
    try
      for I := Count - 1 downto 0 do
        with TIntConst(Items[I]) do
          if AIntegerType.Equals(IntegerType) then
          begin
            Result := @IntToIdent;
            Exit;
          end;
    finally
      IntConstList.UnlockList;
    end;
end;

function FindIdentToInt(AIntegerType: TTypeInfo): TIdentToInt;
var
  I: Integer;
begin
  Result := nil;
  if Assigned(IntConstList) then
    with IntConstList.LockList do
    try
      for I := Count - 1 downto 0 do
        with TIntConst(Items[I]) do
          if AIntegerType.Equals(IntegerType) then
          begin
            Result := @IdentToInt;
            Exit;
          end;
    finally
      IntConstList.UnlockList;
    end;
end;

function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
var
  I: Integer;
begin
  for I := Low(Map) to High(Map) do
    if SameText(Map[I].Name, Ident) then
    begin
      Result := True;
      Int := Map[I].Value;
      Exit;
    end;
  Result := False;
end;

function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
var
  I: Integer;
begin
  for I := Low(Map) to High(Map) do
    if Map[I].Value = Int then
    begin
      Ident := Map[I].Name;
      Result := True;
      Exit;
    end;
  Result := False;
end;

var
  FindGlobalComponentProcs: TList;

procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
begin
  if FindGlobalComponentProcs = nil then
    FindGlobalComponentProcs := TList.Create;
  if FindGlobalComponentProcs.IndexOf(@AFindGlobalComponent) < 0 then
    FindGlobalComponentProcs.Add(@AFindGlobalComponent);
end;

procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent);
begin
  // Ignored in CLR
end;

function FindGlobalComponent(const Name: string): TComponent;
var
  I: Integer;
begin
  Result := nil;
  if FindGlobalComponentProcs <> nil then
  begin
    for I := FindGlobalComponentProcs.Count - 1 downto 0 do
    begin
      Result := TFindGlobalComponent(FindGlobalComponentProcs[I])(Name);
      if Result <> nil then
        Exit;
    end;
  end;
end;

function IsUniqueGlobalComponentName(const Name: string): Boolean;
begin
  if Assigned(IsUniqueGlobalComponentNameProc) then
    Result := IsUniqueGlobalComponentNameProc(Name)
  else
    Result := FindGlobalComponent(Name) = nil;
end;

function InternalReadComponentRes(const ResName: string; HInst: THandle; var Instance: TComponent): Boolean; overload;
var
  HRsrc: THandle;
begin                   { avoid possible EResNotFound exception }
  if HInst = 0 then HInst := HInstance;
  HRsrc := FindResource(HInst, ResName, RT_RCDATA);
  Result := HRsrc <> 0;
  if not Result then Exit;
  with TResourceStream.Create(HInst, ResName, RT_RCDATA) do
  try
    Instance := ReadComponent(Instance);
  finally
    Free;
  end;
  Result := True;
end;

function InternalReadComponentRes(const ResName, BaseName: string;
  ResourceAssembly: Assembly; var Instance: TComponent): Boolean; overload;
var
  Buffer: TBytes;
  ResMgr: ResourceManager;
begin
  Result := False;
  ResMgr := ResourceManager.Create(BaseName, ResourceAssembly);
  if Assigned(ResMgr) then
    try
      Buffer := TBytes(ResMgr.GetObject(UpperCase(ResName)));
    except
      // Prevent MissingManifestResource exception
    end;
  Result := Assigned(Buffer);

  if Result then
    with TMemoryStream.Create do
    try
      Write(Buffer, 0, Length(Buffer));
      Position := 0;
      Instance := ReadComponent(Instance);
    finally
      Free;
    end;
end;

threadvar
  GlobalLoaded: TList;
  GlobalLists: TList;

procedure BeginGlobalLoading;
var
  G: TList;
begin
  G := GlobalLists;
  if G = nil then
  begin
    G := TList.Create;
    GlobalLists := G;
  end;
  G.Add(GlobalLoaded);
  GlobalLoaded := TList.Create;
end;

procedure NotifyGlobalLoading;
var
  I: Integer;
  G: TList;
begin
  G := GlobalLoaded;  // performance:  eliminate repeated trips through TLS lookup
  for I := 0 to G.Count - 1 do
    TComponent(G[I]).Loaded;
end;

procedure EndGlobalLoading;
var
  G: TList;
begin
  GlobalLoaded.Free;
  G := GlobalLists;
  GlobalLoaded := TList(G.Last);
  G.Delete(G.Count - 1);
  if G.Count = 0 then
  begin
    GlobalLists := nil;
    G.Free;
  end;
end;

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

  function InitComponent(ClassType: TClass): Boolean;
  begin
    Result := False;
    if (ClassType = TComponent) or
      (ClassType = RootAncestor) then
        Exit;
    Result := InitComponent(ClassType.ClassParent);
    Result := InternalReadComponentRes(ClassType.ClassName, '_VCLForms',
      ClassType.ClassInfo.Assembly, Instance) or Result; { Do not localize }
  end;

var
  LocalizeLoading: Boolean;
  Cookie: LockCookie;
begin
  Cookie := GlobalNameSpace.UpgradeToWriterLock(MaxInt);  // hold lock across all ancestor loads (performance)
  try
    LocalizeLoading := (Instance.ComponentState * [csInline, csLoading]) = [];
    if LocalizeLoading then
      BeginGlobalLoading;  // push new loadlist onto stack
    try
      Result := InitComponent(Instance.ClassType);
      if LocalizeLoading then
        NotifyGlobalLoading;  // call Loaded
    finally
      if LocalizeLoading then
        EndGlobalLoading;  // pop loadlist off stack
    end;
  finally
    GlobalNameSpace.DowngradeFromWriterLock(Cookie);
  end;
end;

function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
begin
  Result := InitComponentRes(ResName, '_VCLForms', Instance); { Do not localize }
end;

function InitComponentRes(const ResName, BaseName: string; Instance: TComponent): Boolean;
begin
  Result := InternalReadComponentRes(ResName, BaseName, Instance.ClassInfo.Assembly, Instance);
end;

function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
begin
  Result := ReadComponentRes(ResName, '_VCLForms', Instance); { Do not localize }
end;

function ReadComponentRes(const ResName, BaseName: string; Instance: TComponent): TComponent;
var
  LAssembly: Assembly;
begin
  if Instance <> nil then
    LAssembly := Instance.ClassInfo.Assembly
  else
    LAssembly := Assembly.GetEntryAssembly;
  if InternalReadComponentRes(ResName, BaseName, LAssembly, Instance) then
    Result := Instance
  else
    raise EResNotFound.CreateFmt(SResNotFound, [ResName]);
end;

                                                    

function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
var
  Instance: TComponent;
begin
  Instance := nil;
  if InternalReadComponentRes(ResName, HInstance, Instance) then
    Result := Instance
  else
    raise EResNotFound.CreateFmt(SResNotFound, [ResName]);
end;

function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := Stream.ReadComponentRes(Instance);
  finally
    Stream.Free;
  end;
end;

procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    Stream.WriteComponentRes(Instance.ClassName, Instance);
  finally
    Stream.Free;
  end;
end;

function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean;
var
  S1, S2: TMemoryStream;

  function CompareMem(const Mem1: array of Byte; const Mem2: array of Byte;
    Count: Integer): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    for I := 0 to Count - 1 do
      if Mem1[I] <> Mem2[I] then
        Exit;
    Result := True;
  end;

  procedure WriteCollection(Stream: TStream; Collection: TCollection; CollectionOwner: TComponent);
  var
    Writer: TWriter;
  begin
    Writer := TWriter.Create(Stream, 1024);
    Writer.Root := CollectionOwner;
    Writer.FLookupRoot := CollectionOwner;
    try
      Writer.WriteCollection(Collection);
    finally
      Writer.Free;
    end;
  end;

begin
  Result := False;
  if C1.ClassType <> C2.ClassType then
    Exit;
  if C1.Count <> C2.Count then
    Exit;
  S1 := TMemoryStream.Create;
  try
    WriteCollection(S1, C1, Owner1);
    S2 := TMemoryStream.Create;
    try
      WriteCollection(S2, C2, Owner2);
      Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
    finally
      S2.Free;
    end;
  finally
    S1.Free;
  end;
end;

{ TListComparer }

type
  TListComparer = class(TObject, IComparer)
  private
    FCompare: TListSortCompare;
  public
    function Compare(O1, O2: TObject): Integer;
    constructor Create(Compare: TListSortCompare);
  end;

{ TListComparer }

function TListComparer.Compare(O1, O2: TObject): Integer;
begin
  Result := FCompare(O1, O2);
end;

constructor TListComparer.Create(Compare: TListSortCompare);
begin
  inherited Create;
  FCompare := Compare;
end;

{ Utility routines }

function LineStart(Buffer: array of Byte; BufPos: Integer): Integer;
begin
  while (BufPos > 0) and (Buffer[BufPos] <> 10) do
    Dec(BufPos);
  if Buffer[BufPos] = 10 then
    Inc(BufPos);
  Result := BufPos;
end;

function ExtractStrings(Separators, WhiteSpace: TSysCharSet;
  const Content: string; Strings: TStrings): Integer;
var
  Head, Tail, Len: Integer;
  InQuote: Boolean;
  QuoteChar: Char;
begin
  Result := 0;
  if Strings = nil then
    Exit;
  Tail := 1;
  Len := Length(Content);
  InQuote := False;
  QuoteChar := #0;
  Strings.BeginUpdate;
  try
    repeat
      while (Tail <= Len) and (AnsiChar(Content[Tail]) in WhiteSpace + [#13, #10]) do
        Inc(Tail);
      Head := Tail;
      while Tail <= Len do
      begin
        while (InQuote and (Tail <= Len) and not (Content[Tail] <> QuoteChar)) or
          not ((Tail <= Len) and (AnsiChar(Content[Tail]) in Separators + [#13, #10, '''', '"'])) do
          Inc(Tail);
        if Tail > Len then
          Break;
        if AnsiChar(Content[Tail]) in ['''', '"'] then
        begin
          if (QuoteChar <> #0) and (QuoteChar = Content[Tail]) then
            QuoteChar := #0
          else if QuoteChar = #0 then
            QuoteChar := Content[Tail];
          InQuote := QuoteChar <> #0;
          Inc(Tail);
        end
        else
          Break;
      end;
      if (Head <> Tail) and (Head <= Len) then
      begin
        if Strings <> nil then
          Strings.Add(Copy(Content, Head, Tail - Head));
        Inc(Result);
      end;
      Inc(Tail);
    until Tail > Len;
  finally
    Strings.EndUpdate;
  end;
end;

{ TList }

constructor TList.Create;
begin
  inherited Create;
  FList := System.Collections.ArrayList.Create;
end;

function TList.Add(Item: TObject): Integer;
begin
  Result := FList.Add(Item);
  if Item <> nil then
    Notify(Item, lnAdded);
end;

procedure TList.Clear;
begin
  FList.Clear;
end;

procedure TList.Delete(Index: Integer);
var
  Temp: TObject;
begin
  Temp := FList[Index];
  FList.RemoveAt(Index);
  if Temp <> nil then
    Notify(Temp, lnDeleted);
end;

class procedure TList.Error(const Msg: string; Data: Integer);
begin
  raise EListError.CreateFmt(Msg, [Data]);
end;

{
class procedure TList.Error(Msg: PResStringRec; Data: Integer);
begin
  TList.Error(LoadResString(Msg), Data);
end;
}

procedure TList.Exchange(Index1, Index2: Integer);
var
  Item: TObject;
begin
  Item := FList[Index1];
  FList[Index1] := FList[Index2];
  FList[Index2] := Item;
end;

function TList.Expand: TList;
begin
  if FList.Count = FList.Capacity then
    Grow;
  Result := Self;
end;

function TList.First: TObject;
begin
  Result := Get(0);
end;

function TList.Get(Index: Integer): TObject;
begin
  Result := FList[Index];
end;

function TList.GetCapacity: Integer;
begin
  Result := FList.Capacity;
end;

function TList.GetCount: Integer;
begin
  Result := FList.Count;
end;

procedure TList.Grow;
var
  Delta: Integer;
  LCapacity: Integer;
begin
  LCapacity := FList.Capacity;
  if LCapacity > 64 then
    Delta := LCapacity div 4
  else
    if LCapacity > 8 then
      Delta := 16
    else
      Delta := 4;
  SetCapacity(LCapacity + Delta);
end;

function TList.IndexOf(Item: TObject): Integer;
begin
  Result := FList.IndexOf(TObject(Item));
end;

procedure TList.Insert(Index: Integer; Item: TObject);
begin
  FList.Insert(Index, Item);
  if Item <> nil then
    Notify(Item, lnAdded);
end;

function TList.Last: TObject;
begin
  Result := Get(Count - 1);
end;

procedure TList.Move(CurIndex, NewIndex: Integer);
var
  Item: TObject;
begin
  if CurIndex <> NewIndex then
  begin
    if (NewIndex < 0) or (NewIndex >= Count) then
      Error(SListIndexError, NewIndex);
    Item := Get(CurIndex);
    FList.RemoveAt(CurIndex);
    FList.Insert(NewIndex, Item);
  end;
end;

procedure TList.Put(Index: Integer; Item: TObject);
var
  Temp: TObject;
begin
  if (Index < 0) or (Index >= Count) then
    Error(SListIndexError, Index);
  if Item <> FList[Index] then
  begin
    Temp := FList[Index];
    FList[Index] := Item;
    if Temp <> nil then
      Notify(Temp, lnDeleted);
    if Item <> nil then
      Notify(Item, lnAdded);
  end;
end;

function TList.Remove(Item: TObject): Integer;
begin
  Result := IndexOf(Item);
  if Result >= 0 then
    Delete(Result);
end;

procedure TList.Pack;
var
  I: Integer;
begin
  for I := Count - 1 downto 0 do
    if Items[I] = nil then
      Delete(I);
end;

procedure TList.SetCapacity(NewCapacity: Integer);
begin
  if NewCapacity < Count then
    Error(SListCapacityError, NewCapacity);
  FList.Capacity := NewCapacity;
end;

procedure TList.SetCount(NewCount: Integer);
var
  I, C: Integer;
  TempArray: array of System.Object;
begin
  if NewCount < 0 then
    Error(SListCountError, NewCount);
  C := FList.Count;
  if NewCount > C then
  begin
    SetLength(TempArray, NewCount - C);
    FList.AddRange(System.Object(TempArray) as ICollection);
  end
  else
  begin
    SetLength(TempArray, C - NewCount);
    FList.CopyTo(TempArray, NewCount);
    FList.RemoveRange(NewCount, C - NewCount);
    for I := 0 to Length(TempArray) - 1 do
      Notify(TempArray[I], lnDeleted);
  end;
end;

procedure TList.Sort(Compare: TListSortCompare);
begin
  FList.Sort(TListComparer.Create(Compare));
end;

function TList.Extract(Item: TObject): TObject;
var
  I: Integer;
begin
  Result := nil;
  I := IndexOf(Item);
  if I >= 0 then
  begin
    Result := Item;
    FList.RemoveAt(I);
    Notify(Result, lnExtracted);
  end;
end;

procedure TList.Notify(Instance: TObject; Action: TListNotification);
begin
end;

procedure TList.Assign(ListA: TList; AOperator: TListAssignOp; ListB: TList);
var
  I: Integer;
  LTemp, LSource: TList;
begin
  // ListB given?
  if ListB <> nil then
  begin
    LSource := ListB;
    Assign(ListA);
  end
  else
    LSource := ListA;

  // on with the show
  case AOperator of

    // 12345, 346 = 346 : only those in the new list
    laCopy:
      begin
        Clear;
        Capacity := LSource.Capacity;
        for I := 0 to LSource.Count - 1 do
          Add(LSource[I]);
      end;

    // 12345, 346 = 34 : intersection of the two lists
    laAnd:
      for I := Count - 1 downto 0 do
        if LSource.IndexOf(Items[I]) = -1 then
          Delete(I);

    // 12345, 346 = 123456 : union of the two lists
    laOr:
      for I := 0 to LSource.Count - 1 do
        if IndexOf(LSource[I]) = -1 then
          Add(LSource[I]);

    // 12345, 346 = 1256 : only those not in both lists
    laXor:
      begin
        LTemp := TList.Create; // Temp holder of 4 byte values
        LTemp.Capacity := LSource.Count;
        for I := 0 to LSource.Count - 1 do
          if IndexOf(LSource[I]) = -1 then
            LTemp.Add(LSource[I]);
        for I := Count - 1 downto 0 do
          if LSource.IndexOf(Items[I]) <> -1 then
            Delete(I);
        I := Count + LTemp.Count;
        if Capacity < I then
          Capacity := I;
        for I := 0 to LTemp.Count - 1 do
          Add(LTemp[I]);
      end;

    // 12345, 346 = 125 : only those unique to source
    laSrcUnique:
      for I := Count - 1 downto 0 do
        if LSource.IndexOf(Items[I]) <> -1 then
          Delete(I);

    // 12345, 346 = 6 : only those unique to dest
    laDestUnique:
      begin
        LTemp := TList.Create;
        LTemp.Capacity := LSource.Count;
        for I := LSource.Count - 1 downto 0 do
          if IndexOf(LSource[I]) = -1 then
            LTemp.Add(LSource[I]);
        Assign(LTemp);
      end;
  end;
end;


{ TThreadList }

constructor TThreadList.Create;
begin
  inherited Create;
  FList := TList.Create;
  FDuplicates := dupIgnore;
end;

procedure TThreadList.Add(Item: TObject);
begin
  LockList;
  try
    if (Duplicates = dupAccept) or
       (FList.IndexOf(Item) = -1) then
      FList.Add(Item)
    else if Duplicates = dupError then
      FList.Error(SDuplicateItem, Integer(Item));
  finally
    UnlockList;
  end;
end;

procedure TThreadList.Clear;
begin
  LockList;
  try
    FList.Clear;
  finally
    UnlockList;
  end;
end;

function  TThreadList.LockList: TList;
begin
  System.Threading.Monitor.Enter(Self);
  Result := FList;
end;

procedure TThreadList.Remove(Item: TObject);
begin
  LockList;
  try
    FList.Remove(Item);
  finally
    UnlockList;
  end;
end;

procedure TThreadList.UnlockList;
begin
  System.Threading.Monitor.Exit(Self);
end;

{ TInterfaceList }

constructor TInterfaceList.Create;
begin
  inherited Create;
  FList := TThreadList.Create;
end;

procedure TInterfaceList.Clear;
var
  I: Integer;
begin
  if FList <> nil then
  begin
    with FList.LockList do
    try
      for I := 0 to Count - 1 do
        List[I] := nil;
      Clear;
    finally
      Self.FList.UnlockList;
    end;
  end;
end;

procedure TInterfaceList.Delete(Index: Integer);
begin
  with FList.LockList do
  try
    Self.Put(Index, nil);
    Delete(Index);
  finally
    Self.FList.UnlockList;
  end;
end;

function TInterfaceList.Expand: TInterfaceList;
begin
  with FList.LockList do
  try
    Expand;
    Result := Self;
  finally
    Self.FList.Unlocklist;
  end;
end;

function TInterfaceList.First: IInterface;
begin
  Result := Get(0);
end;

function TInterfaceList.Get(Index: Integer): IInterface;
begin
  with FList.LockList do
  try
    if (Index < 0) or (Index >= Count) then
      Error(SListIndexError, Index);
    Result := List[Index] as IInterface;
  finally
    Self.FList.UnlockList;
  end;
end;

function TInterfaceList.GetCapacity: Integer;
begin
  with FList.LockList do
  try
    Result := Capacity;
  finally
    Self.FList.UnlockList;
  end;
end;

function TInterfaceList.GetCount: Integer;
begin
  with FList.LockList do
  try
    Result := Count;
  finally
    Self.FList.UnlockList;
  end;
end;

function TInterfaceList.IndexOf(const Item: IInterface): Integer;
begin
  with FList.LockList do
  try
    Result := IndexOf(Item);
  finally
    Self.FList.UnlockList;
  end;
end;

function TInterfaceList.Add(const Item: IInterface): Integer;
begin
  with FList.LockList do
  try
    Result := Add(nil);
    List[Result] := Item;
  finally
    Self.FList.UnlockList;
  end;
end;

procedure TInterfaceList.Insert(Index: Integer; const Item: IInterface);
begin
  with FList.LockList do
  try
    Insert(Index, nil);
    List[Index] := Item;
  finally
    Self.FList.UnlockList;
  end;
end;

function TInterfaceList.Last: IInterface;
begin
  with FList.LockList do
  try
    Result := Self.Get(Count - 1);
  finally
    Self.FList.UnlockList;
  end;
end;

procedure TInterfaceList.Put(Index: Integer; const Item: IInterface);
begin
  with FList.LockList do
  try
    if (Index < 0) or (Index >= Count) then
      Error(SListIndexError, Index);
    List[Index] := Item;
  finally
    Self.FList.UnlockList;
  end;
end;

function TInterfaceList.Remove(const Item: IInterface): Integer;
begin
  with FList.LockList do
  try
    Result := IndexOf(TObject(Item));
    if Result > -1 then
    begin
      List[Result] := nil;
      Delete(Result);
    end;
  finally
    Self.FList.UnlockList;
  end;
end;

procedure TInterfaceList.SetCapacity(NewCapacity: Integer);
begin
  with FList.LockList do
  try
    Capacity := NewCapacity;
  finally
    Self.FList.UnlockList;
  end;
end;

procedure TInterfaceList.SetCount(NewCount: Integer);
begin
  with FList.LockList do
  try
    Count := NewCount;
  finally
    Self.FList.UnlockList;
  end;
end;

procedure TInterfaceList.Exchange(Index1, Index2: Integer);
begin
  with FList.LockList do
  try
    Exchange(Index1, Index2);
  finally
    Self.FList.UnlockList;
  end;
end;

procedure TInterfaceList.Lock;
begin
  FList.LockList;
end;

procedure TInterfaceList.Unlock;
begin
  FList.UnlockList;
end;

{ TBits }

const
  BitsPerInt = SizeOf(Integer) * 8;

procedure TBits.Error;
begin
  raise EBitsError.Create(SBitsIndexError);
end;

procedure TBits.SetSize(Value: Integer);
var
  NewMemSize: Integer;
  OldMemSize: Integer;
begin
  if Value <> Size then
  begin
    if Value < 0 then
      Error;
    NewMemSize := ((Value + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
    OldMemSize := ((Size + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
    if NewMemSize <> OldMemSize then
      SetLength(FBits, NewMemSize);
    FSize := Value;
  end;
end;

procedure TBits.SetBit(Index: Integer; Value: Boolean);
var
  I: Integer;
begin
  if Index >= FSize then
    SetSize(Index + 1);
  I := Index div BitsPerInt;
  if Value then
    FBits[I] := FBits[I] or (1 shl (Index mod BitsPerInt))
  else
    FBits[I] := FBits[I] and not (1 shl (Index mod BitsPerInt));
end;

function TBits.GetBit(Index: Integer): Boolean;
begin
  if Index >= FSize then
    Result := False
  else
    Result := FBits[Index div BitsPerInt] and (1 shl (Index mod BitsPerInt)) <> 0;
end;

function TBits.OpenBit: Integer;
var
  I, J: Integer;
  B: Integer;
  E: Integer;
begin
  E := (Size + BitsPerInt - 1) div BitsPerInt - 1;
  for I := 0 to E do
    if FBits[I] <> -1 then
    begin
      B := FBits[I];
      for J := 0 to BitsPerInt - 1 do
      begin
        if B and (1 shl J) = 0 then
        begin
          Result := I * BitsPerInt + J;
          if Result >= Size then
            Result := Size;
          Exit;
        end;
      end;
    end;
  Result := Size;
end;

{ TAtomicValues }

type
  TValue = class
  public
    Next: TValue;
    Ref: WeakReference;
  end;

constructor TAtomicValues.Create;
begin
  inherited Create;
  Table := Hashtable.Create;
end;

function TAtomicValues.GetAtomicValueOf(Value: TObject): TObject;
var
  Val: TValue;
  First: TValue;
  OldFirst: TValue;
  Last: TValue;
  Hash: Integer;
begin
  Result := nil;
  System.Threading.Monitor.Enter(Self);
  try
    Hash := Value.GetHashCode;
    Last := nil;                             // Last is tracked so we can delete entries from the TValue list.
    Val := Table[TObject(Hash)] as TValue;   // Entries are stored by the hash value and then chained off the first value in the list
                                             // This uses the hash table as a sparse vector. We cannot use the value as a key to the
                                             // hash table since the hash table will hold on to a reference to the object defeating
                                             // the WeakReference in the TValue object.
    First := Val;                            // First represents what should be the entry in HashTable
    OldFirst := Val;
    while Val <> nil do
    begin
      if not Val.Ref.IsAlive then
      begin
        // If the reference is no longer alive, remove it from the chain
        if not Assigned(Last) then
          First := Val.Next
        else
        begin
          Last.Next := Val.Next;
          Val := Last;
        end
      end
      else
      begin
        // Check to se if the target is the value we are looking for
        Result := Val.Ref.Target;
        // Need to check for nil since IsAlive might have changed since we called it
        // if the reference it was tracking was in another thread. We will wait until
        // IsAlive returns false, however, to remove the value.
        if Assigned(Result) and Result.Equals(Value) then
          Break;
      end;
      Last := Val;
      Val := Val.Next;
    end;
    if not Assigned(Val) then
    begin
      // We didn't find a value that matches, add this into the table of atomic values
      Result := Value;
      Val := TValue.Create;
      Val.Ref := WeakReference.Create(Value);
      Val.Next := First;
      First := Val;
    end;
    if First <> OldFirst then
      Table[TObject(Hash)] := First;
  finally
    System.Threading.Monitor.Exit(Self);
  end;
end;

{ TPersistentHelper }

procedure TPersistentHelper.AssignError(Source: TPersistent);
var
  SourceName: string;
begin
  if Source <> nil then
    SourceName := Source.ClassName
  else
    SourceName := 'nil';
  raise EConvertError.CreateFmt(SAssignError, [SourceName, ClassName]);
end;

procedure TPersistentHelper.Assign(Source: TPersistent);
begin
  if Source <> nil then
    Source.AssignTo(Self)
  else
    AssignError(nil);
end;

procedure TPersistentHelper.AssignTo(Dest: TPersistent);
begin
  Dest.AssignError(Self);
end;

constructor TPersistentHelper.Create;
begin
  inherited Create;
  // This doesn't need to do anything. It is just present to hoist
  // the MarshalByRef constructor public
end;

procedure TPersistentHelper.DefineProperties(Filer: TFiler);
begin
end;

function TPersistentHelper.GetNamePath: string;
var
  S: string;
begin
  Result := ClassName;
  if GetOwner <> nil then
  begin
    S := GetOwner.GetNamePath;
    if S <> '' then
      Result := S + '.' + Result;
  end;
end;

function TPersistentHelper.GetOwner: TPersistent;
begin
  Result := nil;
end;

function FindRootDesigner(Obj: TPersistent): IDesignerNotify;
begin
  if Obj <> nil then
    Result := Obj.GetRootDesigner
  else
    Result := nil;
end;

function CountGenerations(Ancestor, Descendent: TClass): Integer;
var
  R: Integer;
begin
  R := 0;
  while Ancestor <> Descendent do
  begin
    if Descendent = nil then
    begin
      // Descendent wasn't a descendent of Ancestor.
      Result := -1;
      Exit;
    end;
    Descendent := Descendent.ClassParent;
    Inc(R);
  end;
  Result := R;
end;

function DelegatesEqual(A, B: Delegate): Boolean;
begin
  Result := A.Equals(B);
end;

procedure NotifyDesigner(APersistent, Item: TPersistent; Operation: TOperation);
var
  Designer: IDesignerNotify;
begin
  if APersistent <> nil then
  begin
    Designer := APersistent.GetRootDesigner;
    if Designer <> nil then
      Designer.Notification(Item, Operation);
  end;
end;

function TPersistentHelper.GetRootDesigner: IDesignerNotify;
var
  P: TPersistent;
begin
  P := GetOwner;
  if (P is TComponent) and (csDesigning in TComponent(P).ComponentState) then
    Result := P.GetRootDesigner
  else
    Result := nil;
end;

{ TRecall }

constructor TRecall.Create(AStorage, AReference: TPersistent);
begin
  inherited Create;
  FStorage := AStorage;
  FReference := AReference;
  Store;
end;

destructor TRecall.Destroy;
begin
  if Assigned(FReference) then
    FReference.Assign(FStorage);
  Forget;
  inherited;
end;

procedure TRecall.Forget;
begin
  FReference := nil;
  FStorage.Free;
  FStorage := nil;
end;

procedure TRecall.Store;
begin
  if Assigned(FReference) then
    FStorage.Assign(FReference);
end;

{ TCollectionItem }

constructor TCollectionItem.Create(Collection: TCollection);
begin
  inherited Create;
  SetCollection(Collection);
end;

destructor TCollectionItem.Destroy;
begin
  SetCollection(nil);
  inherited;
end;

procedure TCollectionItem.Changed(AllItems: Boolean);
var
  Item: TCollectionItem;
begin
  if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then
  begin
    if AllItems then
      Item := nil
    else
      Item := Self;
    FCollection.Update(Item);
  end;
end;

function TCollectionItem.GetIndex: Integer;
begin
  if FCollection <> nil then
    Result := FCollection.FItems.IndexOf(Self)
  else
    Result := -1;
end;

function TCollectionItem.GetDisplayName: string;
begin
  Result := ClassName;
end;

function TCollectionItem.GetNamePath: string;
begin
  if FCollection <> nil then
    Result := Format('%s[%d]',[FCollection.GetNamePath, Index])
  else
    Result := ClassName;
end;

function TCollectionItem.GetOwner: TPersistent;
begin
  Result := FCollection;
end;

procedure TCollectionItem.SetCollection(Value: TCollection);
begin
  if FCollection <> Value then
  begin
    if FCollection <> nil then
      FCollection.RemoveItem(Self);
    if Value <> nil then
      Value.InsertItem(Self);
  end;
end;

procedure TCollectionItem.SetDisplayName(const Value: string);
begin
  Changed(False);
end;

procedure TCollectionItem.SetIndex(Value: Integer);
var
  CurIndex: Integer;
begin
  CurIndex := GetIndex;
  if (CurIndex >= 0) and (CurIndex <> Value) then
  begin
    FCollection.FItems.Move(CurIndex, Value);
    Changed(True);
  end;
end;

{ TCollection }

constructor TCollection.Create(ItemClass: TCollectionItemClass);
begin
  inherited Create;
  FItemClass := ItemClass;
  FItems := TList.Create;
  NotifyDesigner(Self, Self, opInsert);
end;


destructor TCollection.Destroy;
begin
  FUpdateCount := 1;
  NotifyDesigner(Self, Self, opRemove);
  inherited Destroy;
end;

function TCollection.Add: TCollectionItem;
begin
  Result := FItemClass.Create(Self);
  Added(Result);
end;

procedure TCollection.Assign(Source: TPersistent);
var
  I: Integer;
begin
  if Source is TCollection then
  begin
    BeginUpdate;
    try
      Clear;
      for I := 0 to TCollection(Source).Count - 1 do
        Add.Assign(TCollection(Source).Items[I]);
    finally
      EndUpdate;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TCollection.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TCollection.Changed;
begin
  if FUpdateCount = 0 then
    Update(nil);
end;

procedure TCollection.Clear;
begin
  if FItems.Count > 0 then
  begin
    BeginUpdate;
    try
      while FItems.Count > 0 do
        TCollectionItem(FItems.Last).Free;
    finally
      EndUpdate;
    end;
  end;
end;

procedure TCollection.EndUpdate;
begin
  Dec(FUpdateCount);
  Changed;
end;

function TCollection.FindItemID(ID: Integer): TCollectionItem;
var
  I: Integer;
begin
  for I := 0 to FItems.Count-1 do
  begin
    Result := TCollectionItem(FItems[I]);
    if Result.ID = ID then
      Exit;
  end;
  Result := nil;
end;

function TCollection.GetAttrCount: Integer;
begin
  Result := 0;
end;

function TCollection.GetAttr(Index: Integer): string;
begin
  Result := '';
end;

function TCollection.GetItemAttr(Index, ItemIndex: Integer): string;
begin
  Result := Items[ItemIndex].DisplayName;
end;

function TCollection.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TCollection.GetItem(Index: Integer): TCollectionItem;
begin
  Result := TCollectionItem(FItems[Index]);
end;

function TCollection.GetNamePath: string;
var
  S, P: string;
begin
  Result := ClassName;
  if GetOwner = nil then
    Exit;
  S := GetOwner.GetNamePath;
  if S = '' then
    Exit;
  P := PropName;
  if P = '' then
    Exit;
  Result := S + '.' + P;
end;

function TCollection.GetPropName: string;
var
  I: Integer;
  Props: TPropList;
  Owner: TPersistent;
begin
  Result := FPropName;
  Owner := GetOwner;
  if (Result <> '') or (Owner = nil) then
    Exit;
  Props := GetPropInfos(TTypeInfo(Owner.ClassInfo));
  for I := Low(Props) to High(Props) do
    with Props[I] do
      if GetObjectProp(Owner, Props[I]) = Self then
      begin
        FPropName := Name;
        Break;
      end;
  Result := FPropName;
end;

function TCollection.Insert(Index: Integer): TCollectionItem;
begin
  Result := Add;
  Result.Index := Index;
end;

procedure TCollection.InsertItem(Item: TCollectionItem);
begin
  if not (Item is FItemClass) then
    TList.Error(SInvalidProperty, 0);
  FItems.Add(Item);
  Item.FCollection := Self;
  Item.FID := FNextID;
  Inc(FNextID);
  SetItemName(Item);
  Notify(Item, cnAdded);
  Changed;
  NotifyDesigner(Self, Item, opInsert);
end;

procedure TCollection.RemoveItem(Item: TCollectionItem);
begin
  Notify(Item, cnExtracting);
  if Item = FItems.Last then
    FItems.Delete(FItems.Count - 1)
  else
    FItems.Remove(Item);
  Item.FCollection := nil;
  NotifyDesigner(Self, Item, opRemove);
  Changed;
end;

procedure TCollection.SetItem(Index: Integer; Value: TCollectionItem);
begin
  TCollectionItem(FItems[Index]).Assign(Value);
end;

procedure TCollection.SetItemName(Item: TCollectionItem);
begin
end;

procedure TCollection.Update(Item: TCollectionItem);
begin
end;

procedure TCollection.Delete(Index: Integer);
begin
  Notify(TCollectionItem(FItems[Index]), cnDeleting);
  TCollectionItem(FItems[Index]).Free;
end;

function TCollection.Owner: TPersistent;
begin
  Result := GetOwner;
end;

procedure TCollection.Added(var Item: TCollectionItem);
begin
end;

procedure TCollection.Deleting(Item: TCollectionItem);
begin
end;

procedure TCollection.Notify(Item: TCollectionItem;
  Action: TCollectionNotification);
begin
  case Action of
    cnAdded: Added(Item);
    cnDeleting: Deleting(Item);
  end;
end;

{ TOwnedCollection }

constructor TOwnedCollection.Create(AOwner: TPersistent;
  ItemClass: TCollectionItemClass);
begin
  inherited Create(ItemClass);
  FOwner := AOwner;
end;

function TOwnedCollection.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

{ find the ultimate owner of a collection or item (or persistent for that matter) }

function GetUltimateOwner(ACollectionItem: TCollectionItem): TPersistent;
begin
  Result := ACollectionItem.GetOwner;
  if Result <> nil then
    Result := GetUltimateOwner(TCollection(Result));
end;

function GetUltimateOwner(ACollection: TCollection): TPersistent;
begin
  Result := ACollection.GetOwner;
  if Result <> nil then
    Result := GetUltimateOwner(Result);
end;

function GetUltimateOwner(APersistent: TPersistent): TPersistent;
begin
  Result := APersistent.GetOwner;
end;

{ TStrings }

function TStrings.Add(const S: string): Integer;
begin
  Result := GetCount;
  Insert(Result, S);
end;

function TStrings.AddObject(const S: string; AObject: TObject): Integer;
begin
  Result := Add(S);
  PutObject(Result, AObject);
end;

procedure TStrings.Append(const S: string);
begin
  Add(S);
end;

procedure TStrings.AddStrings(Strings: TStrings);
var
  I: Integer;
begin
  BeginUpdate;
  try
    for I := 0 to Strings.Count - 1 do
      AddObject(Strings[I], Strings.Objects[I]);
  finally
    EndUpdate;
  end;
end;

procedure TStrings.Assign(Source: TPersistent);
begin
  if Source is TStrings then
  begin
    BeginUpdate;
    try
      Clear;
      FDefined := TStrings(Source).FDefined;
      FNameValueSeparator := TStrings(Source).FNameValueSeparator;
      FQuoteChar := TStrings(Source).FQuoteChar;
      FDelimiter := TStrings(Source).FDelimiter;
      FLineBreak := TStrings(Source).FLineBreak;
      AddStrings(TStrings(Source));
    finally
      EndUpdate;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TStrings.BeginUpdate;
begin
  if FUpdateCount = 0 then
    SetUpdateState(True);
  Inc(FUpdateCount);
end;

procedure TStrings.DefineProperties(Filer: TFiler);

  function DoWrite: Boolean;
  begin
    if Filer.Ancestor <> nil then
    begin
      Result := True;
      if Filer.Ancestor is TStrings then
        Result := not Equals(TStrings(Filer.Ancestor))
    end
    else
      Result := Count > 0;
  end;

begin
  Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite);
end;

procedure TStrings.EndUpdate;
begin
  Dec(FUpdateCount);
  if FUpdateCount = 0 then
    SetUpdateState(False);
end;

function TStrings.Equals(Strings: TStrings): Boolean;
var
  I, Count: Integer;
begin
  Result := False;
  Count := GetCount;
  if Count <> Strings.GetCount then
    Exit;
  for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then
    Exit;
  Result := True;
end;

procedure TStrings.Error(const Msg: string; Data: Integer);
begin
  raise EStringListError.CreateFmt(Msg, [Data]);
end;

{
procedure TStrings.Error(Msg: PResStringRec; Data: Integer);
begin
  Error(LoadResString(Msg), Data);
end;
}

procedure TStrings.Exchange(Index1, Index2: Integer);
var
  TempObject: TObject;
  TempString: string;
begin
  BeginUpdate;
  try
    TempString := Strings[Index1];
    TempObject := Objects[Index1];
    Strings[Index1] := Strings[Index2];
    Objects[Index1] := Objects[Index2];
    Strings[Index2] := TempString;
    Objects[Index2] := TempObject;
  finally
    EndUpdate;
  end;
end;

function TStrings.ExtractName(const S: string): string;
var
  P: Integer;
begin
  Result := S;
  P := Pos(NameValueSeparator, Result);
  if P <> 0 then
    SetLength(Result, P-1)
  else
    SetLength(Result, 0);
end;

function TStrings.GetCapacity: Integer;
begin  // descendants may optionally override/replace this default implementation
  Result := Count;
end;

function TStrings.GetCommaText: string;
var
  LOldDefined: TStringsDefined;
  LOldDelimiter: Char;
  LOldQuoteChar: Char;
begin
  LOldDefined := FDefined;
  LOldDelimiter := FDelimiter;
  LOldQuoteChar := FQuoteChar;
  Delimiter := ',';
  QuoteChar := '"';
  try
    Result := GetDelimitedText;
  finally
    FDelimiter := LOldDelimiter;
    FQuoteChar := LOldQuoteChar;
    FDefined := LOldDefined;
  end;
end;

function TStrings.GetDelimitedText: string;
var
  S, D: string;
  P: Integer;
  I, Count, L: Integer;
begin
  Count := GetCount;
  if (Count = 1) and (Get(0) = '') then
    Result := QuoteChar + QuoteChar
  else
  begin
    Result := '';
    D := '';
    for I := 0 to Count - 1 do
    begin
      S := Get(I);
      L := Length(S);
      P := 1;
      while (P <= L) and not(S[P] in [#0..' '])
      and (S[P] <> QuoteChar) and (S[P] <> Delimiter) do
        Inc(P);
      if (P <= L) then
        S := QuotedStr(S, QuoteChar);
      Result := Result + D + S;
      D := Delimiter;
    end;
  end;
end;

function TStrings.GetName(Index: Integer): string;
begin
  Result := ExtractName(Get(Index));
end;

function TStrings.GetObject(Index: Integer): TObject;
begin
  Result := nil;
end;

function TStrings.GetTextStr: string;
var
  Buffer: StringBuilder;
  I, Count: Integer;
begin
  Count := GetCount;
  Buffer := StringBuilder.Create;
  for I := 0 to Count - 1 do
  begin
    Buffer.Append(Get(I));
    Buffer.Append(LineBreak);
  end;
  Result := Buffer.ToString;
end;

function TStrings.GetValue(const Name: string): string;
var
  I: Integer;
begin
  I := IndexOfName(Name);
  if I >= 0 then
    Result := Copy(Get(I), Length(Name) + 2, MaxInt)
  else
    Result := '';
end;

function TStrings.IndexOf(const S: string): Integer;
begin
  for Result := 0 to GetCount - 1 do
    if CompareStrings(Get(Result), S) = 0 then
      Exit;
  Result := -1;
end;

function TStrings.IndexOfName(const Name: string): Integer;
var
  P: Integer;
  S: string;
begin
  for Result := 0 to GetCount - 1 do
  begin
    S := Get(Result);
    P := Pos(NameValueSeparator, S);
    if (P <> 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then
      Exit;
  end;
  Result := -1;
end;

function TStrings.IndexOfObject(AObject: TObject): Integer;
begin
  if AObject = nil then
  begin
    for Result := 0 to GetCount - 1 do
      if GetObject(Result) = nil then
        Exit;
  end
  else
  begin
    for Result := 0 to GetCount - 1 do
      if AObject.Equals(GetObject(Result)) then        
        Exit;
  end;

  Result := -1;
end;

procedure TStrings.InsertObject(Index: Integer; const S: string;
  AObject: TObject);
begin
  Insert(Index, S);
  PutObject(Index, AObject);
end;

procedure TStrings.LoadFromFile(const FileName: string);
begin
  LoadFromFile(FileName, nil);
end;

procedure TStrings.LoadFromFile(const FileName: string; Encoding: System.Text.Encoding);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream, Encoding);
  finally
    Stream.Free;
  end;
end;

procedure TStrings.LoadFromStream(Stream: TStream);
begin
  LoadFromStream(Stream, nil);
end;

procedure TStrings.LoadFromStream(Stream: TStream; Encoding: System.Text.Encoding);

  function ContainsPreamble(Buffer, Signature: array of Byte): Boolean;
  var
    I: Integer;
  begin
    Result := True;
    if Length(Buffer) >= Length(Signature) then
    begin
      for I := 1 to Length(Signature) do
        if Buffer[I - 1] <> Signature [I - 1] then
        begin
          Result := False;
          Break;
        end;
    end
    else
      Result := False;
  end;

var
  Size: Integer;
  Buffer, Preamble: array of Byte;
begin
  BeginUpdate;
  try
    // Read bytes from stream
    Size := Stream.Size - Stream.Position;
    SetLength(Buffer, Size);
    Stream.Read(Buffer, Size);

    Size := 0;
    if Encoding = nil then
    begin
      // Find the appropraite encoding
      if ContainsPreamble(Buffer, System.Text.Encoding.Unicode.GetPreamble) then
        Encoding := System.Text.Encoding.Unicode
      else
        if ContainsPreamble(Buffer, System.Text.Encoding.BigEndianUnicode.GetPreamble) then
          Encoding := System.Text.Encoding.BigEndianUnicode
        else
          if ContainsPreamble(Buffer, System.Text.Encoding.UTF8.GetPreamble) then
            Encoding := System.Text.Encoding.UTF8
          else
            Encoding := System.Text.Encoding.Default;
      Size := Length(Encoding.GetPreamble);
    end
    else
    begin
      // Use specified encoding, ignore preamble bytes if present
      Preamble := Encoding.GetPreamble;
      if ContainsPreamble(Buffer, Preamble) then
        Size := Length(Preamble);
    end;
    SetTextStr(Encoding.GetString(Buffer, Size, Length(Buffer) - Size));
  finally
    EndUpdate;
  end;
end;

procedure TStrings.Move(CurIndex, NewIndex: Integer);
var
  TempObject: TObject;
  TempString: string;
begin
  if CurIndex <> NewIndex then
  begin
    BeginUpdate;
    try
      TempString := Get(CurIndex);
      TempObject := GetObject(CurIndex);
      Delete(CurIndex);
      InsertObject(NewIndex, TempString, TempObject);
    finally
      EndUpdate;
    end;
  end;
end;

procedure TStrings.Put(Index: Integer; const S: string);
var
  TempObject: TObject;
begin
  TempObject := GetObject(Index);
  Delete(Index);
  InsertObject(Index, S, TempObject);
end;

procedure TStrings.PutObject(Index: Integer; AObject: TObject);
begin
end;

procedure TStrings.ReadData(Reader: TReader);
begin
  Reader.ReadListBegin;
  BeginUpdate;
  try
    Clear;
    while not Reader.EndOfList do
      Add(Reader.ReadString);
  finally
    EndUpdate;
  end;
  Reader.ReadListEnd;
end;

procedure TStrings.SaveToFile(const FileName: string);
begin
  SaveToFile(FileName, nil);
end;

procedure TStrings.SaveToFile(const FileName: string; Encoding: System.Text.Encoding);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream, Encoding);
  finally
    Stream.Free;
  end;
end;

procedure TStrings.SaveToStream(Stream: TStream);
begin
  SaveToStream(Stream, nil);
end;

procedure TStrings.SaveToStream(Stream: TStream; Encoding: System.Text.Encoding);
var
  Buffer, Preamble: array of Byte;
begin
  if Encoding = nil then
    Encoding := System.Text.Encoding.Default;
  Buffer := Encoding.GetBytes(GetTextStr);
  Preamble := Encoding.GetPreamble;
  if Length(Preamble) > 0 then
    Stream.WriteBuffer(Preamble, Length(Preamble));
  Stream.WriteBuffer(Buffer, Length(Buffer));
end;

procedure TStrings.SetCapacity(NewCapacity: Integer);
begin
  // do nothing - descendants may optionally implement this method
end;

procedure TStrings.SetCommaText(const Value: string);
begin
  Delimiter := ',';
  QuoteChar := '"';
  SetDelimitedText(Value);
end;

                                        
procedure TStrings.SetTextStr(const Value: string);
var
  P, Start, L: Integer;
begin
  BeginUpdate;
  try
    Clear;

    Start := 1;
    L := Length(LineBreak);
    P := Pos(LineBreak, Value);
    while P > 0 do
    begin
      Add(Copy(Value, Start, P - Start));
      Start := P + L;
      P := PosEx(LineBreak, Value, Start);
    end;
    if Start <= Length(Value) then
      Add(Copy(Value, Start, Length(Value) - Start + 1));
  finally
    EndUpdate;
  end;
end;

procedure TStrings.SetUpdateState(Updating: Boolean);
begin
end;

procedure TStrings.SetValue(const Name, Value: string);
var
  I: Integer;
begin
  I := IndexOfName(Name);
  if Value <> '' then
  begin
    if I < 0 then
      I := Add('');
    Put(I, Name + NameValueSeparator + Value);
  end
  else
  begin
    if I >= 0 then
      Delete(I);
  end;
end;

procedure TStrings.WriteData(Writer: TWriter);
var
  I: Integer;
begin
  Writer.WriteListBegin;
  for I := 0 to Count - 1 do Writer.WriteString(Get(I));
  Writer.WriteListEnd;
end;

procedure TStrings.SetDelimitedText(const Value: string);
var
  P, P1, L: Integer;
  S: string;
begin
  BeginUpdate;
  try
    Clear;
    P := 1;
    L := Length(Value);
    while (P <= L) and (Value[P] in [#1..' ']) do
      Inc(P);
    while P <= L do
    begin
      if Value[P] = QuoteChar then
        S := DequotedStr(Value, QuoteChar, P)
      else
      begin
        P1 := P;
        while (P <= L) and (Value[P] > ' ') and (Value[P] <> Delimiter) do
          Inc(P);
        S := Copy(Value, P1, P - P1);
      end;
      Add(S);
      while (P <= L) and (Value[P] in [#1..' ']) do
        Inc(P);
      if (P <= L) and (Value[P] = Delimiter) then
      begin
        P1 := P;
        Inc(P1);
        if P1 > L then
          Add('');
        repeat
          Inc(P);
        until (P > L) or (not (Value[P] in [#1..' ']));
      end;
    end;
  finally
    EndUpdate;
  end;
end;

function TStrings.GetDelimiter: Char;
begin
  if not (sdDelimiter in FDefined) then
    Delimiter := ',';
  Result := FDelimiter;
end;

function TStrings.GetLineBreak: string;
begin
  if not (sdLineBreak in FDefined) then
    LineBreak := sLineBreak;
  Result := FLineBreak;
end;

function TStrings.GetQuoteChar: Char;
begin
  if not (sdQuoteChar in FDefined) then
    QuoteChar := '"';
  Result := FQuoteChar;
end;

procedure TStrings.SetDelimiter(const Value: Char);
begin
  if (FDelimiter <> Value) or not (sdDelimiter in FDefined) then
  begin
    Include(FDefined, sdDelimiter);
    FDelimiter := Value;
  end
end;

procedure TStrings.SetLineBreak(const Value: string);
begin
  if (FLineBreak <> Value) or not (sdLineBreak in FDefined) then
  begin
    Include(FDefined, sdLineBreak);
    FLineBreak := Value;
  end
end;

procedure TStrings.SetQuoteChar(const Value: Char);
begin
  if (FQuoteChar <> Value) or not (sdQuoteChar in FDefined) then
  begin
    Include(FDefined, sdQuoteChar);
    FQuoteChar := Value;
  end
end;

function TStrings.CompareStrings(const S1, S2: string): Integer;
begin
  Result := CompareText(S1, S2);
end;

function TStrings.GetNameValueSeparator: Char;
begin
  if not (sdNameValueSeparator in FDefined) then
    NameValueSeparator := '=';
  Result := FNameValueSeparator;
end;

procedure TStrings.SetNameValueSeparator(const Value: Char);
begin
  if (FNameValueSeparator <> Value) or not (sdNameValueSeparator in FDefined) then
  begin
    Include(FDefined, sdNameValueSeparator);
    FNameValueSeparator := Value;
  end
end;

function TStrings.GetValueFromIndex(Index: Integer): string;
begin
  if Index >= 0 then
    Result := Copy(Get(Index), Length(Names[Index]) + 2, MaxInt)
  else
    Result := '';
end;

procedure TStrings.SetValueFromIndex(Index: Integer; const Value: string);
begin
  if Value <> '' then
  begin
    if Index < 0 then
      Index := Add('');
    Put(Index, Names[Index] + NameValueSeparator + Value);
  end
  else
    if Index >= 0 then
      Delete(Index);
end;

{ TStringList }

function TStringList.Add(const S: string): Integer;
begin
  Result := AddObject(S, nil);
end;

function TStringList.AddObject(const S: string; AObject: TObject): Integer;
begin
  if not Sorted then
    Result := FCount
  else
    if Find(S, Result) then
      case Duplicates of
        dupIgnore: Exit;
        dupError: Error(SDuplicateString, 0);
      end;
  InsertItem(Result, S, AObject);
end;

procedure TStringList.Changed;
begin
  if (FUpdateCount = 0) and Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TStringList.Changing;
begin
  if (FUpdateCount = 0) and Assigned(FOnChanging) then
    FOnChanging(Self);
end;

procedure TStringList.Clear;
begin
  if FCount <> 0 then
  begin
    Changing;
    FCount := 0;
    SetCapacity(0);
    Changed;
  end;
end;

procedure TStringList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then
    Error(SListIndexError, Index);
  Changing;
  Dec(FCount);
  if Index < FCount then
    System.Array.Copy(System.Array(FList), Index + 1, System.Array(FList),
      Index, FCount - Index);
  Changed;
end;

procedure TStringList.Exchange(Index1, Index2: Integer);
begin
  if (Index1 < 0) or (Index1 >= FCount) then
    Error(SListIndexError, Index1);
  if (Index2 < 0) or (Index2 >= FCount) then
    Error(SListIndexError, Index2);
  Changing;
  ExchangeItems(Index1, Index2);
  Changed;
end;

procedure TStringList.ExchangeItems(Index1, Index2: Integer);
var
  Temp: TStringItem;
begin
  Temp := FList[Index1];
  FList[Index1] := FList[Index2];
  FLIst[Index2] := Temp;
end;

function TStringList.Find(const S: string; var Index: Integer): Boolean;
var
  L, H, I, C: Integer;
begin
  Result := False;
  L := 0;
  H := FCount - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := CompareStrings(FList[I].FString, S);
    if C < 0 then
      L := I + 1
    else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := True;
        if Duplicates <> dupAccept then
          L := I;
      end;
    end;
  end;
  Index := L;
end;

function TStringList.Get(Index: Integer): string;
begin
  if (Index < 0) or (Index >= FCount) then
    Error(SListIndexError, Index);
  Result := FList[Index].FString;
end;

function TStringList.GetCapacity: Integer;
begin
  Result := Length(FList);
end;

function TStringList.GetCount: Integer;
begin
  Result := FCount;
end;

function TStringList.GetObject(Index: Integer): TObject;
begin
  if (Index < 0) or (Index >= FCount) then
    Error(SListIndexError, Index);
  Result := FList[Index].FObject;
end;

procedure TStringList.Grow;
var
  Delta: Integer;
  C: Integer;
begin
  C := Length(FList);
  if C > 64 then
    Delta := C div 4
  else if C > 8 then
    Delta := 16
  else
    Delta := 4;
  SetCapacity(C + Delta);
end;

function TStringList.IndexOf(const S: string): Integer;
begin
  if not Sorted then
    Result := inherited IndexOf(S)
  else if not Find(S, Result) then
    Result := -1;
end;

procedure TStringList.Insert(Index: Integer; const S: string);
begin
  InsertObject(Index, S, nil);
end;

procedure TStringList.InsertObject(Index: Integer; const S: string;
  AObject: TObject);
begin
  if Sorted then
    Error(SSortedListError, 0);
  if (Index < 0) or (Index > Count) then
    Error(SListIndexError, Index);
  InsertItem(Index, S, AObject);
end;

procedure TStringList.InsertItem(Index: Integer; const S: string; AObject: TObject);
begin
  Changing;
  if FCount = Length(FList) then
    Grow;
  if Index < FCount then
    System.Array.Copy(System.Array(FList), Index, System.Array(FList),
      Index + 1, FCount - Index);
  with FList[Index] do
  begin
    FObject := AObject;
    FString := S;
  end;
  Inc(FCount);
  Changed;
end;

procedure TStringList.Put(Index: Integer; const S: string);
begin
  if Sorted then
    Error(SSortedListError, 0);
  if (Index < 0) or (Index >= FCount) then
    Error(SListIndexError, Index);
  Changing;
  FList[Index].FString := S;
  Changed;
end;

procedure TStringList.PutObject(Index: Integer; AObject: TObject);
begin
  if (Index < 0) or (Index >= FCount) then
    Error(SListIndexError, Index);
  Changing;
  FList[Index].FObject := AObject;
  Changed;
end;

procedure TStringList.QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
var
  I, J, P: Integer;
begin
  repeat
    I := L;
    J := R;
    P := (L + R) shr 1;
    repeat
      while SCompare(Self, I, P) < 0 do
        Inc(I);
      while SCompare(Self, J, P) > 0 do
        Dec(J);
      if I <= J then
      begin
        ExchangeItems(I, J);
        if P = I then
          P := J
        else if P = J then
          P := I;
        Inc(I);
        Dec(J);
      end;
    until I > J;
    if L < J then
      QuickSort(L, J, SCompare);
    L := I;
  until I >= R;
end;

procedure TStringList.SetCapacity(NewCapacity: Integer);
begin
  SetLength(FList, NewCapacity);
end;

procedure TStringList.SetSorted(Value: Boolean);
begin
  if FSorted <> Value then
  begin
    if Value then
      Sort;
    FSorted := Value;
  end;
end;

procedure TStringList.SetUpdateState(Updating: Boolean);
begin
  if Updating then
    Changing
  else
    Changed;
end;

function StringListCompareStrings(List: TStringList; Index1,
  Index2: Integer): Integer;
begin
  Result := List.CompareStrings(List.FList[Index1].FString,
    List.FList[Index2].FString);
end;

procedure TStringList.Sort;
begin
  CustomSort(StringListCompareStrings);
end;

procedure TStringList.CustomSort(Compare: TStringListSortCompare);
begin
  if not Sorted and (FCount > 1) then
  begin
    Changing;
    QuickSort(0, FCount - 1, Compare);
    Changed;
  end;
end;

function TStringList.CompareStrings(const S1, S2: string): Integer;
begin
  if CaseSensitive then
    Result := CompareStr(S1, S2)
  else
    Result := CompareText(S1, S2);
end;

procedure TStringList.SetCaseSensitive(const Value: Boolean);
begin
  if Value <> FCaseSensitive then
  begin
    FCaseSensitive := Value;
    if Sorted then
      Sort;
  end;
end;

{ TStream }

function TStream.GetPosition: Int64;
begin
  Result := Seek(0, soCurrent);
end;

procedure TStream.SetPosition(const Pos: Int64);
begin
  Seek(Pos, soBeginning);
end;

function TStream.GetSize: Int64;
var
  Pos: Int64;
begin
  Pos := Seek(0, soCurrent);
  Result := Seek(0, soEnd);
  Seek(Pos, soBeginning);
end;

procedure TStream.ReadBuffer(Buffer: array of Byte; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Byte);
begin
  if Read(Buffer) <> SizeOf(Byte) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Byte; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Boolean);
begin
  if Read(Buffer) <> SizeOf(Boolean) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Boolean; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Char);
begin
  if Read(Buffer) <> SizeOf(Char) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Char; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: AnsiChar);
begin
  if Read(Buffer) <> SizeOf(AnsiChar) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: AnsiChar; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: ShortInt);
begin
  if Read(Buffer) <> SizeOf(ShortInt) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: ShortInt; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: SmallInt);
begin
  if Read(Buffer) <> SizeOf(SmallInt) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: SmallInt; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Word);
begin
  if Read(Buffer) <> SizeOf(Word) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Word; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Integer);
begin
  if Read(Buffer) <> SizeOf(Integer) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Integer; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Cardinal);
begin
  if Read(Buffer) <> SizeOf(Cardinal) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Cardinal; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Int64);
begin
  if Read(Buffer) <> SizeOf(Int64) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Int64; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: UInt64);
begin
  if Read(Buffer) <> SizeOf(UInt64) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: UInt64; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Single);
begin
  if Read(Buffer) <> SizeOf(Single) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Single; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Double);
begin
  if Read(Buffer) <> SizeOf(Double) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Double; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Extended);
begin
  if Read(Buffer) <> 10 then
    raise EReadError.Create(SReadError);
end;

procedure TStream.ReadBuffer(var Buffer: Extended; Count: Longint);
begin
  if (Count <> 0) and (Read(Buffer, Count) <> Count) then
    raise EReadError.Create(SReadError);
end;

procedure TStream.WriteBuffer(const Buffer: array of Byte; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Byte);
begin
  if Write(Buffer) <> SizeOf(Byte) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Byte; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Boolean);
begin
  if Write(Buffer) <> SizeOf(Boolean) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Boolean; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Char);
begin
  if Write(Buffer) <> SizeOf(Char) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Char; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: AnsiChar);
begin
  if Write(Buffer) <> SizeOf(AnsiChar) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: AnsiChar; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: ShortInt);
begin
  if Write(Buffer) <> SizeOf(ShortInt) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: ShortInt; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: SmallInt);
begin
  if Write(Buffer) <> SizeOf(SmallInt) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: SmallInt; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Word);
begin
  if Write(Buffer) <> SizeOf(Word) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Word; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Integer);
begin
  if Write(Buffer, 4) <> 4 then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Integer; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Cardinal);
begin
  if Write(Buffer) <> SizeOf(Cardinal) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Cardinal; Count: Longint);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Int64);
begin
  if Write(Buffer) <> SizeOf(Int64) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Int64; Count: Integer);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: UInt64);
begin
  if Write(Buffer) <> SizeOf(UInt64) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: UInt64; Count: Integer);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Single);
begin
  if Write(Buffer) <> SizeOf(Single) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Single; Count: Integer);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Double);
begin
  if Write(Buffer) <> SizeOf(Double) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Double; Count: Integer);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Extended);
begin
  if Write(Buffer) <> 10 then
    raise EWriteError.Create(SWriteError);
end;

procedure TStream.WriteBuffer(const Buffer: Extended; Count: Integer);
begin
  if (Count <> 0) and (Write(Buffer, Count) <> Count) then
    raise EWriteError.Create(SWriteError);
end;

{MaxBufSize moved out of CopyFrom for performance }
const
  MaxBufSize = $F000;

function TStream.CopyFrom(Source: TStream; Count: Int64): Int64;
var
  BufSize, N: Integer;
  Buffer: array of Byte;
begin
  if Count = 0 then
  begin
    Source.Position := 0;
    Count := Source.Size;
  end;
  Result := Count;
  if Count > MaxBufSize then
    BufSize := MaxBufSize
  else
    BufSize := Count;
  SetLength(Buffer, BufSize);
  while Count <> 0 do
  begin
    if Count > BufSize then
      N := BufSize
    else
      N := Count;
    Source.ReadBuffer(Buffer, N);
    WriteBuffer(Buffer, N);
    Dec(Count, N);
  end;
end;

function TStream.ReadComponent(Instance: TComponent): TComponent;
var
  Reader: TReader;
begin
  Reader := TReader.Create(Self, 4096);
  try
    Result := Reader.ReadRootComponent(Instance);
  finally
    Reader.Free;
  end;
end;

procedure TStream.WriteComponent(Instance: TComponent);
begin
  WriteDescendent(Instance, nil);
end;

procedure TStream.WriteDescendent(Instance, Ancestor: TComponent);
var
  Writer: TWriter;
begin
  Writer := TWriter.Create(Self, 4096);
  try
    Writer.WriteDescendent(Instance, Ancestor);
  finally
    Writer.Free;
  end;
end;

function TStream.ReadComponentRes(Instance: TComponent): TComponent;
begin
  ReadResHeader;
  Result := ReadComponent(Instance);
end;

procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent);
begin
  WriteDescendentRes(ResName, Instance, nil);
end;

procedure TStream.WriteResourceHeader(const ResName: string; out FixupInfo: Integer);
var
  HeaderSize: Integer;
  Header: array[0..79] of Byte;
  LResName: AnsiString;
  L, I: Integer;
begin
  Header[0] := $FF;
  Header[1] := 10;
  Header[2] := 0;
  LResName := UpperCase(ResName);
  L := Length(LResName);
  if L > 63 then
    L := 63;
  for I := 1 to Length(LResName) do
    Header[2 + I] := Byte(LResName[I]);
  Header[3 + L] := 0;
  HeaderSize := L + 10;
  Header[HeaderSize - 6] := $30;
  Header[HeaderSize - 5] := $10;
  Header[HeaderSize - 4] := 0;
  Header[HeaderSize - 3] := 0;
  Header[HeaderSize - 2] := 0;
  Header[HeaderSize - 1] := 0;
  WriteBuffer(Header, HeaderSize);
  FixupInfo := Position;
end;

procedure TStream.FixupResourceHeader(FixupInfo: Integer);
var
  ImageSize: Integer;
begin
  ImageSize := Position - FixupInfo;
  Position := FixupInfo - 4;
  WriteBuffer(ImageSize, SizeOf(Longint));
  Position := FixupInfo + ImageSize;
end;

procedure TStream.WriteDescendentRes(const ResName: string; Instance,
  Ancestor: TComponent);
var
  FixupInfo: Integer;
begin
  WriteResourceHeader(ResName, FixupInfo);
  WriteDescendent(Instance, Ancestor);
  FixupResourceHeader(FixupInfo);
end;

procedure TStream.ReadResHeader;
var
  ReadCount: Integer;
  Header: array[0..79] of Byte;
  I, L: Integer;
begin
  for I := Low(Header) to High(Header) do
    Header[I] := 0;
  ReadCount := Read(Header, Length(Header) - 1);
  if (Header[0] = $FF) and (Header[1] = 10) and (Header[2] = 0) then
  begin
    L := 0;
    while Header[3 + L] <> 0 do
      Inc(L);
    Seek(L + 10 - ReadCount, soCurrent)
  end
  else
    raise EInvalidImage.Create(SInvalidImage);
end;

function TStream.Read(var Buffer: array of Byte; Count: Longint): Longint;
begin
  Result := Read(Buffer, 0, Count);
end;

function TStream.Read(var Buffer: Byte): Longint;
var
  Buf: array[0..0] of Byte;
begin
  Result := Read(Buf, 1);
  Buffer := Buf[0];
end;

function TStream.Read(var Buffer: Byte; Count: Longint): Longint;
var
  Buf: array[0..0] of Byte;
begin
  if Count <> 0 then
  begin
    Result := Read(Buf, 1);
    if Count > 1 then
      Inc(Result, Skip(Count - 1));
    Buffer := Buf[0];
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: Boolean): Longint;
var
  Buf: array[0..0] of Byte;
begin
  Result := Read(Buf, 1);
  Buffer := Boolean(Buf[0]);
end;

function TStream.Read(var Buffer: Boolean; Count: Longint): Longint;
var
  Buf: array[0..0] of Byte;
begin
  if Count <> 0 then
  begin
    Result := Read(Buf, 1);
    if Count > 1 then
      Inc(Result, Skip(Count - 1));
    Buffer := Boolean(Buf[0]);
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: Char): Longint;
var
  Buf: array[0..1] of Byte;
begin
  Result := Read(Buf, 2);
  Buffer := Char(Buf[0] or Buf[1] shl 8);
end;

function TStream.Read(var Buffer: Char; Count: Longint): Longint;
var
  Buf: array[0..1] of Byte;
  S: Integer;
begin
  S := 0;
  if Count > 2 then
  begin
    S := Count - 2;
    Count := 2;
  end;
  if Count <> 0 then
  begin
    Buf[1] := 0;
    Result := Read(Buf, Count);
    Buffer := Char(Buf[0] or Buf[1] shl 8);
    if S <> 0 then
      Inc(Result, Skip(S));
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: AnsiChar): Longint;
var
  Buf: array[0..0] of Byte;
begin
  Result := Read(Buf, 1);
  Buffer := AnsiChar(Buf[0]);
end;

function TStream.Read(var Buffer: AnsiChar; Count: Longint): Longint;
var
  Buf: array[0..0] of Byte;
begin
  if Count <> 0 then
  begin
    Result := Read(Buf, 1);
    if Count > 1 then
      Inc(Result, Skip(Count - 1));
    Buffer := AnsiChar(Buf[0]);
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: ShortInt): Longint;
var
  Buf: array[0..0] of Byte;
begin
  Result := Read(Buf, 1);
  Buffer := ShortInt(Buf[0]);
end;

function TStream.Read(var Buffer: ShortInt; Count: Longint): Longint;
var
  Buf: array[0..0] of Byte;
begin
  if Count <> 0 then
  begin
    Result := Read(Buf, 1);
    if Count > 1 then
      Inc(Result, Skip(Count - 1));
    Buffer := ShortInt(Buf[0]);
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: SmallInt): Longint;
var
  Buf: array[0..1] of Byte;
begin
  Result := Read(Buf, 2);
  Buffer := SmallInt(Buf[0] or (Buf[1] shl 8));
end;

function TStream.Read(var Buffer: SmallInt; Count: Longint): Longint;
var
  Buf: array[0..1] of Byte;
  S: Integer;
begin
  S := 0;
  if Count > 2 then
  begin
    S := Count - 2;
    Count := 2;
  end;
  if Count <> 0 then
  begin
    Buf[1] := 0;
    Result := Read(Buf, Count);
    Buffer := SmallInt(Buf[0] or (Buf[1] shl 8));
    if S <> 0 then
      Inc(Result, Skip(S));
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: Word): Longint;
var
  Buf: array[0..1] of Byte;
begin
  Result := Read(Buf, 2);
  Buffer := Word(Buf[0] or (Buf[1] shl 8));
end;

function TStream.Read(var Buffer: Word; Count: Longint): Longint;
var
  Buf: array[0..1] of Byte;
  S: Integer;
begin
  S := 0;
  if Count > 2 then
  begin
    S := Count - 2;
    Count := 2;
  end;
  if Count <> 0 then
  begin
    Buf[1] := 0;
    Result := Read(Buf, Count);
    Buffer := Word(Buf[0] or (Buf[1] shl 8));
    if S <> 0 then
      Inc(Result, Skip(S));
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: Integer): Longint;
var
  Buf: array[0..3] of Byte;
begin
  Result := Read(Buf, 4);
  Buffer := Integer(Buf[0] or (Buf[1] shl 8) or (Buf[2] shl 16) or (Buf[3] shl 24));
end;

function TStream.Read(var Buffer: Integer; Count: Longint): Longint;
var
  Buf: array[0..3] of Byte;
  S: Integer;
begin
  S := 0;
  if Count > 4 then
  begin
    S := Count - 4;
    Count := 4;
  end;
  if Count <> 0 then
  begin
    Buf[1] := 0;
    Buf[2] := 0;
    Buf[3] := 0;
    Result := Read(Buf, Count);
    Buffer := Integer(Buf[0] or (Buf[1] shl 8) or (Buf[2] shl 16) or (Buf[3] shl 24));
    if S <> 0 then
      Inc(Result, Skip(S));
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: Cardinal): Longint;
var
  Buf: array[0..3] of Byte;
begin
  Result := Read(Buf, 4);
  Buffer := Cardinal(Buf[0] or (Buf[1] shl 8) or (Buf[2] shl 16) or (Buf[3] shl 24));
end;

function TStream.Read(var Buffer: Cardinal; Count: Longint): Longint;
var
  Buf: array[0..3] of Byte;
  S: Integer;
begin
  S := 0;
  if Count > 4 then
  begin
    S := Count - 4;
    Count := 4;
  end;
  if Count <> 0 then
  begin
    Buf[1] := 0;
    Buf[2] := 0;
    Buf[3] := 0;
    Result := Read(Buf, Count);
    Buffer := Cardinal(Buf[0] or (Buf[1] shl 8) or (Buf[2] shl 16) or (Buf[3] shl 24));
    if S <> 0 then
      Inc(Result, Skip(S));
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: Int64): Longint;
var
  Buf: array[0..7] of Byte;
begin
  Result := Read(Buf, 8);
  Buffer := Int64(Buf[0]) or (Int64(Buf[1]) shl 8) or
      (Int64(Buf[2]) shl 16) or (Int64(Buf[3]) shl 24) or
      (Int64(Buf[4]) shl 32) or (Int64(Buf[5]) shl 40) or
      (Int64(Buf[6]) shl 48) or (Int64(Buf[7]) shl 56);
end;

function TStream.Read(var Buffer: Int64; Count: Longint): Longint;
var
  Buf: array[0..7] of Byte;
  S: Integer;
begin
  S := 0;
  if Count > 8 then
  begin
    S := Count - 8;
    Count := 8;
  end;
  if Count <> 0 then
  begin
    Buf[1] := 0;
    Buf[2] := 0;
    Buf[3] := 0;
    Buf[4] := 0;
    Buf[5] := 0;
    Buf[6] := 0;
    Buf[7] := 0;
    Result := Read(Buf, Count);
    Buffer := Int64(Buf[0]) or (Int64(Buf[1]) shl 8) or
        (Int64(Buf[2]) shl 16) or (Int64(Buf[3]) shl 24) or
        (Int64(Buf[4]) shl 32) or (Int64(Buf[5]) shl 40) or
        (Int64(Buf[6]) shl 48) or (Int64(Buf[7]) shl 56);
    if S <> 0 then
      Inc(Result, Skip(S));
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: UInt64): Longint;
var
  Buf: array[0..7] of Byte;
begin
  Result := Read(Buf, 8);
  Buffer := Int64(Buf[0]) or (Int64(Buf[1]) shl 8) or
      (Int64(Buf[2]) shl 16) or (Int64(Buf[3]) shl 24) or
      (Int64(Buf[4]) shl 32) or (Int64(Buf[5]) shl 40) or
      (Int64(Buf[6]) shl 48) or (Int64(Buf[7]) shl 56);
end;

function TStream.Read(var Buffer: UInt64; Count: Longint): Longint;
var
  Buf: array[0..7] of Byte;
  S: Integer;
begin
  S := 0;
  if Count > 8 then
  begin
    S := Count - 8;
    Count := 8;
  end;
  if Count <> 0 then
  begin
    Buf[1] := 0;
    Buf[2] := 0;
    Buf[3] := 0;
    Buf[4] := 0;
    Buf[5] := 0;
    Buf[6] := 0;
    Buf[7] := 0;
    Result := Read(Buf, Count);
    Buffer := Int64(Buf[0]) or (Int64(Buf[1]) shl 8) or
        (Int64(Buf[2]) shl 16) or (Int64(Buf[3]) shl 24) or
        (Int64(Buf[4]) shl 32) or (Int64(Buf[5]) shl 40) or
        (Int64(Buf[6]) shl 48) or (Int64(Buf[7]) shl 56);
    if S <> 0 then
      Inc(Result, Skip(S));
  end
  else
    Result := 0;
end;

function TStream.Read(var Buffer: Single): Longint;
var
  Buf: array[0..3] of Byte;
begin
  Result := Read(Buf, 4);
  Buffer := BitConverter.ToSingle(Buf, 0);
end;

function TStream.Read(var Buffer: Single; Count: Longint): Longint;
var
  Buf: array[0..3] of Byte;
begin
  if Count <> 4 then
  begin
    Buffer := 0;
    Result := Skip(Count);
  end
  else
  begin
    Result := Read(Buf, 4);
    Buffer := BitConverter.ToSingle(Buf, 0);
  end;
end;

function TStream.Read(var Buffer: Double): Longint;
var
  Buf: array[0..7] of Byte;
begin
  Result := Read(Buf, 8);
  Buffer := BitConverter.ToDouble(Buf, 0);
end;

function TStream.Read(var Buffer: Double; Count: Longint): Longint;
var
  Buf: array[0..7] of Byte;
begin
  if Count = 8 then
  begin
    Result := Read(Buf, 8);
    Buffer := BitConverter.ToDouble(Buf, 0);
  end
  else
  begin
    Buffer := 0;
    Result := Skip(Count);
  end;
end;

function TStream.Read(var Buffer: Extended): Longint;
var
  Buf: array[0..9] of Byte;
begin
  // Read Win32 compatible extended
  Result := Read(Buf, 10);
  Buffer := ExtendedAsBytesToDouble(Buf);
end;

function TStream.Read(var Buffer: Extended; Count: Longint): Longint;
var
  Buf: array[0..9] of Byte;
begin
  if Count = SizeOf(Double) then
  begin
    Result := Read(Buf, SizeOf(Double));
    Buffer := BitConverter.ToDouble(Buf, 0);
  end
  else if Count = 10 then
  begin
    // Read Win32 compatible extended
    Result := Read(Buf, 10);
    Buffer := ExtendedAsBytesToDouble(Buf);
  end
  else
  begin
    Buffer := 0;
    Result := Skip(Count);
  end;
end;

function TStream.Skip(Amount: Integer): Integer;
var
  P: Integer;
begin
  P := Position;
  Result := Seek(Amount, soCurrent) - P;
end;

function TStream.Write(const Buffer: array of Byte; Count: Longint): Longint;
begin
  Result := Write(Buffer, 0, Count);
end;

function TStream.Write(const Buffer: Byte): Longint;
var
  Buf: array[0..0] of Byte;
begin
  Buf[0] := Buffer;
  Result := Write(Buf, 1);
end;

function TStream.Write(const Buffer: Byte; Count: Longint): Longint;
var
  Buf: array[0..0] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 1 then
    C := 1;
  Buf[0] := Buffer;
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Boolean): Longint;
var
  Buf: array[0..0] of Byte;
begin
  Buf[0] := Byte(Buffer);
  Result := Write(Buf, 1);
end;

function TStream.Write(const Buffer: Boolean; Count: Longint): Longint;
var
  Buf: array[0..0] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 1 then
    C := 1;
  Buf[0] := Byte(Buffer);
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Char): Longint;
var
  Buf: array[0..1] of Byte;
begin
  Buf[0] := Word(Buffer) and $FF;
  Buf[1] := (Word(Buffer) shr 8) and $FF;
  Result := Write(Buf, 2);
end;

function TStream.Write(const Buffer: Char; Count: Longint): Longint;
var
  Buf: array[0..1] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 2 then
    C := 2;
  Buf[0] := Word(Buffer) and $FF;
  Buf[1] := (Word(Buffer) shr 8) and $FF;
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: AnsiChar): Longint;
var
  Buf: array[0..0] of Byte;
begin
  Buf[0] := Byte(Buffer);
  Result := Write(Buf, 1);
end;

function TStream.Write(const Buffer: AnsiChar; Count: Longint): Longint;
var
  Buf: array[0..0] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 1 then
    C := 1;
  Buf[0] := Byte(Buffer);
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: ShortInt): Longint;
var
  Buf: array[0..0] of Byte;
begin
  Buf[0] := Buffer;
  Result := Write(Buf, 1);
end;

function TStream.Write(const Buffer: ShortInt; Count: Longint): Longint;
var
  Buf: array[0..0] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 1 then
    C := 1;
  Buf[0] := Buffer;
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: SmallInt): Longint;
var
  Buf: array[0..1] of Byte;
begin
  Buf[0] := Buffer and $FF;
  Buf[1] := (Buffer shr 8) and $FF;
  Result := Write(Buf, 2);
end;

function TStream.Write(const Buffer: SmallInt; Count: Longint): Longint;
var
  Buf: array[0..1] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 2 then
    C := 2;
  Buf[0] := Buffer and $FF;
  Buf[1] := (Buffer shr 8) and $FF;
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Word): Longint;
var
  Buf: array[0..1] of Byte;
begin
  Buf[0] := Word(Buffer) and $FF;
  Buf[1] := (Word(Buffer) shr 8) and $FF;
  Result := Write(Buf, 2);
end;

function TStream.Write(const Buffer: Word; Count: Longint): Longint;
var
  Buf: array[0..1] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 2 then
    C := 2;
  Buf[0] := Word(Buffer) and $FF;
  Buf[1] := (Word(Buffer) shr 8) and $FF;
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Integer): Longint;
var
  Buf: array[0..3] of Byte;
begin
  Buf[0] := Buffer and $FF;
  Buf[1] := (Buffer shr 8) and $FF;
  Buf[2] := (Buffer shr 16) and $FF;
  Buf[3] := (Buffer shr 24) and $FF;
  Result := Write(Buf, 4);
end;

function TStream.Write(const Buffer: Integer; Count: Longint): Longint;
var
  Buf: array[0..3] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 4 then
    C := 4;
  Buf[0] := Buffer and $FF;
  Buf[1] := (Buffer shr 8) and $FF;
  Buf[2] := (Buffer shr 16) and $FF;
  Buf[3] := (Buffer shr 24) and $FF;
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Cardinal): Longint;
var
  Buf: array[0..3] of Byte;
begin
  Buf[0] := Buffer and $FF;
  Buf[1] := (Buffer shr 8) and $FF;
  Buf[2] := (Buffer shr 16) and $FF;
  Buf[3] := (Buffer shr 24) and $FF;
  Result := Write(Buf, 4);
end;

function TStream.Write(const Buffer: Cardinal; Count: Longint): Longint;
var
  Buf: array[0..3] of Byte;
  C: Integer;
begin
  C := Count;
  if C > 4 then
    C := 4;
  Buf[0] := Buffer and $FF;
  Buf[1] := (Buffer shr 8) and $FF;
  Buf[2] := (Buffer shr 16) and $FF;
  Buf[3] := (Buffer shr 24) and $FF;
  Result := Write(Buf, C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Int64): Longint;
begin
  Result := Write(BitConverter.GetBytes(Buffer), SizeOf(Int64));
end;

function TStream.Write(const Buffer: Int64; Count: Integer): Longint;
var
  C: Integer;
begin
  C := Count;
  if C > 8 then
    C := 8;
  Result := Write(BitConverter.GetBytes(Buffer), C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: UInt64): Longint;
begin
  Result := Write(BitConverter.GetBytes(Buffer), SizeOf(UInt64));
end;

function TStream.Write(const Buffer: UInt64; Count: Integer): Longint;
var
  C: Integer;
begin
  C := Count;
  if C > 8 then
    C := 8;
  Result := Write(BitConverter.GetBytes(Buffer), C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Single): Longint;
begin
  Result := Write(BitConverter.GetBytes(Buffer), SizeOf(Single));
end;

function TStream.Write(const Buffer: Single; Count: Integer): Longint;
var
  C: Integer;
begin
  C := Count;
  if C > 4 then
    C := 4;
  Result := Write(BitConverter.GetBytes(Buffer), C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Double): Longint;
begin
  Result := Write(BitConverter.GetBytes(Buffer), SizeOf(Double));
end;

function TStream.Write(const Buffer: Double; Count: Integer): Longint;
var
  C: Integer;
begin
  C := Count;
  if C > 8 then
    C := 8;
  Result := Write(BitConverter.GetBytes(Buffer), C);
  if C < Count then
    Inc(Result, Skip(Count - C));
end;

function TStream.Write(const Buffer: Extended): Longint;
begin
  // Write Win32 compatible extended
  Result := Write(DoubleToExtendedAsBytes(Buffer), 10);
end;

function TStream.Write(const Buffer: Extended; Count: Longint): Longint;
begin
  if Count = SizeOf(Double) then
  begin
    Result := Write(BitConverter.GetBytes(Double(Buffer)), SizeOf(Double));
  end
  else if Count = 10 then
    // Write Win32 compatible extended
    Result := Write(DoubleToExtendedAsBytes(Buffer), 10)
  else
    Result := Skip(Count);
end;

{ TCLRStreamWrapper }

constructor TCLRStreamWrapper.Create(AHandle: System.IO.Stream);
begin
  inherited Create;
  FHandle := AHandle;
end;

destructor TCLRStreamWrapper.Destroy;
begin
  if FHandle <> nil then
    FHandle.Close;
  inherited Destroy;
end;

function TCLRStreamWrapper.Read(var Buffer: array of Byte; Offset, Count: Longint): Longint;
begin
  Result := FHandle.Read(Buffer, Offset, Count);
end;

const
  OriginMap: array[TSeekOrigin] of System.IO.SeekOrigin =
    (System.IO.SeekOrigin.Begin, System.IO.SeekOrigin.Current,
    System.IO.SeekOrigin.End);

function TCLRStreamWrapper.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  Result := FHandle.Seek(Offset, OriginMap[Origin]);
end;

procedure TCLRStreamWrapper.SetSize(NewSize: Int64);
begin
  FHandle.SetLength(NewSize);
end;

function TCLRStreamWrapper.Write(const Buffer: array of Byte; Offset, Count: Longint): Longint;
begin
  try
    FHandle.Write(Buffer, Offset, Count);
    Result := Count;
  except
    Result := 0;
  end;
end;

{ TFileStream }

constructor TFileStream.Create(const FileName: string; Mode: Word);
begin
  Create(FileName, Mode, 0);
end;

constructor TFileStream.Create(const FileName: string; Mode: Word; Rights: Cardinal);
var
  LMode: System.IO.FileMode;
  LAccess: System.IO.FileAccess;
  LShare: System.IO.FileShare;
begin
  inherited Create(nil);
  if Mode = fmCreate then
  begin
    LMode := System.IO.FileMode.Create;
    LAccess := System.IO.FileAccess.ReadWrite;
  end
  else
  begin
    LMode := System.IO.FileMode.Open;
    case Mode and $F of
      fmOpenReadWrite: LAccess := System.IO.FileAccess.ReadWrite;
      fmOpenWrite: LAccess := System.IO.FileAccess.Write;
    else
      LAccess := System.IO.FileAccess.Read;
    end;
  end;
  case Mode and $F0 of
    fmShareDenyWrite: LShare := System.IO.FileShare.Read;
    fmShareDenyRead: LShare := System.IO.FileShare.Write;
    fmShareDenyNone: LShare := System.IO.FileShare.None;
  else
    LShare := System.IO.FileShare.ReadWrite;
  end;
  FHandle := System.IO.FileStream.Create(FileName, LMode, LAccess, LShare);
end;

{ TCustomMemoryStream }

function TCustomMemoryStream.Read(var Buffer: array of Byte; Offset, Count: Longint): Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Result := FSize - FPosition;
    if Result > 0 then
    begin
      if Result > Count then
        Result := Count;
      System.Array.Copy(System.Array(FMemory), FPosition, System.Array(Buffer),
        Offset, Result);
      Inc(FPosition, Result);
      Exit;
    end;
  end;
  Result := 0;
end;

function TCustomMemoryStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
begin
  case Origin of
    soBeginning: FPosition := Offset;
    soCurrent: Inc(FPosition, Offset);
    soEnd: FPosition := FSize + Offset;
  end;
  Result := FPosition;
end;

procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
begin
  if FSize <> 0 then
    Stream.WriteBuffer(FMemory, FSize);
end;

procedure TCustomMemoryStream.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

{ TMemoryStream }

const
  MemoryDelta = $2000; { Must be a power of 2 }

procedure TMemoryStream.Clear;
begin
  SetCapacity(0);
  FSize := 0;
  FPosition := 0;
end;

function TMemoryStream.GetCapacity: Longint;
begin
  Result := System.Array(FMemory).Length;
end;

procedure TMemoryStream.LoadFromStream(Stream: TStream);
var
  Count: Longint;
begin
  Stream.Position := 0;
  Count := Stream.Size;
  SetSize(Count);
  if Count <> 0 then
    Stream.ReadBuffer(FMemory, Count);
end;

procedure TMemoryStream.LoadFromFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TMemoryStream.SetCapacity(NewCapacity: Longint);
begin
  FMemory := Realloc(NewCapacity);
end;

procedure TMemoryStream.SetSize(NewSize: Int64);
var
  OldPosition: Longint;
begin
  OldPosition := FPosition;
  SetCapacity(NewSize);
  FSize := NewSize;
  if OldPosition > NewSize then
    Seek(0, soEnd);
end;

function TMemoryStream.Realloc(var NewCapacity: Longint): TBytes;
begin
  if (NewCapacity > 0) and (NewCapacity <> FSize) then
    NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  Result := FMemory;
  if NewCapacity <> Length(Result) then
    SetLength(Result, NewCapacity);
end;

function TMemoryStream.Write(const Buffer: array of Byte; Offset, Count: Longint): Longint;
var
  Pos: Longint;
begin
  if (FPosition >= 0) and (Count >= 0) then
  begin
    Pos := FPosition + Count;
    if Pos > 0 then
    begin
      if Pos > FSize then
      begin
        if Pos > Length(Memory) then
          SetCapacity(Pos);
        FSize := Pos;
      end;
      System.Array.Copy(System.Array(Buffer), Offset, System.Array(Memory),
        FPosition, Count);
      FPosition := Pos;
      Result := Count;
      Exit;
    end;
  end;
  Result := 0;
end;

{ TStringStream }

constructor TStringStream.Create(const AString: string);
begin
  inherited Create;
  FMemory := BytesOf(AString);
end;

function TStringStream.GetString: string;
begin
  Result := StringOf(FMemory);
end;

procedure TStringStream.WriteString(const AString: string);
var
  Bytes: TBytes;
begin
  Bytes := BytesOf(AString);
  Write(Bytes, Length(Bytes));
end;

{ TStreamToCLRStream }

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

procedure TStreamToCLRStream.Close;
begin
  FStream.Free;
  FStream := nil;
end;

procedure TStreamToCLRStream.Flush;
begin
  // Nothing applicable
end;

function TStreamToCLRStream.get_CanRead: Boolean;
begin
  Result := True;
end;

function TStreamToCLRStream.get_CanSeek: Boolean;
begin
  Result := True;
end;

function TStreamToCLRStream.get_CanWrite: Boolean;
begin
  Result := True;
end;

function TStreamToCLRStream.get_Length: Int64;
begin
  Result := FStream.Size;
end;

function TStreamToCLRStream.get_Position: Int64;
begin
  Result := FStream.Position;
end;

function TStreamToCLRStream.Read(Buffer: array of Byte; Offset: Integer; Count: Integer): Integer;
begin
  Result := FStream.Read(Buffer, Offset, Count);
end;

function TStreamToCLRStream.Seek(Offset: Int64; Origin: System.IO.SeekOrigin): Int64;
var
  LOrigin: TSeekOrigin;
begin
  case Origin of
    SeekOrigin.Current:
      LOrigin := soCurrent;
    SeekOrigin.End:
      LOrigin := soEnd;
  else
    LOrigin := soBeginning;
  end;
  Result := FStream.Seek(Offset, LOrigin);
end;

procedure TStreamToCLRStream.SetLength(Value: Int64);
begin
  FStream.Size := Value;
end;

procedure TStreamToCLRStream.set_Position(Value: Int64);
begin
  FStream.Position := Value;
end;

procedure TStreamToCLRStream.Write(Buffer: array of Byte; Offset: Integer; Count: Integer);
begin
  FStream.Write(Buffer, Offset, Count);
end;

destructor TStreamToCLRStream.Destroy;
begin
  FStream.Free;
  inherited;
end;

class function TStreamToCLRStream.GetStream(Stream: TStream): System.IO.Stream;
begin
  if Stream is TCLRStreamWrapper then
    Result := TCLRStreamWrapper(Stream).Handle
  else
    Result := TStreamToCLRStream.Create(Stream);
end;

{ TResourceStream }

constructor TResourceStream.Create(Instance: THandle; const ResName: string;
  ResType: Integer);
begin
  inherited Create;
  Initialize(Instance, FindResource(Instance, ResName, ResType), ResName);
end;

constructor TResourceStream.Create(Instance: THandle; const ResName, ResType: string);
begin
  inherited Create;
  Initialize(Instance, FindResource(Instance, ResName, ResType), ResName);
end;

constructor TResourceStream.CreateFromID(Instance: THandle; ResID, ResType: Integer);
begin
  inherited Create;
  Initialize(Instance, FindResource(Instance, ResID, ResType), IntToStr(ResID));
end;

constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer;
  ResType: string);
begin
  inherited Create;
  Initialize(Instance, FindResource(Instance, ResID, ResType), IntToStr(ResID));
end;

procedure TResourceStream.Initialize(Instance, ResInfo: THandle; const Name: string);

  procedure Error;
  begin
    raise EResNotFound.CreateFmt(SResNotFound, [Name]);
  end;

var
  PResData: IntPtr;
begin
  HResInfo := ResInfo;
  if HResInfo = 0 then Error;
  HGlobal := LoadResource(Instance, HResInfo);
  if HGlobal = 0 then Error;
  try
    SetSize(SizeOfResource(Instance, HResInfo));
    PResData := LockResource(HGlobal);
    try
      Marshal.Copy(PResData, FMemory, 0, FSize);
    finally
      UnlockResource(HGlobal);
    end;
  finally
    FreeResource(HGlobal);
  end;
end;

procedure TResourceStream.SetSize(NewSize: Int64);
var
  OldPosition: Longint;
begin
  OldPosition := FPosition;
  FSize := NewSize;
  SetLength(FMemory, FSize);
  if OldPosition > FSize then
    Seek(0, soEnd);
end;

function TResourceStream.Write(const Buffer: array of Byte; Offset, Count: Longint): Longint;
begin
  raise EStreamError.Create(SCantWriteResourceStreamError);
end;

{ TStreamAdapter }

constructor TStreamAdapter.Create(Stream: TStream; Ownership: TStreamOwnership);
begin
  inherited Create;
  FStream := Stream;
  FOwnership := Ownership;
end;

destructor TStreamAdapter.Destroy;
begin
  if FOwnership = soOwned then
  begin
    FStream.Free;
    FStream := nil;
  end;
  inherited Destroy;
end;

procedure TStreamAdapter.Read(pv: TBytes; cb: Longint; pcbRead: IntPtr);
var
  NumRead: Longint;
begin
  try
    if pv = nil then
    begin
      Marshal.ThrowExceptionForHR(STG_E_INVALIDPOINTER);
      Exit;
    end;
    NumRead := FStream.Read(pv, cb);
    if pcbRead <> nil then
      Marshal.WriteInt32(pcbRead, NumRead);
  except
      Marshal.ThrowExceptionForHR(S_FALSE);
  end;
end;

procedure TStreamAdapter.Write(pv: TBytes; cb: Longint; pcbWritten: IntPtr);
var
  NumWritten: Longint;
begin
  try
    if pv = nil then
    begin
      Marshal.ThrowExceptionForHR(STG_E_INVALIDPOINTER);
      Exit;
    end;
    NumWritten := FStream.Write(pv, cb);
    if pcbWritten <> nil then
      Marshal.WriteInt32(pcbWritten, NumWritten);
  except
    Marshal.ThrowExceptionForHR(STG_E_CANTSAVE);
  end;
end;

procedure TStreamAdapter.Seek(dlibMove: Int64; dwOrigin: Longint;
  libNewPosition: IntPtr);
var
  NewPos: Int64;
begin
  try
    if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then
    begin
      Marshal.ThrowExceptionForHR(STG_E_INVALIDFUNCTION);
      Exit;
    end;
    NewPos := FStream.Seek(dlibMove, TSeekOrigin(dwOrigin));
    if libNewPosition <> nil then
      Marshal.WriteInt64(libNewPosition, NewPos);
  except
    Marshal.ThrowExceptionForHR(STG_E_INVALIDPOINTER);
  end;
end;

procedure TStreamAdapter.SetSize(libNewSize: Int64);
begin
  try
    FStream.Size := libNewSize;
    if libNewSize <> FStream.Size then
      Marshal.ThrowExceptionForHR(E_FAIL);
  except
    Marshal.ThrowExceptionForHR(E_UNEXPECTED);
  end;
end;

procedure TStreamAdapter.CopyTo(stm: IStream; cb: Int64; cbRead: IntPtr;
  cbWritten: IntPtr);
const
  MaxBufSize = 1024 * 1024;  // 1mb
var
  Result: Integer;
  Buffer: TBytes;
  BufSize, N, I: Integer;
  R, BytesRead, BytesWritten, W: Int64;
  Ptr: IntPtr;
begin
  Result := S_OK;
  BytesRead := 0;
  BytesWritten := 0;
  try
    if cb > MaxBufSize then
      BufSize := MaxBufSize
    else
      BufSize := Integer(cb);
    SetLength(Buffer, BufSize);
    Ptr := Marshal.AllocHGlobal(SizeOf(Int64));
    try
      while cb > 0 do
      begin
        if cb > MaxInt then
          I := MaxInt
        else
          I := cb;
        while I > 0 do
        begin
          if I > BufSize then N := BufSize else N := I;
          R := FStream.Read(Buffer, N);
          if R = 0 then Exit; // The end of the stream was hit.
          Inc(BytesRead, R);
          Marshal.WriteInt64(Ptr, 0);
          stm.Write(Buffer, R, Ptr);
          W := Marshal.ReadInt64(Ptr);
          Inc(BytesWritten, W);
          if W <> R then
          begin
            Result := E_FAIL; // Flag to except block that an exception is thrown
            Marshal.ThrowExceptionForHR(E_FAIL);
          end;
          Dec(I, R);
          Dec(cb, R);
        end;
      end;
    finally
      Marshal.FreeHGlobal(Ptr);
      if (cbWritten <> nil) then
        Marshal.WriteInt64(cbWritten, BytesWritten);
      if (cbRead <> nil) then
        Marshal.WriteInt64(cbRead, BytesRead);
    end;
  except
    if Result = S_OK then
      Marshal.ThrowExceptionForHR(E_UNEXPECTED);
  end;
end;

procedure TStreamAdapter.Commit(grfCommitFlags: Longint);
begin
  { Do nothing }  // Result := S_OK;  
end;

procedure TStreamAdapter.Revert;
begin
  Marshal.ThrowExceptionForHR(STG_E_REVERTED);
end;

procedure TStreamAdapter.LockRegion(libOffset: Int64; cb: Int64;
  dwLockType: Longint);
begin
  Marshal.ThrowExceptionForHR(STG_E_INVALIDFUNCTION);
end;

procedure TStreamAdapter.UnlockRegion(libOffset: Int64; cb: Int64;
  dwLockType: Longint);
begin
  Marshal.ThrowExceptionForHR(STG_E_INVALIDFUNCTION);
end;

procedure TStreamAdapter.Stat(out StatStg: TStatStg; grfStatFlag: Longint);
begin
  try
    with StatStg do
    begin
      &Type := STGTY_STREAM;
      cbSize := FStream.Size;
      mTime.dwLowDateTime := 0;
      mTime.dwHighDateTime := 0;
      cTime.dwLowDateTime := 0;
      cTime.dwHighDateTime := 0;
      aTime.dwLowDateTime := 0;
      aTime.dwHighDateTime := 0;
      grfLocksSupported := LOCK_WRITE;
    end;
  except
    Marshal.ThrowExceptionForHR(E_UNEXPECTED);
  end;
end;

procedure TStreamAdapter.Clone(out stm: IStream);
begin
  Marshal.ThrowExceptionForHR(E_NOTIMPL);
end;

{ TFiler }

constructor TFiler.Create(Stream: TStream; BufSize: Integer);
begin
  inherited Create;
  FStream := Stream;
  SetLength(FBuffer, BufSize);
end;

procedure TFiler.SetRoot(Value: TComponent);
begin
  FRoot := Value;
end;

{ TFilerAccess }

constructor TFilerAccess.Create(APersistent: TPersistent);
begin
  inherited Create;
  FPersistent := APersistent;
end;

procedure TFilerAccess.DefineProperties(AFiler: TFiler);
begin
  FPersistent.DefineProperties(AFiler);
end;

function TFilerAccess.GetChildOwner: TComponent;
begin
  Result := TComponent(FPersistent).GetChildOwner;
end;

function TFilerAccess.GetChildParent: TComponent;
begin
  Result := TComponent(FPersistent).GetChildParent;
end;

procedure TFilerAccess.GetChildren(Proc: TGetChildProc; Root: TComponent);
begin
  TComponent(FPersistent).GetChildren(Proc, Root);
end;

procedure TFilerAccess.SetAncestor(Value: Boolean);
begin
  TComponent(FPersistent).SetAncestor(Value);
end;

procedure TFilerAccess.SetChildOrder(Child: TComponent; Order: Integer);
begin
  TComponent(FPersistent).SetChildOrder(Child, Order);
end;

procedure TFilerAccess.Updated;
begin
  TComponent(FPersistent).Updated;
end;

procedure TFilerAccess.Updating;
begin
  TComponent(FPersistent).Updating;
end;

{ TPropFixup }

type
  TPropFixup = class
    FInstance: TPersistent;
    FInstanceRoot: TComponent;
    FPropInfo: TPropInfo;
    FRootName: string;
    FName: string;
    constructor Create(Instance: TPersistent; InstanceRoot: TComponent;
      PropInfo: TPropInfo; const RootName, Name: string);
    function MakeGlobalReference: Boolean;
    procedure ResolveReference(Reference: TObject); virtual;
  end;

  TPropIntfFixup = class(TPropFixup)
    procedure ResolveReference(Reference: TObject); override;
  end;

var
  GlobalFixupList: TThreadList;

constructor TPropFixup.Create(Instance: TPersistent; InstanceRoot: TComponent;
  PropInfo: TPropInfo; const RootName, Name: string);
begin
  inherited Create;
  FInstance := Instance;
  FInstanceRoot := InstanceRoot;
  FPropInfo := PropInfo;
  FRootName := RootName;
  FName := Name;
end;

function TPropFixup.MakeGlobalReference: Boolean;
var
  P: Integer;
begin
  Result := False;
  P := 1;
  while (P <= Length(FName)) and (FName[P] <> '.') do
    Inc(P);
  if P > Length(FName) then
    Exit;
  FRootName := Copy(FName, 1, P - 1);
  FName := Copy(FName, P + 1);
  Result := True;
end;

procedure TPropFixup.ResolveReference(Reference: TObject);
begin
  SetObjectProp(FInstance, FPropInfo, Reference);
end;

procedure TPropIntfFixup.ResolveReference(Reference: TObject);
begin
  SetObjectProp(FInstance, FPropInfo, Reference);
end;

function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent;
var
  Current, Found: TComponent;
  S, P, L: Integer;
  Name: string;
begin
  Result := nil;
  if NamePath = '' then
    Exit;
  Current := Root;
  P := 1;
  L := Length(NamePath);
  while P <= L do
  begin
    S := P;
    while (P <= L) and not (NamePath[P] in ['.', '-', #0]) do
      Inc(P);
    Name := Copy(NamePath, S, P - S);
    Found := Current.FindComponent(Name);
    if (Found = nil) and SameText(Name, 'Owner') then                           { Do not translate }
      Found := Current;
    if Found = nil then
      Exit;
    if P <= L then
    begin
      if NamePath[P] = '.' then
        Inc(P);
      if P <= L then
      begin
        if NamePath[P] = '-' then
          Inc(P);
        if (P <= L) and (NamePath[P] = '>') then
          Inc(P);
      end;
    end;
    Current := Found;
  end;
  Result := Current;
end;

procedure GlobalFixupReferences;
var
  FinishedList: TList;
  NotFinishedList: TList;
  GlobalList: TList;
  I: Integer;
  Root: TComponent;
  Instance: TPersistent;
  Reference: TObject;
  Cookie: LockCookie;

  procedure AddFinished(Instance: TPersistent);
  begin
    if (FinishedList.IndexOf(Instance) < 0) and
      (NotFinishedList.IndexOf(Instance) >= 0) then
      FinishedList.Add(Instance);
  end;

  procedure AddNotFinished(Instance: TPersistent);
  var
    Index: Integer;
  begin
    Index := FinishedList.IndexOf(Instance);
    if Index <> -1 then
      FinishedList.Delete(Index);
    if NotFinishedList.IndexOf(Instance) < 0 then
      NotFinishedList.Add(Instance);
  end;

begin
  // Fixup resolution requires a stable component / name space
  // Block construction and destruction of forms / datamodules during fixups
  Cookie := GlobalNameSpace.UpgradeToWriterLock(MaxInt);
  try
    GlobalList := GlobalFixupList.LockList;
    try
      if GlobalList.Count > 0 then
      begin
         FinishedList := TList.Create;
        try
          NotFinishedList := TList.Create;
          try
            I := 0;
            while I < GlobalList.Count do
              with TPropFixup(GlobalList[I]) do
              begin
                Root := FindGlobalComponent(FRootName);
                if (Root <> nil) or (GetObjectProp(FInstance, FPropInfo) <> nil) then
                begin
                  if Root <> nil then
                  begin
                    Reference := FindNestedComponent(Root, FName);
                    ResolveReference(Reference);
                  end;
                  AddFinished(FInstance);
                  GlobalList.Delete(I);
                  Free;
                end
                else
                begin
                  AddNotFinished(FInstance);
                  Inc(I);
                end;
              end;
          finally
            NotFinishedList.Free;
          end;
          for I := 0 to FinishedList.Count - 1 do
          begin
            Instance := TPersistent(FinishedList[I]);
            if Instance is TComponent then
              TComponent(Instance).FComponentState :=
                TComponent(Instance).FComponentState - [csFixups];
          end;
        finally
          FinishedList.Free;
        end;
      end;
    finally
      GlobalFixupList.UnlockList;
    end;
  finally
    GlobalNameSpace.DowngradeFromWriterLock(Cookie);
  end;
end;

function NameInStrings(Strings: TStrings; const Name: string): Boolean;
var
  I: Integer;
begin
  Result := True;
  for I := 0 to Strings.Count - 1 do
    if SameText(Name, Strings[I]) then
      Exit;
  Result := False;
end;

procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
var
  I: Integer;
  Fixup: TPropFixup;
begin
  with GlobalFixupList.LockList do
  try
    for I := 0 to Count - 1 do
    begin
      Fixup := TPropFixup(Items[I]);
      if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
        not NameInStrings(Names, Fixup.FRootName) then
        Names.Add(Fixup.FRootName);
    end;
  finally
    GlobalFixupList.UnlockList;
  end;
end;

procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  NewRootName: string);
var
  I: Integer;
  Fixup: TPropFixup;
begin
  with GlobalFixupList.LockList do
  try
    for I := 0 to Count - 1 do
    begin
      Fixup := TPropFixup(Items[I]);
      if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
        SameText(OldRootName, Fixup.FRootName) then
        Fixup.FRootName := NewRootName;
    end;
    GlobalFixupReferences;
  finally
    GlobalFixupList.Unlocklist;
  end;
end;

procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
var
  I: Integer;
  Fixup: TPropFixup;
begin
  if GlobalFixupList = nil then
    Exit;
  with GlobalFixupList.LockList do
  try
    for I := Count - 1 downto 0 do
    begin
      Fixup := TPropFixup(Items[I]);
      if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
        ((RootName = '') or SameText(RootName, Fixup.FRootName)) then
      begin
        Delete(I);
        Fixup.Free;
      end;
    end;
  finally
    GlobalFixupList.UnlockList;
  end;
end;

procedure RemoveFixups(Instance: TPersistent);
var
  I: Integer;
  Fixup: TPropFixup;
begin
  if GlobalFixupList = nil then
    Exit;
  with GlobalFixupList.LockList do
  try
    for I := Count - 1 downto 0 do
    begin
      Fixup := TPropFixup(Items[I]);
      if (Fixup.FInstance = Instance) then
      begin
        Delete(I);
        Fixup.Free;
      end;
    end;
  finally
    GlobalFixupList.UnlockList;
  end;
end;

procedure GetFixupInstanceNames(Root: TComponent;
  const ReferenceRootName: string; Names: TStrings);
var
  I: Integer;
  Fixup: TPropFixup;
begin
  with GlobalFixupList.LockList do
  try
    for I := 0 to Count - 1 do
    begin
      Fixup := TPropFixup(Items[I]);
      if (Fixup.FInstanceRoot = Root) and
        SameText(ReferenceRootName, Fixup.FRootName) and
        not NameInStrings(Names, Fixup.FName) then
        Names.Add(Fixup.FName);
    end;
  finally
    GlobalFixupList.UnlockList;
  end;
end;

{ TReader }

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

procedure PropValueError;
begin
  ReadError(SInvalidPropertyValue);
end;

procedure PropertyNotFound(const Name: string);
begin
  raise EReadError.CreateFmt(SUnknownProperty, [Name]);
end;

function EnumValue(EnumType: TTypeInfo; const EnumName: string): Integer;
begin
  Result := GetEnumValue(EnumType, EnumName);
  if Result = -1 then
    PropValueError;
end;

destructor TReader.Destroy;
begin
  FStream.Seek(FBufPos - FBufCount, soCurrent);
  inherited Destroy;
end;

procedure TReader.BeginReferences;
begin
  FLoaded := TList.Create;
  FFixups := TList.Create;
end;

procedure TReader.CheckValue(Value: TValueType);
begin
  if ReadValue <> Value then
  begin
    Dec(FBufPos);
    SkipValue;
    PropValueError;
  end;
end;

procedure TReader.DefineProperty(const Name: string;
  ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
begin
  if SameText(Name, FPropName) and Assigned(ReadData) then
  begin
    ReadData(Self);
    FPropName := '';
  end;
end;

procedure TReader.DefineBinaryProperty(const Name: string;
  ReadData, WriteData: TStreamProc; HasData: Boolean);
var
  Stream: TMemoryStream;
  Count: Longint;
  Memory: TBytes;
begin
  if SameText(Name, FPropName) and Assigned(ReadData) then
  begin
    if ReadValue <> vaBinary then
    begin
      Dec(FBufPos);
      SkipValue;
      FCanHandleExcepts := True;
      PropValueError;
    end;
    Stream := TMemoryStream.Create;
    try
      Read(Count, SizeOf(Count));
      Stream.SetSize(Count);
      Memory := Stream.Memory;
      Read(Memory, Count);
      FCanHandleExcepts := True;
      ReadData(Stream);
    finally
      Stream.Free;
    end;
    FPropName := '';
  end;
end;

function TReader.EndOfList: Boolean;
begin
  Result := ReadValue = vaNull;
  Dec(FBufPos);
end;

procedure TReader.EndReferences;
begin
  FreeFixups;
  FLoaded.Free;
  FLoaded := nil;
end;

procedure TReader.EnsureAtLeast(NumBytes: Integer);
var
  C: Integer;
begin
  C := FBufCount - FBufPos;
  if C < NumBytes then
  begin
    ReadBuffer(C);
    if Length(FBuffer) < NumBytes then
    begin
      // Grow the buffer if the buffer is to small for what we are reading
      SetLength(FBuffer, NumBytes);
      ReadBuffer(FBufCount);
    end;
    if FBufCount - FBufPos < NumBytes then
      raise EReadError.Create(SReadError);
  end;
end;

function TReader.Error(const Message: string): Boolean;
begin
  Result := False;
  if Assigned(FOnError) then
    FOnError(Self, Message, Result);
end;

function TReader.FindMethodInstance(Root: TComponent; const MethodName: string): TMethod;
var
  Error: Boolean;
begin
  if Assigned(FOnFindMethodInstance) then
  begin
    Result.Code := Root.MethodAddress(MethodName);
    Result.Data := Root;
    Error := Result.Code = nil;
    FOnFindMethodInstance(Self, MethodName, Result, Error);
  end else
    Error := True;
  if Error then
  begin
    Result.Data := Root;
    Result.Code := FindMethod(Root, MethodName);
  end;
end;

function TReader.FindMethod(Root: TComponent; const MethodName: string): TMethodCode;
var
  Error: Boolean;
begin
  Result := Root.MethodAddress(MethodName);
  Error := Result = nil;
  if Assigned(FOnFindMethod) then
    FOnFindMethod(Self, MethodName, Result, Error);
  if Error then
    PropValueError;
end;

procedure RemoveGlobalFixup(Fixup: TPropFixup);
var
  I: Integer;
begin
  with GlobalFixupList.LockList do
  try
    for I := Count-1 downto 0 do
      with TPropFixup(Items[I]) do
        if (FInstance = Fixup.FInstance) and (FPropInfo = Fixup.FPropInfo) then
        begin
          Free;
          Delete(I);
        end;
  finally
    GlobalFixupList.UnlockList;
  end;
end;

procedure TReader.DoFixupReferences;
var
  I: Integer;
  CompName: string;
  Reference: TObject;
begin
  if FFixups <> nil then
    try
      for I := 0 to FFixups.Count - 1 do
        with TPropFixup(FFixups[I]) do
        begin
          CompName := FName;
          ReferenceName(CompName);
          Reference := FindNestedComponent(FInstanceRoot, CompName);
          if (Reference = nil) and Assigned(FOnFindComponentInstance) then
            FOnFindComponentInstance(Self, CompName, Reference);
          { Free any preexisting global fixups for this instance/property.
            Last fixup added is the only one that counts.
            In particular, fixups created when streaming inherited forms/frames
            must be destroyed when overriding references are found later
            in the stream.  }
          RemoveGlobalFixup(TPropFixup(FFixups[I]));
          if (Reference = nil) and MakeGlobalReference then
          begin
            GlobalFixupList.Add(FFixups[I]);
            FFixups[I] := nil;
          end
          else
            ResolveReference(Reference);
        end;
    finally
      FreeFixups;
    end;
end;

procedure TReader.FixupReferences;
var
  I: Integer;
begin
  DoFixupReferences;
  GlobalFixupReferences;
  for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
end;

procedure TReader.FlushBuffer;
begin
  FStream.Position := Position;
  FBufPos := 0;
  FBufCount := 0;
end;

procedure TReader.FreeFixups;
var
  I: Integer;
begin
  if FFixups <> nil then
  begin
    for I := 0 to FFixups.Count - 1 do TPropFixup(FFixups[I]).Free;
    FFixups.Free;
    FFixups := nil;
  end;
end;

function TReader.GetFieldClass(Instance: TObject; const AClassName: string): TPersistentClass;

  function SameClass(const AClassName, TypeName: string): Boolean;
  var
    ClassLen, TypeLen, I: Integer;
  begin
    ClassLen := Length(AClassName);
    TypeLen := Length(TypeName);
    Result := False;
    if (ClassLen > TypeLen) or
      ((ClassLen < TypeLen) and (TypeName[TypeLen - ClassLen] <> '.')) then
      Exit
    else
      for I := ClassLen - 1 downto 0 do
        if AClassName[ClassLen - I] <> TypeName[TypeLen - I] then
          Exit;
    Result := True;
  end;

var
  I: Integer;
  Fields: array of System.Reflection.FieldInfo;
  LField: System.Reflection.FieldInfo;
begin
  Fields := Instance.ClassInfo.GetFields;
  for I := Low(Fields) to High(Fields) do
  begin
    LField := Fields[I];
    if SameClass(AClassName, LField.FieldType.Name) then
    begin
      if TypeOf(TPersistent).IsAssignableFrom(LField.FieldType) then
        Result := TPersistentClass(LField.FieldType)
      else
        Result := nil;
      Exit;
    end;
  end;
  if FFinder <> nil then
    Result := FFinder.GetClass(AClassName)
  else
    Result := GetClass(AClassName);
end;

function TReader.GetPosition: Longint;
begin
  Result := FStream.Position - (FBufCount - FBufPos);
end;

function TReader.NextValue: TValueType;
begin
  Result := ReadValue;
  Dec(FBufPos);
end;

procedure TReader.PropertyError(const Name: string);
begin
  SkipValue;
  PropertyNotFound(Name);
end;

procedure TReader.Read(var Buffer: array of Byte; Offset, Count: Longint);
var
  C: Integer;
begin
  while Count > 0 do
  begin
    C := FBufCount - FBufPos;
    if C <= 0 then
    begin
      ReadBuffer;
      C := FBufCount;
    end;
    if C > Count then
      C := Count;
    System.Array.Copy(System.Array(FBuffer), FBufPos, System.Array(Buffer),
      Offset, C);
    Dec(Count, C);
    Inc(Offset, C);
    Inc(FBufPos, C);
  end;
end;

procedure TReader.Read(var Buffer: array of Byte; Count: Longint);
begin
  Read(Buffer, 0, Count);
end;

procedure TReader.Read(var Buffer: Byte; Count: Longint = SizeOf(Byte));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count >= 1 then
    Buffer := FBuffer[FBufPos];
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: Char; Count: Longint = SizeOf(Char));
begin
  Buffer := #0;
  EnsureAtLeast(Count);
  if Count = 1 then
    Buffer := Char(FBuffer[FBufPos])
  else if Count >= 2 then
    Buffer := Char(FBuffer[FBufPos] or (FBuffer[FBufPos + 1] shl 8));
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: AnsiChar; Count: Longint = SizeOf(AnsiChar));
begin
  Buffer := #0;
  EnsureAtLeast(Count);
  if Count >= 1 then
    Buffer := AnsiChar(FBuffer[FBufPos]);
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: ShortInt; Count: Longint = SizeOf(ShortInt));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count > 0 then
  begin
    Buffer := ShortInt(FBuffer[FBufPos]);
    if Count > 1 then
      Buffer := Buffer or ShortInt(FBuffer[FBufPos + 1] shl 8);
  end;
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: SmallInt; Count: Longint = SizeOf(SmallInt));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count > 0 then
  begin
    Buffer := SmallInt(FBuffer[FBufPos]);
    if Count > 1 then
      Buffer := Buffer or (SmallInt(FBuffer[FBufPos + 1]) shl 8);
  end;
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: Word; Count: Longint = SizeOf(Word));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count > 0 then
  begin
    Buffer := Word(FBuffer[FBufPos]);
    if Count > 1 then
      Buffer := Buffer or (Word(FBuffer[FBufPos + 1]) shl 8);
  end;
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: Integer; Count: Longint = SizeOf(Integer));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count > 0 then
  begin
    Buffer := Integer(FBuffer[FBufPos]);
    if Count > 1 then
    begin
      Buffer := Buffer or (Integer(FBuffer[FBufPos + 1]) shl 8);
      if Count > 2 then
      begin
        Buffer := Buffer or (Integer(FBuffer[FBufPos + 2]) shl 16);
        if Count > 3 then
          Buffer := Buffer or (Integer(FBuffer[FBufPos + 3]) shl 24);
      end;
    end;
  end;
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: Cardinal; Count: Longint = SizeOf(Cardinal));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count > 0 then
  begin
    Buffer := Cardinal(FBuffer[FBufPos]);
    if Count > 1 then
    begin
      Buffer := Buffer or (Cardinal(FBuffer[FBufPos + 1]) shl 8);
      if Count > 2 then
      begin
        Buffer := Buffer or (Cardinal(FBuffer[FBufPos + 2]) shl 16);
        if Count > 3 then
          Buffer := Buffer or (Cardinal(FBuffer[FBufPos + 3]) shl 24);
      end;
    end;
  end;
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: Int64; Count: Longint = SizeOf(Int64));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count > 0 then
  begin
    Buffer := Int64(FBuffer[FBufPos]);
    if Count > 1 then
    begin
      Buffer := Buffer or (Int64(FBuffer[FBufPos + 1]) shl 8);
      if Count > 2 then
      begin
        Buffer := Buffer or (Int64(FBuffer[FBufPos + 2]) shl 16);
        if Count > 3 then
        begin
          Buffer := Buffer or (Int64(FBuffer[FBufPos + 3]) shl 24);
          if Count > 4 then
          begin
            Buffer := Buffer or (Int64(FBuffer[FBufPos + 4]) shl 32);
            if Count > 5 then
            begin
              Buffer := Buffer or (Int64(FBuffer[FBufPos + 5]) shl 40);
              if Count > 6 then
              begin
                Buffer := Buffer or (Int64(FBuffer[FBufPos + 6]) shl 48);
                if Count > 7 then
                  Buffer := Buffer or (Int64(FBuffer[FBufPos + 7]) shl 56);
              end;
            end;
          end;
        end;
      end;
    end;
  end;
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: UInt64; Count: Longint = SizeOf(UInt64));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count > 0 then
  begin
    Buffer := UInt64(FBuffer[FBufPos]);
    if Count > 1 then
    begin
      Buffer := Buffer or (UInt64(FBuffer[FBufPos + 1]) shl 8);
      if Count > 2 then
      begin
        Buffer := Buffer or (UInt64(FBuffer[FBufPos + 2]) shl 16);
        if Count > 3 then
        begin
          Buffer := Buffer or (UInt64(FBuffer[FBufPos + 3]) shl 24);
          if Count > 4 then
          begin
            Buffer := Buffer or (UInt64(FBuffer[FBufPos + 4]) shl 32);
            if Count > 5 then
            begin
              Buffer := Buffer or (UInt64(FBuffer[FBufPos + 5]) shl 40);
              if Count > 6 then
              begin
                Buffer := Buffer or (UInt64(FBuffer[FBufPos + 6]) shl 48);
                if Count > 7 then
                  Buffer := Buffer or (UInt64(FBuffer[FBufPos + 7]) shl 56);
              end;
            end;
          end;
        end;
      end;
    end;
  end;
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: Single; Count: Longint = SizeOf(Single));
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count >= 4 then
    Buffer := BitConverter.ToSingle(FBuffer, FBufPos);
  Inc(FBufPos, Count);
end;

procedure TReader.Read(var Buffer: Double; Count: Longint = SizeOf(Double));
var
  Buf: array[0..9] of Byte;
begin
  Buffer := 0;
  EnsureAtLeast(Count);
  if Count >= 10 then
  begin
    Read(Buf, 10);
    Buffer := ExtendedAsBytesToDouble(Buf);
    Inc(FBufPos, Count - 10);
  end
  else
  begin
    if Count >= 8 then
      Buffer := BitConverter.ToDouble(FBuffer, FBufPos)
    else if Count >= 4 then
      Buffer := BitConverter.ToSingle(FBuffer, FBufPos);
    Inc(FBufPos, Count);
  end;
end;

procedure TReader.ReadBuffer(Keeping: Integer);
begin
  if Keeping > 0 then
    System.Array.Copy(FBuffer, Length(FBuffer) - Keeping,
      FBuffer, 0, Keeping);
  FBufCount := FStream.Read(FBuffer, Keeping, Length(FBuffer) - Keeping);
  if FBufCount = 0 then
    raise EReadError.Create(SReadError);
  Inc(FBufCount, Keeping);
  FBufPos := 0;
end;

function TReader.ReadBoolean: Boolean;
begin
  Result := ReadValue = vaTrue;
end;

function TReader.ReadChar: Char;
begin
  Result := ReadWideChar;
end;

function TReader.ReadAnsiChar: AnsiChar;
var
  Temp: string;
begin
  Temp := ReadString;
  if Length(Temp) > 1 then
    PropValueError;
  Result := AnsiChar(Temp[1]);
end;

function TReader.ReadWideChar: WideChar;
var
  Temp: string;
begin
  Temp := ReadString;
  if Length(Temp) > 1 then
    PropValueError;
  Result := WideChar(Temp[1]);
end;

procedure TReader.ReadCollection(Collection: TCollection);
var
  Item: TPersistent;
begin
  Collection.BeginUpdate;
  try
    if not EndOfList then
      Collection.Clear;
    while not EndOfList do
    begin
      if NextValue in [vaInt8, vaInt16, vaInt32] then
        ReadInteger;
      Item := Collection.Add;
      ReadListBegin;
      while not EndOfList do
        ReadProperty(Item);
      ReadListEnd;
    end;
    ReadListEnd;
  finally
    Collection.EndUpdate;
  end;
end;

function TReader.CreateComponentFromType(ComponentClass: TComponentClass;
  Owner: TComponent): TComponent;
var
  Params: array of System.Type;
  ParamValues: array of TObject;
  ConstructorInfo: System.Reflection.ConstructorInfo;
begin
  SetLength(Params, 1);
  Params[0] := TypeOf(TComponentClass);
  ConstructorInfo := ComponentClass.ClassInfo.GetConstructor(Params);
  if ConstructorInfo <> nil then
  begin
    SetLength(ParamValues, 1);
    ParamValues[0] := Owner;
    Result := TComponent(ConstructorInfo.Invoke(ParamValues));
  end
  else
  begin
    SetLength(Params, 0);
    ConstructorInfo := ComponentClass.ClassInfo.GetConstructor(Params);
    if ConstructorInfo <> nil then
    begin
      SetLength(ParamValues, 0);
      Result := TComponent(ConstructorInfo.Invoke(ParamValues));
      if Owner <> nil then
        Owner.InsertComponent(Result);
    end
    else
    begin
      Error(SNoConstructorFound);
      Result := nil;
    end;
  end;
end;

function TReader.ReadComponent(Component: TComponent): TComponent;
var
  CompClass, CompName: string;
  Flags: TFilerFlags;
  Position: Integer;
  OldParent, OldLookupRoot: TComponent;
  SubComponents: array of TComponent;

  procedure AddSubComponentsToLoaded(Component: TComponent);
  var
    I: Integer;
  begin
    for I := 0 to Length(SubComponents) - 1 do
      FLoaded.Add(SubComponents[I]);
  end;

  procedure CheckSubComponents(Component: TComponent);
  var
    I: Integer;
  begin
    for I := 0 to Component.ComponentCount - 1 do
      if csSubComponent in Component.Components[I].FComponentStyle then
      begin
        SetLength(SubComponents, Length(SubComponents) + 1);
        SubComponents[Length(SubComponents) - 1] := Component.Components[I];
      end;
  end;

  procedure SetSubComponentState(State: TComponentState; Add: Boolean = True);
  var
    I: Integer;
  begin
    for I := 0 to Length(SubComponents) - 1 do
      if Add then
        SubComponents[I].FComponentState := SubComponents[I].FComponentState + State
      else
        SubComponents[I].FComponentState := SubComponents[I].FComponentState - State;
  end;

  function ComponentCreated: Boolean;
  begin
    Result := not (ffInherited in Flags) and (Component = nil);
  end;

  function Recover(var Component: TComponent; E: Exception): Boolean;
  begin
    if ComponentCreated then
      Component.Free;
    Component := nil;
    SkipComponent(False);
    Result := Error(E.Message);
  end;

  procedure CreateComponent;
  var
    ComponentClass: TComponentClass;
  begin
    try
      ComponentClass := FindComponentClass(CompClass);
      Result := nil;
      if Assigned(FOnCreateComponent) then
        FOnCreateComponent(Self, ComponentClass, Result);
      if Result = nil then
        try
          Result := CreateComponentFromType(ComponentClass, Owner);
          if ffInline in Flags then
            Result.FComponentState := Result.FComponentState + [csLoading, csInline];
        except
          Result := nil;
          raise;
        end;
      Result.FComponentState := Result.FComponentState + [csLoading];
    except
      on E: Exception do
        if not Recover(Result, E) then
          raise;
    end;
  end;

  procedure SetCompName;
  begin
    try
      Result.SetParentComponent(Parent);
      SetName(Result, CompName);
      if (csDesigning in Result.ComponentState) and (FindGlobalComponent(CompName) = Result) then
        Result.FComponentState := Result.FComponentState + [csInline];
    except
      on E: Exception do
        if not Recover(Result, E) then
          raise;
    end;
  end;

  procedure FindExistingComponent;
  begin
    try
      Result := FindAncestorComponent(CompName, FindComponentClass(CompClass));
      Parent := Result.GetParentComponent;
      if Parent = nil then
        Parent := Root;
    except
      on E: Exception do
        if not Recover(Result, E) then
          raise;
    end;
  end;


begin
  ReadPrefix(Flags, Position);
  CompClass := ReadStr;
  CompName := ReadStr;
  OldParent := Parent;
  OldLookupRoot := FLookupRoot;
  try
    Result := Component;
    if Result = nil then
      if ffInherited in Flags then
        FindExistingComponent
      else
        CreateComponent;
    if Result <> nil then
      try
        CheckSubComponents(Result);
        Result.FComponentState := Result.FComponentState + [csLoading];
        SetSubComponentState([csLoading]);
        if not (ffInherited in Flags) then
          SetCompName;
        if Result = nil then
          Exit;
        if csInline in Result.ComponentState then
          FLookupRoot := Result;
        Result.FComponentState := Result.FComponentState + [csReading];
        SetSubComponentState([csReading]);
        Result.ReadState(Self);
        Result.FComponentState := Result.FComponentState - [csReading];
        SetSubComponentState([csReading], False);
        if ffChildPos in Flags then
          Parent.SetChildOrder(Result, Position);
        if (ffInherited in Flags) or (csInline in Result.ComponentState) then
        begin
          if FLoaded.IndexOf(Result) < 0 then
          begin
            AddSubComponentsToLoaded(Result);
            FLoaded.Add(Result);
          end;
        end
        else
        begin
          AddSubComponentsToLoaded(Result);
          FLoaded.Add(Result);
        end;
      except
        if ComponentCreated then
          Result.Free;
        raise;
      end;
  finally
    Parent := OldParent;
    FLookupRoot := OldLookupRoot;
  end;
end;

procedure TReader.ReadData(Instance: TComponent);
begin
  if FFixups = nil then
  begin
    FFixups := TList.Create;
    try
      ReadDataInner(Instance);
      DoFixupReferences;
    finally
      FreeFixups;
    end;
  end
  else
    ReadDataInner(Instance);
end;

procedure TReader.ReadDataInner(Instance: TComponent);
var
  OldParent, OldOwner: TComponent;
begin
  while not EndOfList do
    ReadProperty(Instance);
  ReadListEnd;
  OldParent := Parent;
  OldOwner := Owner;
  Parent := Instance.GetChildParent;
  try
    Owner := Instance.GetChildOwner;
    if not Assigned(Owner) then
      Owner := Root;
    while not EndOfList do
      ReadComponent(nil);
    ReadListEnd;
  finally
    Parent := OldParent;
    Owner := OldOwner;
  end;
end;

function TReader.ReadFloat: Extended;
var
  Buffer: array of Byte;
begin
  if NextValue = vaExtended then
  begin
    ReadValue;
    SetLength(Buffer, 10);
    Read(Buffer, 10);
    Result := ExtendedAsBytesToDouble(Buffer);
  end
  else
    Result := ReadDouble;
end;

function TReader.ReadSingle: Single;
begin
  if NextValue = vaSingle then
  begin
    ReadValue;
    Read(Result, SizeOf(Single));
  end
  else
    Result := ReadInt64;
end;

function TReader.ReadDouble: Double;
begin
  if NextValue = vaDouble then
  begin
    ReadValue;
    Read(Result, SizeOf(Double));
  end
  else
    Result := ReadSingle;
end;

function TReader.ReadCurrency: Currency;
var
  LResult: TOACurrency;
begin
  if NextValue = vaCurrency then
  begin
    ReadValue;
    Read(LResult, SizeOf(LResult));
    Result := Currency.FromOACurrency(LResult);
  end
  else
    Result := ReadFloat;
end;

function TReader.ReadDate: TDateTime;
var
  LResult: TOADate;
begin
  if NextValue = vaDate then
  begin
    ReadValue;
    Read(LResult, SizeOf(LResult));
    Result := TDateTime.FromOADate(LResult);
  end
  else
    Result := TDateTime(ReadFloat);
end;

function TReader.ReadIdent: string;
begin
  case ReadValue of
    vaIdent:
      Result := ReadStr;
    vaFalse:
      Result := 'False';
    vaTrue:
      Result := 'True';
    vaNil:
      Result := 'nil';
    vaNull:
      Result := 'Null';
  else
    PropValueError;
  end;
end;

function TReader.ReadInteger: Longint;
begin
  case ReadValue of
    vaInt8:
      begin
        EnsureAtLeast(1);
        Result := Shortint(FBuffer[FBufPos]);
        Inc(FBufPos);
      end;
    vaInt16:
      begin
        EnsureAtLeast(2);
        Result := BitConverter.ToInt16(FBuffer, FBufPos);
        Inc(FBufPos, 2);
      end;
    vaInt32:
      begin
        EnsureAtLeast(4);
        Result := BitConverter.ToInt32(FBuffer, FBufPos);
        Inc(FBufPos, 4);
      end;
  else
    PropValueError;
    Result := 0;
  end;
end;

function TReader.ReadInt64: Int64;
begin
  if NextValue = vaInt64 then
  begin
    ReadValue;
    Read(Result);
  end
  else
    Result := ReadInteger;
end;

procedure TReader.ReadListBegin;
begin
  CheckValue(vaList);
end;

procedure TReader.ReadListEnd;
begin
  CheckValue(vaNull);
end;

procedure TReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
begin
  Flags := [];
  if Byte(NextValue) and $F0 = $F0 then
  begin
    Flags := TFilerFlags(Byte(ReadValue) and $0F);
    if ffChildPos in Flags then
      AChildPos := ReadInteger;
  end;
end;

procedure TReader.ReadProperty(AInstance: TPersistent);
var
  I, J, L: Integer;
  Instance: TPersistent;
  PropInfo: TPropInfo;
  PropValue: TObject;
  PropPath: string;

  procedure HandleException(E: Exception);
  var
    Name: string;
  begin
    Name := '';
    if AInstance is TComponent then
      Name := TComponent(AInstance).Name;
    if Name = '' then
      Name := AInstance.ClassName;
    raise EReadError.CreateFmt(SPropertyException, [Name, DotSep, PropPath, E.Message]);
  end;

  procedure PropPathError;
  begin
    SkipValue;
    ReadError(SInvalidPropertyPath);
  end;

begin
  try
    PropPath := ReadStr;
    try
      I := 1;
      L := Length(PropPath);
      Instance := AInstance;
      FCanHandleExcepts := True;
      while True do
      begin
        J := I;
        while (I <= L) and (PropPath[I] <> '.') do
          Inc(I);
        FPropName := Copy(PropPath, J, I - J);
        if I > L then
          Break;
        PropInfo := GetPropInfo(Instance.ClassType, FPropName);
        if PropInfo = nil then
          PropertyError(FPropName);
        PropValue := nil;
        if PropInfo.PropType.Kind = tkClass then
          PropValue := GetObjectProp(Instance, PropInfo); 
        if not (PropValue is TPersistent) then
          PropPathError;
        Instance := TPersistent(PropValue);
        Inc(I);
      end;
      PropInfo := GetPropInfo(Instance.ClassType, FPropName);
      if PropInfo <> nil then
        ReadPropValue(Instance, PropInfo)
      else
      begin
        { Cannot reliably recover from an error in a defined property }
        FCanHandleExcepts := False;
        Instance.DefineProperties(Self);
        FCanHandleExcepts := True;
        if FPropName <> '' then
          PropertyError(FPropName);
      end;
    except
      on E: Exception do HandleException(E);
    end;
  except
    on E: Exception do
      if not FCanHandleExcepts or not Error(E.Message) then
        raise;
  end;
end;

                       
procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: TPropInfo);
const
  NilMethod: TMethod = (Code: nil; Data: nil);
var
  PropType: TTypeInfo;
  Method: TMethod;

  procedure SetIntIdent(Instance: TPersistent; PropInfo: TPropInfo;
    const Ident: string);
  var
    V: Longint;
    IdentToInt: TIdentToInt;
  begin
    IdentToInt := FindIdentToInt(PropInfo.PropType);
    if Assigned(IdentToInt) and IdentToInt(Ident, V) then
      SetOrdProp(Instance, PropInfo, V)
    else
      PropValueError;
  end;

  procedure SetObjectIdent(Instance: TPersistent; PropInfo: TPropInfo;
    const Ident: string);
  begin
    FFixups.Add(TPropFixup.Create(Instance, Root, PropInfo, '', Ident));
  end;

  // This is isolated into a local to help reduce transient VarClears
  procedure SetVariantReference;
  begin
    SetVariantProp(Instance, PropInfo, ReadVariant);
  end;

  procedure SetInterfaceReference;
  var
    Intf: IInterface;
  begin
    if NextValue = vaNil then
    begin
      SkipValue;
      //ReadValue;
      Intf := nil;
                               
      // SetInterfaceProp(Instance, PropInfo, Intf);
    end
    else
      FFixups.Add(TPropIntfFixup.Create(Instance, Root, PropInfo, '', ReadIdent));
  end;

begin
  if not CanWrite(PropInfo) then
    if not ((PropInfo.PropType.Kind = tkClass) and
      (GetObjectProp(Instance, PropInfo) is TComponent) and
      (csSubComponent in TComponent(GetObjectProp(Instance, PropInfo)).ComponentStyle)) then
      ReadError(SReadOnlyProperty);
  PropType := PropInfo.PropType;
  case PropType.Kind of
    tkInteger:
      if NextValue = vaIdent then
        SetIntIdent(Instance, PropInfo, ReadIdent)
      else
        SetOrdProp(Instance, PropInfo, ReadInteger);
    tkChar:
      SetOrdProp(Instance, PropInfo, Ord(ReadAnsiChar));
    tkWChar:
      SetOrdProp(Instance, PropInfo, Ord(ReadWideChar));
    tkEnumeration:
      SetEnumProp(Instance, PropInfo, ReadIdent);
    tkFloat:
      SetFloatProp(Instance, PropInfo, ReadFloat);
    tkLString:
      SetAnsiStrProp(Instance, PropInfo, ReadString);
    tkString, tkWString:
      SetWideStrProp(Instance, PropInfo, ReadWideString);
    tkSet:
      SetSetProp(Instance, PropInfo, ReadSetAsText(PropType));
    tkClass:
      case NextValue of
        vaNil:
          begin
            ReadValue;
            SetOrdProp(Instance, PropInfo, 0)
          end;
        vaCollection:
          begin
            ReadValue;
            ReadCollection(TCollection(GetObjectProp(Instance, PropInfo)));
          end
      else
        SetObjectIdent(Instance, PropInfo, ReadIdent);
      end;
    tkMethod:
      if NextValue = vaNil then
      begin
        ReadValue;
        SetMethodProp(Instance, PropInfo, NilMethod);
      end
      else
      begin
        Method := FindMethodInstance(Root, ReadIdent);
        if Method.Code <> nil then
          SetMethodProp(Instance, PropInfo, Method);
      end;
    tkVariant:
      SetVariantReference;
    tkInt64:
      SetInt64Prop(Instance, PropInfo, ReadInt64);
    tkInterface:
      SetInterfaceReference;
  end;
end;

function TReader.ReadRootComponent(Root: TComponent): TComponent;

  function FindUniqueName(const Name: string): string;
  var
    I: Integer;
  begin
    I := 0;
    Result := Name;
    while not IsUniqueGlobalComponentName(Result) do
    begin
      Inc(I);
      Result := Format('%s_%d', [Name, I]);
    end;
  end;

var
  I: Integer;
  Flags: TFilerFlags;
  G: TList;
  S: TComponentState;
  Cookie: LockCookie;
begin
  ReadSignature;
  Result := nil;
  Cookie := GlobalNameSpace.UpgradeToWriterLock(MaxInt);  // Loading from stream adds to name space
  try
    try
      ReadPrefix(Flags, I);
      if Root = nil then
      begin
        Result := CreateComponentFromType(TComponentClass(FindClass(ReadStr)),
          nil);
        Result.Name := ReadStr;
      end
      else
      begin
        Result := Root;
        ReadStr; { Ignore class name }
        if csDesigning in Result.ComponentState then
          ReadStr
        else
        begin
          S := Result.ComponentState;
          Include(S, csLoading);
          Include(S, csReading);
          Result.FComponentState := S;
          Result.Name := FindUniqueName(ReadStr);
        end;
      end;
      FRoot := Result;
      FFinder := TClassFinder.Create(TPersistentClass(Result.ClassType), True);
      try
        FLookupRoot := Result;
        G := GlobalLoaded;
        if G <> nil then
          FLoaded := G
        else
          FLoaded := TList.Create;
        try
          if FLoaded.IndexOf(FRoot) < 0 then
            FLoaded.Add(FRoot);
          FOwner := FRoot;
          S := FRoot.ComponentState;
          Include(S, csLoading);
          Include(S, csReading);
          FRoot.FComponentState := S;
          FRoot.ReadState(Self);
          S := FRoot.ComponentState;
          Exclude(S, csReading);
          FRoot.FComponentState := S;
          if G = nil then
            for I := 0 to FLoaded.Count - 1 do
              TComponent(FLoaded[I]).Loaded;
        finally
          if G = nil then
            FLoaded.Free;
          FLoaded := nil;
        end;
      finally
        FreeAndNil(FFinder);
      end;
      while True do
      try
        // Try to fix up all references until no exceptions or the exception
        // itself terminates the loop. This will loop if the error is ignored
        // in, for example, the form designer.
        GlobalFixupReferences;
        Break;
      except
        on E: Exception do
          if not Error(E.Message) then
            raise;
      end;
    except
      RemoveFixupReferences(Root, '');
      if Root = nil then
        Result.Free;
      raise;
    end;
  finally
    GlobalNameSpace.DowngradeFromWriterLock(Cookie);
  end;
end;

procedure TReader.ReadComponents(AOwner, AParent: TComponent;
  Proc: TReadComponentsProc);
var
  Component: TComponent;
begin
  Root := AOwner;
  Owner := AOwner;
  Parent := AParent;
  BeginReferences;
  try
    FFinder := TClassFinder.Create(TPersistentClass(AOwner.ClassType), True);
    try
      while not EndOfList do
      begin
        ReadSignature;
        Component := ReadComponent(nil);
        if Assigned(Proc) then
          Proc(Component);
      end;
      ReadListEnd;
      FixupReferences;
    finally
      FreeAndNil(FFinder);
    end;
  finally
    EndReferences;
  end;
end;

function TReader.ReadSetAsText(SetType: TTypeInfo): string;
var
  LValueType: TValueType;
  LElement: string;
begin
  try
    LValueType := ReadValue;
    if LValueType <> vaSet then
      PropValueError;
    Result := '';
    repeat
      LElement := ReadStr;
      if LElement <> '' then
        Result := Result + ' ' + LElement;
    until LElement = '';
  except
    SkipSetBody;
    raise;
  end;
end;

function TReader.ReadSet(SetType: TTypeInfo): Integer;
begin
  Result := Convert.ToInt32(GetSetValue(SetType, ReadSetAsText(SetType)));
end;

procedure TReader.ReadSignature;
var
  Signature: Longint;
begin
  Read(Signature, SizeOf(Signature));
  if Signature <> Longint(FilerSignature) then
    ReadError(SInvalidImage);
end;

function TReader.ReadStr: string;
var
  L: Byte;
begin
  Read(L, SizeOf(Byte));
  EnsureAtLeast(L);
  Result := AnsiEncoding.GetString(FBuffer, FBufPos, L);
  Inc(FBufPos, L);
end;

function TReader.ReadString: string;
var
  L: Integer;
begin
  if NextValue in [vaWString, vaUTF8String] then
    Result := ReadWideString
  else
  begin
    L := 0;
    case ReadValue of
      vaString:
        Read(L, SizeOf(Byte));
      vaLString:
        Read(L, SizeOf(Integer));
    else
      PropValueError;
    end;
    EnsureAtLeast(L);
    Result := AnsiEncoding.GetString(FBuffer, FBufPos, L);
    Inc(FBufPos, L);
  end;
end;

function TReader.ReadWideString: WideString;
var
  I, L, P: Integer;
  SB: StringBuilder;
begin
  if NextValue in [vaString, vaLString] then
    Result := ReadString
  else
  begin
    L := 0;
    case ReadValue of
      vaWString:
        begin
          Read(L, SizeOf(Integer));
          EnsureAtLeast(L * 2);
          SB := StringBuilder.Create;
          for I := 0 to L - 1 do
          begin
            P := FBufPos + I * 2;
            SB.Append(Char(FBuffer[P] or (FBuffer[P + 1] shl 8)));
          end;
          Result := SB.ToString;
          Inc(FBufPos, L * 2);
        end;
      vaUtf8String:
        begin
          Read(L, SizeOf(Integer));
          EnsureAtLeast(L);
          Result := Encoding.UTF8.GetString(FBuffer, FBufPos, L);
          Inc(FBufPos, L);
        end;
    else
      PropValueError;
    end;
  end;
end;

function TReader.ReadValue: TValueType;
begin
  EnsureAtLeast(1);
  Result := TValueType(FBuffer[FBufPos]);
  Inc(FBufPos);
end;

procedure TReader.SetPosition(Value: Longint);
begin
  FStream.Position := Value;
  FBufPos := 0;
  FBufCount := 0;
end;

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

procedure TReader.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 [vaInt8, vaInt16, vaInt32] then
        SkipValue;
      SkipBytes(1);
      while not EndOfList do
        SkipProperty;
      ReadListEnd;
    end;
    ReadListEnd;
  end;

begin
  case ReadValue of
    vaNull: { no value field, just an identifier };
    vaList:
      SkipList;
    vaInt8:
      SkipBytes(SizeOf(Byte));
    vaInt16:
      SkipBytes(SizeOf(Word));
    vaInt32:
      SkipBytes(SizeOf(LongInt));
    vaExtended:
      SkipBytes(SizeOf(Extended));
    vaString, vaIdent:
      ReadStr;
    vaFalse, vaTrue:
      { no value field, just an identifier };
    vaBinary:
      SkipBinary(1);
    vaSet:
      SkipSetBody;
    vaLString:
      SkipBinary(1);
    vaCollection:
      SkipCollection;
    vaSingle:
      SkipBytes(Sizeof(Single));
    vaCurrency:
      SkipBytes(SizeOf(TOACurrency));
    vaDate:
      SkipBytes(Sizeof(TOADate));
    vaWString:
      SkipBinary(Sizeof(WideChar));
    vaInt64:
      SkipBytes(Sizeof(Int64));
    vaUTF8String:
      SkipBinary(1);
    vaDouble:
      SkipBytes(SizeOf(Double));
  end;
end;

procedure TReader.CopyValue(Writer: TWriter);

  procedure CopySetBody;
  var
    s: string;
  begin
    Writer.WriteValue(ReadValue);
    repeat
      s := ReadStr;
      Writer.WriteStr(s);
    until s = '';
  end;

  procedure CopyList;
  begin
    Writer.WriteValue(ReadValue);
    while not EndOfList do
      CopyValue(Writer);
    ReadListEnd;
    Writer.WriteListEnd;
  end;

  procedure CopyBytes(Count: Longint);
  var
    Bytes: array[0..8191] of Byte;
  begin
    while Count > SizeOf(Bytes) do
    begin
      Read(Bytes, SizeOf(Bytes));
      Writer.Write(Bytes, SizeOf(Bytes));
      Dec(Count, SizeOf(Bytes));
    end;
    if Count > 0 then
    begin
      Read(Bytes, Count);
      Writer.Write(Bytes, Count);
    end;
  end;

  procedure CopyBinary(BytesPerUnit: Integer);
  var
    Count: Longint;
  begin
    Writer.WriteValue(ReadValue);
    Read(Count, SizeOf(Count));
    Writer.Write(Count, SizeOf(Count));
    CopyBytes(Count * BytesPerUnit);
  end;

begin
  case NextValue of
    vaNull, vaFalse, vaTrue, vaNil:
      Writer.WriteValue(ReadValue);
    vaList, vaCollection:
      CopyList;
    vaInt8, vaInt16, vaInt32:
      Writer.WriteInteger(ReadInteger);
    vaExtended:
      Writer.WriteFloat(ReadFloat);
    vaString:
      Writer.WriteString(ReadString);
    vaIdent:
      Writer.WriteIdent(ReadIdent);
    vaBinary, vaLString, vaUTF8String:
      CopyBinary(1);
    vaWString:
      CopyBinary(SizeOf(WideChar));
    vaSet:
      CopySetBody;
    vaSingle:
      Writer.WriteSingle(ReadSingle);
    vaCurrency:
      Writer.WriteCurrency(ReadCurrency);
    vaDate:
      Writer.WriteDate(ReadDate);
    vaInt64:
      Writer.WriteInt64(ReadInt64);
    vaDouble:
      Writer.WriteDouble(ReadDouble);
  end;
end;

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

procedure TReader.SkipComponent(SkipHeader: Boolean);
var
  Flags: TFilerFlags;
  Position: Integer;
begin
  if SkipHeader then
  begin
    ReadPrefix(Flags, Position);
    ReadStr;
    ReadStr;
  end;
  while not EndOfList do
    SkipProperty;
  ReadListEnd;
  while not EndOfList do
    SkipComponent(True);
  ReadListEnd;
end;

function TReader.FindAncestorComponent(const Name: string;
  ComponentClass: TPersistentClass): TComponent;
var
  CompName: string;
begin
  CompName := Name;
  Result := nil;
  if FLookupRoot <> nil then
    Result := FLookupRoot.FindComponent(CompName);
  if Result = nil then
  begin
    if Assigned(FOnAncestorNotFound) then
      FOnAncestorNotFound(Self, CompName, ComponentClass, Result);
    if Result = nil then
      raise EReadError.CreateFmt(SAncestorNotFound, [CompName]);
  end;
end;

procedure TReader.ReferenceName(var Name: string);
begin
  if Assigned(FOnReferenceName) then
    FOnReferenceName(Self, Name);
end;

procedure TReader.SetName(Component: TComponent; var Name: string);
begin
  if Assigned(FOnSetName) then
    FOnSetName(Self, Component, Name);
  Component.Name := Name;
end;

function TReader.FindComponentClass(const ClassName: string): TComponentClass;
begin
  Result := TComponentClass(GetFieldClass(Root, ClassName));
  if not Assigned(Result) and Assigned(FLookupRoot) and (FLookupRoot <> Root) then
    Result := TComponentClass(GetFieldClass(FLookupRoot, ClassName));
  if Assigned(FOnFindComponentClass) then
    FOnFindComponentClass(Self, ClassName, Result);
  if (Result = nil) or not Result.InheritsFrom(TComponent) then
    ClassNotFound(ClassName);
end;

procedure TReader.SkipBytes(Count: Integer);
var
  Bytes: array[0..255] of Byte;
begin
  while Count > 0 do
    if Count > SizeOf(Bytes) then
    begin
      Read(Bytes, SizeOf(Bytes));
      Dec(Count, SizeOf(Bytes));
    end
    else
    begin
      Read(Bytes, Count);
      Count := 0;
    end;
end;

function TReader.ReadVariant: Variant;
begin
  case NextValue of
    vaNil, vaNull:
      if ReadValue <> vaNil then
        Result := NULL;
    vaInt8:
      Result := Byte(ReadInteger);
    vaInt16:
      Result := Smallint(ReadInteger);
    vaInt32:
      Result := ReadInteger;
    vaExtended:
      Result := ReadFloat;
    vaSingle:
      Result := ReadSingle;
    vaDouble:
      Result := ReadDouble;
    vaCurrency:
      Result := ReadCurrency;
    vaDate:
      Result := ReadDate;
    vaString, vaLString:
      Result := ReadString;
    vaWString, vaUTF8String:
      Result := ReadWideString;
    vaFalse, vaTrue:
      Result := ReadBoolean;
    vaInt64:
      Result := ReadInt64;
  else
    raise EReadError.Create(SReadError);
    Result := Unassigned; // suppress a warning
  end;
end;

{ TWriter }

destructor TWriter.Destroy;
begin
  WriteBuffer;
  inherited Destroy;
end;

procedure TWriter.AddAncestor(Component: TComponent);
begin
  FAncestorList.Add(Component);
end;

procedure TWriter.EnsureAtLeast(Amount: Integer);
begin
  if FBufPos + Amount > Length(FBuffer) then
    WriteBuffer;
end;

procedure TWriter.DefineProperty(const Name: string;
  ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
begin
  if HasData and Assigned(WriteData) then
  begin
    WritePropName(Name);
    WriteData(Self);
  end;
end;

procedure TWriter.DefineBinaryProperty(const Name: string;
  ReadData, WriteData: TStreamProc; HasData: Boolean);
begin
  if HasData and Assigned(WriteData) then
  begin
    WritePropName(Name);
    WriteBinary(WriteData);
  end;
end;

function TWriter.GetPosition: Longint;
begin
  Result := FStream.Position + FBufPos;
end;

function TWriter.FindMethodName(Method: TMethod): string;
begin
  Result := '';
  if Assigned(FOnFindMethodName) then
    FOnFindMethodName(Self, Method, Result);
  if Result = '' then
    Result := FLookupRoot.MethodName(Method.Code);
end;

procedure TWriter.FlushBuffer;
begin
  WriteBuffer;
end;

procedure TWriter.SetPosition(Value: Longint);
var
  StreamPosition: Longint;
begin
  StreamPosition := FStream.Position;
  { Only flush the buffer if the repostion is outside the buffer range }
  if (Value < StreamPosition) or (Value > StreamPosition + FBufPos) then
  begin
    WriteBuffer;
    FStream.Position := Value;
  end
  else
    FBufPos := Value - StreamPosition;
end;

procedure TWriter.SetRoot(Value: TComponent);
begin
  inherited SetRoot(Value);
  FLookupRoot := Value;
end;

procedure TWriter.Write(const Buffer: array of Byte; Offset, Count: Integer);
var
  P, C, S, I: Integer;
begin
  P := Offset;
  if Offset + Count > High(Buffer) + 1 then
  begin
    C := High(Buffer) - Offset + 1;
    S := Count - C;
    Count := C;
  end
  else
    S := 0;
  while Count > 0 do
  begin
    C := Length(FBuffer) - FBufPos;
    if C <= 0 then
    begin
      WriteBuffer;
      C := Length(FBuffer);
    end;
    if C > Count then
      C := Count;
    System.Array.Copy(System.Array(Buffer), P, System.Array(FBuffer), FBufPos,
      C);
    Inc(P, C);
    Inc(FBufPos, C);
    Dec(Count, C);
  end;
  while S > 0 do
  begin
    C := Length(FBuffer) - FBufPos;
    if C <= 0 then
    begin
      WriteBuffer;
      C := Length(FBuffer);
    end;
    if C > S then
      C := S;
    for I := 0 to C - 1 do
      FBuffer[FBufPos + I] := 0;
    Inc(FBufPos, C);
    Dec(S, C);
  end;
end;

procedure TWriter.Write(const Buffer: array of Byte; Count: Longint);
begin
  Write(Buffer, 0, Count);
end;

procedure TWriter.Write(const Buffer: Integer; Count: Longint);
begin
  EnsureAtLeast(Count);
  FBuffer[FBufPos] := Byte(Buffer and $FF);
  if Count > 1 then
  begin
    FBuffer[FBufPos + 1] := Byte(Buffer shr 8);
    if Count > 2 then
    begin
      FBuffer[FBufPos + 2] := Byte((Buffer shr 16) and $FF);
      if Count > 3 then
      begin
        FBuffer[FBufPos + 3] := Byte((Buffer shr 24) and $FF);
        if Count > 4 then
        begin
          Inc(FBufPos, 4);
          Write(Integer(0), Count - 4);
          Exit;
        end;
      end;
    end;
  end;
  Inc(FBufPos, Count);
end;

procedure TWriter.Write(const Buffer: Byte; Count: Longint);
begin
  EnsureAtLeast(1);
  FBuffer[FBufPos] := Buffer;
  Inc(FBufPos, Count);
end;

procedure TWriter.Write(const Buffer: Cardinal; Count: Longint);
begin
  EnsureAtLeast(4);
  FBuffer[FBufPos] := Byte(Buffer and $FF);
  if Count > 1 then
  begin
    FBuffer[FBufPos + 1] := Byte((Buffer shr 8) and $FF);
    if Count > 2 then
    begin
      FBuffer[FBufPos + 2] := Byte((Buffer shr 16) and $FF);
      if Count > 3 then
      begin
        FBuffer[FBufPos + 3] := Byte((Buffer shr 24) and $FF);
        if Count > 4 then
        begin
          Inc(FBufPos, 4);
          Write(Integer(0), Count - 4);
          Exit;
        end;
      end;
    end;
  end;
  Inc(FBufPos, Count);
end;

procedure TWriter.Write(const Buffer: Int64; Count: Longint);
var
  B: TBytes;
begin
  if Count <= 4 then
    Write(Integer(Buffer), Count)
  else
  begin
    B := BitConverter.GetBytes(Buffer);
    Write(B, Count);
  end;
end;

procedure TWriter.Write(const Buffer: Extended; Count: Longint);
var
  B: TBytes;
  S: Single;
begin
  case Count of
    4:
      begin
        S := Buffer;
        B := BitConverter.GetBytes(S);
      end;
    8: B := BitConverter.GetBytes(Double(Buffer));
   10: B := DoubleToExtendedAsBytes(Buffer);
  else
    SetLength(B, 0);
  end;
  Write(B, Count);
end;

procedure TWriter.WriteBinary(WriteData: TStreamProc);
var
  Stream: TMemoryStream;
  Count: Longint;
begin
  Stream := TMemoryStream.Create;
  try
    WriteData(Stream);
    WriteValue(vaBinary);
    Count := Stream.Size;
    Write(Count, SizeOf(Count));
    Write(Stream.Memory, Count);
  finally
    Stream.Free;
  end;
end;

procedure TWriter.WriteBuffer;
begin
  FStream.WriteBuffer(FBuffer, FBufPos);
  FBufPos := 0;
end;

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

procedure TWriter.WriteChar(Value: AnsiChar);
begin
  WriteString(Value);
end;

procedure TWriter.WriteChar(Value: WideChar);
begin
  WriteString(Value);
end;

procedure TWriter.WriteCollection(Value: TCollection);
var
  I: Integer;
  OldAncestor: TPersistent;
begin
  OldAncestor := Ancestor;
  Ancestor := nil;
  try
    WriteValue(vaCollection);
    if Value <> nil then
      for I := 0 to Value.Count - 1 do
      begin
        WriteListBegin;
        WriteProperties(Value.Items[I]);
        WriteListEnd;
      end;
    WriteListEnd;
  finally
    Ancestor := OldAncestor;
  end;
end;

procedure TWriter.WriteComponent(Component: TComponent);

  function FindAncestor(const Name: string): TComponent;
  var
    I: Integer;
  begin
    for I := 0 to FAncestorList.Count - 1 do
    begin
      Result := TComponent(FAncestorList[I]);
      if SameText(Result.Name, Name) then
        Exit;
    end;
    Result := nil;
  end;

var
  OldAncestor: TPersistent;
  OldRootAncestor: TComponent;
  AncestorComponent: TComponent;
  I: Integer;
begin
  OldAncestor := Ancestor;
  OldRootAncestor := RootAncestor;
  try
    Component.FComponentState := Component.FComponentState + [csWriting];
    for I := 0 to Component.ComponentCount - 1 do
      if csSubComponent in Component.Components[I].ComponentStyle then
        Component.Components[I].FComponentState := Component.Components[I].FComponentState + [csWriting];
    if Assigned(FAncestorList) then
      Ancestor := FindAncestor(Component.Name);
    if Assigned(FOnFindAncestor) and ((Ancestor = nil) or (Ancestor is
      TComponent)) then
    begin
      AncestorComponent := TComponent(Ancestor);
      FOnFindAncestor(Self, Component, Component.Name, AncestorComponent,
        FRootAncestor);
      Ancestor := AncestorComponent;
    end;
    Component.WriteState(Self);
    Component.FComponentState := Component.FComponentState - [csWriting];
    for I := 0 to Component.ComponentCount - 1 do
      if csSubComponent in Component.Components[I].ComponentStyle then
        Component.Components[I].FComponentState := Component.Components[I].FComponentState - [csWriting];
  finally
    Ancestor := OldAncestor;
    FRootAncestor := OldRootAncestor;
  end;
end;

procedure TWriter.WriteData(Instance: TComponent);
var
  PreviousPosition, PropertiesPosition: Longint;
  OldAncestorList: TList;
  OldAncestorPos, OldChildPos: Integer;
  OldRoot, OldRootAncestor: TComponent;
  Flags: TFilerFlags;
begin
  if Length(FBuffer) - FBufPos < Length(Instance.ClassName) +
    Length(Instance.Name) + 1+5+3 then
      WriteBuffer;
     { Prefix + vaInt + integer + 2 end lists }
  PreviousPosition := Position;
  Flags := [];
  if csInline in Instance.ComponentState then
    if (Ancestor <> nil) and (csAncestor in Instance.ComponentState) and (FAncestorList <> nil) then
      // If the AncestorList is not nil, this really came from an ancestor form
      Include(Flags, ffInherited)
    else
      // otherwise the Ancestor is the original frame
      Include(Flags, ffInline)
  else if Ancestor <> nil then
    Include(Flags, ffInherited);
  if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) and
    ((Ancestor = nil) or (FAncestorList[FAncestorPos] <> Ancestor)) then
    Include(Flags, ffChildPos);
  WritePrefix(Flags, FChildPos);
  if UseQualifiedNames then
    WriteStr(GetTypeData(PTypeInfo(Instance.ClassType.ClassInfo)).UnitName + '.' + Instance.ClassName)
  else
    WriteStr(Instance.ClassName);
  WriteStr(Instance.Name);
  PropertiesPosition := Position;
  if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) then
  begin
    if Ancestor <> nil then
      Inc(FAncestorPos);
    Inc(FChildPos);
  end;
  WriteProperties(Instance);
  WriteListEnd;
  OldAncestorList := FAncestorList;
  OldAncestorPos := FAncestorPos;
  OldChildPos := FChildPos;
  OldRoot := FRoot;
  OldRootAncestor := FRootAncestor;
  try
    FAncestorList := nil;
    FAncestorPos := 0;
    FChildPos := 0;
    if not IgnoreChildren then
      try
        if (FAncestor <> nil) and (FAncestor is TComponent) then
        begin
          if (FAncestor is TComponent) and (csInline in TComponent(FAncestor).ComponentState) then
            FRootAncestor := TComponent(FAncestor);
          FAncestorList := TList.Create;
          TComponent(FAncestor).GetChildren(AddAncestor, FRootAncestor);
        end;
        if csInline in Instance.ComponentState then
          FRoot := Instance;
        Instance.GetChildren(WriteComponent, FRoot);
      finally
        FAncestorList.Free;
      end;
  finally
    FAncestorList := OldAncestorList;
    FAncestorPos := OldAncestorPos;
    FChildPos := OldChildPos;
    FRoot := OldRoot;
    FRootAncestor := OldRootAncestor;
  end;
  WriteListEnd;
  if (Instance <> Root) and (Flags = [ffInherited]) and
    (Position = PropertiesPosition + (1 + 1)) then { (1 + 1) is two end lists }
    Position := PreviousPosition;
end;

procedure TWriter.WriteDescendent(Root: TComponent; AAncestor: TComponent);
begin
  FRootAncestor := AAncestor;
  FAncestor := AAncestor;
  FRoot := Root;
  FLookupRoot := Root;
  WriteSignature;
  WriteComponent(Root);
end;

procedure TWriter.WriteFloat(const Value: Extended);
begin
  {$IF SizeOf(Extended) = SizeOf(Double)}
  WriteDouble(Value);
  {$ELSE}
  WriteValue(vaExtended);
  Write(Value, SizeOf(Extended));
  {$IFEND}
end;

procedure TWriter.WriteSingle(const Value: Single);
begin
  WriteValue(vaSingle);
  Write(Value, SizeOf(Single));
end;

procedure TWriter.WriteDouble(const Value: Double);
begin
  WriteValue(vaDouble);
  Write(Value, SizeOf(Double));
end;

procedure TWriter.WriteCurrency(const Value: Currency);
begin
  WriteValue(vaCurrency);
  Write(Value.ToOACurrency, SizeOf(TOACurrency));
end;

procedure TWriter.WriteDate(const Value: TDateTime);
begin
  WriteValue(vaDate);
  Write(Value.ToOADate, SizeOf(TOADate));
end;

procedure TWriter.WriteIdent(const Ident: string);
begin
  if SameText(Ident, 'False') then
    WriteValue(vaFalse)
  else if SameText(Ident ,'True') then
    WriteValue(vaTrue)
  else if SameText(Ident ,'Null') then
    WriteValue(vaNull)
  else if SameText(Ident, 'nil') then
    WriteValue(vaNil)
  else
  begin
    WriteValue(vaIdent);
    WriteStr(Ident);
  end;
end;

procedure TWriter.WriteInteger(Value: Longint);
begin
  if (Value >= Low(ShortInt)) and (Value <= High(ShortInt)) then
  begin
    WriteValue(vaInt8);
    Write(Value, SizeOf(Shortint));
  end
  else if (Value >= Low(SmallInt)) and (Value <= High(SmallInt)) then
  begin
    WriteValue(vaInt16);
    Write(Value, SizeOf(Smallint));
  end
  else
  begin
    WriteValue(vaInt32);
    Write(Value, SizeOf(Integer));
  end;
end;

procedure TWriter.WriteInteger(const Value: Int64);
begin
  if (Value >= Low(Integer)) and (Value <= High(Integer)) then
    WriteInteger(Longint(Value))
  else
  begin
    WriteValue(vaInt64);
    Write(Value, Sizeof(Int64));
  end;
end;

procedure TWriter.WriteInt64(const Value: Int64);
begin
  WriteInteger(Value);
end;

procedure TWriter.WriteListBegin;
begin
  WriteValue(vaList);
end;

procedure TWriter.WriteListEnd;
begin
  WriteValue(vaNull);
end;

procedure TWriter.WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
var
  Prefix: Byte;
begin
  if Flags <> [] then
  begin
    Prefix := $F0 or Byte(Flags);
    Write(Prefix, SizeOf(Prefix));
    if ffChildPos in Flags then
      WriteInteger(AChildPos);
  end;
end;

procedure TWriter.WriteProperties(Instance: TPersistent);
var
  I: Integer;
  PropInfo: TPropInfo;
  PropList: TPropList;
begin
  PropList := GetPropList(Instance);
  for I := Low(PropList) to High(PropList) do
  begin
    PropInfo := PropList[I];
    if PropInfo = nil then
      break;
    if IsStoredProp(Instance, PropInfo) then
      WriteProperty(Instance, PropInfo);
  end;
  Instance.DefineProperties(Self);
end;

function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean;
  begin
    Result := (Ancestor <> nil) and (RootAncestor <> nil) and
      Root.InheritsFrom(RootAncestor.ClassType);
  end;

function IsDefaultPropertyValue(Instance: TObject; PropInfo: TPropInfo;
  OnGetLookupInfo: TGetLookupInfoEvent; Writer: TWriter = nil;
  OnFindMethodName: TFindMethodNameEvent = nil): Boolean;
var
  PropType: TTypeInfo;
  Ancestor: TPersistent;
  LookupRoot: TComponent;
  RootAncestor: TComponent;
  Root: TComponent;
  AncestorValid: Boolean;
  LKind: TTypeKind;

  function IsDefaultOrdProp: Boolean;
  var
    Value: Longint;
    Default: LongInt;
  begin
    Value := GetOrdProp(Instance, PropInfo);
    if AncestorValid then
      Result := Value = GetOrdProp(Ancestor, PropInfo)
    else
    begin
      Default := GetOrdPropDefault(PropInfo);
      Result :=  (Default <> LongInt($80000000)) and (Value = Default);
    end;
  end;

  function IsDefaultFloatProp: Boolean;
  var
    Value: Extended;
  begin
    Value := GetFloatProp(Instance, PropInfo);
    if AncestorValid then
      Result := Value = GetFloatProp(Ancestor, PropInfo)
    else
      Result := Value = 0;;
  end;

  function IsDefaultInt64Prop: Boolean;
  var
    Value: Int64;
  begin
    Value := GetInt64Prop(Instance, PropInfo);
    if AncestorValid then
      Result := Value = GetInt64Prop(Ancestor, PropInfo)
      else
    Result := Value = 0;
  end;

  function IsDefaultStrProp: Boolean;
  var
    Value: WideString;
  begin
    Value := GetWideStrProp(Instance, PropInfo);
    if AncestorValid then
      Result := Value = GetWideStrProp(Ancestor, PropInfo)
    else
      Result := Value = '';
  end;

  function ObjectAncestorMatch(AncestorValue, Value: TComponent): Boolean;
  begin
    Result := (AncestorValue <> nil) and (AncestorValue.Owner = RootAncestor) and
      (Value <> nil) and (Value.Owner = Root) and
      SameText(AncestorValue.Name, Value.Name);
  end;

  function IsDefaultObjectProp: Boolean;
  var
    Value: TObject;

    function IsDefault: Boolean;
    var
      AncestorValue: TObject;
    begin
      AncestorValue := nil;
      if AncestorValid then
      begin
        AncestorValue := GetObjectProp(Ancestor, PropInfo);
        if ObjectAncestorMatch(TComponent(AncestorValue), TComponent(Value)) then
          AncestorValue := Value;
      end;
      Result := Value = AncestorValue;
    end;

  begin
    Result := True;
    Value := GetObjectProp(Instance, PropInfo);
    if (Value = nil) and not IsDefault then
    begin
      Result := False; // nil wasn't the "default" value
    end
    else if Value is TPersistent then
    begin
      if (Value is TComponent) and
        not (csSubComponent in TComponent(Value).ComponentStyle) then
      begin
        if not IsDefault then
        begin
          // A non sub-component TComponent is only non-default if
          // it actually has a name (that way, it can be streamed out -
          // it can't be streamed without a name).
          if TComponent(Value).Name <> '' then
            Result := False;
        end
      end else
      begin
        Result := False; // The TPersistent should be checked for default's by the caller
      end;
    end;
  end;

                             
(*
  function IsDefaultInterfaceProp: Boolean;
  var
    Intf: IInterface;
    Value: TComponent;

    function IsDefaultValue: Boolean;
    var
      AncestorIntf: IInterface;
      ASR: IInterfaceComponentReference;
    begin
      Result := Intf = nil;
      if AncestorValid then
      begin
        AncestorIntf := GetInterfaceProp(Ancestor, PropInfo);
        Result := Intf = AncestorIntf;
        if not Result then
        begin
          if Supports(AncestorIntf, IInterfaceComponentReference, ASR) then
            Result := ObjectAncestorMatch(ASR.GetComponent, Value);
        end;
      end;
    end;

  var
    SR: IInterfaceComponentReference;
  begin
    Result := True;
    Intf := GetInterfaceProp(Instance, PropInfo);
    if (Intf = nil) or (not Supports(Intf, IInterfaceComponentReference, SR)) then
    begin
      if AncestorValid and (GetInterfaceProp(Ancestor, PropInfo) <> nil) then
        Result := False;
    end
    else
    begin
      Value := SR.GetComponent;
      if not IsDefaultValue then
      begin
        // We can only stream out components (ie: non-default ones)
        // if they actually have a name
        if Value.Name <> '' then
          Result := False;
      end;
    end;
  end;
*)

  function FindMethodName(Method: TMethod): string;
  begin
    Result := '';
    if Assigned(OnFindMethodName) then
      OnFindMethodName(Writer, Method, Result);
    if Result = '' then
      Result := LookupRoot.MethodName(Method.Code);
  end;

  function IsDefaultMethodProp: Boolean;
  var
    Value: TMethod;
    DefaultCode: TMethodCode;
  begin
    Value := GetMethodProp(Instance, PropInfo);
    DefaultCode := nil;
    if AncestorValid then
      DefaultCode := GetMethodProp(Ancestor, PropInfo).Code;
    Result := (Value.Code = DefaultCode) or
              ((Value.Code <> nil) and (FindMethodName(Value) = ''));
  end;

  function IsDefaultVariantProp: Boolean;
  var
    Value: Variant;
  begin
    Value := GetVariantProp(Instance, PropInfo);
    if AncestorValid then
      Result := VarSameValue(Value, GetVariantProp(Ancestor, PropInfo))
    else
      Result := VarIsClear(Value);
  end;

begin
  Ancestor := nil;
  Root := nil;
  LookupRoot := nil;
  RootAncestor := nil;

  if Assigned(OnGetLookupInfo) then
    OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor);

  AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);

  Result := True;
  if CanRead(PropInfo) and
    (CanWrite(PropInfo) or
    ((PropInfo.PropType.Kind = tkClass) and
     (GetObjectProp(Instance, PropInfo) is TComponent) and
     (csSubComponent in TComponent(GetObjectProp(Instance, PropInfo)).ComponentStyle))) then
  begin
    PropType := PropInfo.PropType;
    LKind := PropType.Kind;
    case LKind of
      tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
        Result := IsDefaultOrdProp;
      tkFloat:
        Result := IsDefaultFloatProp;
      tkString, tkLString, tkWString:
        Result := IsDefaultStrProp;
      tkClass:
        Result := IsDefaultObjectProp;
      tkMethod:
        Result := IsDefaultMethodProp;
      tkVariant:
        Result := IsDefaultVariantProp;
      tkInt64:
        Result := IsDefaultInt64Prop;
                         
//      tkInterface:
//        Result := IsDefaultInterfaceProp;
    else
                           
      WriteLn('Can''t deal with Kind: ', TObject(LKind).ToString);
    end;
  end;
end;

procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: TPropInfo);
var
  PropType: TTypeInfo;
  AncestorValid: Boolean;

  procedure WritePropPath;
  begin
    WritePropName(PropInfo.Name);
  end;

  procedure WriteIntProp(IntType: TTypeInfo; Value: Longint);
  var
    Ident: string;
    IntToIdent: TIntToIdent;
  begin
    IntToIdent := FindIntToIdent(IntType);
    if Assigned(IntToIdent) and IntToIdent(Value, Ident) then
      WriteIdent(Ident)
    else
      WriteInteger(Value);
  end;

  procedure WriteCollectionProp(Collection: TCollection);
  var
    SavePropPath: string;
  begin
    WritePropPath;
    SavePropPath := FPropPath;
    try
      FPropPath := '';
      WriteCollection(Collection);
    finally
      FPropPath := SavePropPath;
    end;
  end;

  procedure WriteSet(Value: Longint);
  var
    I: Integer;
  begin
    WriteValue(vaSet);
    I := 0;
    while Value <> 0 do
    begin
      if (Value and $1) <> 0 then
        WriteStr(GetEnumName(PropType, 1 shl I));
      Value := Value shr 1;
      Inc(I);
    end;
    WriteStr('');
  end;

  procedure WriteOrdProp;
  var
    Value: Longint;
  begin
    Value := GetOrdProp(Instance, PropInfo);
    WritePropPath;
    case PropType.Kind of
      tkInteger:
        WriteIntProp(PropInfo.PropType, Value);
      tkChar:
        WriteChar(AnsiChar(Value));
      tkWChar:
        WriteChar(WideChar(Value));
      tkSet:
        WriteSet(Value);
      tkEnumeration:
        WriteIdent(GetEnumName(PropType, Value));
    end;
  end;

  procedure WriteFloatProp;
  var
    Value: Extended;
  begin
    Value := GetFloatProp(Instance, PropInfo);
    WritePropPath;
    WriteFloat(Value);
  end;

  procedure WriteInt64Prop;
  var
    Value: Int64;
  begin
    Value := GetInt64Prop(Instance, PropInfo);
    WritePropPath;
    WriteInt64(Value);
  end;

  procedure WriteStrProp;
  var
    Value: WideString;
  begin
    Value := GetWideStrProp(Instance, PropInfo);
    WritePropPath;
    WriteWideString(Value);
  end;

  function GetComponentValue(Component: TComponent): string;
  begin
    if Component.Owner = LookupRoot then
      Result := Component.Name
    else if Component = LookupRoot then
      Result := 'Owner'                                                       { Do not translate }
    else if (Component.Owner <> nil) and (Component.Owner.Name <> '') and
      (Component.Name <> '') then
      if OwnedBy(Component.Owner, LookupRoot) then
        Result := GetComponentValue(Component.Owner) + '.' + Component.Name
      else
        Result := Component.Owner.Name + '.' + Component.Name
    else if Component.Name <> '' then
      Result := Component.Name + '.Owner'                                     { Do not translate }
    else
      Result := '';
  end;

  function ObjectAncestorMatch(AncestorValue, Value: TComponent): Boolean;
  begin
    Result := (AncestorValue <> nil) and (AncestorValue.Owner = FRootAncestor) and
      (Value <> nil) and (Value.Owner = Root) and
      SameText(AncestorValue.Name, Value.Name);
  end;

  procedure WriteObjectProp;
  var
    Value: TObject;
    OldAncestor: TPersistent;
    SavePropPath, ComponentValue: string;
  begin
    Value := GetObjectProp(Instance, PropInfo);
    if Value = nil then
    begin
      WritePropPath;
      WriteValue(vaNil);
    end
    else if Value is TPersistent then
      if (Value is TComponent) and
        not (csSubComponent in TComponent(Value).ComponentStyle) then
      begin
          ComponentValue := GetComponentValue(TComponent(Value));
        // ComponentValue will never be '' since we are to always
        // write out the value (in other words: it is not the default)
        // but it doesn't hurt to check
        if ComponentValue <> '' then
        begin
          WritePropPath;
          WriteIdent(ComponentValue);
        end
      end
      else
      begin
        OldAncestor := Ancestor;
        SavePropPath := FPropPath;
        try
          FPropPath := FPropPath + PropInfo.Name + '.';
          if AncestorValid then
            Ancestor := TPersistent(GetObjectProp(Ancestor, PropInfo));
          WriteProperties(TPersistent(Value));
        finally
          Ancestor := OldAncestor;
          FPropPath := SavePropPath;
        end;
        if Value is TCollection then
        begin
          if not AncestorValid or
            not CollectionsEqual(TCollection(Value),
              TCollection(GetObjectProp(Ancestor, PropInfo)), FLookupRoot, FRootAncestor) then
              WriteCollectionProp(TCollection(Value));
        end;
      end;
  end;

                      
  procedure WriteInterfaceProp;
  {var
    Intf: IInterface;
    Value: TComponent;
    SR: IInterfaceComponentReference;
    RefStr: string;}
  begin
    {Intf := GetInterfaceProp(Instance, PropInfo);
    if Intf = nil then
    begin
      WritePropPath;
      WriteValue(vaNil);
    end
    else if Supports(Intf, IInterfaceComponentReference, SR) then
    begin
      Value := SR.GetComponent;
      RefStr := GetComponentValue(Value);
      if RefStr <> '' then
      begin
        WritePropPath;
        WriteIdent(RefStr);
      end;
    end;}
  end;

  procedure WriteMethodProp;
  var
    Value: TMethod;
  begin
    Value := GetMethodProp(Instance, PropInfo);
    WritePropPath;
    if Value.Code = nil then
      WriteValue(vaNil)
    else
      WriteIdent(FLookupRoot.MethodName(Value.Code));
  end;

  procedure WriteVariantProp;
  var
    Value: Variant;
  begin
    Value := GetVariantProp(Instance, PropInfo);
    WritePropPath;
    WriteVariant(Value);
  end;

var
  LKind: TTypeKind;
begin
  // Using IsDefaultPropertyValue will tell us if we should write out
  // a given property because it was different from the default or
  // different from the Ancestor (if applicable).
  if CanRead(PropInfo) and
    (CanWrite(PropInfo) or
    ((PropInfo.PropType.Kind = tkClass) and
     (GetObjectProp(Instance, PropInfo) is TComponent) and
     (csSubComponent in TComponent(GetObjectProp(Instance, PropInfo)).ComponentStyle))) then
  begin
    if not IsDefaultPropertyValue(Instance, PropInfo, GetLookupInfo, Self, FOnFindMethodName) then
    begin
      AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor);
      PropType := PropInfo.PropType;
      LKind := PropType.Kind;
      case LKind of
        tkInteger, tkChar, tkEnumeration, tkSet, tkWChar:
          WriteOrdProp;
        tkFloat:
          WriteFloatProp;
        tkString, tkLString, tkWString:
          WriteStrProp;
        tkClass:
          WriteObjectProp;
        tkMethod:
          WriteMethodProp;
        tkVariant:
          WriteVariantProp;
        tkInt64:
          WriteInt64Prop;
        tkInterface:
          WriteInterfaceProp;
      end;
    end;
  end;
end;

procedure TWriter.WriteVariant(const Value: Variant);
begin
  if VarIsArray(Value) then
    raise EWriteError.Create(SWriteError);
  case VarType(Value) and varTypeMask of
    varEmpty:
      WriteValue(vaNil);
    varNull:
      WriteValue(vaNull);
    varByte, varShortInt, varWord, varSmallInt, varInteger:
      WriteInteger(Value);
    varSingle:
      WriteSingle(Value);
    varDouble:
      WriteDouble(Value);
    varCurrency:
      WriteCurrency(Value);
    varDate:
      WriteDate(Value);
    varBoolean:
      WriteBoolean(Value);
    varLongWord, varInt64:
      WriteInt64(Value);
  else
    // everything else is just written out as a string
    // varString, varDateTime, varDecimal, varEtc...
    WriteWideString(Value);
  end;
end;

procedure TWriter.WritePropName(const PropName: string);
begin
  WriteStr(FPropPath + PropName);
end;

procedure TWriter.WriteRootComponent(Root: TComponent);
begin
  WriteDescendent(Root, nil);
end;

procedure TWriter.WriteSignature;
begin
  Write(FilerSignature, SizeOf(FilerSignature));
end;

procedure TWriter.WriteStr(const Value: string);
var
  B: TBytes;
  L: Integer;
begin
  L := Length(Value);
  if L > 0 then
  begin
    B := AnsiEncoding.GetBytes(Value);
    L := Length(B); // just in case Value has multibyte chars in Ansi version
  end
  else
    SetLength(B, 0);
  if L > 255 then
    L := 255;
  Write(L, SizeOf(Byte));
  Write(B, L);
end;

procedure TWriter.WriteMinStr(const Value: string);

  function SameBytes(const B1: array of Byte; const B2: array of Byte): Boolean;
  var
    I: Integer;
  begin
    Result := False;
    if High(B1) <> High(B2) then
      Exit;
    for I := 0 to High(B1) do
      if B1[I] <> B2[I] then
        Exit;
    Result := True;
  end;

var
  LocalBytes: TBytes;
  Utf8Bytes: TBytes;
  L: Integer;
begin
  LocalBytes := AnsiEncoding.GetBytes(Value);
  Utf8Bytes := Encoding.UTF8.GetBytes(Value);
  if not SameBytes(LocalBytes, Utf8Bytes) then
  begin
    L := Length(Utf8Bytes);
    if L > Length(Value) * 2 then
    begin
      WriteValue(vaWString);
      Utf8Bytes := WideBytesOf(Value);
      L := Length(Utf8Bytes);
      Write(L div 2, SizeOf(Integer));
    end
    else
    begin
      WriteValue(vaUtf8String);
      Write(L, SizeOf(Integer));
    end;
    Write(Utf8Bytes, L);
  end
  else
  begin
    L := Length(LocalBytes);
    if L <= 255 then
    begin
      WriteValue(vaString);
      Write(L, SizeOf(Byte));
    end
    else
    begin
      WriteValue(vaLString);
      Write(L, SizeOf(Integer));
    end;
    Write(LocalBytes, L);
  end;
end;

procedure TWriter.WriteString(const Value: string);
begin
  WriteMinStr(Value);
end;

procedure TWriter.WriteWideString(const Value: WideString);
begin
  WriteMinStr(Value);
end;

procedure TWriter.WriteValue(Value: TValueType);
begin
  Write(Byte(Value), SizeOf(Value));
end;

procedure TWriter.GetLookupInfo(var Ancestor: TPersistent; var Root,
  LookupRoot, RootAncestor: TComponent);
begin
  Ancestor := Self.Ancestor;
  Root := Self.Root;
  LookupRoot := Self.LookupRoot;
  RootAncestor := Self.RootAncestor;
end;

{ TParser }

const
  ParseBufSize = 4096;
  B2HConvert: array[0..15] of Byte = ($30, $31, $32, $33, $34, $35, $36, $37, $38, $39, $41, $42, $43, $44, $45, $46);

procedure BinToHex(const Buffer: array of Byte; BufOffset: Integer;
  var Text: array of Byte; TextOffset: Integer; Count: Integer);
var
  I: Integer;
begin
  for I := 0  to Count - 1 do
  begin
    Text[TextOffset + I * 2] := B2HConvert[Buffer[BufOffset + I] shr 4];
    Text[TextOffset + 1 + I * 2] := B2HConvert[Buffer[BufOffset + I] and $F];
  end;
end;

const
  H2BConvert: array['0'..'f'] of SmallInt =
    ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1,
     -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1,
     -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,
     -1,10,11,12,13,14,15);

function HexToBin(const Text: array of Byte; TextOffset: Integer;
  Buffer: array of Byte; BufOffset: Integer; Count: Integer): Integer;
var
  I, C: Integer;
begin
  C := 0;
  for I := 0 to Count - 1 do
  begin
    if not (AnsiChar(Text[TextOffset + I * 2]) in [AnsiChar('0')..AnsiChar('f')]) or
       not (AnsiChar(Text[TextOffset + 1 + I * 2]) in [AnsiChar('0')..AnsiChar('f')]) then
      Break;
    Buffer[BufOffset + I] :=
      (H2BConvert[AnsiChar(Text[TextOffset + I * 2])] shl 4) or
       H2BConvert[AnsiChar(Text[TextOffset + 1 + I * 2])];
    Inc(C);
  end;
  Result := C;
end;

constructor TParser.Create(Stream: TStream);
begin
  inherited Create;
  FStream := Stream;
  SetLength(FBuffer, ParseBufSize);
  FBuffer[0] := 0;
  FBufPtr := 0;
  FBufEnd := ParseBufSize;
  FSourcePtr := 0;
  FSourceEnd := 0;
  FTokenPtr := 0;
  FSourceLine := 1;
  NextToken;
end;

destructor TParser.Destroy;
begin
  if Length(FBuffer) > 0 then
    FStream.Seek(FTokenPtr - FBufPtr, TSeekOrigin.soCurrent);
  inherited Destroy;
end;

const
  tkString = toString; // Avoids a conflict with the ToString method

procedure TParser.CheckToken(T: Char);
begin
  if Token <> T then
    case T of
      toSymbol:
        Error(SIdentifierExpected);
      tkString, toWString:
        Error(SStringExpected);
      toInteger, toFloat:
        Error(SNumberExpected);
    else
      ErrorFmt(SCharExpected, [T]);
    end;
end;

procedure TParser.CheckTokenSymbol(const S: string);
begin
  if not TokenSymbolIs(S) then
    ErrorFmt(SSymbolExpected, [S]);
end;

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

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

procedure TParser.ErrorStr(const Message: string);
begin
  raise EParserError.CreateFmt(SParseError, [Message, FSourceLine]);
end;

procedure TParser.HexToBinary(Stream: TStream);
var
  Count: Integer;
  Buffer: array[0..255] of Byte;
begin
  SkipBlanks;
  while Char(FBuffer[FSourcePtr]) <> '}' do
  begin
    Count := HexToBin(FBuffer, FSourcePtr, Buffer, 0, SizeOf(Buffer));
    if Count = 0 then
      Error(SInvalidBinary);
    Stream.Write(Buffer, Count);
    Inc(FSourcePtr, Count * 2);
    SkipBlanks;
  end;
  NextToken;
end;

function TParser.NextToken: Char;
var
  I, J: Integer;
  IsWideStr: Boolean;
  P, S: Integer;
begin
  SkipBlanks;
  P := FSourcePtr;
  FTokenPtr := P;
  case Char(FBuffer[P]) of
    'A'..'Z', 'a'..'z', '_':
      begin
        Inc(P);
        while AnsiChar(FBuffer[P]) in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do
          Inc(P);
        Result := toSymbol;
      end;
    '#', '''':
      begin
        IsWideStr := False;
        J := 0;
        S := P;
        while True do
          case Char(FBuffer[P]) of
            '#':
              begin
                Inc(P);
                I := 0;
                while AnsiChar(FBuffer[P]) in ['0'..'9'] do
                begin
                  I := I * 10 + (FBuffer[P] - Ord('0'));
                  Inc(P);
                end;
                if (I > 127) then
                  IsWideStr := True;
                Inc(J);
              end;
            '''':
              begin
                Inc(P);
                while True do
                begin
                  case AnsiChar(FBuffer[P]) of
                    #0, #10, #13:
                      Error(SInvalidString);
                    '''':
                      begin
                        Inc(P);
                        if Char(FBuffer[P]) <> '''' then
                          Break;
                      end;
                  end;
                  Inc(J);
                  Inc(P);
                end;
              end;
          else
            Break;
          end;
        P := S;
        if IsWideStr then
          SetLength(FWideStr, J);
        J := 1;
        while True do
          case Char(FBuffer[P]) of
            '#':
              begin
                Inc(P);
                I := 0;
                while AnsiChar(FBuffer[P]) in ['0'..'9'] do
                begin
                  I := I * 10 + (FBuffer[P] - Ord('0'));
                  Inc(P);
                end;
                if IsWideStr then
                begin
                  FWideStr[J] := WideChar(SmallInt(I));
                  Inc(J);
                end
                else
                begin
                  FBuffer[S] := I;
                  Inc(S);
                end;
              end;
            '''':
              begin
                Inc(P);
                while True do
                begin
                  case FBuffer[P] of
                    0, 10, 13:
                      Error(SInvalidString);
                    Ord(''''):
                      begin
                        Inc(P);
                        if Char(FBuffer[P]) <> '''' then
                          Break;
                      end;
                  end;
                  if IsWideStr then
                  begin
                    FWideStr[J] := WideChar(FBuffer[P]);
                    Inc(J);
                  end
                  else
                  begin
                    FBuffer[S] := FBuffer[P];
                    Inc(S);
                  end;
                  Inc(P);
                end;
              end;
          else
            Break;
          end;
        FStringPtr := S;
        if IsWideStr then
          Result := toWString
        else
          Result := tkString;
      end;
    '$':
      begin
        Inc(P);
        while AnsiChar(FBuffer[P]) in ['0'..'9', 'A'..'F', 'a'..'f'] do
          Inc(P);
        Result := toInteger;
      end;
    '-', '0'..'9':
      begin
        Inc(P);
        while AnsiChar(FBuffer[P]) in ['0'..'9'] do
          Inc(P);
        Result := toInteger;
        while AnsiChar(FBuffer[P]) in ['0'..'9', '.', 'e', 'E', '+', '-'] do
        begin
          Inc(P);
          Result := toFloat;
        end;
        if (AnsiChar(FBuffer[P]) in ['c', 'C', 'd', 'D', 's', 'S', 'f', 'F']) then
        begin
          Result := toFloat;
          FFloatType := Char(FBuffer[P]);
          Inc(P);
        end
        else
          FFloatType := #0;
      end;
  else
    Result := Char(FBuffer[P]);
    if Result <> toEOF then
      Inc(P);
  end;
  FSourcePtr := P;
  FToken := Result;
end;

procedure TParser.ReadBuffer;
var
  Count: Integer;
begin
  Inc(FOrigin, FSourcePtr);
  FBuffer[FSourceEnd] := FSaveChar;
  Count := FBufPtr - FSourcePtr;
  if Count <> 0 then
    System.Array.Copy(FBuffer, FSourcePtr, FBuffer, 0, Count);
  FBufPtr := Count;
  Inc(FBufPtr, FStream.Read(FBuffer, FBufPtr, FBufEnd - FBufPtr));
  FSourcePtr := 0;
  FSourceEnd := FBufPtr;
  if FSourceEnd = FBufEnd then
  begin
    FSourceEnd := LineStart(FBuffer, FSourceEnd - 2);
    if FSourceEnd = 0 then
      Error(SLineTooLong);
  end;
  FSaveChar := FBuffer[FSourceEnd];
  FBuffer[FSourceEnd] := 0;
end;

procedure TParser.SkipBlanks;
begin
  while True do
  begin
    case FBuffer[FSourcePtr] of
      0:
        begin
          ReadBuffer;
          if FBuffer[FSourcePtr] = 0 then
            Exit;
          Continue;
        end;
      10:
        Inc(FSourceLine);
      33..255:
        Exit;
    end;
    Inc(FSourcePtr);
  end;
end;

function TParser.SourcePos: Longint;
begin
  Result := FOrigin + FTokenPtr;
end;

function TParser.TokenFloat: Extended;
begin
  if FFloatType <> #0 then
    Dec(FSourcePtr);
  Result := StrToFloat(TokenString);
  if FFloatType <> #0 then
    Inc(FSourcePtr);
end;

function TParser.TokenInt: Int64;
begin
  Result := StrToInt64(TokenString);
end;

function TParser.TokenString: string;
var
  L: Integer;
begin
  if FToken = tkString then
    L := FStringPtr - FTokenPtr
  else
    L := FSourcePtr - FTokenPtr;
  Result := AnsiEncoding.GetString(FBuffer, FTokenPtr, L);
end;

function TParser.TokenWideString: WideString;
begin
  if FToken = tkString then
    Result := TokenString
  else
    Result := FWideStr;
end;

function TParser.TokenSymbolIs(const S: string): Boolean;
begin
  Result := (Token = toSymbol) and SameText(S, TokenString);
end;

function TParser.TokenComponentIdent: string;
var
  P: Integer;
begin
  CheckToken(toSymbol);
  P := FSourcePtr;
  while AnsiChar(FBuffer[P]) = '.' do
  begin
    Inc(P);
    if not (AnsiChar(FBuffer[P]) in ['A'..'Z', 'a'..'z', '_']) then
      Error(SIdentifierExpected);
    repeat
      Inc(P)
    until not (AnsiChar(FBuffer[P]) in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
  end;
  FSourcePtr := P;
  Result := TokenString;
end;

{ Binary to text conversion }
const
  Blanks: array[0..1] of Byte = ($20, $20);
  BytesPerLine = 32;

procedure ObjectBinaryToText(Input, Output: TStream);
var
  NestingLevel: Integer;
  SaveDecimalSeparator: string;
  SaveThousandSeparator: string;
  Reader: TReader;
  Writer: TWriter;
  ObjectName, PropName: string;

  procedure WriteIndent;
  var
    I: Integer;
  begin
    for I := 1 to NestingLevel do
      Writer.Write(Blanks, Length(Blanks));
  end;

  procedure WriteStr(const S: string);
  var
    B: TBytes;
  begin
    B := AnsiEncoding.GetBytes(S);
    Writer.Write(B, Length(B));
  end;

  procedure NewLine;
  begin
    WriteStr(sLineBreak);
    WriteIndent;
  end;

  procedure ConvertValue; forward;

  procedure ConvertHeader;
  var
    ClassName: string;
    Flags: TFilerFlags;
    Position: Integer;
  begin
    Reader.ReadPrefix(Flags, Position);
    ClassName := Reader.ReadStr;
    ObjectName := Reader.ReadStr;
    WriteIndent;
    if ffInherited in Flags then
      WriteStr('inherited ')
    else if ffInline in Flags then
      WriteStr('inline ')
    else
      WriteStr('object ');
    if ObjectName <> '' then
    begin
      WriteStr(ObjectName);
      WriteStr(': ');
    end;
    WriteStr(ClassName);
    if ffChildPos in Flags then
    begin
      WriteStr(' [');
      WriteStr(IntToStr(Position));
      WriteStr(']');
    end;

    if ObjectName = '' then
      ObjectName := ClassName;  // save for error reporting

    WriteStr(sLineBreak);
  end;

  procedure ConvertBinary;
  var
    MultiLine: Boolean;
    I: Integer;
    Count: Longint;
    Buffer: array[0..BytesPerLine - 1] of Byte;
    Text: array[0..BytesPerLine * 2 - 1] of Byte;
  begin
    Reader.ReadValue;
    WriteStr('{');
    Inc(NestingLevel);
    Reader.Read(Count, SizeOf(Count));
    MultiLine := Count >= BytesPerLine;
    while Count > 0 do
    begin
      if MultiLine then
        NewLine;
      if Count >= 32 then
        I := 32
      else
        I := Count;
      Reader.Read(Buffer, I);
      BinToHex(Buffer, 0, Text, 0, I);
      Writer.Write(Text, I * 2);
      Dec(Count, I);
    end;
    Dec(NestingLevel);
    WriteStr('}');
  end;

  procedure ConvertProperty; forward;

  procedure ConvertValue;
  const
    LineLength = 64;
  var
    I, J, K, L: Integer;
    S: string;
    W: WideString;
    LineBreak: Boolean;
  begin
    case Reader.NextValue of
      vaList:
        begin
          Reader.ReadValue;
          WriteStr('(');
          Inc(NestingLevel);
          while not Reader.EndOfList do
          begin
            NewLine;
            ConvertValue;
          end;
          Reader.ReadListEnd;
          Dec(NestingLevel);
          WriteStr(')');
        end;
      vaInt8, vaInt16, vaInt32:
        WriteStr(IntToStr(Reader.ReadInteger));
      vaExtended, vaDouble:
        WriteStr(FloatToStr(Reader.ReadFloat));
      vaSingle:
        WriteStr(FloatToStr(Reader.ReadSingle) + 's');
      vaCurrency:
        WriteStr(CurrToStr(Reader.ReadCurrency) + 'c');
      vaDate:
        WriteStr(FloatToStr(Reader.ReadDate) + 'd');
      vaWString, vaUTF8String, vaString, vaLString:
        begin
          W := Reader.ReadWideString;
          L := Length(W);
          if L = 0 then
            WriteStr('''''')
          else
          begin
            I := 1;
            Inc(NestingLevel);
            try
              if L > LineLength then
                NewLine;
              K := I;
              repeat
                LineBreak := False;
                if (W[I] >= ' ') and (W[I] <> '''') and (Ord(W[i]) <= 127) then
                begin
                  J := I;
                  repeat
                    Inc(I)
                  until (I > L) or (W[I] < ' ') or (W[I] = '''') or
                    ((I - K) >= LineLength) or (Ord(W[i]) > 127);
                  if ((I - K) >= LineLength) then
                    LineBreak := True;
                  WriteStr('''');
                  while J < I do
                  begin
                    WriteStr(Char(W[J]));
                    Inc(J);
                  end;
                  WriteStr('''');
                end
                else
                begin
                  WriteStr('#');
                  WriteStr(IntToStr(Ord(W[I])));
                  Inc(I);
                  if ((I - K) >= LineLength) then
                    LineBreak := True;
                end;
                if LineBreak and (I <= L) then
                begin
                  WriteStr(' +');
                  NewLine;
                  K := I;
                end;
              until I > L;
            finally
              Dec(NestingLevel);
            end;
          end;
        end;
      vaIdent, vaFalse, vaTrue, vaNil, vaNull:
        WriteStr(Reader.ReadIdent);
      vaBinary:
        ConvertBinary;
      vaSet:
        begin
          Reader.ReadValue;
          WriteStr('[');
          I := 0;
          while True do
          begin
            S := Reader.ReadStr;
            if S = '' then
              Break;
            if I > 0 then
              WriteStr(', ');
            WriteStr(S);
            Inc(I);
          end;
          WriteStr(']');
        end;
      vaCollection:
        begin
          Reader.ReadValue;
          WriteStr('<');
          Inc(NestingLevel);
          while not Reader.EndOfList do
          begin
            NewLine;
            WriteStr('item');
            if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
            begin
              WriteStr(' [');
              ConvertValue;
              WriteStr(']');
            end;
            WriteStr(sLineBreak);
            Reader.CheckValue(vaList);
            Inc(NestingLevel);
            while not Reader.EndOfList do
              ConvertProperty;
            Reader.ReadListEnd;
            Dec(NestingLevel);
            WriteIndent;
            WriteStr('end');
          end;
          Reader.ReadListEnd;
          Dec(NestingLevel);
          WriteStr('>');
        end;
      vaInt64:
        WriteStr(IntToStr(Reader.ReadInt64));
    else
      raise EReadError.CreateFmt(SPropertyException,
        [ObjectName, DotSep, PropName, IntToStr(Ord(Reader.NextValue))]);
    end;
  end;

  procedure ConvertProperty;
  begin
    WriteIndent;
    PropName := Reader.ReadStr;  // save for error reporting
    WriteStr(PropName);
    WriteStr(' = ');
    ConvertValue;
    WriteStr(sLineBreak);
  end;

  procedure ConvertObject;
  begin
    ConvertHeader;
    Inc(NestingLevel);
    while not Reader.EndOfList do
      ConvertProperty;
    Reader.ReadListEnd;
    while not Reader.EndOfList do
      ConvertObject;
    Reader.ReadListEnd;
    Dec(NestingLevel);
    WriteIndent;
    WriteStr('end' + sLineBreak);
  end;

begin
  NestingLevel := 0;
  Reader := TReader.Create(Input, 4096);
  SaveDecimalSeparator := DecimalSeparator;
  SaveThousandSeparator := ThousandSeparator;
  DecimalSeparator := '.';
  ThousandSeparator := ',';
  try
    Writer := TWriter.Create(Output, 4096);
    try
      Reader.ReadSignature;
      ConvertObject;
    finally
      Writer.Free;
    end;
  finally
    DecimalSeparator := SaveDecimalSeparator;
    ThousandSeparator := SaveThousandSeparator;
    Reader.Free;
  end;
end;

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

procedure InternalBinaryToText(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat;
  ConvertProc: TObjectTextConvertProc;
  BinarySignature: Integer; SignatureLength: Byte);
var
  Pos: Integer;
  Signature: Integer;
begin
  Pos := Input.Position;
  Signature := 0;
  if SignatureLength > SizeOf(Signature) then
    SignatureLength := SizeOf(Signature);
  Input.Read(Signature, SignatureLength);
  Input.Position := Pos;
  if Signature = BinarySignature then
  begin     // definitely binary format
    if OriginalFormat = sofBinary then
      Output.CopyFrom(Input, Input.Size - Input.Position)
    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 AnsiChar(Signature) 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
        Output.CopyFrom(Input, Input.Size - Input.Position);
    end;
  end;
end;

procedure InternalTextToBinary(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat;
  ConvertProc: TObjectTextConvertProc;
  BinarySignature: Integer; SignatureLength: Byte);
var
  Pos: Integer;
  Signature: Integer;
begin
  Pos := Input.Position;
  Signature := 0;
  if SignatureLength > sizeof(Signature) then
    SignatureLength := sizeof(Signature);
  Input.Read(Signature, SignatureLength);
  Input.Position := Pos;
  if Signature = BinarySignature then
  begin     // definitely binary format
    if OriginalFormat = sofUnknown then
      Originalformat := sofBinary;
    if OriginalFormat = sofBinary then
      Output.CopyFrom(Input, Input.Size - Input.Position)
    else    // let it raise the exception
      ConvertProc(Input, Output);
  end
  else  // might be text format
  begin
    case OriginalFormat of
      sofUnknown:
        begin  // text format may begin with "object", "inherited", or whitespace
          if AnsiChar(Signature) in ['o','O','i','I',' ',#13,#11,#9] then
            OriginalFormat := sofText;
          // if its not binary, not text... let it raise the exception
          ConvertProc(Input, Output);
        end;
      sofBinary:  ConvertProc(Input, Output);
      sofText:    Output.CopyFrom(Input, Input.Size - Input.Position);
    end;
  end;
end;

procedure ObjectBinaryToText(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat);
begin
  InternalBinaryToText(Input, Output, OriginalFormat, ObjectBinaryToText,
    Integer(FilerSignature), sizeof(Integer));
end;

{ Text to binary conversion }

procedure ObjectTextToBinary(Input, Output: TStream);
var
  SaveDecimalSeparator: string;
  SaveThousandSeparator: string;
  Parser: TParser;
  Writer: TWriter;
  TokenStr: string;

  function ConvertOrderModifier: Integer;
  begin
    Result := -1;
    if Parser.Token = '[' then
    begin
      Parser.NextToken;
      Parser.CheckToken(toInteger);
      Result := Parser.TokenInt;
      Parser.NextToken;
      Parser.CheckToken(']');
      Parser.NextToken;
    end;
  end;

  procedure ConvertHeader(IsInherited, IsInline: Boolean);
  var
    ClassName, ObjectName: string;
    Flags: TFilerFlags;
    Position: Integer;
  begin
    Parser.CheckToken(toSymbol);
    ClassName := Parser.TokenString;
    ObjectName := '';
    if Parser.NextToken = ':' then
    begin
      Parser.NextToken;
      Parser.CheckToken(toSymbol);
      ObjectName := ClassName;
      ClassName := Parser.TokenString;
      Parser.NextToken;
    end;
    Flags := [];
    Position := ConvertOrderModifier;
    if IsInherited then
      Include(Flags, ffInherited);
    if IsInline then
      Include(Flags, ffInline);
    if Position >= 0 then
      Include(Flags, ffChildPos);
    Writer.WritePrefix(Flags, Position);
    Writer.WriteStr(ClassName);
    Writer.WriteStr(ObjectName);
  end;

  procedure ConvertProperty; forward;

  procedure ConvertValue;
  var
    Order: Integer;

    function CombineWideString: WideString;
    begin
      Result := Parser.TokenWideString;
      while Parser.NextToken = '+' do
      begin
        Parser.NextToken;
        if not (Parser.Token in [toString, toWString]) then
          Parser.CheckToken(tkString);
        Result := Result + Parser.TokenWideString;
      end;
    end;

  begin
    if Parser.Token in [toString, toWString] then
      Writer.WriteWideString(CombineWideString)
    else
    begin
      case Parser.Token of
        toSymbol:
          Writer.WriteIdent(Parser.TokenComponentIdent);
        toInteger:
          Writer.WriteInteger(Parser.TokenInt);
        toFloat:
          begin
            case Parser.FloatType of
              's', 'S': Writer.WriteSingle(Parser.TokenFloat);
              'c', 'C': Writer.WriteCurrency(Parser.TokenFloat / 10000);
              'd', 'D': Writer.WriteDate(Parser.TokenFloat);
            else
              Writer.WriteFloat(Parser.TokenFloat);
            end;
          end;
        '[':
          begin
            Parser.NextToken;
            Writer.WriteValue(vaSet);
            if Parser.Token <> ']' then
              while True do
              begin
                TokenStr := Parser.TokenString;
                case Parser.Token of
                  toInteger: begin end;
                  toString,toWString: TokenStr := '#'+IntToStr(Ord(TokenStr[1]));
                  else
                    Parser.CheckToken(toSymbol);
                end;   
                Writer.WriteStr(TokenStr);
                if Parser.NextToken = ']' then
                  Break;
                Parser.CheckToken(',');
                Parser.NextToken;
              end;
            Writer.WriteStr('');
          end;
        '(':
          begin
            Parser.NextToken;
            Writer.WriteListBegin;
            while Parser.Token <> ')' do
              ConvertValue;
            Writer.WriteListEnd;
          end;
        '{':
          Writer.WriteBinary(Parser.HexToBinary);
        '<':
          begin
            Parser.NextToken;
            Writer.WriteValue(vaCollection);
            while Parser.Token <> '>' do
            begin
              Parser.CheckTokenSymbol('item');
              Parser.NextToken;
              Order := ConvertOrderModifier;
              if Order <> -1 then
                Writer.WriteInteger(Order);
              Writer.WriteListBegin;
              while not Parser.TokenSymbolIs('end') do
                ConvertProperty;
              Writer.WriteListEnd;
              Parser.NextToken;
            end;
            Writer.WriteListEnd;
          end;
      else
        Parser.Error(SInvalidProperty);
      end;
      Parser.NextToken;
    end;
  end;

  procedure ConvertProperty;
  var
    PropName: string;
  begin
    Parser.CheckToken(toSymbol);
    PropName := Parser.TokenString;
    Parser.NextToken;
    while Parser.Token = '.' do
    begin
      Parser.NextToken;
      Parser.CheckToken(toSymbol);
      PropName := PropName + '.' + Parser.TokenString;
      Parser.NextToken;
    end;
    Writer.WriteStr(PropName);
    Parser.CheckToken('=');
    Parser.NextToken;
    ConvertValue;
  end;

  procedure ConvertObject;
  var
    InheritedObject: Boolean;
    InlineObject: Boolean;
  begin
    InheritedObject := False;
    InlineObject := False;
    if Parser.TokenSymbolIs('INHERITED') then
      InheritedObject := True
    else if Parser.TokenSymbolIs('INLINE') then
      InlineObject := True
    else
      Parser.CheckTokenSymbol('OBJECT');
    Parser.NextToken;
    ConvertHeader(InheritedObject, InlineObject);
    while not Parser.TokenSymbolIs('END') and
          not Parser.TokenSymbolIs('OBJECT') and
          not Parser.TokenSymbolIs('INHERITED') and
          not Parser.TokenSymbolIs('INLINE') do
      ConvertProperty;
    Writer.WriteListEnd;
    while not Parser.TokenSymbolIs('END') do
      ConvertObject;
    Writer.WriteListEnd;
    Parser.NextToken;
  end;

begin
  Parser := TParser.Create(Input);
  SaveDecimalSeparator := DecimalSeparator;
  SaveThousandSeparator := ThousandSeparator;
  DecimalSeparator := '.';
  ThousandSeparator := ',';
  try
    Writer := TWriter.Create(Output, 4096);
    try
      Writer.WriteSignature;
      ConvertObject;
    finally
      Writer.Free;
    end;
  finally
    DecimalSeparator := SaveDecimalSeparator;
    ThousandSeparator := SaveThousandSeparator;
    Parser.Free;
  end;
end;

procedure ObjectTextToBinary(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat);
begin
  InternalTextToBinary(Input, Output, OriginalFormat, ObjectTextToBinary,
    Integer(FilerSignature), sizeof(Integer));
end;

{ Resource to text conversion }

procedure ObjectResourceToText(Input, Output: TStream);
begin
  Input.ReadResHeader;
  ObjectBinaryToText(Input, Output);
end;

procedure ObjectResourceToText(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat);
begin
  InternalBinaryToText(Input, Output, OriginalFormat, ObjectResourceToText, $FF, 1);
end;

{ Text to resource conversion }

procedure ObjectTextToResource(Input, Output: TStream);

  procedure NameLengthError(Len: Byte; Stream: TStream);
  var
    Buffer: array of Byte;
  begin
    SetLength(Buffer, Len);
    Stream.Read(Buffer, Len);
    raise EParserError.CreateFmt(SComponentNameTooLong, [StringOf(Buffer)]);
  end;

var
  Len: Byte;
  Tmp: Longint;
  MemoryStream: TMemoryStream;
  MemorySize: Longint;
  Header: array[0..79] of Byte;
  I: Integer;
begin
  MemoryStream := TMemoryStream.Create;
  try
    ObjectTextToBinary(Input, MemoryStream);
    MemorySize := MemoryStream.Size;
    MemoryStream.Position := SizeOf(Longint); { Skip header }
    MemoryStream.Read(Len, 1);

    { Skip over object prefix if it is present }
    if Len and $F0 = $F0 then
    begin
      if ffChildPos in TFilerFlags((Len and $F0)) then
      begin
        MemoryStream.Read(Len, 1);
        case TValueType(Len) of
          vaInt8: Len := 1;
          vaInt16: Len := 2;
          vaInt32: Len := 4;
        end;
        MemoryStream.Read(Tmp, Len);
      end;
      MemoryStream.Read(Len, 1);
    end;

    if Len > High(Header) - 10 then
      NameLengthError(Len, MemoryStream);
    MemoryStream.Read(Header, 3, Len);
    for I := 3 to Len + 2 do
      if AnsiChar(Header[I]) in ['a'..'z'] then
        Dec(Header[I], Byte('a') - Byte('A'));
    Header[0] := $FF;
    Header[1] := 10;
    Header[2] := 0;
    Header[Len + 4] := $30;
    Header[Len + 5] := $10;
    Header[Len + 6] := Byte(MemorySize and $FF);
    Header[Len + 7] := Byte((MemorySize shr 8) and $FF);
    Header[Len + 8] := Byte((MemorySize shr 16) and $FF);
    Header[Len + 9] := Byte((MemorySize shr 24) and $FF);
    Output.Write(Header, Len + 10);
    Output.Write(MemoryStream.Memory, MemorySize);
  finally
    MemoryStream.Free;
  end;
end;

procedure ObjectTextToResource(Input, Output: TStream;
  var OriginalFormat: TStreamOriginalFormat);
begin
  InternalTextToBinary(Input, Output, OriginalFormat, ObjectTextToResource, $FF, 1);
end;

function TestStreamFormat(Stream: TStream): TStreamOriginalFormat;
var
  Pos: Integer;
  Signature: Cardinal;
begin
  Pos := Stream.Position;
  Signature := 0;
  Stream.Read(Signature, SizeOf(Signature));
  Stream.Position := Pos;
  if (Byte(Signature) = $FF) or (Signature = FilerSignature) then
    Result := sofBinary
    // text format may begin with "object", "inherited", or whitespace
  else if AnsiChar(Signature) in ['o','O','i','I',' ',#13,#11,#9] then
    Result := sofText
  else
    Result := sofUnknown;
end;

{ TThread }

type
  TSyncProc = record
    SyncRec: TSynchronizeRecord;
    Queued: Boolean;
    Signal: ManualResetEvent;
  end;

var
  SyncList: TList;
  ThreadLock: TObject;
//  ThreadCount: Integer;


procedure InitThreadSynchronization;
begin
  ThreadLock := TObject.Create;
  SyncEvent := System.Threading.ManualResetEvent.Create(False);
  if SyncEvent.Handle = nil then
    RaiseLastOSError;
end;

procedure DoneThreadSynchronization;
begin
  FreeAndNil(ThreadLock);
  SyncEvent.Close;
end;

procedure ResetSyncEvent;
begin
  SyncEvent.Reset;
end;

procedure WaitForSyncEvent(Timeout: Integer);
begin
  if SyncEvent.WaitOne(Timeout, True) then
    ResetSyncEvent;
end;

procedure SignalSyncEvent;
begin
  SyncEvent.&Set;
end;

                                   
(*
procedure AddThread;
begin
  InterlockedIncrement(ThreadCount);
end;

procedure RemoveThread;
begin
  InterlockedDecrement(ThreadCount);
end;
*)

function CheckSynchronize(Timeout: Integer = 0): Boolean;
var
  SyncProc: TSyncProc;
  LocalSyncList: TList;
begin
  if System.Threading.Thread.CurrentThread <> MainThread then
    raise EThread.Create(SCheckSynchronizeError);
  if Timeout > 0 then
    WaitForSyncEvent(Timeout)
  else
    ResetSyncEvent;
  LocalSyncList := nil;
  System.Threading.Monitor.Enter(ThreadLock);
  try
    if SyncList <> nil then
    begin
      System.Threading.Monitor.Enter(SyncList);
//      Integer(LocalSyncList) := InterlockedExchange(Integer(SyncList), Integer(LocalSyncList));
      LocalSyncList := SyncList;
      SyncList := LocalSyncList;
      System.Threading.Monitor.Exit(LocalSyncList);
    end;
    try
      Result := (LocalSyncList <> nil) and (LocalSyncList.Count > 0);
      if Result then
      begin
        while LocalSyncList.Count > 0 do
        begin
          SyncProc := TSyncProc(LocalSyncList[0]);
          LocalSyncList.Delete(0);
          System.Threading.Monitor.Exit(ThreadLock);
          try
            try
              SyncProc.SyncRec.FMethod;
            except
              on E: Exception do
                SyncProc.SyncRec.FSynchronizeException := E;
            end;
          finally
            System.Threading.Monitor.Enter(ThreadLock);
          end;
          if not SyncProc.Queued then
            SyncProc.Signal.&Set;
        end;
      end;
    finally
      LocalSyncList.Free;
    end;
  finally
    System.Threading.Monitor.Exit(ThreadLock);
  end;
end;

type
  TThreadRunner = class
    FThread: TThread;
  public
    constructor Create(AThread: TThread);
    procedure ThreadProc;
    procedure Initialize; virtual;
  end;

constructor TThreadRunner.Create(AThread: TThread);
begin
  inherited Create;
  FThread := AThread;
end;

procedure TThreadRunner.ThreadProc;
var
  FreeThread: Boolean;
begin
  try
    if not FThread.Terminated then
    try
      Initialize;
      FThread.Execute;
    except
      on E: Exception do
        FThread.FFatalException := E;
    end;
  finally
    FreeThread := FThread.FFreeOnTerminate;
    FThread.DoTerminate;
    FThread.FFinished := True;
    SignalSyncEvent;
    if FreeThread then FThread.Free;
  end;
end;

procedure TThreadRunner.Initialize;
begin
end;

constructor TThread.Create(CreateSuspended: Boolean);
begin
  inherited Create;
//  AddThread;
  FSuspended := CreateSuspended;
  FCreateSuspended := CreateSuspended;
  Initialize;
end;

procedure TThread.Initialize;
var
  Runner: TThreadRunner;
begin
  Runner := TThreadRunner.Create(self);
  FHandle := System.Threading.Thread.Create(@Runner.ThreadProc);
  if not FCreateSuspended then
  begin
    FStarted := True;
    FHandle.Start;
  end
  else
    FSuspendCount := 1;
end;

destructor TThread.Destroy;
begin
  if (FHandle <> nil) and FStarted and not FFinished then
  begin
    Terminate;
    if not FHandle.IsAlive then
      Resume;
    WaitFor;
  end;
  RemoveQueuedEvents(Self, nil);
  FHandle := nil;
  FFatalException.Free;
  inherited Destroy;
//  RemoveThread;
end;

procedure TThread.ThreadError(O: TObject);
var
  S: string;
begin
  if Assigned(O) then
  begin
    if O is Exception then
      S := Exception(O).Message
    else
      S := O.ToString;
    raise EThread.CreateFmt(SThreadError, [S]);
  end;
end;

procedure TThread.CallOnTerminate;
begin
  if Assigned(FOnTerminate) then FOnTerminate(Self);
end;

procedure TThread.DoTerminate;
begin
  if Assigned(FOnTerminate) then Synchronize(CallOnTerminate);
end;

const
  Priorities: array [TThreadPriority] of System.Threading.ThreadPriority =
   (System.Threading.ThreadPriority.Lowest,
    System.Threading.ThreadPriority.BelowNormal,
    System.Threading.ThreadPriority.Normal,
    System.Threading.ThreadPriority.AboveNormal,
    System.Threading.ThreadPriority.Highest);

function TThread.GetPriority: TThreadPriority;
var
  P: System.Threading.ThreadPriority;
  I: TThreadPriority;
begin
  try
    P := FHandle.Priority;

    Result := tpNormal;
    for I := Low(TThreadPriority) to High(TThreadPriority) do
      if Priorities[I] = P then
      begin
        Result := I;
        Break;
      end;
  except
    on E: Exception do
      ThreadError(E);
  end;
end;

procedure TThread.SetPriority(Value: TThreadPriority);
begin
  try
    FHandle.Priority := Priorities[Value];
  except
    on E: Exception do
      ThreadError(E);
  end;
end;

procedure TThread.Queue(AMethod: TThreadMethod);
var
  LSynchronize: TSynchronizeRecord;
begin
  LSynchronize.FThread := Self;
  LSynchronize.FSynchronizeException := nil;
  LSynchronize.FMethod := AMethod;
  Synchronize(LSynchronize, True);
end;

class procedure TThread.Queue(AThread: TThread; AMethod: TThreadMethod);
var
  LSynchronize: TSynchronizeRecord;
begin
  if AThread <> nil then
    AThread.Queue(AMethod)
  else
  begin
    LSynchronize.FThread := nil;
    LSynchronize.FSynchronizeException := nil;
    LSynchronize.FMethod := AMethod;
    Synchronize(LSynchronize, True);
  end;
end;

class procedure TThread.RemoveQueuedEvents(AThread: TThread; AMethod: TThreadMethod);
var
  I: Integer;
  SyncProc: TSyncProc;
begin
  System.Threading.Monitor.Enter(ThreadLock);
  try
    if SyncList <> nil then
      for I := SyncList.Count - 1 downto 0 do
      begin
        SyncProc := TSyncProc(SyncList[I]);
        if (SyncProc.Signal = nil) and
          (((AThread <> nil) and (SyncProc.SyncRec.FThread = AThread)) or
            (Assigned(AMethod) and TObject(@AMethod).Equals(TObject(@SyncProc.SyncRec.FMethod)))) then
          SyncList.Delete(I);
      end;
  finally
    System.Threading.Monitor.Exit(ThreadLock);
  end;
end;

class procedure TThread.StaticQueue(AThread: TThread; AMethod: TThreadMethod);
begin
  Queue(AThread, AMethod);
end;

class procedure TThread.Synchronize(ASyncRec: TSynchronizeRecord; QueueEvent: Boolean = False);
var
  SyncProc: TSyncProc;
begin
  if System.Threading.Thread.CurrentThread = MainThread then
    ASyncRec.FMethod
  else
  begin
    if not QueueEvent then
      SyncProc.Signal := System.Threading.ManualResetEvent.Create(False)
    else
      SyncProc.Signal := nil;
    try
      System.Threading.Monitor.Enter(ThreadLock);
      try
        SyncProc.Queued := QueueEvent; 
        if SyncList = nil then
          SyncList := TList.Create;
        SyncProc.SyncRec := ASyncRec;
        System.Threading.Monitor.Enter(SyncList);
        try
          SyncList.Add(TObject(SyncProc));
        finally
          System.Threading.Monitor.Exit(SyncList);
        end;
        SignalSyncEvent;
        if Assigned(WakeMainThread) then
          WakeMainThread(SyncProc.SyncRec.FThread);
        if not QueueEvent then
        begin 
          System.Threading.Monitor.Exit(ThreadLock);
          try
            SyncProc.Signal.WaitOne;
          finally
            System.Threading.Monitor.Enter(ThreadLock);
          end;
        end;
      finally
        System.Threading.Monitor.Exit(ThreadLock);
      end;
    finally
      if not QueueEvent then
        SyncProc.Signal.Close;
    end;
    if not QueueEvent and Assigned(ASyncRec.FSynchronizeException) then 
      raise ASyncRec.FSynchronizeException;
  end;
end;

procedure TThread.Synchronize(Method: TThreadMethod);
begin
  FSynchronize.FThread := Self;
  FSynchronize.FSynchronizeException := nil;
  FSynchronize.FMethod := Method;
  Synchronize(FSynchronize);
end;

(*
class procedure TThread.Synchronize(AThread: TThread; AMethod: TThreadMethod);
var
  SyncRec: TSynchronizeRecord;
begin
  if AThread <> nil then
    AThread.Synchronize(AMethod)
  else
  begin
    SyncRec.FThread := nil;
    SyncRec.FSynchronizeException := nil;
    SyncRec.FMethod := AMethod;
    TThread.Synchronize(SyncRec);
  end;
end;

class procedure TThread.StaticSynchronize(AThread: TThread; AMethod: TThreadMethod);
begin
  Synchronize(AThread, AMethod);
end;
*)

procedure TThread.SetSuspended(Value: Boolean);
begin
  if Value <> FSuspended then
    if Value then
      Suspend
    else
      Resume;
end;

procedure TThread.Suspend;
var
  OldSuspend: Boolean;
begin
  OldSuspend := FSuspended;
  try
    System.Threading.Monitor.Enter(self);
    try
      FSuspended := True;
      FHandle.Suspend;
      Inc(FSuspendCount);
    finally
      System.Threading.Monitor.Exit(self);
    end;
  except
    on E: Exception do
    begin
      FSuspended := OldSuspend;
      ThreadError(E);
    end;
  end;
end;

procedure TThread.Resume;
begin
  if FSuspendCount > 0 then
  begin
    System.Threading.Monitor.Enter(self);
    try
      Dec(FSuspendCount);
      if FSuspendCount = 0 then
      begin
        if not FStarted then
          FHandle.Start
        else
          FHandle.Resume;
        FSuspended := False;
      end;
    finally
      System.Threading.Monitor.Exit(self);
    end;
  end;
end;

procedure TThread.Terminate;
begin
  FTerminated := True;
end;

function TThread.WaitFor: LongWord;
begin
  WaitFor(System.Threading.Timeout.Infinite, Result);
end;

function TThread.WaitFor(TimeOut: Integer; var ReturnValue: LongWord): Boolean;
begin
  Result := False;
  try
    if (TimeOut = System.Threading.Timeout.Infinite) and
       (System.Threading.Thread.CurrentThread = MainThread) then
    begin
      while True do
      begin
      { This prevents a potential deadlock if the background thread
        does a Synchronize to the foreground thread }
        Result := FHandle.Join(500);
        if Result then
        begin
          ReturnValue := FReturnValue;
          Exit;
        end;
        if SyncEvent.WaitOne(500, True) then
          CheckSynchronize;
                                                                   
                                                                   
                                                               
                                                                       
                                                                          
                          
      end
    end else
    begin
      Result := FHandle.Join(Timeout);
      if Result then
        ReturnValue := FReturnValue;
    end;
  except
    on E: Exception do
      ThreadError(E);
  end;
end;

{TWin32Thread}

type
  TWin32ThreadRunner = class(TThreadRunner)
  private
    FSignal: System.Threading.ManualResetEvent;
  public
    constructor Create(AThread: TThread);
    procedure Initialize; override;
  end;

constructor TWin32ThreadRunner.Create(AThread: TThread);
begin
  inherited Create(AThread);
  FSignal := System.Threading.ManualResetEvent.Create(False);
end;

procedure TWin32ThreadRunner.Initialize;
begin
  if FThread is TWin32Thread then
    with FThread as TWin32Thread do
      FThreadID := GetCurrentThreadID;
  FSignal.&Set;
end;


procedure TWin32Thread.Initialize;
var
  Runner: TWin32ThreadRunner;
begin
  Runner := TWin32ThreadRunner.Create(self);
  FHandle := System.Threading.Thread.Create(@Runner.ThreadProc);
  FStarted := True;
  FHandle.Start;
  Runner.FSignal.WaitOne; // don't return til we have a thread ID
  if FCreateSuspended then
    Suspend;
  Runner.FSignal.Close;
end;

threadvar
  GDesigning: Boolean;
  GInline: Boolean;
  GDesignInstance: Boolean;

{ TComponentSite }

constructor TComponentSite.Create(AInstance, AOwner: TComponent);
begin
  inherited Create;
  if Assigned(AInstance) then
    FComponent := AInstance as IComponent
  else
    FComponent := nil;
  FOwner := AOwner;
  FName := '';
  if GDesigning then
    Include(FComponentState, csDesigning);
  if GDesignInstance then
    Include(FComponentState, csDesignInstance);
  if GInline then
    Include(FComponentState, csInline);
  GDesigning := False;
  GDesignInstance := False;
  GInline := False;
  FDesignMode := csDesigning in FComponentState;
end;

function TComponentSite.get_Container: IContainer;
begin
  if Assigned(FOwner) and (FOwner.Site is IContainer) then
    Result := FOwner.Site as IContainer
  else
    Result := nil;
end;

function TComponentSite.GetService(serviceType: System.Type): TObject;
begin
                             
  Result := nil;
end;

procedure TComponentSite.Add(Component: IComponent);
begin
  TComponent(TObject(FComponent)).InsertComponent(TComponent(TObject(Component)));
end;

procedure TComponentSite.Add(Component: IComponent; Name: string);
var
  C: TComponent;
begin
  C := TComponent(TObject(Component));
  C.Name := Name;
  Add(Component);
end;

procedure TComponentSite.Remove(Component: IComponent);
begin
  TComponent(TObject(FComponent)).RemoveComponent(TComponent(TObject(Component)));
end;

function TComponentSite.Get_Components: ComponentCollection;
var
  Components: array of IComponent;
  I: Integer;
begin
  SetLength(Components, FComponents.Count);
  for I := 0 to FComponents.Count - 1 do
    Components[I] := FComponents[I] as IComponent;
  Result := ComponentCollection.Create(Components);
end;

{ TComponentHelper }

constructor TComponentHelper.Create(AOwner: TComponent);
begin
  inherited Create;
  FComponentStyle := [csInheritable];
  if AOwner <> nil then
    AOwner.InsertComponent(Self);
  add_Disposed(HandleDisposed);
end;

procedure TComponentHelper.HandleDisposed(Sender: TObject; Args: EventArgs);
begin
  Destroying;
  if FFreeNotifies <> nil then
  begin
    while Assigned(FFreeNotifies) and (FFreeNotifies.Count > 0) do
      TComponent(FFreeNotifies[FFreeNotifies.Count - 1]).Notification(Self, opRemove);
  end;
  DestroyComponents;
  if Owner <> nil then
    Owner.RemoveComponent(Self);
end;

function TComponentHelper.GetSiteObject: TComponentSite;
begin
  if Site = nil then
    Site := TComponentSite.Create(Self, nil);
  if TObject(Site) is TComponentSite then
    Result := TObject(Site) as TComponentSite
  else
    Result := TComponentSite.Create(Self, nil);
end;

procedure TComponentHelper.FreeNotification(AComponent: TComponent);
begin
  if (Owner = nil) or (AComponent.Owner <> Owner) then
  begin
    // Never acquire a reference to a component that is being deleted.
    assert(not (csDestroying in (ComponentState + AComponent.ComponentState)));
    if not Assigned(FFreeNotifies) then
      FFreeNotifies := TList.Create;
    if FFreeNotifies.IndexOf(AComponent) < 0 then
    begin
      FFreeNotifies.Add(AComponent);
      AComponent.FreeNotification(Self);
    end;
  end;
  FComponentState := FComponentState + [csFreeNotification];
end;

procedure TComponentHelper.ReadLeft(Reader: TReader);
begin
  with GetSiteObject do
    FDesignInfo := (FDesignInfo and $FFFF) or (Reader.ReadInteger shl 16);
end;

procedure TComponentHelper.ReadTop(Reader: TReader);
begin
  with GetSiteObject do
    FDesignInfo := (FDesignInfo and Integer($FFFF0000)) or (Reader.ReadInteger and $FFFF);
end;

procedure TComponentHelper.WriteLeft(Writer: TWriter);
begin
  with GetSiteObject do
    Writer.WriteInteger(FDesignInfo shr 16);
end;

procedure TComponentHelper.WriteTop(Writer: TWriter);
begin
  with GetSiteObject do
    Writer.WriteInteger(FDesignInfo and $FFFF);
end;

procedure TComponentHelper.Insert(AComponent: TComponent);
begin
  with GetSiteObject do
  begin
    if FComponents = nil then
      FComponents := TList.Create;
    FComponents.Add(AComponent);
    with AComponent.GetSiteObject do
      FOwner := Self;
  end;
end;

procedure TComponentHelper.Remove(AComponent: TComponent);
begin
  with AComponent.GetSiteObject do
    FOwner := nil;
  with GetSiteObject do
  begin
    FComponents.Remove(AComponent);
    if FComponents.Count = 0 then
    begin
      FComponents.Free;
      FComponents := nil;
    end;
  end;
end;

procedure TComponentHelper.InsertComponent(AComponent: TComponent);
begin
  AComponent.ValidateContainer(Self);
  ValidateRename(AComponent, '', AComponent.Name);
  Insert(AComponent);
  AComponent.SetReference(True);
  if csDesigning in ComponentState then
    AComponent.SetDesigning(True);
  Notification(AComponent, opInsert);
end;

procedure TComponentHelper.RemoveComponent(AComponent: TComponent);
begin
  ValidateRename(AComponent, AComponent.Name, '');
  Notification(AComponent, opRemove);
  AComponent.SetReference(False);
  Remove(AComponent);
end;

procedure TComponentHelper.DestroyComponents;
var
  Instance: TComponent;
  LSite: TComponentSite;
begin
  LSite := GetSiteObject;
  while LSite.FComponents <> nil do
  begin
    Instance := TComponent(LSite.FComponents.Last);
    if (csFreeNotification in Instance.FComponentState)
      or (LSite.FComponentState * [csDesigning, csInline] = [csDesigning, csInline]) then
      RemoveComponent(Instance)
    else
      Remove(Instance);
    Instance.Free;
  end;
end;

procedure TComponentHelper.Destroying;
var
  I: Integer;
begin
  if not (csDestroying in FComponentState) then
  begin
    FComponentState := FComponentState + [csDestroying];
    with GetSiteObject do
      if FComponents <> nil then
        for I := 0 to FComponents.Count - 1 do
          TComponent(FComponents[I]).Destroying;
  end;
end;

procedure TComponentHelper.RemoveNotification(AComponent: TComponent);
begin
  with GetSiteObject do
    if FFreeNotifies <> nil then
    begin
      FFreeNotifies.Remove(AComponent);
      if FFreeNotifies.Count = 0 then
      begin
        FFreeNotifies.Free;
        FFreeNotifies := nil;
      end;
    end;
end;

procedure TComponentHelper.RemoveFreeNotification(AComponent: TComponent);
begin
  RemoveNotification(AComponent);
  AComponent.RemoveNotification(Self);
end;

procedure TComponentHelper.Notification(AComponent: TComponent;
  Operation: TOperation);
var
  I: Integer;
begin
  if (Operation = opRemove) and (AComponent <> nil) then
    RemoveFreeNotification(AComponent);
  with GetSiteObject do
    if FComponents <> nil then
    begin
      I := FComponents.Count - 1;
      while I >= 0 do
      begin
        TComponent(FComponents[I]).Notification(AComponent, Operation);
        Dec(I);
        if I >= FComponents.Count then
          I := FComponents.Count - 1;
      end;
    end;
end;

function SendNotification(ASender, AComponent: TComponent; Operation: TOperation): Boolean;
begin
  with ASender do

    // if the sender has an owner and we have not notified already then do so
    if (Owner <> nil) and (not (csNotificationSent in Owner.ComponentState) and
       (not (csInline in ComponentState) or OwnedBy(AComponent, ASender))) then
    begin

      // caller should NOT attempt any inherited notification
      Owner.SetComponentState(Owner.ComponentState + [csNotificationSent]);
      try
        Owner.Notification(AComponent, Operation);
        Result := False;
      finally
        Owner.SetComponentState(Owner.ComponentState - [csNotificationSent]);
      end;
    end

    // caller should continue with normal notification behavior
    else
      Result := True;
end;

procedure TComponentHelper.DefineProperties(Filer: TFiler);
var
  Ancestor: TComponent;
  AncestorInfo: Longint;
  DesignInfo: Longint;
begin
  AncestorInfo := 0;
  DesignInfo := GetSiteObject.FDesignInfo;
  Ancestor := TComponent(Filer.Ancestor);
  if Ancestor <> nil then
    AncestorInfo := Ancestor.GetSiteObject.FDesignInfo;
  Filer.DefineProperty('Left', ReadLeft, WriteLeft, (DesignInfo and $FFFF) <>
    (AncestorInfo and $FFFF));
  Filer.DefineProperty('Top', ReadTop, WriteTop, (DesignInfo shr 16) <>
    (AncestorInfo shl 16));
end;

function TComponentHelper.HasParent: Boolean;
begin
  Result := False;
end;

procedure TComponentHelper.GetChildren(Proc: TGetChildProc; Root: TComponent);
begin
end;

function TComponentHelper.GetChildOwner: TComponent;
begin
  Result := nil;
end;

function TComponentHelper.GetChildParent: TComponent;
begin
  Result := Self;
end;

function TComponentHelper.GetNamePath: string;
begin
  Result := Site.Name;
end;

function TComponentHelper.GetOwner: TPersistent;
begin
  Result := Owner;
end;

procedure TComponentHelper.SetChildOrder(Child: TComponent; Order: Integer);
begin
end;

function TComponentHelper.GetParentComponent: TComponent;
begin
  Result := nil;
end;

procedure TComponentHelper.SetParentComponent(Value: TComponent);
begin
end;

procedure TComponentHelper.Updating;
begin
  FComponentState := FComponentState + [csUpdating];
end;

procedure TComponentHelper.Updated;
begin
  FComponentState := FComponentState - [csUpdating];
end;

procedure TComponentHelper.Loaded;
begin
  FComponentState := FComponentState - [csLoading];
end;

procedure TComponentHelper.PaletteCreated;
begin
  // Notification
end;

procedure TComponentHelper.ReadState(Reader: TReader);
begin
  Reader.ReadData(Self);
end;

procedure TComponentHelper.WriteState(Writer: TWriter);
begin
  Writer.WriteData(Self);
end;

procedure TComponentHelper.ValidateRename(AComponent: TComponent;
  const CurName, NewName: string);
begin
  if (AComponent <> nil) and not SameText(CurName, NewName) and
    (AComponent.Owner = Self) and (FindComponent(NewName) <> nil) then
    raise EComponentError.CreateFmt(SDuplicateName, [NewName]);
  if (csDesigning in ComponentState) and (Owner <> nil) then
    Owner.ValidateRename(AComponent, CurName, NewName);
end;

procedure TComponentHelper.ValidateContainer(AComponent: TComponent);
begin
  AComponent.ValidateInsert(Self);
end;

procedure TComponentHelper.ValidateInsert(AComponent: TComponent);
begin
end;

function TComponentHelper.FindComponent(const AName: string): TComponent;
var
  I: Integer;
begin
  if AName <> '' then
    with GetSiteObject do
      if FComponents <> nil then
        for I := 0 to FComponents.Count - 1 do
        begin
          Result := TComponent(FComponents[I]);
          if SameText(Result.Name, AName) then
            Exit;
        end;
  Result := nil;
end;

procedure TComponentHelper.SetName(const NewName: TComponentName);
begin
  if Name <> NewName then
  begin
    if (NewName <> '') and not IsValidIdent(NewName) then
      raise EComponentError.CreateFmt(SInvalidName, [NewName]);
    if Owner <> nil then
      Owner.ValidateRename(Self, Name, NewName)
    else
      ValidateRename(nil, Name, NewName);
    SetReference(False);
    ChangeName(NewName);
    SetReference(True);
  end;
end;

procedure TComponentHelper.ChangeName(const NewName: TComponentName);
begin
  GetSiteObject.Name := NewName;
end;

function TComponentHelper.GetComponentIndex: Integer;
begin
  Result := -1;
  if Owner <> nil then
    with Owner.GetSiteObject do
      if FComponents <> nil then
        Result := FComponents.IndexOf(Self);
end;

function TComponentHelper.GetComponentState: TComponentState;
begin
  Result := GetSiteObject.FComponentState;
end;

function TComponentHelper.GetComponentStyle: TComponentStyle;
begin
  Result := GetSiteObject.FComponentStyle;
end;

function TComponentHelper.GetDesignInfo: Integer;
begin
  Result := GetSiteObject.FDesignInfo;
end;

function TComponentHelper.GetName: TComponentName;
begin
  Result := GetSiteObject.FName;
end;

function TComponentHelper.GetSelfOwner: TComponent;
begin
  Result := GetSiteObject.FOwner;
end;

function TComponentHelper.GetTag: TTag;
begin
  Result := GetSiteObject.FTag;
end;

function TComponentHelper.GetComponents(Index: Integer): TComponent;
begin
  with GetSiteObject do
  begin
    if FComponents = nil then
      TList.Error(SListIndexError, Index);
    Result := TComponent(FComponents[Index]);
  end;
end;

function TComponentHelper.GetComponentCount: Integer;
begin
  with GetSiteObject do
    if FComponents <> nil then
      Result := FComponents.Count
    else
      Result := 0;
end;

procedure TComponentHelper.SetComponentIndex(Value: Integer);
var
  I, Count: Integer;
  Components: TList;
begin
  with GetSiteObject do
  begin
    Components := Owner.GetSiteObject.FComponents;
    I := Components.IndexOf(Self);
    if I >= 0 then
    begin
      Count := Components.Count;
      if Value < 0 then
        Value := 0;
      if Value >= Count then
        Value := Count - 1;
      if Value <> I then
      begin
        Components.Delete(I);
        Components.Insert(Value, Self);
      end;
    end;
  end;
end;

procedure TComponentHelper.SetComponentStyle(Value: TComponentStyle);
begin
  GetSiteObject.FComponentStyle := Value;
end;

procedure TComponentHelper.SetComponentState(Value: TComponentState);
begin
  GetSiteObject.FComponentState := Value;
end;

procedure TComponentHelper.SetDesignInfo(Value: Integer);
begin
  GetSiteObject.FDesignInfo := Value;
end;

procedure TComponentHelper.SetTag(Value: TTag);
begin
  GetSiteObject.FTag := Value;
end;

function TComponentHelper.GetFFreeNotifies: TList;
begin
  Result := GetSiteObject.FFreeNotifies;
end;

procedure TComponentHelper.SetFFreeNotifies(Value: TList);
begin
  GetSiteObject.FFreeNotifies := Value;
end;

procedure TComponentHelper.SetAncestor(Value: Boolean);
var
  I: Integer;
begin
  if Value then
    FComponentState := FComponentState + [csAncestor]
  else
    FComponentState := FComponentState - [csAncestor];
  for I := 0 to ComponentCount - 1 do
    Components[I].SetAncestor(Value);
end;

procedure TComponentHelper.SetDesigning(Value, SetChildren: Boolean);
var
  I: Integer;
begin
  if Value then
    FComponentState := FComponentState + [csDesigning]
  else
    FComponentState := FComponentState - [csDesigning];
  if SetChildren then
    for I := 0 to ComponentCount - 1 do
      Components[I].SetDesigning(Value);
end;

procedure TComponentHelper.SetInline(Value: Boolean);
begin
  if Value then
    FComponentState := FComponentState + [csInline]
  else
    FComponentState := FComponentState - [csInline];
end;

procedure TComponentHelper.SetDesignInstance(Value: Boolean);
begin
  if Value then
    FComponentState := FComponentState + [csDesignInstance]
  else
    FComponentState := FComponentState - [csDesignInstance];
end;

procedure TComponentHelper.SetReference(Enable: Boolean);
var
  Field: FieldInfo;
begin
  if Owner <> nil then
  begin
    Field := FieldInfo(Owner.FieldAddress(Name));
    if Field <> nil then
      if Enable then
        Field.SetValue(Owner, Self)
      else
        Field.SetValue(Owner, nil);
  end;
end;

function TComponentHelper.ExecuteAction(Action: TBasicAction): Boolean;
begin
  Result := Action.HandlesTarget(Self);
  if Result then
    Action.ExecuteTarget(Self);
end;

function TComponentHelper.UpdateAction(Action: TBasicAction): Boolean;
begin
  Result := Action.HandlesTarget(Self);
  if Result then
    Action.UpdateTarget(Self);
end;

procedure TComponentHelper.SetSubComponent(IsSubComponent: Boolean);
begin
  if IsSubComponent then
    FComponentStyle := FComponentStyle + [csSubComponent]
  else
    FComponentStyle := FComponentStyle - [csSubComponent];
end;

class procedure TComponentHelper.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
begin
end;

function TComponentHelper.IsImplementorOf(const I: IInterface): Boolean;
begin
  Result := TObject(I) = Self;
end;

{ TComponent.ReferenceInterface
  Establishes (opInsert) or removes (opRemove) internal links that
  notify us when the component that implements the given interface is
  destroyed.  The function result indicates whether the function was able
  to establish/remove a notification link or not.  A result of False
  doesn't necessarily indicate an error, but it does mean that the
  interface's implementor does not participate in the interfaced component
  reference model.  This could mean that the given interface employs true
  reference counting, independent of component lifetimes.  That doesn't
  affect the use of interface properties at runtime, but non-component
  interfaces cannot be stored by the property streaming system.

  When implementing components with interface-type properties, implement
  setter methods for the interface-type properties like this:

  procedure TMyComponent.SetMyIntfProp(const Value: IMyInterface);
  begin
    ReferenceInterface(FIntfField, opRemove);
    FIntfField := Value;
    ReferenceInterface(FIntfField, opInsert);
  end;

  Also override Notification to do the following for each interface property
  in your component:

  procedure TMyComponent.Notification(AComponent: TComponent; Operation: TOperation);
  begin
    inherited;
    if Assigned(MyIntfProp) and AComponent.IsImplementorOf(MyIntfProp) then
      MyIntfProp := nil;
    ... repeat for other interface properties ...
  end;

  Note that the Notification code assigns nil to the *property*, not to the
  private field, so that the property setter will call
  ReferenceInterface(FIntfField, opRemove to undo any links established by
  a previous opInsert operation.  All assignments to the interface property
  *must* be made through the property setter.

  TComponent.ReferenceInterface hides the details of how links are
  established between the implementor and the holder of an interface.
  The implementation details may change in the future.  Code that relies
  on those implementation details (instead of using ReferenceInterface)
  will not be supported.  In particular, avoid the temptation to use
  IInterfaceComponentReference in your own code, as this interface may
  not be available in the future.
}

function TComponentHelper.ReferenceInterface(const I: IInterface; Operation: TOperation): Boolean;
begin
  Result := TObject(I) is TComponent;
  if Result then
    if Operation = opInsert then
      TComponent(TObject(I)).FreeNotification(Self)
    else
      TComponent(TObject(I)).RemoveFreeNotification(Self);
end;

class procedure TComponentHelper.ChangeComponentName(Instance: TComponent; const NewName: string);
begin
  Instance.ChangeName(NewName);
end;

class procedure TComponentHelper.SetComponentParent(Instance, Parent: TComponent);
begin
  Instance.SetParentComponent(Parent);
end;

{ TBasicActionLink }

constructor TBasicActionLink.Create(AClient: TObject);
begin
  inherited Create;
  AssignClient(AClient);
end;

procedure TBasicActionLink.AssignClient(AClient: TObject);
begin
end;

destructor TBasicActionLink.Destroy;
begin
  if FAction <> nil then
    FAction.UnRegisterChanges(Self);
  inherited Destroy;
end;

procedure TBasicActionLink.Change;
begin
  if Assigned(FOnChange) then
    FOnChange(FAction);
end;

function TBasicActionLink.Execute(AComponent: TComponent): Boolean;
begin
  FAction.ActionComponent := AComponent;
  Result := FAction.Execute;
end;

procedure TBasicActionLink.SetAction(Value: TBasicAction);
begin
  if Value <> FAction then
  begin
    if FAction <> nil then
      FAction.UnRegisterChanges(Self);
    FAction := Value;
    if Value <> nil then
      Value.RegisterChanges(Self);
  end;
end;

function TBasicActionLink.IsOnExecuteLinked: Boolean;
begin
  Result := True;
end;

procedure TBasicActionLink.SetOnExecute(Value: TNotifyEvent);
begin
end;

function TBasicActionLink.Update: Boolean;
begin
  Result := FAction.Update;
end;

{ TBasicAction }

constructor TBasicAction.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FClients := TList.Create;
end;

destructor TBasicAction.Destroy;
begin
  inherited Destroy;
  if Assigned(ActionComponent) then
    ActionComponent.RemoveFreeNotification(Self);
  while FClients.Count > 0 do
    UnRegisterChanges(TBasicActionLink(FClients.Last));
end;

function TBasicAction.HandlesTarget(Target: TObject): Boolean;
begin
  Result := False;
end;

procedure TBasicAction.ExecuteTarget(Target: TObject);
begin
end;

procedure TBasicAction.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = ActionComponent) then
    FActionComponent := nil;
end;

procedure TBasicAction.UpdateTarget(Target: TObject);
begin
end;

function TBasicAction.Execute: Boolean;
begin
  if Assigned(FOnExecute) then
  begin
    FOnExecute(Self);
    Result := True;
  end
  else
    Result := False;
end;

function TBasicAction.Update: Boolean;
begin
  if Assigned(FOnUpdate) then
  begin
    FOnUpdate(Self);
    Result := True;
  end
  else
    Result := False;
end;

procedure TBasicAction.SetOnExecute(Value: TNotifyEvent);
var
  I: Integer;
begin
  for I := 0 to FClients.Count - 1 do
    TBasicActionLink(FClients[I]).SetOnExecute(Value);
  FOnExecute := Value;
  Change;
end;

procedure TBasicAction.Change;
begin
  if Assigned(FOnChange) then
    FOnChange(Self);
end;

procedure TBasicAction.RegisterChanges(Value: TBasicActionLink);
begin
  Value.FAction := Self;
  FClients.Add(Value);
end;

procedure TBasicAction.UnRegisterChanges(Value: TBasicActionLink);
var
  I: Integer;
begin
  for I := 0 to FClients.Count - 1 do
    if FClients[I] = Value then
    begin
      Value.FAction := nil;
      FClients.Delete(I);
      Break;
    end;
end;

procedure TBasicAction.SetActionComponent(const Value: TComponent);
begin
  if FActionComponent <> Value then
  begin
    if Assigned(FActionComponent) then
      FActionComponent.RemoveFreeNotification(Self);
    FActionComponent := Value;
    if Assigned(FActionComponent) then
      FActionComponent.FreeNotification(Self);
  end;
end;

{ TDataModule }

constructor TDataModule.Create(AOwner: TComponent);
var
  Cookie: LockCookie;
begin
  Cookie := GlobalNameSpace.UpgradeToWriterLock(MaxInt);
  try
    CreateNew(AOwner, 0);
    if (ClassType <> TDataModule) and not (csDesigning in ComponentState) then
    begin
      if not InitInheritedComponent(Self, TDataModule) then
        raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
      DoCreate;
    end;
  finally
    GlobalNameSpace.DowngradeFromWriterLock(Cookie);
  end;
end;

constructor TDataModule.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
  inherited Create(AOwner);
  if Assigned(AddDataModule) and (Dummy >= 0) then
    AddDataModule(Self);
end;

destructor TDataModule.Destroy;
var
  Cookie: LockCookie;
begin
  Cookie := GlobalNameSpace.UpgradeToWriterLock(MaxInt);
  try
    DoDestroy;
    if Assigned(RemoveDataModule) then
      RemoveDataModule(Self);
    inherited Destroy;
  finally
    GlobalNameSpace.DowngradeFromWriterLock(Cookie);
  end;
end;

procedure TDataModule.DoCreate;
begin
  if Assigned(FOnCreate) then
  try
    FOnCreate(Self);
  except
    if not HandleCreateException then
      raise;
  end;
end;

procedure TDataModule.DoDestroy;
begin
  if Assigned(FOnDestroy) then
  try
    FOnDestroy(Self);
  except
    if Assigned(ApplicationHandleException) then
      ApplicationHandleException(Self);
  end;
end;

procedure TDataModule.DefineProperties(Filer: TFiler);
var
  Ancestor: TDataModule;

  function DoWriteWidth: Boolean;
  begin
    Result := True;
    if Ancestor <> nil then
      Result := FDesignSize.X <> Ancestor.FDesignSize.X;
  end;

  function DoWriteHorizontalOffset: Boolean;
  begin
    if Ancestor <> nil then
      Result := FDesignOffset.X <> Ancestor.FDesignOffset.X
    else
      Result := FDesignOffset.X <> 0;
  end;

  function DoWriteVerticalOffset: Boolean;
  begin
    if Ancestor <> nil then
      Result := FDesignOffset.Y <> Ancestor.FDesignOffset.Y
    else
      Result := FDesignOffset.Y <> 0;
  end;

  function DoWriteHeight: Boolean;
  begin
    Result := True;
    if Ancestor <> nil then
      Result := FDesignSize.Y <> Ancestor.FDesignSize.Y;
  end;

begin
  inherited DefineProperties(Filer);
  Ancestor := TDataModule(Filer.Ancestor);
  Filer.DefineProperty('Height', ReadHeight, WriteHeight, DoWriteHeight);
  Filer.DefineProperty('HorizontalOffset', ReadHorizontalOffset,
    WriteHorizontalOffset, DoWriteHorizontalOffset);
  Filer.DefineProperty('OldCreateOrder', IgnoreIdent, nil, False);
  Filer.DefineProperty('VerticalOffset', ReadVerticalOffset,
    WriteVerticalOffset, DoWriteVerticalOffset);
  Filer.DefineProperty('Width', ReadWidth, WriteWidth, DoWriteWidth);
end;

procedure TDataModule.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
  I: Integer;
  OwnedComponent: TComponent;
begin
  inherited GetChildren(Proc, Root);
  if Root = Self then
    for I := 0 to ComponentCount - 1 do
    begin
      OwnedComponent := Components[I];
      if not OwnedComponent.HasParent then
        Proc(OwnedComponent);
    end;
end;

function TDataModule.HandleCreateException: Boolean;
begin
  if Assigned(ApplicationHandleException) then
  begin
    ApplicationHandleException(Self);
    Result := True;
  end
  else
    Result := False;
end;

procedure TDataModule.IgnoreIdent(Reader: TReader);
begin
  Reader.ReadIdent;
end;

procedure TDataModule.ReadWidth(Reader: TReader);
begin
  FDesignSize.X := Reader.ReadInteger;
end;

procedure TDataModule.ReadHorizontalOffset(Reader: TReader);
begin
  FDesignOffset.X := Reader.ReadInteger;
end;

procedure TDataModule.ReadVerticalOffset(Reader: TReader);
begin
  FDesignOffset.Y := Reader.ReadInteger;
end;

procedure TDataModule.ReadHeight(Reader: TReader);
begin
  FDesignSize.Y := Reader.ReadInteger;
end;

procedure TDataModule.WriteWidth(Writer: TWriter);
begin
  Writer.WriteInteger(FDesignSize.X);
end;

procedure TDataModule.WriteHorizontalOffset(Writer: TWriter);
begin
  Writer.WriteInteger(FDesignOffset.X);
end;

procedure TDataModule.WriteVerticalOffset(Writer: TWriter);
begin
  Writer.WriteInteger(FDesignOffset.Y);
end;

procedure TDataModule.WriteHeight(Writer: TWriter);
begin
  Writer.WriteInteger(FDesignSize.Y);
end;

procedure SetComponentDesigning(Component: TComponent; Value: Boolean;
  SetChildren: Boolean = True);
begin
  Component.SetDesigning(Value, SetChildren);
end;

procedure SetComponentTransient(Component: TComponent; IsTransient: Boolean);
begin
  if not Assigned(Component) then exit;
  if IsTransient then
    Component.FComponentStyle := Component.FComponentStyle + [csTransient]
  else
    Component.FComponentStyle := Component.FComponentStyle - [csTransient];
end;

procedure HandleBeforeDestruction(AInstance: TObject);
var
  Site: ISite;
  Component: TComponent;
begin
  if AInstance is TComponent then
  begin
    Component := TComponent(AInstance);
    Site := Component.Site;
    if Assigned(Site) and not TObject(Site).InheritsFrom(TComponentSite) then
      Exit;
    Component.Destroying;
  end;
end;

function HandleGetClassName(AType: System.Type; const ASuggestedName: string): string;
begin
  if AType.Equals(TypeOf(TComponent)) then
    Result := 'TComponent' // DO NOT LOCALIZE
  else if AType.Equals(TypeOf(TPersistent)) then
    Result := 'TPersistent' // DO NOT LOCALIZE
  else
    Result := ASuggestedName;
end;

function CreateDesignComponent(ComponentClass: TComponentClass;
  AOwner: TComponent = nil; ADesigning: Boolean = True;
  ADesignInstance: Boolean = False; AInline: Boolean = False): TComponent;
var
  Params: array of System.Type;
  ParamValues: array of TObject;
  ConstructorInfo: System.Reflection.ConstructorInfo;
begin
  GDesigning := ADesigning;
  GInline := AInline;
  GDesignInstance := ADesignInstance;
  try
    SetLength(Params, 1);
    Params[0] := TypeOf(TComponentClass);
    ConstructorInfo := ComponentClass.ClassInfo.GetConstructor(Params);
    if ConstructorInfo <> nil then
    begin
      SetLength(ParamValues, 1);
      ParamValues[0] := AOwner;
      Result := TComponent(ConstructorInfo.Invoke(ParamValues));
    end else
    begin
      SetLength(Params, 0);
      ConstructorInfo := ComponentClass.ClassInfo.GetConstructor(Params);
      if ConstructorInfo <> nil then
      begin
        SetLength(ParamValues, 0);
        Result := TComponent(ConstructorInfo.Invoke(ParamValues));
        if AOwner <> nil then
          AOwner.InsertComponent(Result);
      end else
        Result := nil;
    end;
    if Result <> nil then
      Result.GetSiteObject;
  finally
    GDesigning := False;
    GInline := False;
    GDesignInstance := False;
  end;
end;

initialization
  InitThreadSynchronization;
  GlobalNameSpace := ReaderWriterLock.Create;
  RegGroups := TRegGroups.Create;
  GlobalFixupList := TThreadList.Create;
  Borland.Delphi.System.VCLFreeNotify := @HandleBeforeDestruction;
  Borland.Delphi.System.VCLGetClassName := @HandleGetClassName;
finalization
  DoneThreadSynchronization;

end.
