home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / VCL / CLASSES.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-03  |  166.0 KB  |  6,620 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Classes;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses SysUtils, Windows, ActiveX;
  17.  
  18. const
  19.  
  20. { Maximum TList size }
  21.  
  22.   MaxListSize = Maxint div 16;
  23.  
  24. { TStream seek origins }
  25.  
  26.   soFromBeginning = 0;
  27.   soFromCurrent = 1;
  28.   soFromEnd = 2;
  29.  
  30. { TFileStream create mode }
  31.  
  32.   fmCreate = $FFFF;
  33.  
  34. { TParser special tokens }
  35.  
  36.   toEOF     = Char(0);
  37.   toSymbol  = Char(1);
  38.   toString  = Char(2);
  39.   toInteger = Char(3);
  40.   toFloat   = Char(4);
  41.  
  42. type
  43.  
  44. { Text alignment types }
  45.  
  46.   TAlignment = (taLeftJustify, taRightJustify, taCenter);
  47.   TLeftRight = taLeftJustify..taRightJustify;
  48.  
  49. { Types used by standard events }
  50.  
  51.   TShiftState = set of (ssShift, ssAlt, ssCtrl,
  52.     ssLeft, ssRight, ssMiddle, ssDouble);
  53.  
  54.   THelpContext = -MaxLongint..MaxLongint;
  55.  
  56. { Standard events }
  57.  
  58.   TNotifyEvent = procedure(Sender: TObject) of object;
  59.   THelpEvent = function (Command: Word; Data: Longint;
  60.     var CallHelp: Boolean): Boolean of object;
  61.   TGetStrProc = procedure(const S: string) of object;
  62.  
  63. { Exception classes }
  64.  
  65.   EStreamError = class(Exception);
  66.   EFCreateError = class(EStreamError);
  67.   EFOpenError = class(EStreamError);
  68.   EFilerError = class(EStreamError);
  69.   EReadError = class(EFilerError);
  70.   EWriteError = class(EFilerError);
  71.   EClassNotFound = class(EFilerError);
  72.   EMethodNotFound = class(EFilerError);
  73.   EInvalidImage = class(EFilerError);
  74.   EResNotFound = class(Exception);
  75.   EListError = class(Exception);
  76.   EBitsError = class(Exception);
  77.   EStringListError = class(Exception);
  78.   EComponentError = class(Exception);
  79.   EParserError = class(Exception);
  80.   EOutOfResources = class(EOutOfMemory);
  81.   EInvalidOperation = class(Exception);
  82.  
  83. { Forward class declarations }
  84.  
  85.   TStream = class;
  86.   TFiler = class;
  87.   TReader = class;
  88.   TWriter = class;
  89.   TComponent = class;
  90.  
  91. { TList class }
  92.  
  93.   PPointerList = ^TPointerList;
  94.   TPointerList = array[0..MaxListSize - 1] of Pointer;
  95.   TListSortCompare = function (Item1, Item2: Pointer): Integer;
  96.  
  97.   TList = class(TObject)
  98.   private
  99.     FList: PPointerList;
  100.     FCount: Integer;
  101.     FCapacity: Integer;
  102.   protected
  103.     function Get(Index: Integer): Pointer;
  104.     procedure Grow; virtual;
  105.     procedure Put(Index: Integer; Item: Pointer);
  106.     procedure SetCapacity(NewCapacity: Integer);
  107.     procedure SetCount(NewCount: Integer);
  108.   public
  109.     destructor Destroy; override;
  110.     function Add(Item: Pointer): Integer;
  111.     procedure Clear;
  112.     procedure Delete(Index: Integer);
  113.     class procedure Error(const Msg: string; Data: Integer); virtual;
  114.     procedure Exchange(Index1, Index2: Integer);
  115.     function Expand: TList;
  116.     function First: Pointer;
  117.     function IndexOf(Item: Pointer): Integer;
  118.     procedure Insert(Index: Integer; Item: Pointer);
  119.     function Last: Pointer;
  120.     procedure Move(CurIndex, NewIndex: Integer);
  121.     function Remove(Item: Pointer): Integer;
  122.     procedure Pack;
  123.     procedure Sort(Compare: TListSortCompare);
  124.     property Capacity: Integer read FCapacity write SetCapacity;
  125.     property Count: Integer read FCount write SetCount;
  126.     property Items[Index: Integer]: Pointer read Get write Put; default;
  127.     property List: PPointerList read FList;
  128.   end;
  129.  
  130. { TThreadList class }
  131.  
  132.   TThreadList = class
  133.   private
  134.     FList: TList;
  135.     FLock: TRTLCriticalSection;
  136.   public
  137.     constructor Create;
  138.     destructor Destroy; override;
  139.     procedure Add(Item: Pointer);
  140.     procedure Clear;
  141.     function  LockList: TList;
  142.     procedure Remove(Item: Pointer);
  143.     procedure UnlockList;
  144.   end;
  145.  
  146. { TBits class }
  147.  
  148.   TBits = class
  149.   private
  150.     FSize: Integer;
  151.     FBits: Pointer;
  152.     procedure Error;
  153.     procedure SetSize(Value: Integer);
  154.     procedure SetBit(Index: Integer; Value: Boolean);
  155.     function GetBit(Index: Integer): Boolean;
  156.   public
  157.     destructor Destroy; override;
  158.     function OpenBit: Integer;
  159.     property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
  160.     property Size: Integer read FSize write SetSize;
  161.   end;
  162.  
  163. { TPersistent abstract class }
  164.  
  165. {$M+}
  166.  
  167.   TPersistent = class(TObject)
  168.   private
  169.     procedure AssignError(Source: TPersistent);
  170.   protected
  171.     procedure AssignTo(Dest: TPersistent); virtual;
  172.     procedure DefineProperties(Filer: TFiler); virtual;
  173.     function  GetOwner: TPersistent; dynamic;
  174.   public
  175.     destructor Destroy; override;
  176.     procedure Assign(Source: TPersistent); virtual;
  177.     function  GetNamePath: string; dynamic;
  178.   end;
  179.  
  180. {$M-}
  181.  
  182. { TPersistent class reference type }
  183.  
  184.   TPersistentClass = class of TPersistent;
  185.  
  186. { TCollection class }
  187.  
  188.   TCollection = class;
  189.  
  190.   TCollectionItem = class(TPersistent)
  191.   private
  192.     FCollection: TCollection;
  193.     FID: Integer;
  194.     function GetIndex: Integer;
  195.     procedure SetCollection(Value: TCollection);
  196.   protected
  197.     procedure Changed(AllItems: Boolean);
  198.     function GetNamePath: string; override;
  199.     function GetOwner: TPersistent; override;
  200.     function GetDisplayName: string; virtual;
  201.     procedure SetIndex(Value: Integer); virtual;
  202.     procedure SetDisplayName(const Value: string); virtual;
  203.   public
  204.     constructor Create(Collection: TCollection); virtual;
  205.     destructor Destroy; override;
  206.     property Collection: TCollection read FCollection write SetCollection;
  207.     property ID: Integer read FID;
  208.     property Index: Integer read GetIndex write SetIndex;
  209.     property DisplayName: string read GetDisplayName write SetDisplayName;
  210.   end;
  211.  
  212.   TCollectionItemClass = class of TCollectionItem;
  213.  
  214.   TCollection = class(TPersistent)
  215.   private
  216.     FItemClass: TCollectionItemClass;
  217.     FItems: TList;
  218.     FUpdateCount: Integer;
  219.     FNextID: Integer;
  220.     FPropName: string;
  221.     function GetCount: Integer;
  222.     function GetPropName: string;
  223.     procedure InsertItem(Item: TCollectionItem);
  224.     procedure RemoveItem(Item: TCollectionItem);
  225.   protected
  226.     { Design-time editor support }
  227.     function GetAttrCount: Integer; dynamic;
  228.     function GetAttr(Index: Integer): string; dynamic;
  229.     function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
  230.     function GetNamePath: string; override;
  231.     procedure Changed;
  232.     function GetItem(Index: Integer): TCollectionItem;
  233.     procedure SetItem(Index: Integer; Value: TCollectionItem);
  234.     procedure SetItemName(Item: TCollectionItem); virtual;
  235.     procedure Update(Item: TCollectionItem); virtual;
  236.     property PropName: string read GetPropName write FPropName;
  237.   public
  238.     constructor Create(ItemClass: TCollectionItemClass);
  239.     destructor Destroy; override;
  240.     function Add: TCollectionItem;
  241.     procedure Assign(Source: TPersistent); override;
  242.     procedure BeginUpdate;
  243.     procedure Clear;
  244.     procedure EndUpdate;
  245.     function FindItemID(ID: Integer): TCollectionItem;
  246.     property Count: Integer read GetCount;
  247.     property ItemClass: TCollectionItemClass read FItemClass;
  248.     property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
  249.   end;
  250.  
  251.   TStrings = class;
  252.  
  253. { IStringsAdapter interface }
  254. { Maintains link between TStrings and IStrings implementations }
  255.  
  256.   IStringsAdapter = interface
  257.     ['{739C2F34-52EC-11D0-9EA6-0020AF3D82DA}']
  258.     procedure ReferenceStrings(S: TStrings);
  259.     procedure ReleaseStrings;
  260.   end;
  261.  
  262. { TStrings class }
  263.  
  264.   TStrings = class(TPersistent)
  265.   private
  266.     FUpdateCount: Integer;
  267.     FAdapter: IStringsAdapter;
  268.     function GetCommaText: string;
  269.     function GetName(Index: Integer): string;
  270.     function GetValue(const Name: string): string;
  271.     procedure ReadData(Reader: TReader);
  272.     procedure SetCommaText(const Value: string);
  273.     procedure SetStringsAdapter(const Value: IStringsAdapter);
  274.     procedure SetValue(const Name, Value: string);
  275.     procedure WriteData(Writer: TWriter);
  276.   protected
  277.     procedure DefineProperties(Filer: TFiler); override;
  278.     procedure Error(const Msg: string; Data: Integer);
  279.     function Get(Index: Integer): string; virtual; abstract;
  280.     function GetCapacity: Integer; virtual;
  281.     function GetCount: Integer; virtual; abstract;
  282.     function GetObject(Index: Integer): TObject; virtual;
  283.     function GetTextStr: string; virtual;
  284.     procedure Put(Index: Integer; const S: string); virtual;
  285.     procedure PutObject(Index: Integer; AObject: TObject); virtual;
  286.     procedure SetCapacity(NewCapacity: Integer); virtual;
  287.     procedure SetTextStr(const Value: string); virtual;
  288.     procedure SetUpdateState(Updating: Boolean); virtual;
  289.   public
  290.     destructor Destroy; override;
  291.     function Add(const S: string): Integer; virtual;
  292.     function AddObject(const S: string; AObject: TObject): Integer; virtual;
  293.     procedure Append(const S: string);
  294.     procedure AddStrings(Strings: TStrings); virtual;
  295.     procedure Assign(Source: TPersistent); override;
  296.     procedure BeginUpdate;
  297.     procedure Clear; virtual; abstract;
  298.     procedure Delete(Index: Integer); virtual; abstract;
  299.     procedure EndUpdate;
  300.     function Equals(Strings: TStrings): Boolean;
  301.     procedure Exchange(Index1, Index2: Integer); virtual;
  302.     function GetText: PChar; virtual;
  303.     function IndexOf(const S: string): Integer; virtual;
  304.     function IndexOfName(const Name: string): Integer;
  305.     function IndexOfObject(AObject: TObject): Integer;
  306.     procedure Insert(Index: Integer; const S: string); virtual; abstract;
  307.     procedure InsertObject(Index: Integer; const S: string;
  308.       AObject: TObject);
  309.     procedure LoadFromFile(const FileName: string); virtual;
  310.     procedure LoadFromStream(Stream: TStream); virtual;
  311.     procedure Move(CurIndex, NewIndex: Integer); virtual;
  312.     procedure SaveToFile(const FileName: string); virtual;
  313.     procedure SaveToStream(Stream: TStream); virtual;
  314.     procedure SetText(Text: PChar); virtual;
  315.     property Capacity: Integer read GetCapacity write SetCapacity;
  316.     property CommaText: string read GetCommaText write SetCommaText;
  317.     property Count: Integer read GetCount;
  318.     property Names[Index: Integer]: string read GetName;
  319.     property Objects[Index: Integer]: TObject read GetObject write PutObject;
  320.     property Values[const Name: string]: string read GetValue write SetValue;
  321.     property Strings[Index: Integer]: string read Get write Put; default;
  322.     property Text: string read GetTextStr write SetTextStr;
  323.     property StringsAdapter: IStringsAdapter read FAdapter write SetStringsAdapter;
  324.   end;
  325.  
  326. { TStringList class }
  327.  
  328.   TDuplicates = (dupIgnore, dupAccept, dupError);
  329.  
  330.   PStringItem = ^TStringItem;
  331.   TStringItem = record
  332.     FString: string;
  333.     FObject: TObject;
  334.   end;
  335.  
  336.   PStringItemList = ^TStringItemList;
  337.   TStringItemList = array[0..MaxListSize] of TStringItem;
  338.  
  339.   TStringList = class(TStrings)
  340.   private
  341.     FList: PStringItemList;
  342.     FCount: Integer;
  343.     FCapacity: Integer;
  344.     FSorted: Boolean;
  345.     FDuplicates: TDuplicates;
  346.     FOnChange: TNotifyEvent;
  347.     FOnChanging: TNotifyEvent;
  348.     procedure ExchangeItems(Index1, Index2: Integer);
  349.     procedure Grow;
  350.     procedure QuickSort(L, R: Integer);
  351.     procedure InsertItem(Index: Integer; const S: string);
  352.     procedure SetSorted(Value: Boolean);
  353.   protected
  354.     procedure Changed; virtual;
  355.     procedure Changing; virtual;
  356.     function Get(Index: Integer): string; override;
  357.     function GetCapacity: Integer; override;
  358.     function GetCount: Integer; override;
  359.     function GetObject(Index: Integer): TObject; override;
  360.     procedure Put(Index: Integer; const S: string); override;
  361.     procedure PutObject(Index: Integer; AObject: TObject); override;
  362.     procedure SetCapacity(NewCapacity: Integer); override;
  363.     procedure SetUpdateState(Updating: Boolean); override;
  364.   public
  365.     destructor Destroy; override;
  366.     function Add(const S: string): Integer; override;
  367.     procedure Clear; override;
  368.     procedure Delete(Index: Integer); override;
  369.     procedure Exchange(Index1, Index2: Integer); override;
  370.     function Find(const S: string; var Index: Integer): Boolean; virtual;
  371.     function IndexOf(const S: string): Integer; override;
  372.     procedure Insert(Index: Integer; const S: string); override;
  373.     procedure Sort; virtual;
  374.     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  375.     property Sorted: Boolean read FSorted write SetSorted;
  376.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  377.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  378.   end;
  379.  
  380. { TStream abstract class }
  381.  
  382.   TStream = class(TObject)
  383.   private
  384.     function GetPosition: Longint;
  385.     procedure SetPosition(Pos: Longint);
  386.     function GetSize: Longint;
  387.   protected
  388.     procedure SetSize(NewSize: Longint); virtual;
  389.   public
  390.     function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
  391.     function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
  392.     function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
  393.     procedure ReadBuffer(var Buffer; Count: Longint);
  394.     procedure WriteBuffer(const Buffer; Count: Longint);
  395.     function CopyFrom(Source: TStream; Count: Longint): Longint;
  396.     function ReadComponent(Instance: TComponent): TComponent;
  397.     function ReadComponentRes(Instance: TComponent): TComponent;
  398.     procedure WriteComponent(Instance: TComponent);
  399.     procedure WriteComponentRes(const ResName: string; Instance: TComponent);
  400.     procedure WriteDescendent(Instance, Ancestor: TComponent);
  401.     procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
  402.     procedure ReadResHeader;
  403.     property Position: Longint read GetPosition write SetPosition;
  404.     property Size: Longint read GetSize write SetSize;
  405.   end;
  406.  
  407. { THandleStream class }
  408.  
  409.   THandleStream = class(TStream)
  410.   private
  411.     FHandle: Integer;
  412.   protected
  413.     procedure SetSize(NewSize: Longint); override;
  414.   public
  415.     constructor Create(AHandle: Integer);
  416.     function Read(var Buffer; Count: Longint): Longint; override;
  417.     function Write(const Buffer; Count: Longint): Longint; override;
  418.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  419.     property Handle: Integer read FHandle;
  420.   end;
  421.  
  422. { TFileStream class }
  423.  
  424.   TFileStream = class(THandleStream)
  425.   public
  426.     constructor Create(const FileName: string; Mode: Word);
  427.     destructor Destroy; override;
  428.   end;
  429.  
  430. { TCustomMemoryStream abstract class }
  431.  
  432.   TCustomMemoryStream = class(TStream)
  433.   private
  434.     FMemory: Pointer;
  435.     FSize, FPosition: Longint;
  436.   protected
  437.     procedure SetPointer(Ptr: Pointer; Size: Longint);
  438.   public
  439.     function Read(var Buffer; Count: Longint): Longint; override;
  440.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  441.     procedure SaveToStream(Stream: TStream);
  442.     procedure SaveToFile(const FileName: string);
  443.     property Memory: Pointer read FMemory;
  444.   end;
  445.  
  446. { TMemoryStream }
  447.  
  448.   TMemoryStream = class(TCustomMemoryStream)
  449.   private
  450.     FCapacity: Longint;
  451.     procedure SetCapacity(NewCapacity: Longint);
  452.   protected
  453.     function Realloc(var NewCapacity: Longint): Pointer; virtual;
  454.     property Capacity: Longint read FCapacity write SetCapacity;
  455.   public
  456.     destructor Destroy; override;
  457.     procedure Clear;
  458.     procedure LoadFromStream(Stream: TStream);
  459.     procedure LoadFromFile(const FileName: string);
  460.     procedure SetSize(NewSize: Longint); override;
  461.     function Write(const Buffer; Count: Longint): Longint; override;
  462.   end;
  463.  
  464. { TStringStream }
  465.  
  466.   TStringStream = class(TStream)
  467.   private
  468.     FDataString: string;
  469.     FPosition: Integer;
  470.   protected
  471.     procedure SetSize(NewSize: Longint); override;
  472.   public
  473.     constructor Create(const AString: string);
  474.     function Read(var Buffer; Count: Longint): Longint; override;
  475.     function ReadString(Count: Longint): string;
  476.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  477.     function Write(const Buffer; Count: Longint): Longint; override;
  478.     procedure WriteString(const AString: string);
  479.     property DataString: string read FDataString;
  480.   end;
  481.  
  482. { TResourceStream }
  483.  
  484.   TResourceStream = class(TCustomMemoryStream)
  485.   private
  486.     HResInfo: HRSRC;
  487.     HGlobal: THandle;
  488.     procedure Initialize(Instance: THandle; Name, ResType: PChar);
  489.   public
  490.     constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
  491.     constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
  492.     destructor Destroy; override;
  493.     function Write(const Buffer; Count: Longint): Longint; override;
  494.   end;
  495.  
  496. { TStreamAdapter }
  497. { Implements OLE IStream on VCL TStream }
  498.  
  499.   TStreamAdapter = class(TInterfacedObject, IStream)
  500.   private
  501.     FStream: TStream;
  502.   public
  503.     constructor Create(Stream: TStream);
  504.     function Read(pv: Pointer; cb: Longint;
  505.       pcbRead: PLongint): HResult; stdcall;
  506.     function Write(pv: Pointer; cb: Longint;
  507.       pcbWritten: PLongint): HResult; stdcall;
  508.     function Seek(dlibMove: Largeint; dwOrigin: Longint;
  509.       out libNewPosition: Largeint): HResult; stdcall;
  510.     function SetSize(libNewSize: Largeint): HResult; stdcall;
  511.     function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  512.       out cbWritten: Largeint): HResult; stdcall;
  513.     function Commit(grfCommitFlags: Longint): HResult; stdcall;
  514.     function Revert: HResult; stdcall;
  515.     function LockRegion(libOffset: Largeint; cb: Largeint;
  516.       dwLockType: Longint): HResult; stdcall;
  517.     function UnlockRegion(libOffset: Largeint; cb: Largeint;
  518.       dwLockType: Longint): HResult; stdcall;
  519.     function Stat(out statstg: TStatStg;
  520.       grfStatFlag: Longint): HResult; stdcall;
  521.     function Clone(out stm: IStream): HResult; stdcall;
  522.   end;
  523.  
  524. { TFiler }
  525.  
  526.   TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
  527.     vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
  528.     vaNil, vaCollection);
  529.  
  530.   TFilerFlag = (ffInherited, ffChildPos);
  531.   TFilerFlags = set of TFilerFlag;
  532.  
  533.   TReaderProc = procedure(Reader: TReader) of object;
  534.   TWriterProc = procedure(Writer: TWriter) of object;
  535.   TStreamProc = procedure(Stream: TStream) of object;
  536.  
  537.   TFiler = class(TObject)
  538.   private
  539.     FStream: TStream;
  540.     FBuffer: Pointer;
  541.     FBufSize: Integer;
  542.     FBufPos: Integer;
  543.     FBufEnd: Integer;
  544.     FRoot: TComponent;
  545.     FAncestor: TPersistent;
  546.     FIgnoreChildren: Boolean;
  547.   public
  548.     constructor Create(Stream: TStream; BufSize: Integer);
  549.     destructor Destroy; override;
  550.     procedure DefineProperty(const Name: string;
  551.       ReadData: TReaderProc; WriteData: TWriterProc;
  552.       HasData: Boolean); virtual; abstract;
  553.     procedure DefineBinaryProperty(const Name: string;
  554.       ReadData, WriteData: TStreamProc;
  555.       HasData: Boolean); virtual; abstract;
  556.     procedure FlushBuffer; virtual; abstract;
  557.     property Root: TComponent read FRoot write FRoot;
  558.     property Ancestor: TPersistent read FAncestor write FAncestor;
  559.     property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
  560.   end;
  561.  
  562. { TReader }
  563.  
  564.   TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
  565.     var Address: Pointer; var Error: Boolean) of object;
  566.   TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
  567.     var Name: string) of object;
  568.   TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object;
  569.   TAncestorNotFoundEvent = procedure(Reader: TReader; const ComponentName: string;
  570.     ComponentClass: TPersistentClass; var Component: TComponent) of object;
  571.   TReadComponentsProc = procedure(Component: TComponent) of object;
  572.   TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;
  573.  
  574.   TReader = class(TFiler)
  575.   private
  576.     FOwner: TComponent;
  577.     FParent: TComponent;
  578.     FFixups: TList;
  579.     FLoaded: TList;
  580.     FOnFindMethod: TFindMethodEvent;
  581.     FOnSetName: TSetNameEvent;
  582.     FOnReferenceName: TReferenceNameEvent;
  583.     FOnAncestorNotFound: TAncestorNotFoundEvent;
  584.     FOnError: TReaderError;
  585.     FCanHandleExcepts: Boolean;
  586.     FPropName: string;
  587.     procedure CheckValue(Value: TValueType);
  588.     procedure DoFixupReferences;
  589.     procedure FreeFixups;
  590.     function GetPosition: Longint;
  591.     procedure PropertyError;
  592.     procedure ReadBuffer;
  593.     procedure ReadData(Instance: TComponent);
  594.     procedure ReadDataInner(Instance: TComponent);
  595.     procedure ReadProperty(AInstance: TPersistent);
  596.     procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  597.     function ReadSet(SetType: Pointer): Integer;
  598.     procedure SetPosition(Value: Longint);
  599.     procedure SkipSetBody;
  600.     procedure SkipValue;
  601.     procedure SkipProperty;
  602.     procedure SkipComponent(SkipHeader: Boolean);
  603.   protected
  604.     function Error(const Message: string): Boolean; virtual;
  605.     function FindMethod(Root: TComponent; const MethodName: string): Pointer; virtual;
  606.     procedure SetName(Component: TComponent; var Name: string); virtual;
  607.     procedure ReferenceName(var Name: string); virtual;
  608.     function FindAncestorComponent(const Name: string;
  609.       ComponentClass: TPersistentClass): TComponent; virtual;
  610.   public
  611.     destructor Destroy; override;
  612.     procedure BeginReferences;
  613.     procedure DefineProperty(const Name: string;
  614.       ReadData: TReaderProc; WriteData: TWriterProc;
  615.       HasData: Boolean); override;
  616.     procedure DefineBinaryProperty(const Name: string;
  617.       ReadData, WriteData: TStreamProc;
  618.       HasData: Boolean); override;
  619.     function EndOfList: Boolean;
  620.     procedure EndReferences;
  621.     procedure FixupReferences;
  622.     procedure FlushBuffer; override;
  623.     function NextValue: TValueType;
  624.     procedure Read(var Buf; Count: Longint);
  625.     function ReadBoolean: Boolean;
  626.     function ReadChar: Char;
  627.     procedure ReadCollection(Collection: TCollection);
  628.     function ReadComponent(Component: TComponent): TComponent;
  629.     procedure ReadComponents(AOwner, AParent: TComponent;
  630.       Proc: TReadComponentsProc);
  631.     function ReadFloat: Extended;
  632.     function ReadIdent: string;
  633.     function ReadInteger: Longint;
  634.     procedure ReadListBegin;
  635.     procedure ReadListEnd;
  636.     procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
  637.     function ReadRootComponent(Root: TComponent): TComponent;
  638.     procedure ReadSignature;
  639.     function ReadStr: string;
  640.     function ReadString: string;
  641.     function ReadValue: TValueType;
  642.     procedure CopyValue(Writer: TWriter); {!!!}
  643.     property Owner: TComponent read FOwner write FOwner;
  644.     property Parent: TComponent read FParent write FParent;
  645.     property Position: Longint read GetPosition write SetPosition;
  646.     property OnError: TReaderError read FOnError write FOnError;
  647.     property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
  648.     property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
  649.     property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName;
  650.     property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound;
  651.   end;
  652.  
  653. { TWriter }
  654.  
  655.   TWriter = class(TFiler)
  656.   private
  657.     FRootAncestor: TComponent;
  658.     FPropPath: string;
  659.     FAncestorList: TList;
  660.     FAncestorPos: Integer;
  661.     FChildPos: Integer;
  662.     procedure AddAncestor(Component: TComponent);
  663.     function GetPosition: Longint;
  664.     procedure SetPosition(Value: Longint);
  665.     procedure WriteBuffer;
  666.     procedure WriteData(Instance: TComponent); virtual; // linker optimization
  667.     procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  668.     procedure WriteProperties(Instance: TPersistent);
  669.     procedure WritePropName(const PropName: string);
  670.   protected
  671.     procedure WriteBinary(WriteData: TStreamProc);
  672.     procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  673.     procedure WriteValue(Value: TValueType);
  674.   public
  675.     destructor Destroy; override;
  676.     procedure DefineProperty(const Name: string;
  677.       ReadData: TReaderProc; WriteData: TWriterProc;
  678.       HasData: Boolean); override;
  679.     procedure DefineBinaryProperty(const Name: string;
  680.       ReadData, WriteData: TStreamProc;
  681.       HasData: Boolean); override;
  682.     procedure FlushBuffer; override;
  683.     procedure Write(const Buf; Count: Longint);
  684.     procedure WriteBoolean(Value: Boolean);
  685.     procedure WriteCollection(Value: TCollection);
  686.     procedure WriteComponent(Component: TComponent);
  687.     procedure WriteChar(Value: Char);
  688.     procedure WriteDescendent(Root: TComponent; AAncestor: TComponent);
  689.     procedure WriteFloat(Value: Extended);
  690.     procedure WriteIdent(const Ident: string);
  691.     procedure WriteInteger(Value: Longint);
  692.     procedure WriteListBegin;
  693.     procedure WriteListEnd;
  694.     procedure WriteRootComponent(Root: TComponent);
  695.     procedure WriteSignature;
  696.     procedure WriteStr(const Value: string);
  697.     procedure WriteString(const Value: string);
  698.     property Position: Longint read GetPosition write SetPosition;
  699.     property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
  700.   end;
  701.  
  702. { TParser }
  703.  
  704.   TParser = class(TObject)
  705.   private
  706.     FStream: TStream;
  707.     FOrigin: Longint;
  708.     FBuffer: PChar;
  709.     FBufPtr: PChar;
  710.     FBufEnd: PChar;
  711.     FSourcePtr: PChar;
  712.     FSourceEnd: PChar;
  713.     FTokenPtr: PChar;
  714.     FStringPtr: PChar;
  715.     FSourceLine: Integer;
  716.     FSaveChar: Char;
  717.     FToken: Char;
  718.     procedure ReadBuffer;
  719.     procedure SkipBlanks;
  720.   public
  721.     constructor Create(Stream: TStream);
  722.     destructor Destroy; override;
  723.     procedure CheckToken(T: Char);
  724.     procedure CheckTokenSymbol(const S: string);
  725.     procedure Error(const Ident: string);
  726.     procedure ErrorFmt(const Ident: string; const Args: array of const);
  727.     procedure ErrorStr(const Message: string);
  728.     procedure HexToBinary(Stream: TStream);
  729.     function NextToken: Char;
  730.     function SourcePos: Longint;
  731.     function TokenComponentIdent: String;
  732.     function TokenFloat: Extended;
  733.     function TokenInt: Longint;
  734.     function TokenString: string;
  735.     function TokenSymbolIs(const S: string): Boolean;
  736.     property SourceLine: Integer read FSourceLine;
  737.     property Token: Char read FToken;
  738.   end;
  739.  
  740. { TThread }
  741.  
  742.   EThread = class(Exception);
  743.  
  744.   TThreadMethod = procedure of object;
  745.   TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  746.     tpTimeCritical);
  747.  
  748.   TThread = class
  749.   private
  750.     FHandle: THandle;
  751.     FThreadID: THandle;
  752.     FTerminated: Boolean;
  753.     FSuspended: Boolean;
  754.     FFreeOnTerminate: Boolean;
  755.     FFinished: Boolean;
  756.     FReturnValue: Integer;
  757.     FOnTerminate: TNotifyEvent;
  758.     FMethod: TThreadMethod;
  759.     FSynchronizeException: TObject;
  760.     procedure CallOnTerminate;
  761.     function GetPriority: TThreadPriority;
  762.     procedure SetPriority(Value: TThreadPriority);
  763.     procedure SetSuspended(Value: Boolean);
  764.   protected
  765.     procedure DoTerminate; virtual;
  766.     procedure Execute; virtual; abstract;
  767.     procedure Synchronize(Method: TThreadMethod);
  768.     property ReturnValue: Integer read FReturnValue write FReturnValue;
  769.     property Terminated: Boolean read FTerminated;
  770.   public
  771.     constructor Create(CreateSuspended: Boolean);
  772.     destructor Destroy; override;
  773.     procedure Resume;
  774.     procedure Suspend;
  775.     procedure Terminate;
  776.     function WaitFor: Integer;
  777.     property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  778.     property Handle: THandle read FHandle;
  779.     property Priority: TThreadPriority read GetPriority write SetPriority;
  780.     property Suspended: Boolean read FSuspended write SetSuspended;
  781.     property ThreadID: THandle read FThreadID;
  782.     property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
  783.   end;
  784.  
  785. { TComponent class }
  786.  
  787.   TOperation = (opInsert, opRemove);
  788.   TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
  789.     csDesigning, csAncestor, csUpdating, csFixups);
  790.   TComponentStyle = set of (csInheritable, csCheckPropAvail);
  791.   TGetChildProc = procedure (Child: TComponent) of object;
  792.  
  793.   TComponentName = type string;
  794.  
  795.   IVCLComObject = interface
  796.     ['{E07892A0-F52F-11CF-BD2F-0020AF0E5B81}']
  797.     function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
  798.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
  799.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  800.       NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
  801.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  802.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
  803.     function SafeCallException(ExceptObject: TObject;
  804.       ExceptAddr: Pointer): Integer;
  805.     procedure FreeOnRelease;
  806.   end;
  807.  
  808.   TComponent = class(TPersistent)
  809.   private
  810.     FOwner: TComponent;
  811.     FName: TComponentName;
  812.     FTag: Longint;
  813.     FComponents: TList;
  814.     FFreeNotifies: TList;
  815.     FDesignInfo: Longint;
  816.     FVCLComObject: Pointer;
  817.     FComponentState: TComponentState;
  818.     function GetComObject: IUnknown;
  819.     function GetComponent(AIndex: Integer): TComponent;
  820.     function GetComponentCount: Integer;
  821.     function GetComponentIndex: Integer;
  822.     procedure Insert(AComponent: TComponent);
  823.     procedure ReadLeft(Reader: TReader);
  824.     procedure ReadTop(Reader: TReader);
  825.     procedure Remove(AComponent: TComponent);
  826.     procedure SetComponentIndex(Value: Integer);
  827.     procedure SetReference(Enable: Boolean);
  828.     procedure WriteLeft(Writer: TWriter);
  829.     procedure WriteTop(Writer: TWriter);
  830.   protected
  831.     FComponentStyle: TComponentStyle;
  832.     procedure ChangeName(const NewName: TComponentName);
  833.     procedure DefineProperties(Filer: TFiler); override;
  834.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic;
  835.     function GetChildOwner: TComponent; dynamic;
  836.     function GetChildParent: TComponent; dynamic;
  837.     function GetNamePath: string; override;
  838.     function GetOwner: TPersistent; override;
  839.     procedure Loaded; virtual;
  840.     procedure Notification(AComponent: TComponent;
  841.       Operation: TOperation); virtual;
  842.     procedure ReadState(Reader: TReader); virtual;
  843.     procedure SetAncestor(Value: Boolean);
  844.     procedure SetDesigning(Value: Boolean);
  845.     procedure SetName(const NewName: TComponentName); virtual;
  846.     procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic;
  847.     procedure SetParentComponent(Value: TComponent); dynamic;
  848.     procedure Updating; dynamic;
  849.     procedure Updated; dynamic;
  850.     class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); dynamic;
  851.     procedure ValidateRename(AComponent: TComponent;
  852.       const CurName, NewName: string); virtual;
  853.     procedure ValidateContainer(AComponent: TComponent); dynamic;
  854.     procedure ValidateInsert(AComponent: TComponent); dynamic;
  855.     procedure WriteState(Writer: TWriter); virtual;
  856.     { IUnknown }
  857.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  858.     function _AddRef: Integer; stdcall;
  859.     function _Release: Integer; stdcall;
  860.     { IDispatch }
  861.     function GetTypeInfoCount(out Count: Integer): Integer; stdcall;
  862.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer; stdcall;
  863.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  864.       NameCount, LocaleID: Integer; DispIDs: Pointer): Integer; stdcall;
  865.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  866.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
  867.   public
  868.     constructor Create(AOwner: TComponent); virtual;
  869.     destructor Destroy; override;
  870.     procedure DestroyComponents;
  871.     procedure Destroying;
  872.     function FindComponent(const AName: string): TComponent;
  873.     procedure FreeNotification(AComponent: TComponent);
  874.     procedure FreeOnRelease;
  875.     function GetParentComponent: TComponent; dynamic;
  876.     function HasParent: Boolean; dynamic;
  877.     procedure InsertComponent(AComponent: TComponent);
  878.     procedure RemoveComponent(AComponent: TComponent);
  879.     function SafeCallException(ExceptObject: TObject;
  880.       ExceptAddr: Pointer): Integer; override;
  881.     property ComObject: IUnknown read GetComObject;
  882.     property Components[Index: Integer]: TComponent read GetComponent;
  883.     property ComponentCount: Integer read GetComponentCount;
  884.     property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
  885.     property ComponentState: TComponentState read FComponentState;
  886.     property ComponentStyle: TComponentStyle read FComponentStyle;
  887.     property DesignInfo: Longint read FDesignInfo write FDesignInfo;
  888.     property Owner: TComponent read FOwner;
  889.     property VCLComObject: Pointer read FVCLComObject write FVCLComObject;
  890.   published
  891.     property Name: TComponentName read FName write SetName stored False;
  892.     property Tag: Longint read FTag write FTag default 0;
  893.   end;
  894.  
  895. { TComponent class reference type }
  896.  
  897.   TComponentClass = class of TComponent;
  898.  
  899. { Component registration handlers }
  900.  
  901.   TActiveXRegType = (axrComponentOnly, axrIncludeDescendants);
  902.  
  903. var
  904.   RegisterComponentsProc: procedure(const Page: string;
  905.     ComponentClasses: array of TComponentClass) = nil;
  906.   RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass) = nil;
  907.   RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
  908.     AxRegType: TActiveXRegType) = nil;
  909.   CurrentGroup: Integer = -1; { Current design group }
  910.   CreateVCLComObjectProc: procedure(Component: TComponent) = nil;
  911.  
  912. { Point and rectangle constructors }
  913.  
  914. function Point(AX, AY: Integer): TPoint;
  915. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  916. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  917. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  918.  
  919. { Class registration routines }
  920.  
  921. procedure RegisterClass(AClass: TPersistentClass);
  922. procedure RegisterClasses(AClasses: array of TPersistentClass);
  923. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  924. procedure UnRegisterClass(AClass: TPersistentClass);
  925. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  926. procedure UnRegisterModuleClasses(Module: HMODULE);
  927. function FindClass(const ClassName: string): TPersistentClass;
  928. function GetClass(const ClassName: string): TPersistentClass;
  929.  
  930. { Component registration routines }
  931.  
  932. procedure RegisterComponents(const Page: string;
  933.   ComponentClasses: array of TComponentClass);
  934. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  935. procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
  936.   AxRegType: TActiveXRegType);
  937.  
  938.  
  939. { Object filing routines }
  940.  
  941. type
  942.   TIdentMapEntry = record
  943.     Value: Integer;
  944.     Name: String;
  945.   end;
  946.  
  947.   TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
  948.   TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
  949.   TFindGlobalComponent = function(const Name: string): TComponent;
  950.  
  951. var
  952.   MainThreadID: THandle;
  953.   FindGlobalComponent: TFindGlobalComponent;
  954.  
  955. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  956.   IntToIdent: TIntToIdent);
  957. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  958. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  959.  
  960. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  961. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  962. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  963. function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
  964. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  965. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  966.  
  967. procedure GlobalFixupReferences;
  968. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  969. procedure GetFixupInstanceNames(Root: TComponent;
  970.   const ReferenceRootName: string; Names: TStrings);
  971. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  972.   NewRootName: string);
  973. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  974. procedure RemoveFixups(Instance: TPersistent);
  975.  
  976. procedure BeginGlobalLoading;
  977. procedure NotifyGlobalLoading;
  978. procedure EndGlobalLoading;
  979.  
  980. function CollectionsEqual(C1, C2: TCollection): Boolean;
  981.  
  982. { Object conversion routines }
  983.  
  984. procedure ObjectBinaryToText(Input, Output: TStream);
  985. procedure ObjectTextToBinary(Input, Output: TStream);
  986.  
  987. procedure ObjectResourceToText(Input, Output: TStream);
  988. procedure ObjectTextToResource(Input, Output: TStream);
  989.  
  990. { Utility routines }
  991.  
  992. function LineStart(Buffer, BufPos: PChar): PChar;
  993.  
  994. implementation
  995.  
  996. uses Consts, TypInfo;
  997.  
  998. const
  999.   FilerSignature: array[1..4] of Char = 'TPF0';
  1000.  
  1001. var
  1002.   ClassList: TList = nil;
  1003.   ClassAliasList: TStringList = nil;
  1004.   IntConstList: TList = nil;
  1005.  
  1006. type
  1007.   TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;
  1008.  
  1009. { Point and rectangle constructors }
  1010.  
  1011. function Point(AX, AY: Integer): TPoint;
  1012. begin
  1013.   with Result do
  1014.   begin
  1015.     X := AX;
  1016.     Y := AY;
  1017.   end;
  1018. end;
  1019.  
  1020. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  1021. begin
  1022.   with Result do
  1023.   begin
  1024.     X := AX;
  1025.     Y := AY;
  1026.   end;
  1027. end;
  1028.  
  1029. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  1030. begin
  1031.   with Result do
  1032.   begin
  1033.     Left := ALeft;
  1034.     Top := ATop;
  1035.     Right := ARight;
  1036.     Bottom := ABottom;
  1037.   end;
  1038. end;
  1039.  
  1040. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  1041. begin
  1042.   with Result do
  1043.   begin
  1044.     Left := ALeft;
  1045.     Top := ATop;
  1046.     Right := ALeft + AWidth;
  1047.     Bottom :=  ATop + AHeight;
  1048.   end;
  1049. end;
  1050.  
  1051. { Class registration routines }
  1052.  
  1053. type
  1054.   PFieldClassTable = ^TFieldClassTable;
  1055.   TFieldClassTable = packed record
  1056.     Count: Smallint;
  1057.     Classes: array[0..8191] of ^TPersistentClass;
  1058.   end;
  1059.  
  1060. function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;
  1061. asm
  1062.         MOV     EAX,[EAX].vmtFieldTable
  1063.         OR      EAX,EAX
  1064.         JE      @@1
  1065.         MOV     EAX,[EAX+2].Integer
  1066. @@1:
  1067. end;
  1068.  
  1069. procedure ClassNotFound(const ClassName: string);
  1070. begin
  1071.   raise EClassNotFound.Create(Format(SClassNotFound, [ClassName]));
  1072. end;
  1073.  
  1074. function GetClass(const ClassName: string): TPersistentClass;
  1075. var
  1076.   I: Integer;
  1077. begin
  1078.   for I := 0 to ClassList.Count - 1 do
  1079.   begin
  1080.     Result := ClassList[I];
  1081.     if Result.ClassNameIs(ClassName) then Exit;
  1082.   end;
  1083.   I := ClassAliasList.IndexOf(ClassName);
  1084.   if I >= 0 then
  1085.   begin
  1086.     Result := TPersistentClass(ClassAliasList.Objects[I]);
  1087.     Exit;
  1088.   end;
  1089.   Result := nil;
  1090. end;
  1091.  
  1092. function FindClass(const ClassName: string): TPersistentClass;
  1093. begin
  1094.   Result := GetClass(ClassName);
  1095.   if Result = nil then ClassNotFound(ClassName);
  1096. end;
  1097.  
  1098. function FindFieldClass(Instance: TObject;
  1099.   const ClassName: string): TPersistentClass;
  1100. var
  1101.   I: Integer;
  1102.   ClassTable: PFieldClassTable;
  1103.   ClassType: TClass;
  1104. begin
  1105.   ClassType := Instance.ClassType;
  1106.   while ClassType <> TPersistent do
  1107.   begin
  1108.     ClassTable := GetFieldClassTable(ClassType);
  1109.     if ClassTable <> nil then
  1110.       for I := 0 to ClassTable^.Count - 1 do
  1111.       begin
  1112.         Result := ClassTable^.Classes[I]^;
  1113.         if CompareText(Result.ClassName, ClassName) = 0 then Exit;
  1114.       end;
  1115.     ClassType := ClassType.ClassParent;
  1116.   end;
  1117.   Result := FindClass(ClassName);
  1118. end;
  1119.  
  1120. procedure RegisterClass(AClass: TPersistentClass);
  1121. var
  1122.   ClassName: string;
  1123. begin
  1124.   while ClassList.IndexOf(AClass) = -1 do
  1125.   begin
  1126.     ClassName := AClass.ClassName;
  1127.     if GetClass(ClassName) <> nil then
  1128.       raise EFilerError.CreateFmt(SDuplicateClass, [ClassName]);
  1129.     ClassList.Add(AClass);
  1130.     if AClass = TPersistent then Break;
  1131.     AClass := TPersistentClass(AClass.ClassParent);
  1132.   end;
  1133. end;
  1134.  
  1135. procedure RegisterClasses(AClasses: array of TPersistentClass);
  1136. var
  1137.   I: Integer;
  1138. begin
  1139.   for I := Low(AClasses) to High(AClasses) do RegisterClass(AClasses[I]);
  1140. end;
  1141.  
  1142. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  1143. begin
  1144.   RegisterClass(AClass);
  1145.   ClassAliasList.AddObject(Alias, TObject(AClass));
  1146. end;
  1147.  
  1148. procedure UnRegisterClass(AClass: TPersistentClass);
  1149. begin
  1150.   ClassList.Remove(AClass);
  1151. end;
  1152.  
  1153. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  1154. var
  1155.   I: Integer;
  1156. begin
  1157.   for I := Low(AClasses) to High(AClasses) do UnRegisterClass(AClasses[I]);
  1158. end;
  1159.  
  1160. procedure UnRegisterModuleClasses(Module: HMODULE);
  1161. var
  1162.   I: Integer;
  1163.   M: TMemoryBasicInformation;
  1164. begin
  1165.   for I := ClassList.Count - 1 downto 0 do
  1166.   begin
  1167.     VirtualQuery(ClassList[I], M, SizeOf(M));
  1168.     if (Module = 0) or (HMODULE(M.AllocationBase) = Module) then
  1169.       ClassList.Delete(I);
  1170.   end;
  1171.   for I := ClassAliasList.Count - 1 downto 0 do
  1172.   begin
  1173.     VirtualQuery(Pointer(ClassAliasList.Objects[I]), M, SizeOf(M));
  1174.     if (Module = 0) or (HMODULE(M.AllocationBase) = Module) then
  1175.       ClassAliasList.Delete(I);
  1176.   end;
  1177. end;
  1178.  
  1179. { Component registration routines }
  1180.  
  1181. procedure RegisterComponents(const Page: string;
  1182.   ComponentClasses: array of TComponentClass);
  1183. begin
  1184.   if Assigned(RegisterComponentsProc) then
  1185.     RegisterComponentsProc(Page, ComponentClasses)
  1186.   else
  1187.     raise EComponentError.Create(SRegisterError);
  1188. end;
  1189.  
  1190. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  1191. begin
  1192.   if Assigned(RegisterNoIconProc) then
  1193.     RegisterNoIconProc(ComponentClasses)
  1194.   else
  1195.     raise EComponentError.Create(SRegisterError);
  1196. end;
  1197.  
  1198. procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
  1199.   AxRegType: TActiveXRegType);
  1200. begin
  1201.   if Assigned(RegisterNonActiveXProc) then
  1202.     RegisterNonActiveXProc(ComponentClasses, AxRegType)
  1203.   else
  1204.     raise EComponentError.Create(SRegisterError);
  1205. end;
  1206.  
  1207. { Component filing }
  1208.  
  1209. type
  1210.   TIntConst = class
  1211.     IntegerType: PTypeInfo;
  1212.     IdentToInt: TIdentToInt;
  1213.     IntToIdent: TIntToIdent;
  1214.     constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  1215.       AIntToIdent: TIntToIdent);
  1216.   end;
  1217.  
  1218. constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  1219.   AIntToIdent: TIntToIdent);
  1220. begin
  1221.   IntegerType := AIntegerType;
  1222.   IdentToInt := AIdentToInt;
  1223.   IntToIdent := AIntToIdent;
  1224. end;
  1225.  
  1226. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  1227.   IntToIdent: TIntToIdent);
  1228. begin
  1229.   IntConstList.Add(TIntConst.Create(IntegerType, IdentToInt, IntToIdent));
  1230. end;
  1231.  
  1232. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  1233. var
  1234.   I: Integer;
  1235. begin
  1236.   for I := Low(Map) to High(Map) do
  1237.     if CompareText(Map[I].Name, Ident) = 0 then
  1238.     begin
  1239.       Result := True;
  1240.       Int := Map[I].Value;
  1241.       Exit;
  1242.     end;
  1243.   Result := False;
  1244. end;
  1245.  
  1246. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  1247. var
  1248.   I: Integer;
  1249. begin
  1250.   for I := Low(Map) to High(Map) do
  1251.     if Map[I].Value = Int then
  1252.     begin
  1253.       Result := True;
  1254.       Ident := Map[I].Name;
  1255.       Exit;
  1256.     end;
  1257.   Result := False;
  1258. end;
  1259.  
  1260.  
  1261. function InternalReadComponentRes(const ResName: string; HInst: THandle; var Instance: TComponent): Boolean;
  1262. var
  1263.   HRsrc: THandle;
  1264. begin                   { avoid possible EResNotFound exception }
  1265.   if HInst = 0 then HInst := HInstance;
  1266.   HRsrc := FindResource(HInst, PChar(ResName), RT_RCDATA);
  1267.   Result := HRsrc <> 0;
  1268.   if not Result then Exit;
  1269.   with TResourceStream.Create(HInst, ResName, RT_RCDATA) do
  1270.   try
  1271.     Instance := ReadComponent(Instance);
  1272.   finally
  1273.     Free;
  1274.   end;
  1275.   Result := True;
  1276. end;
  1277.  
  1278. var
  1279.   GlobalLoaded: TList;
  1280.   GlobalLists: TList;
  1281.  
  1282. procedure BeginGlobalLoading;
  1283. begin
  1284.   GlobalLists.Add(GlobalLoaded);
  1285.   GlobalLoaded := TList.Create;
  1286. end;
  1287.  
  1288. procedure NotifyGlobalLoading;
  1289. var
  1290.   I: Integer;
  1291. begin
  1292.   for I := 0 to GlobalLoaded.Count - 1 do
  1293.     TComponent(GlobalLoaded[I]).Loaded;
  1294. end;
  1295.  
  1296. procedure EndGlobalLoading;
  1297. begin
  1298.   GlobalLoaded.Free;
  1299.   GlobalLoaded := GlobalLists.Last;
  1300.   GlobalLists.Delete(GlobalLists.Count - 1);
  1301. end;
  1302.  
  1303. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  1304.  
  1305.   function InitComponent(ClassType: TClass): Boolean;
  1306.   begin
  1307.     Result := False;
  1308.     if (ClassType = TComponent) or (ClassType = RootAncestor) then Exit;
  1309.     Result := InitComponent(ClassType.ClassParent);
  1310.     Result := InternalReadComponentRes(ClassType.ClassName, FindResourceHInstance(
  1311.       FindClassHInstance(ClassType)), Instance) or Result;
  1312.   end;
  1313.  
  1314. begin
  1315.   BeginGlobalLoading;
  1316.   try
  1317.     Result := InitComponent(Instance.ClassType);
  1318.     NotifyGlobalLoading;
  1319.   finally
  1320.     EndGlobalLoading;
  1321.   end;
  1322. end;
  1323.  
  1324. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  1325. begin
  1326.   Result := InternalReadComponentRes(ResName, FindResourceHInstance(
  1327.     FindClassHInstance(Instance.ClassType)), Instance);
  1328. end;
  1329.  
  1330. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  1331. var
  1332.   HInstance: THandle;
  1333. begin
  1334.   if Instance <> nil then
  1335.     HInstance := FindResourceHInstance(FindClassHInstance(Instance.ClassType))
  1336.   else HInstance := 0;
  1337.   if InternalReadComponentRes(ResName, HInstance, Instance) then
  1338.     Result := Instance else
  1339.     raise EResNotFound.CreateFmt(SResNotFound, [ResName]);
  1340. end;
  1341.  
  1342. function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
  1343. var
  1344.   Instance: TComponent;
  1345. begin
  1346.   Instance := nil;
  1347.   if InternalReadComponentRes(ResName, HInstance, Instance) then
  1348.     Result := Instance else
  1349.     raise EResNotFound.CreateFmt(SResNotFound, [ResName]);
  1350. end;
  1351.  
  1352. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  1353. var
  1354.   Stream: TStream;
  1355. begin
  1356.   Stream := TFileStream.Create(FileName, fmOpenRead);
  1357.   try
  1358.     Result := Stream.ReadComponentRes(Instance);
  1359.   finally
  1360.     Stream.Free;
  1361.   end;
  1362. end;
  1363.  
  1364. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  1365. var
  1366.   Stream: TStream;
  1367. begin
  1368.   Stream := TFileStream.Create(FileName, fmCreate);
  1369.   try
  1370.     Stream.WriteComponentRes(Instance.ClassName, Instance);
  1371.   finally
  1372.     Stream.Free;
  1373.   end;
  1374. end;
  1375.  
  1376. function CollectionsEqual(C1, C2: TCollection): Boolean;
  1377. var
  1378.   S1, S2: TMemoryStream;
  1379.  
  1380.   procedure WriteCollection(Stream: TStream; Collection: TCollection);
  1381.   var
  1382.     Writer: TWriter;
  1383.   begin
  1384.     Writer := TWriter.Create(Stream, 1024);
  1385.     try
  1386.       Writer.WriteCollection(Collection);
  1387.     finally
  1388.       Writer.Free;
  1389.     end;
  1390.   end;
  1391.  
  1392. begin
  1393.   Result := False;
  1394.   if C1.ClassType <> C2.ClassType then Exit;
  1395.   if C1.Count <> C2.Count then Exit;
  1396.   S1 := TMemoryStream.Create;
  1397.   try
  1398.     WriteCollection(S1, C1);
  1399.     S2 := TMemoryStream.Create;
  1400.     try
  1401.       WriteCollection(S2, C2);
  1402.       Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
  1403.     finally
  1404.       S2.Free;
  1405.     end;
  1406.   finally
  1407.     S1.Free;
  1408.   end;
  1409. end;
  1410.  
  1411. { Utility routines }
  1412.  
  1413. function LineStart(Buffer, BufPos: PChar): PChar; assembler;
  1414. asm
  1415.         PUSH    EDI
  1416.         MOV     EDI,EDX
  1417.         MOV     ECX,EDX
  1418.         SUB     ECX,EAX
  1419.         SUB     ECX,1
  1420.         JBE     @@1
  1421.         MOV     EDX,EAX
  1422.         DEC     EDI
  1423.         MOV     AL,0AH
  1424.         STD
  1425.         REPNE   SCASB
  1426.         CLD
  1427.         MOV     EAX,EDX
  1428.         JNE     @@1
  1429.         LEA     EAX,[EDI+2]
  1430. @@1:    POP     EDI
  1431. end;
  1432.  
  1433. { TList }
  1434.  
  1435. destructor TList.Destroy;
  1436. begin
  1437.   Clear;
  1438. end;
  1439.  
  1440. function TList.Add(Item: Pointer): Integer;
  1441. begin
  1442.   Result := FCount;
  1443.   if Result = FCapacity then Grow;
  1444.   FList^[Result] := Item;
  1445.   Inc(FCount);
  1446. end;
  1447.  
  1448. procedure TList.Clear;
  1449. begin
  1450.   SetCount(0);
  1451.   SetCapacity(0);
  1452. end;
  1453.  
  1454. procedure TList.Delete(Index: Integer);
  1455. begin
  1456.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  1457.   Dec(FCount);
  1458.   if Index < FCount then
  1459.     System.Move(FList^[Index + 1], FList^[Index],
  1460.       (FCount - Index) * SizeOf(Pointer));
  1461. end;
  1462.  
  1463. class procedure TList.Error(const Msg: string; Data: Integer);
  1464.  
  1465.   function ReturnAddr: Pointer;
  1466.   asm
  1467.           MOV     EAX,[EBP+4]
  1468.   end;
  1469.  
  1470. begin
  1471.   raise EListError.CreateFmt(Msg, [Data]) at ReturnAddr;
  1472. end;
  1473.  
  1474. procedure TList.Exchange(Index1, Index2: Integer);
  1475. var
  1476.   Item: Pointer;
  1477. begin
  1478.   if (Index1 < 0) or (Index1 >= FCount) then Error(SListIndexError, Index1);
  1479.   if (Index2 < 0) or (Index2 >= FCount) then Error(SListIndexError, Index2);
  1480.   Item := FList^[Index1];
  1481.   FList^[Index1] := FList^[Index2];
  1482.   FList^[Index2] := Item;
  1483. end;
  1484.  
  1485. function TList.Expand: TList;
  1486. begin
  1487.   if FCount = FCapacity then Grow;
  1488.   Result := Self;
  1489. end;
  1490.  
  1491. function TList.First: Pointer;
  1492. begin
  1493.   Result := Get(0);
  1494. end;
  1495.  
  1496. function TList.Get(Index: Integer): Pointer;
  1497. begin
  1498.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  1499.   Result := FList^[Index];
  1500. end;
  1501.  
  1502. procedure TList.Grow;
  1503. var
  1504.   Delta: Integer;
  1505. begin
  1506.   if FCapacity > 64 then Delta := FCapacity div 4 else
  1507.     if FCapacity > 8 then Delta := 16 else
  1508.       Delta := 4;
  1509.   SetCapacity(FCapacity + Delta);
  1510. end;
  1511.  
  1512. function TList.IndexOf(Item: Pointer): Integer;
  1513. begin
  1514.   Result := 0;
  1515.   while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result);
  1516.   if Result = FCount then Result := -1;
  1517. end;
  1518.  
  1519. procedure TList.Insert(Index: Integer; Item: Pointer);
  1520. begin
  1521.   if (Index < 0) or (Index > FCount) then Error(SListIndexError, Index);
  1522.   if FCount = FCapacity then Grow;
  1523.   if Index < FCount then
  1524.     System.Move(FList^[Index], FList^[Index + 1],
  1525.       (FCount - Index) * SizeOf(Pointer));
  1526.   FList^[Index] := Item;
  1527.   Inc(FCount);
  1528. end;
  1529.  
  1530. function TList.Last: Pointer;
  1531. begin
  1532.   Result := Get(FCount - 1);
  1533. end;
  1534.  
  1535. procedure TList.Move(CurIndex, NewIndex: Integer);
  1536. var
  1537.   Item: Pointer;
  1538. begin
  1539.   if CurIndex <> NewIndex then
  1540.   begin
  1541.     if (NewIndex < 0) or (NewIndex >= FCount) then Error(SListIndexError, NewIndex);
  1542.     Item := Get(CurIndex);
  1543.     Delete(CurIndex);
  1544.     Insert(NewIndex, Item);
  1545.   end;
  1546. end;
  1547.  
  1548. procedure TList.Put(Index: Integer; Item: Pointer);
  1549. begin
  1550.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  1551.   FList^[Index] := Item;
  1552. end;
  1553.  
  1554. function TList.Remove(Item: Pointer): Integer;
  1555. begin
  1556.   Result := IndexOf(Item);
  1557.   if Result <> -1 then Delete(Result);
  1558. end;
  1559.  
  1560. procedure TList.Pack;
  1561. var
  1562.   I: Integer;
  1563. begin
  1564.   for I := FCount - 1 downto 0 do if Items[I] = nil then Delete(I);
  1565. end;
  1566.  
  1567. procedure TList.SetCapacity(NewCapacity: Integer);
  1568. begin
  1569.   if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
  1570.     Error(SListCapacityError, NewCapacity);
  1571.   if NewCapacity <> FCapacity then
  1572.   begin
  1573.     ReallocMem(FList, NewCapacity * SizeOf(Pointer));
  1574.     FCapacity := NewCapacity;
  1575.   end;
  1576. end;
  1577.  
  1578. procedure TList.SetCount(NewCount: Integer);
  1579. begin
  1580.   if (NewCount < 0) or (NewCount > MaxListSize) then
  1581.     Error(SListCountError, NewCount);
  1582.   if NewCount > FCapacity then SetCapacity(NewCount);
  1583.   if NewCount > FCount then
  1584.     FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0);
  1585.   FCount := NewCount;
  1586. end;
  1587.  
  1588. procedure QuickSort(SortList: PPointerList; L, R: Integer;
  1589.   SCompare: TListSortCompare);
  1590. var
  1591.   I, J: Integer;
  1592.   P, T: Pointer;
  1593. begin
  1594.   repeat
  1595.     I := L;
  1596.     J := R;
  1597.     P := SortList^[(L + R) shr 1];
  1598.     repeat
  1599.       while SCompare(SortList^[I], P) < 0 do Inc(I);
  1600.       while SCompare(SortList^[J], P) > 0 do Dec(J);
  1601.       if I <= J then
  1602.       begin
  1603.         T := SortList^[I];
  1604.         SortList^[I] := SortList^[J];
  1605.         SortList^[J] := T;
  1606.         Inc(I);
  1607.         Dec(J);
  1608.       end;
  1609.     until I > J;
  1610.     if L < J then QuickSort(SortList, L, J, SCompare);
  1611.     L := I;
  1612.   until I >= R;
  1613. end;
  1614.  
  1615. procedure TList.Sort(Compare: TListSortCompare);
  1616. begin
  1617.   if (FList <> nil) and (Count > 0) then
  1618.     QuickSort(FList, 0, Count - 1, Compare);
  1619. end;
  1620.  
  1621. { TThreadList }
  1622.  
  1623. constructor TThreadList.Create;
  1624. begin
  1625.   inherited Create;
  1626.   InitializeCriticalSection(FLock);
  1627.   FList := TList.Create;
  1628. end;
  1629.  
  1630. destructor TThreadList.Destroy;
  1631. begin
  1632.   LockList;    // Make sure nobody else is inside the list.
  1633.   try
  1634.     FList.Free;
  1635.     inherited Destroy;
  1636.   finally
  1637.     UnlockList;
  1638.     DeleteCriticalSection(FLock);
  1639.   end;
  1640. end;
  1641.  
  1642. procedure TThreadList.Add(Item: Pointer);
  1643. begin
  1644.   LockList;
  1645.   try
  1646.     if FList.IndexOf(Item) = -1 then
  1647.       FList.Add(Item);
  1648.   finally
  1649.     UnlockList;
  1650.   end;
  1651. end;
  1652.  
  1653. procedure TThreadList.Clear;
  1654. begin
  1655.   LockList;
  1656.   try
  1657.     FList.Clear;
  1658.   finally
  1659.     UnlockList;
  1660.   end;
  1661. end;
  1662.  
  1663. function  TThreadList.LockList: TList;
  1664. begin
  1665.   EnterCriticalSection(FLock);
  1666.   Result := FList;
  1667. end;
  1668.  
  1669. procedure TThreadList.Remove(Item: Pointer);
  1670. begin
  1671.   LockList;
  1672.   try
  1673.     FList.Remove(Item);
  1674.   finally
  1675.     UnlockList;
  1676.   end;
  1677. end;
  1678.  
  1679. procedure TThreadList.UnlockList;
  1680. begin
  1681.   LeaveCriticalSection(FLock);
  1682. end;
  1683.  
  1684.  
  1685. { TBits }
  1686.  
  1687. const
  1688.   BitsPerInt = SizeOf(Integer) * 8;
  1689.  
  1690. type
  1691.   TBitEnum = 0..BitsPerInt - 1;
  1692.   TBitSet = set of TBitEnum;
  1693.   PBitArray = ^TBitArray;
  1694.   TBitArray = array[0..4096] of TBitSet;
  1695.  
  1696. destructor TBits.Destroy;
  1697. begin
  1698.   SetSize(0);
  1699.   inherited Destroy;
  1700. end;
  1701.  
  1702. procedure TBits.Error;
  1703. begin
  1704.   raise EBitsError.Create(SBitsIndexError);
  1705. end;
  1706.  
  1707. procedure TBits.SetSize(Value: Integer);
  1708. var
  1709.   NewMem: Pointer;
  1710.   NewMemSize: Integer;
  1711.   OldMemSize: Integer;
  1712.  
  1713.   function Min(X, Y: Integer): Integer;
  1714.   begin
  1715.     Result := X;
  1716.     if X > Y then Result := Y;
  1717.   end;
  1718.  
  1719. begin
  1720.   if Value <> Size then
  1721.   begin
  1722.     if Value < 0 then Error;
  1723.     NewMemSize := ((Value + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  1724.     OldMemSize := ((Size + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  1725.     if NewMemSize <> OldMemSize then
  1726.     begin
  1727.       NewMem := nil;
  1728.       if NewMemSize <> 0 then
  1729.       begin
  1730.         GetMem(NewMem, NewMemSize);
  1731.         FillChar(NewMem^, NewMemSize, 0);
  1732.       end;
  1733.       if OldMemSize <> 0 then
  1734.       begin
  1735.         if NewMem <> nil then
  1736.           Move(FBits^, NewMem^, Min(OldMemSize, NewMemSize));
  1737.         FreeMem(FBits, OldMemSize);
  1738.       end;
  1739.       FBits := NewMem;
  1740.     end;
  1741.     FSize := Value;
  1742.   end;
  1743. end;
  1744.  
  1745.  
  1746. procedure TBits.SetBit(Index: Integer; Value: Boolean); assembler;
  1747. asm
  1748.         CMP     Index,[EAX].FSize
  1749.         JAE     @@Size
  1750.  
  1751. @@1:    MOV     EAX,[EAX].FBits
  1752.         OR      Value,Value
  1753.         JZ      @@2
  1754.         BTS     [EAX],Index
  1755.         RET
  1756.  
  1757. @@2:    BTR     [EAX],Index
  1758.         RET
  1759.  
  1760. @@Size: CMP     Index,0
  1761.         JL      TBits.Error
  1762.         PUSH    Self
  1763.         PUSH    Index
  1764.         PUSH    ECX {Value}
  1765.         INC     Index
  1766.         CALL    TBits.SetSize
  1767.         POP     ECX {Value}
  1768.         POP     Index
  1769.         POP     Self
  1770.         JMP     @@1
  1771. end;
  1772.  
  1773. function TBits.GetBit(Index: Integer): Boolean; assembler;
  1774. asm
  1775.         CMP     Index,[EAX].FSize
  1776.         JAE     TBits.Error
  1777.         MOV     EAX,[EAX].FBits
  1778.         BT      [EAX],Index
  1779.         SBB     EAX,EAX
  1780.         AND     EAX,1
  1781. end;
  1782.  
  1783.  
  1784. function TBits.OpenBit: Integer;
  1785. var
  1786.   I: Integer;
  1787.   B: TBitSet;
  1788.   J: TBitEnum;
  1789.   E: Integer;
  1790. begin
  1791.   E := (Size + BitsPerInt - 1) div BitsPerInt - 1;
  1792.   for I := 0 to E do
  1793.     if PBitArray(FBits)^[I] <> [0..BitsPerInt - 1] then
  1794.     begin
  1795.       B := PBitArray(FBits)^[I];
  1796.       for J := Low(J) to High(J) do
  1797.       begin
  1798.         if not (J in B) then
  1799.         begin
  1800.           Result := I * BitsPerInt + J;
  1801.           if Result >= Size then Result := Size;
  1802.           Exit;
  1803.         end;
  1804.       end;
  1805.     end;
  1806.   Result := Size;
  1807. end;
  1808.  
  1809. { TPersistent }
  1810.  
  1811. destructor TPersistent.Destroy;
  1812. begin
  1813.   RemoveFixups(Self);
  1814.   inherited Destroy;
  1815. end;
  1816.  
  1817. procedure TPersistent.Assign(Source: TPersistent);
  1818. begin
  1819.   if Source <> nil then Source.AssignTo(Self) else AssignError(nil);
  1820. end;
  1821.  
  1822. procedure TPersistent.AssignError(Source: TPersistent);
  1823. var
  1824.   SourceName: string;
  1825. begin
  1826.   if Source <> nil then
  1827.     SourceName := Source.ClassName else
  1828.     SourceName := 'nil';
  1829.   raise EConvertError.CreateFmt(SAssignError, [SourceName, ClassName]);
  1830. end;
  1831.  
  1832. procedure TPersistent.AssignTo(Dest: TPersistent);
  1833. begin
  1834.   Dest.AssignError(Self);
  1835. end;
  1836.  
  1837. procedure TPersistent.DefineProperties(Filer: TFiler);
  1838. begin
  1839. end;
  1840.  
  1841. function TPersistent.GetNamePath: string;
  1842. var
  1843.   S: string;
  1844. begin
  1845.   Result := ClassName;
  1846.   if (GetOwner <> nil) then
  1847.   begin
  1848.     S := GetOwner.GetNamePath;
  1849.     if S <> '' then
  1850.       Result := S + '.' + Result;
  1851.   end;
  1852. end;
  1853.  
  1854. function TPersistent.GetOwner: TPersistent;
  1855. begin
  1856.   Result := nil;
  1857. end;
  1858.  
  1859. { TCollectionItem }
  1860.  
  1861. constructor TCollectionItem.Create(Collection: TCollection);
  1862. begin
  1863.   SetCollection(Collection);
  1864. end;
  1865.  
  1866. destructor TCollectionItem.Destroy;
  1867. begin
  1868.   SetCollection(nil);
  1869.   inherited Destroy;
  1870. end;
  1871.  
  1872. procedure TCollectionItem.Changed(AllItems: Boolean);
  1873. var
  1874.   Item: TCollectionItem;
  1875. begin
  1876.   if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then
  1877.   begin
  1878.     if AllItems then Item := nil else Item := Self;
  1879.     FCollection.Update(Item);
  1880.   end;
  1881. end;
  1882.  
  1883. function TCollectionItem.GetIndex: Integer;
  1884. begin
  1885.   if FCollection <> nil then
  1886.     Result := FCollection.FItems.IndexOf(Self) else
  1887.     Result := -1;
  1888. end;
  1889.  
  1890. function TCollectionItem.GetDisplayName: string;
  1891. begin
  1892.   Result := ClassName;
  1893. end;
  1894.  
  1895. function TCollectionItem.GetNamePath: string;
  1896. begin
  1897.   if FCollection <> nil then
  1898.     Result := Format('%s[%d]',[FCollection.GetNamePath, Index])
  1899.   else
  1900.     Result := ClassName;
  1901. end;
  1902.  
  1903. function TCollectionItem.GetOwner: TPersistent;
  1904. begin
  1905.   Result := FCollection;
  1906. end;
  1907.  
  1908. procedure TCollectionItem.SetCollection(Value: TCollection);
  1909. begin
  1910.   if FCollection <> Value then
  1911.   begin
  1912.     if FCollection <> nil then FCollection.RemoveItem(Self);
  1913.     if Value <> nil then Value.InsertItem(Self);
  1914.   end;
  1915. end;
  1916.  
  1917. procedure TCollectionItem.SetDisplayName(const Value: string);
  1918. begin
  1919.   Changed(False);
  1920. end;
  1921.  
  1922. procedure TCollectionItem.SetIndex(Value: Integer);
  1923. var
  1924.   CurIndex: Integer;
  1925. begin
  1926.   CurIndex := GetIndex;
  1927.   if (CurIndex >= 0) and (CurIndex <> Value) then
  1928.   begin
  1929.     FCollection.FItems.Move(CurIndex, Value);
  1930.     Changed(True);
  1931.   end;
  1932. end;
  1933.  
  1934. { TCollection }
  1935.  
  1936. constructor TCollection.Create(ItemClass: TCollectionItemClass);
  1937. begin
  1938.   FItemClass := ItemClass;
  1939.   FItems := TList.Create;
  1940. end;
  1941.  
  1942. destructor TCollection.Destroy;
  1943. begin
  1944.   FUpdateCount := 1;
  1945.   if FItems <> nil then Clear;
  1946.   FItems.Free;
  1947.   inherited Destroy;
  1948. end;
  1949.  
  1950. function TCollection.Add: TCollectionItem;
  1951. begin
  1952.   Result := FItemClass.Create(Self);
  1953. end;
  1954.  
  1955. procedure TCollection.Assign(Source: TPersistent);
  1956. var
  1957.   I: Integer;
  1958. begin
  1959.   if Source is TCollection then
  1960.   begin
  1961.     BeginUpdate;
  1962.     try
  1963.       Clear;
  1964.       for I := 0 to TCollection(Source).Count - 1 do
  1965.         Add.Assign(TCollection(Source).Items[I]);
  1966.     finally
  1967.       EndUpdate;
  1968.     end;
  1969.     Exit;
  1970.   end;
  1971.   inherited Assign(Source);
  1972. end;
  1973.  
  1974. procedure TCollection.BeginUpdate;
  1975. begin
  1976.   Inc(FUpdateCount);
  1977. end;
  1978.  
  1979. procedure TCollection.Changed;
  1980. begin
  1981.   if FUpdateCount = 0 then Update(nil);
  1982. end;
  1983.  
  1984. procedure TCollection.Clear;
  1985. begin
  1986.   if FItems.Count > 0 then
  1987.   begin
  1988.     BeginUpdate;
  1989.     try
  1990.       while FItems.Count > 0 do TCollectionItem(FItems.Last).Free;
  1991.     finally
  1992.       EndUpdate;
  1993.     end;
  1994.   end;
  1995. end;
  1996.  
  1997. procedure TCollection.EndUpdate;
  1998. begin
  1999.   Dec(FUpdateCount);
  2000.   Changed;
  2001. end;
  2002.  
  2003. function TCollection.FindItemID(ID: Integer): TCollectionItem;
  2004. var
  2005.   I: Integer;
  2006. begin
  2007.   for I := 0 to FItems.Count-1 do
  2008.   begin
  2009.     Result := TCollectionItem(FItems[I]);
  2010.     if Result.ID = ID then Exit;
  2011.   end;
  2012.   Result := nil;
  2013. end;
  2014.  
  2015. function TCollection.GetAttrCount: Integer;
  2016. begin
  2017.   Result := 0;
  2018. end;
  2019.  
  2020. function TCollection.GetAttr(Index: Integer): string;
  2021. begin
  2022.   Result := '';
  2023. end;
  2024.  
  2025. function TCollection.GetItemAttr(Index, ItemIndex: Integer): string;
  2026. begin
  2027.   Result := Items[ItemIndex].DisplayName;
  2028. end;
  2029.  
  2030. function TCollection.GetCount: Integer;
  2031. begin
  2032.   Result := FItems.Count;
  2033. end;
  2034.  
  2035. function TCollection.GetItem(Index: Integer): TCollectionItem;
  2036. begin
  2037.   Result := FItems[Index];
  2038. end;
  2039.  
  2040. function TCollection.GetNamePath: string;
  2041. var
  2042.   S, P: string;
  2043. begin
  2044.   Result := ClassName;
  2045.   if GetOwner = nil then Exit;
  2046.   S := GetOwner.GetNamePath;
  2047.   if S = '' then Exit;
  2048.   P := PropName;
  2049.   if P = '' then Exit;
  2050.   Result := S + '.' + P;
  2051. end;
  2052.  
  2053. function TCollection.GetPropName: string;
  2054. var
  2055.   I: Integer;
  2056.   Props: PPropList;
  2057.   TypeData: PTypeData;
  2058.   Owner: TPersistent;
  2059. begin
  2060.   Result := FPropName;
  2061.   Owner := GetOwner;
  2062.   if (Result <> '') or (Owner = nil) or (Owner.ClassInfo = nil) then Exit;
  2063.   TypeData := GetTypeData(Owner.ClassInfo);
  2064.   if (TypeData = nil) or (TypeData^.PropCount = 0) then Exit;
  2065.   GetMem(Props, TypeData^.PropCount * sizeof(Pointer));
  2066.   try
  2067.     GetPropInfos(Owner.ClassInfo, Props);
  2068.     for I := 0 to TypeData^.PropCount-1 do
  2069.     begin
  2070.       with Props^[I]^ do
  2071.         if (PropType^^.Kind = tkClass) and
  2072.           (GetOrdProp(Owner, Props^[I]) = Integer(Self)) then
  2073.           FPropName := Name;
  2074.     end;
  2075.   finally
  2076.     Freemem(Props);
  2077.   end;
  2078.   Result := FPropName;
  2079. end;
  2080.  
  2081. procedure TCollection.InsertItem(Item: TCollectionItem);
  2082. begin
  2083.   if not (Item is FItemClass) then TList.Error(SInvalidProperty, 0);
  2084.   FItems.Add(Item);
  2085.   Item.FCollection := Self;
  2086.   Item.FID := FNextID;
  2087.   Inc(FNextID);
  2088.   SetItemName(Item);
  2089.   Changed;
  2090. end;
  2091.  
  2092. procedure TCollection.RemoveItem(Item: TCollectionItem);
  2093. begin
  2094.   FItems.Remove(Item);
  2095.   Item.FCollection := nil;
  2096.   Changed;
  2097. end;
  2098.  
  2099. procedure TCollection.SetItem(Index: Integer; Value: TCollectionItem);
  2100. begin
  2101.   TCollectionItem(FItems[Index]).Assign(Value);
  2102. end;
  2103.  
  2104. procedure TCollection.SetItemName(Item: TCollectionItem);
  2105. begin
  2106. end;
  2107.  
  2108. procedure TCollection.Update(Item: TCollectionItem);
  2109. begin
  2110. end;
  2111.  
  2112. { TStrings }
  2113. destructor TStrings.Destroy;
  2114. begin
  2115.   StringsAdapter := nil;
  2116.   inherited Destroy;
  2117. end;
  2118.  
  2119. function TStrings.Add(const S: string): Integer;
  2120. begin
  2121.   Result := GetCount;
  2122.   Insert(Result, S);
  2123. end;
  2124.  
  2125. function TStrings.AddObject(const S: string; AObject: TObject): Integer;
  2126. begin
  2127.   Result := Add(S);
  2128.   PutObject(Result, AObject);
  2129. end;
  2130.  
  2131. procedure TStrings.Append(const S: string);
  2132. begin
  2133.   Add(S);
  2134. end;
  2135.  
  2136. procedure TStrings.AddStrings(Strings: TStrings);
  2137. var
  2138.   I: Integer;
  2139. begin
  2140.   BeginUpdate;
  2141.   try
  2142.     for I := 0 to Strings.Count - 1 do
  2143.       AddObject(Strings[I], Strings.Objects[I]);
  2144.   finally
  2145.     EndUpdate;
  2146.   end;
  2147. end;
  2148.  
  2149. procedure TStrings.Assign(Source: TPersistent);
  2150. begin
  2151.   if Source is TStrings then
  2152.   begin
  2153.     BeginUpdate;
  2154.     try
  2155.       Clear;
  2156.       AddStrings(TStrings(Source));
  2157.     finally
  2158.       EndUpdate;
  2159.     end;
  2160.     Exit;
  2161.   end;
  2162.   inherited Assign(Source);
  2163. end;
  2164.  
  2165. procedure TStrings.BeginUpdate;
  2166. begin
  2167.   if FUpdateCount = 0 then SetUpdateState(True);
  2168.   Inc(FUpdateCount);
  2169. end;
  2170.  
  2171. procedure TStrings.DefineProperties(Filer: TFiler);
  2172.  
  2173.   function DoWrite: Boolean;
  2174.   begin
  2175.     if Filer.Ancestor <> nil then
  2176.     begin
  2177.       Result := True;
  2178.       if Filer.Ancestor is TStrings then
  2179.         Result := not Equals(TStrings(Filer.Ancestor))
  2180.     end
  2181.     else Result := Count > 0;
  2182.   end;
  2183.  
  2184. begin
  2185.   Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite);
  2186. end;
  2187.  
  2188. procedure TStrings.EndUpdate;
  2189. begin
  2190.   Dec(FUpdateCount);
  2191.   if FUpdateCount = 0 then SetUpdateState(False);
  2192. end;
  2193.  
  2194. function TStrings.Equals(Strings: TStrings): Boolean;
  2195. var
  2196.   I, Count: Integer;
  2197. begin
  2198.   Result := False;
  2199.   Count := GetCount;
  2200.   if Count <> Strings.GetCount then Exit;
  2201.   for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit;
  2202.   Result := True;
  2203. end;
  2204.  
  2205. procedure TStrings.Error(const Msg: string; Data: Integer);
  2206.  
  2207.   function ReturnAddr: Pointer;
  2208.   asm
  2209.           MOV     EAX,[EBP+4]
  2210.   end;
  2211.  
  2212. begin
  2213.   raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr;
  2214. end;
  2215.  
  2216. procedure TStrings.Exchange(Index1, Index2: Integer);
  2217. var
  2218.   TempObject: TObject;
  2219.   TempString: string;
  2220. begin
  2221.   BeginUpdate;
  2222.   try
  2223.     TempString := Strings[Index1];
  2224.     TempObject := Objects[Index1];
  2225.     Strings[Index1] := Strings[Index2];
  2226.     Objects[Index1] := Objects[Index2];
  2227.     Strings[Index2] := TempString;
  2228.     Objects[Index2] := TempObject;
  2229.   finally
  2230.     EndUpdate;
  2231.   end;
  2232. end;
  2233.  
  2234. function TStrings.GetCapacity: Integer;
  2235. begin  // descendants may optionally override/replace this default implementation
  2236.   Result := Count;
  2237. end;
  2238.  
  2239. function TStrings.GetCommaText: string;
  2240. var
  2241.   S: string;
  2242.   P: PChar;
  2243.   I, Count: Integer;
  2244. begin
  2245.   Count := GetCount;
  2246.   if (Count = 1) and (Get(0) = '') then
  2247.     Result := '""'
  2248.   else
  2249.   begin
  2250.     Result := '';
  2251.     for I := 0 to Count - 1 do
  2252.     begin
  2253.       S := Get(I);
  2254.       P := PChar(S);
  2255.       while not (P^ in [#0..' ','"',',']) do P := CharNext(P);
  2256.       if (P^ <> #0) then S := AnsiQuotedStr(S, '"');
  2257.       Result := Result + S + ',';
  2258.     end;
  2259.     System.Delete(Result, Length(Result), 1);
  2260.   end;
  2261. end;
  2262.  
  2263. function TStrings.GetName(Index: Integer): string;
  2264. var
  2265.   P: Integer;
  2266. begin
  2267.   Result := Get(Index);
  2268.   P := AnsiPos('=', Result);
  2269.   if P <> 0 then
  2270.     SetLength(Result, P-1) else
  2271.     SetLength(Result, 0);
  2272. end;
  2273.  
  2274. function TStrings.GetObject(Index: Integer): TObject;
  2275. begin
  2276.   Result := nil;
  2277. end;
  2278.  
  2279. function TStrings.GetText: PChar;
  2280. begin
  2281.   Result := StrNew(PChar(GetTextStr));
  2282. end;
  2283.  
  2284. function TStrings.GetTextStr: string;
  2285. var
  2286.   I, L, Size, Count: Integer;
  2287.   P: PChar;
  2288.   S: string;
  2289. begin
  2290.   Count := GetCount;
  2291.   Size := 0;
  2292.   for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + 2);
  2293.   SetString(Result, nil, Size);
  2294.   P := Pointer(Result);
  2295.   for I := 0 to Count - 1 do
  2296.   begin
  2297.     S := Get(I);
  2298.     L := Length(S);
  2299.     if L <> 0 then
  2300.     begin
  2301.       System.Move(Pointer(S)^, P^, L);
  2302.       Inc(P, L);
  2303.     end;
  2304.     P^ := #13;
  2305.     Inc(P);
  2306.     P^ := #10;
  2307.     Inc(P);
  2308.   end;
  2309. end;
  2310.  
  2311. function TStrings.GetValue(const Name: string): string;
  2312. var
  2313.   I: Integer;
  2314. begin
  2315.   I := IndexOfName(Name);
  2316.   if I >= 0 then
  2317.     Result := Copy(Get(I), Length(Name) + 2, MaxInt) else
  2318.     Result := '';
  2319. end;
  2320.  
  2321. function TStrings.IndexOf(const S: string): Integer;
  2322. begin
  2323.   for Result := 0 to GetCount - 1 do
  2324.     if AnsiCompareText(Get(Result), S) = 0 then Exit;
  2325.   Result := -1;
  2326. end;
  2327.  
  2328. function TStrings.IndexOfName(const Name: string): Integer;
  2329. var
  2330.   P: Integer;
  2331.   S: string;
  2332. begin
  2333.   for Result := 0 to GetCount - 1 do
  2334.   begin
  2335.     S := Get(Result);
  2336.     P := AnsiPos('=', S);
  2337.     if (P <> 0) and (AnsiCompareText(Copy(S, 1, P - 1), Name) = 0) then Exit;
  2338.   end;
  2339.   Result := -1;
  2340. end;
  2341.  
  2342. function TStrings.IndexOfObject(AObject: TObject): Integer;
  2343. begin
  2344.   for Result := 0 to GetCount - 1 do
  2345.     if GetObject(Result) = AObject then Exit;
  2346.   Result := -1;
  2347. end;
  2348.  
  2349. procedure TStrings.InsertObject(Index: Integer; const S: string;
  2350.   AObject: TObject);
  2351. begin
  2352.   Insert(Index, S);
  2353.   PutObject(Index, AObject);
  2354. end;
  2355.  
  2356. procedure TStrings.LoadFromFile(const FileName: string);
  2357. var
  2358.   Stream: TStream;
  2359. begin
  2360.   Stream := TFileStream.Create(FileName, fmOpenRead);
  2361.   try
  2362.     LoadFromStream(Stream);
  2363.   finally
  2364.     Stream.Free;
  2365.   end;
  2366. end;
  2367.  
  2368. procedure TStrings.LoadFromStream(Stream: TStream);
  2369. var
  2370.   Size: Integer;
  2371.   S: string;
  2372. begin
  2373.   BeginUpdate;
  2374.   try
  2375.     Size := Stream.Size - Stream.Position;
  2376.     SetString(S, nil, Size);
  2377.     Stream.Read(Pointer(S)^, Size);
  2378.     SetTextStr(S);
  2379.   finally
  2380.     EndUpdate;
  2381.   end;
  2382. end;
  2383.  
  2384. procedure TStrings.Move(CurIndex, NewIndex: Integer);
  2385. var
  2386.   TempObject: TObject;
  2387.   TempString: string;
  2388. begin
  2389.   if CurIndex <> NewIndex then
  2390.   begin
  2391.     BeginUpdate;
  2392.     try
  2393.       TempString := Get(CurIndex);
  2394.       TempObject := GetObject(CurIndex);
  2395.       Delete(CurIndex);
  2396.       InsertObject(NewIndex, TempString, TempObject);
  2397.     finally
  2398.       EndUpdate;
  2399.     end;
  2400.   end;
  2401. end;
  2402.  
  2403. procedure TStrings.Put(Index: Integer; const S: string);
  2404. var
  2405.   TempObject: TObject;
  2406. begin
  2407.   TempObject := GetObject(Index);
  2408.   Delete(Index);
  2409.   InsertObject(Index, S, TempObject);
  2410. end;
  2411.  
  2412. procedure TStrings.PutObject(Index: Integer; AObject: TObject);
  2413. begin
  2414. end;
  2415.  
  2416. procedure TStrings.ReadData(Reader: TReader);
  2417. begin
  2418.   Reader.ReadListBegin;
  2419.   BeginUpdate;
  2420.   try
  2421.     Clear;
  2422.     while not Reader.EndOfList do Add(Reader.ReadString);
  2423.   finally
  2424.     EndUpdate;
  2425.   end;
  2426.   Reader.ReadListEnd;
  2427. end;
  2428.  
  2429. procedure TStrings.SaveToFile(const FileName: string);
  2430. var
  2431.   Stream: TStream;
  2432. begin
  2433.   Stream := TFileStream.Create(FileName, fmCreate);
  2434.   try
  2435.     SaveToStream(Stream);
  2436.   finally
  2437.     Stream.Free;
  2438.   end;
  2439. end;
  2440.  
  2441. procedure TStrings.SaveToStream(Stream: TStream);
  2442. var
  2443.   S: string;
  2444. begin
  2445.   S := GetTextStr;
  2446.   Stream.WriteBuffer(Pointer(S)^, Length(S));
  2447. end;
  2448.  
  2449. procedure TStrings.SetCapacity(NewCapacity: Integer);
  2450. begin
  2451.   // do nothing - descendants may optionally implement this method
  2452. end;
  2453.  
  2454. procedure TStrings.SetCommaText(const Value: string);
  2455. var
  2456.   P, P1: PChar;
  2457.   S: string;
  2458. begin
  2459.   BeginUpdate;
  2460.   try
  2461.     Clear;
  2462.     P := PChar(Value);
  2463.     while P^ in [#1..' '] do P := CharNext(P);
  2464.     while P^ <> #0 do
  2465.     begin
  2466.       if P^ = '"' then
  2467.         S := AnsiExtractQuotedStr(P, '"')
  2468.       else
  2469.       begin
  2470.         P1 := P;
  2471.         while (P^ > ' ') and (P^ <> ',') do P := CharNext(P);
  2472.         SetString(S, P1, P - P1);
  2473.       end;
  2474.       Add(S);
  2475.       while P^ in [#1..' '] do P := CharNext(P);
  2476.       if P^ = ',' then
  2477.         repeat
  2478.           P := CharNext(P);
  2479.         until not (P^ in [#1..' ']);
  2480.     end;
  2481.   finally
  2482.     EndUpdate;
  2483.   end;
  2484. end;
  2485.  
  2486. procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter);
  2487. begin
  2488.   if FAdapter <> nil then FAdapter.ReleaseStrings;
  2489.   FAdapter := Value;
  2490.   if FAdapter <> nil then FAdapter.ReferenceStrings(Self);
  2491. end;
  2492.  
  2493. procedure TStrings.SetText(Text: PChar);
  2494. begin
  2495.   SetTextStr(Text);
  2496. end;
  2497.  
  2498. procedure TStrings.SetTextStr(const Value: string);
  2499. var
  2500.   P, Start: PChar;
  2501.   S: string;
  2502. begin
  2503.   BeginUpdate;
  2504.   try
  2505.     Clear;
  2506.     P := Pointer(Value);
  2507.     if P <> nil then
  2508.       while P^ <> #0 do
  2509.       begin
  2510.         Start := P;
  2511.         while not (P^ in [#0, #10, #13]) do Inc(P);
  2512.         SetString(S, Start, P - Start);
  2513.         Add(S);
  2514.         if P^ = #13 then Inc(P);
  2515.         if P^ = #10 then Inc(P);
  2516.       end;
  2517.   finally
  2518.     EndUpdate;
  2519.   end;
  2520. end;
  2521.  
  2522. procedure TStrings.SetUpdateState(Updating: Boolean);
  2523. begin
  2524. end;
  2525.  
  2526. procedure TStrings.SetValue(const Name, Value: string);
  2527. var
  2528.   I: Integer;
  2529. begin
  2530.   I := IndexOfName(Name);
  2531.   if Value <> '' then
  2532.   begin
  2533.     if I < 0 then I := Add('');
  2534.     Put(I, Name + '=' + Value);
  2535.   end else
  2536.   begin
  2537.     if I >= 0 then Delete(I);
  2538.   end;
  2539. end;
  2540.  
  2541. procedure TStrings.WriteData(Writer: TWriter);
  2542. var
  2543.   I: Integer;
  2544. begin
  2545.   Writer.WriteListBegin;
  2546.   for I := 0 to Count - 1 do Writer.WriteString(Get(I));
  2547.   Writer.WriteListEnd;
  2548. end;
  2549.  
  2550. { TStringList }
  2551.  
  2552. destructor TStringList.Destroy;
  2553. begin
  2554.   FOnChange := nil;
  2555.   FOnChanging := nil;
  2556.   inherited Destroy;
  2557.   if FCount <> 0 then Finalize(FList^[0], FCount);
  2558.   FCount := 0;
  2559.   SetCapacity(0);
  2560. end;
  2561.  
  2562. function TStringList.Add(const S: string): Integer;
  2563. begin
  2564.   if not Sorted then
  2565.     Result := FCount
  2566.   else
  2567.     if Find(S, Result) then
  2568.       case Duplicates of
  2569.         dupIgnore: Exit;
  2570.         dupError: Error(SDuplicateString, 0);
  2571.       end;
  2572.   InsertItem(Result, S);
  2573. end;
  2574.  
  2575. procedure TStringList.Changed;
  2576. begin
  2577.   if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
  2578. end;
  2579.  
  2580. procedure TStringList.Changing;
  2581. begin
  2582.   if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
  2583. end;
  2584.  
  2585. procedure TStringList.Clear;
  2586. begin
  2587.   if FCount <> 0 then
  2588.   begin
  2589.     Changing;
  2590.     Finalize(FList^[0], FCount);
  2591.     FCount := 0;
  2592.     SetCapacity(0);
  2593.     Changed;
  2594.   end;
  2595. end;
  2596.  
  2597. procedure TStringList.Delete(Index: Integer);
  2598. begin
  2599.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2600.   Changing;
  2601.   Finalize(FList^[Index]);
  2602.   Dec(FCount);
  2603.   if Index < FCount then
  2604.     System.Move(FList^[Index + 1], FList^[Index],
  2605.       (FCount - Index) * SizeOf(TStringItem));
  2606.   Changed;
  2607. end;
  2608.  
  2609. procedure TStringList.Exchange(Index1, Index2: Integer);
  2610. begin
  2611.   if (Index1 < 0) or (Index1 >= FCount) then Error(SListIndexError, Index1);
  2612.   if (Index2 < 0) or (Index2 >= FCount) then Error(SListIndexError, Index2);
  2613.   Changing;
  2614.   ExchangeItems(Index1, Index2);
  2615.   Changed;
  2616. end;
  2617.  
  2618. procedure TStringList.ExchangeItems(Index1, Index2: Integer);
  2619. var
  2620.   Temp: Integer;
  2621.   Item1, Item2: PStringItem;
  2622. begin
  2623.   Item1 := @FList^[Index1];
  2624.   Item2 := @FList^[Index2];
  2625.   Temp := Integer(Item1^.FString);
  2626.   Integer(Item1^.FString) := Integer(Item2^.FString);
  2627.   Integer(Item2^.FString) := Temp;
  2628.   Temp := Integer(Item1^.FObject);
  2629.   Integer(Item1^.FObject) := Integer(Item2^.FObject);
  2630.   Integer(Item2^.FObject) := Temp;
  2631. end;
  2632.  
  2633. function TStringList.Find(const S: string; var Index: Integer): Boolean;
  2634. var
  2635.   L, H, I, C: Integer;
  2636. begin
  2637.   Result := False;
  2638.   L := 0;
  2639.   H := FCount - 1;
  2640.   while L <= H do
  2641.   begin
  2642.     I := (L + H) shr 1;
  2643.     C := AnsiCompareText(FList^[I].FString, S);
  2644.     if C < 0 then L := I + 1 else
  2645.     begin
  2646.       H := I - 1;
  2647.       if C = 0 then
  2648.       begin
  2649.         Result := True;
  2650.         if Duplicates <> dupAccept then L := I;
  2651.       end;
  2652.     end;
  2653.   end;
  2654.   Index := L;
  2655. end;
  2656.  
  2657. function TStringList.Get(Index: Integer): string;
  2658. begin
  2659.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2660.   Result := FList^[Index].FString;
  2661. end;
  2662.  
  2663. function TStringList.GetCapacity: Integer;
  2664. begin
  2665.   Result := FCapacity;
  2666. end;
  2667.  
  2668. function TStringList.GetCount: Integer;
  2669. begin
  2670.   Result := FCount;
  2671. end;
  2672.  
  2673. function TStringList.GetObject(Index: Integer): TObject;
  2674. begin
  2675.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2676.   Result := FList^[Index].FObject;
  2677. end;
  2678.  
  2679. procedure TStringList.Grow;
  2680. var
  2681.   Delta: Integer;
  2682. begin
  2683.   if FCapacity > 64 then Delta := FCapacity div 4 else
  2684.     if FCapacity > 8 then Delta := 16 else
  2685.       Delta := 4;
  2686.   SetCapacity(FCapacity + Delta);
  2687. end;
  2688.  
  2689. function TStringList.IndexOf(const S: string): Integer;
  2690. begin
  2691.   if not Sorted then Result := inherited IndexOf(S) else
  2692.     if not Find(S, Result) then Result := -1;
  2693. end;
  2694.  
  2695. procedure TStringList.Insert(Index: Integer; const S: string);
  2696. begin
  2697.   if Sorted then Error(SSortedListError, 0);
  2698.   if (Index < 0) or (Index > FCount) then Error(SListIndexError, Index);
  2699.   InsertItem(Index, S);
  2700. end;
  2701.  
  2702. procedure TStringList.InsertItem(Index: Integer; const S: string);
  2703. begin
  2704.   Changing;
  2705.   if FCount = FCapacity then Grow;
  2706.   if Index < FCount then
  2707.     System.Move(FList^[Index], FList^[Index + 1],
  2708.       (FCount - Index) * SizeOf(TStringItem));
  2709.   with FList^[Index] do
  2710.   begin
  2711.     Pointer(FString) := nil;
  2712.     FObject := nil;
  2713.     FString := S;
  2714.   end;
  2715.   Inc(FCount);
  2716.   Changed;
  2717. end;
  2718.  
  2719. procedure TStringList.Put(Index: Integer; const S: string);
  2720. begin
  2721.   if Sorted then Error(SSortedListError, 0);
  2722.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2723.   Changing;
  2724.   FList^[Index].FString := S;
  2725.   Changed;
  2726. end;
  2727.  
  2728. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  2729. begin
  2730.   if (Index < 0) or (Index >= FCount) then Error(SListIndexError, Index);
  2731.   Changing;
  2732.   FList^[Index].FObject := AObject;
  2733.   Changed;
  2734. end;
  2735.  
  2736. procedure TStringList.QuickSort(L, R: Integer);
  2737. var
  2738.   I, J: Integer;
  2739.   P: string;
  2740. begin
  2741.   repeat
  2742.     I := L;
  2743.     J := R;
  2744.     P := FList^[(L + R) shr 1].FString;
  2745.     repeat
  2746.       while AnsiCompareText(FList^[I].FString, P) < 0 do Inc(I);
  2747.       while AnsiCompareText(FList^[J].FString, P) > 0 do Dec(J);
  2748.       if I <= J then
  2749.       begin
  2750.         ExchangeItems(I, J);
  2751.         Inc(I);
  2752.         Dec(J);
  2753.       end;
  2754.     until I > J;
  2755.     if L < J then QuickSort(L, J);
  2756.     L := I;
  2757.   until I >= R;
  2758. end;
  2759.  
  2760. procedure TStringList.SetCapacity(NewCapacity: Integer);
  2761. begin
  2762.   ReallocMem(FList, NewCapacity * SizeOf(TStringItem));
  2763.   FCapacity := NewCapacity;
  2764. end;
  2765.  
  2766. procedure TStringList.SetSorted(Value: Boolean);
  2767. begin
  2768.   if FSorted <> Value then
  2769.   begin
  2770.     if Value then Sort;
  2771.     FSorted := Value;
  2772.   end;
  2773. end;
  2774.  
  2775. procedure TStringList.SetUpdateState(Updating: Boolean);
  2776. begin
  2777.   if Updating then Changing else Changed;
  2778. end;
  2779.  
  2780. procedure TStringList.Sort;
  2781. begin
  2782.   if not Sorted and (FCount > 1) then
  2783.   begin
  2784.     Changing;
  2785.     QuickSort(0, FCount - 1);
  2786.     Changed;
  2787.   end;
  2788. end;
  2789.  
  2790. { TStream }
  2791.  
  2792. function TStream.GetPosition: Longint;
  2793. begin
  2794.   Result := Seek(0, 1);
  2795. end;
  2796.  
  2797. procedure TStream.SetPosition(Pos: Longint);
  2798. begin
  2799.   Seek(Pos, 0);
  2800. end;
  2801.  
  2802. function TStream.GetSize: Longint;
  2803. var
  2804.   Pos: Longint;
  2805. begin
  2806.   Pos := Seek(0, 1);
  2807.   Result := Seek(0, 2);
  2808.   Seek(Pos, 0);
  2809. end;
  2810.  
  2811. procedure TStream.SetSize(NewSize: Longint);
  2812. begin
  2813.   // default = do nothing  (read-only streams, etc)
  2814. end;
  2815.  
  2816. procedure TStream.ReadBuffer(var Buffer; Count: Longint);
  2817. begin
  2818.   if (Count <> 0) and (Read(Buffer, Count) <> Count) then
  2819.     raise EReadError.Create(SReadError);
  2820. end;
  2821.  
  2822. procedure TStream.WriteBuffer(const Buffer; Count: Longint);
  2823. begin
  2824.   if (Count <> 0) and (Write(Buffer, Count) <> Count) then
  2825.     raise EWriteError.Create(SWriteError);
  2826. end;
  2827.  
  2828. function TStream.CopyFrom(Source: TStream; Count: Longint): Longint;
  2829. const
  2830.   MaxBufSize = $F000;
  2831. var
  2832.   BufSize, N: Integer;
  2833.   Buffer: PChar;
  2834. begin
  2835.   if Count = 0 then
  2836.   begin
  2837.     Source.Position := 0;
  2838.     Count := Source.Size;
  2839.   end;
  2840.   Result := Count;
  2841.   if Count > MaxBufSize then BufSize := MaxBufSize else BufSize := Count;
  2842.   GetMem(Buffer, BufSize);
  2843.   try
  2844.     while Count <> 0 do
  2845.     begin
  2846.       if Count > BufSize then N := BufSize else N := Count;
  2847.       Source.ReadBuffer(Buffer^, N);
  2848.       WriteBuffer(Buffer^, N);
  2849.       Dec(Count, N);
  2850.     end;
  2851.   finally
  2852.     FreeMem(Buffer, BufSize);
  2853.   end;
  2854. end;
  2855.  
  2856. function TStream.ReadComponent(Instance: TComponent): TComponent;
  2857. var
  2858.   Reader: TReader;
  2859. begin
  2860.   Reader := TReader.Create(Self, 4096);
  2861.   try
  2862.     Result := Reader.ReadRootComponent(Instance);
  2863.   finally
  2864.     Reader.Free;
  2865.   end;
  2866. end;
  2867.  
  2868. procedure TStream.WriteComponent(Instance: TComponent);
  2869. begin
  2870.   WriteDescendent(Instance, nil);
  2871. end;
  2872.  
  2873. procedure TStream.WriteDescendent(Instance, Ancestor: TComponent);
  2874. var
  2875.   Writer: TWriter;
  2876. begin
  2877.   Writer := TWriter.Create(Self, 4096);
  2878.   try
  2879.     Writer.WriteDescendent(Instance, Ancestor);
  2880.   finally
  2881.     Writer.Free;
  2882.   end;
  2883. end;
  2884.  
  2885. function TStream.ReadComponentRes(Instance: TComponent): TComponent;
  2886. begin
  2887.   ReadResHeader;
  2888.   Result := ReadComponent(Instance);
  2889. end;
  2890.  
  2891. procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent);
  2892. begin
  2893.   WriteDescendentRes(ResName, Instance, nil);
  2894. end;
  2895.  
  2896. procedure TStream.WriteDescendentRes(const ResName: string; Instance,
  2897.   Ancestor: TComponent);
  2898. var
  2899.   HeaderSize: Integer;
  2900.   Origin, ImageSize: Longint;
  2901.   Header: array[0..79] of Char;
  2902. begin
  2903.   Byte((@Header[0])^) := $FF;
  2904.   Word((@Header[1])^) := 10;
  2905.   HeaderSize := StrLen(StrUpper(StrPLCopy(@Header[3], ResName, 63))) + 10;
  2906.   Word((@Header[HeaderSize - 6])^) := $1030;
  2907.   Longint((@Header[HeaderSize - 4])^) := 0;
  2908.   WriteBuffer(Header, HeaderSize);
  2909.   Origin := Position;
  2910.   WriteDescendent(Instance, Ancestor);
  2911.   ImageSize := Position - Origin;
  2912.   Position := Origin - 4;
  2913.   WriteBuffer(ImageSize, SizeOf(Longint));
  2914.   Position := Origin + ImageSize;
  2915. end;
  2916.  
  2917. procedure TStream.ReadResHeader;
  2918. var
  2919.   ReadCount: Longint;
  2920.   Header: array[0..79] of Char;
  2921. begin
  2922.   FillChar(Header, SizeOf(Header), 0);
  2923.   ReadCount := Read(Header, SizeOf(Header) - 1);
  2924.   if (Byte((@Header[0])^) = $FF) and (Word((@Header[1])^) = 10) then
  2925.     Seek(StrLen(Header + 3) + 10 - ReadCount, 1)
  2926.   else
  2927.     raise EInvalidImage.Create(SInvalidImage);
  2928. end;
  2929.  
  2930. { THandleStream }
  2931.  
  2932. constructor THandleStream.Create(AHandle: Integer);
  2933. begin
  2934.   FHandle := AHandle;
  2935. end;
  2936.  
  2937. function THandleStream.Read(var Buffer; Count: Longint): Longint;
  2938. begin
  2939.   Result := FileRead(FHandle, Buffer, Count);
  2940.   if Result = -1 then Result := 0;
  2941. end;
  2942.  
  2943. function THandleStream.Write(const Buffer; Count: Longint): Longint;
  2944. begin
  2945.   Result := FileWrite(FHandle, Buffer, Count);
  2946.   if Result = -1 then Result := 0;
  2947. end;
  2948.  
  2949. function THandleStream.Seek(Offset: Longint; Origin: Word): Longint;
  2950. begin
  2951.   Result := FileSeek(FHandle, Offset, Origin);
  2952. end;
  2953.  
  2954. procedure THandleStream.SetSize(NewSize: Longint);
  2955. begin
  2956.   Seek(NewSize, soFromBeginning);
  2957.   Win32Check(SetEndOfFile(FHandle));
  2958. end;
  2959.  
  2960. { TFileStream }
  2961.  
  2962. constructor TFileStream.Create(const FileName: string; Mode: Word);
  2963. begin
  2964.   if Mode = fmCreate then
  2965.   begin
  2966.     FHandle := FileCreate(FileName);
  2967.     if FHandle < 0 then
  2968.       raise EFCreateError.CreateFmt(SFCreateError, [FileName]);
  2969.   end else
  2970.   begin
  2971.     FHandle := FileOpen(FileName, Mode);
  2972.     if FHandle < 0 then
  2973.       raise EFOpenError.CreateFmt(SFOpenError, [FileName]);
  2974.   end;
  2975. end;
  2976.  
  2977. destructor TFileStream.Destroy;
  2978. begin
  2979.   if FHandle >= 0 then FileClose(FHandle);
  2980. end;
  2981.  
  2982.  
  2983. { TCustomMemoryStream }
  2984.  
  2985. procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; Size: Longint);
  2986. begin
  2987.   FMemory := Ptr;
  2988.   FSize := Size;
  2989. end;
  2990.  
  2991. function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
  2992. begin
  2993.   if (FPosition >= 0) and (Count >= 0) then
  2994.   begin
  2995.     Result := FSize - FPosition;
  2996.     if Result > 0 then
  2997.     begin
  2998.       if Result > Count then Result := Count;
  2999.       Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
  3000.       Inc(FPosition, Result);
  3001.       Exit;
  3002.     end;
  3003.   end;
  3004.   Result := 0;
  3005. end;
  3006.  
  3007. function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
  3008. begin
  3009.   case Origin of
  3010.     0: FPosition := Offset;
  3011.     1: Inc(FPosition, Offset);
  3012.     2: FPosition := FSize + Offset;
  3013.   end;
  3014.   Result := FPosition;
  3015. end;
  3016.  
  3017. procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
  3018. begin
  3019.   if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
  3020. end;
  3021.  
  3022. procedure TCustomMemoryStream.SaveToFile(const FileName: string);
  3023. var
  3024.   Stream: TStream;
  3025. begin
  3026.   Stream := TFileStream.Create(FileName, fmCreate);
  3027.   try
  3028.     SaveToStream(Stream);
  3029.   finally
  3030.     Stream.Free;
  3031.   end;
  3032. end;
  3033.  
  3034. { TMemoryStream }
  3035.  
  3036. const
  3037.   MemoryDelta = $2000; { Must be a power of 2 }
  3038.  
  3039. destructor TMemoryStream.Destroy;
  3040. begin
  3041.   Clear;
  3042.   inherited Destroy;
  3043. end;
  3044.  
  3045. procedure TMemoryStream.Clear;
  3046. begin
  3047.   SetCapacity(0);
  3048.   FSize := 0;
  3049.   FPosition := 0;
  3050. end;
  3051.  
  3052. procedure TMemoryStream.LoadFromStream(Stream: TStream);
  3053. var
  3054.   Count: Longint;
  3055. begin
  3056.   Stream.Position := 0;
  3057.   Count := Stream.Size;
  3058.   SetSize(Count);
  3059.   if Count <> 0 then Stream.ReadBuffer(FMemory^, Count);
  3060. end;
  3061.  
  3062. procedure TMemoryStream.LoadFromFile(const FileName: string);
  3063. var
  3064.   Stream: TStream;
  3065. begin
  3066.   Stream := TFileStream.Create(FileName, fmOpenRead);
  3067.   try
  3068.     LoadFromStream(Stream);
  3069.   finally
  3070.     Stream.Free;
  3071.   end;
  3072. end;
  3073.  
  3074. procedure TMemoryStream.SetCapacity(NewCapacity: Longint);
  3075. begin
  3076.   SetPointer(Realloc(NewCapacity), FSize);
  3077.   FCapacity := NewCapacity;
  3078. end;
  3079.  
  3080. procedure TMemoryStream.SetSize(NewSize: Longint);
  3081. var
  3082.   OldPosition: Longint;
  3083. begin
  3084.   OldPosition := FPosition;
  3085.   SetCapacity(NewSize);
  3086.   FSize := NewSize;
  3087.   if OldPosition > NewSize then Seek(0, soFromEnd);
  3088. end;
  3089.  
  3090. function TMemoryStream.Realloc(var NewCapacity: Longint): Pointer;
  3091. begin
  3092.   if NewCapacity > 0 then
  3093.     NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  3094.   Result := Memory;
  3095.   if NewCapacity <> FCapacity then
  3096.   begin
  3097.     if NewCapacity = 0 then
  3098.     begin
  3099.       GlobalFreePtr(Memory);
  3100.       Result := nil;
  3101.     end else
  3102.     begin
  3103.       if Capacity = 0 then
  3104.         Result := GlobalAllocPtr(HeapAllocFlags, NewCapacity)
  3105.       else
  3106.         Result := GlobalReallocPtr(Memory, NewCapacity, HeapAllocFlags);
  3107.       if Result = nil then raise EStreamError.Create(SMemoryStreamError);
  3108.     end;
  3109.   end;
  3110. end;
  3111.  
  3112. function TMemoryStream.Write(const Buffer; Count: Longint): Longint;
  3113. var
  3114.   Pos: Longint;
  3115. begin
  3116.   if (FPosition >= 0) and (Count >= 0) then
  3117.   begin
  3118.     Pos := FPosition + Count;
  3119.     if Pos > 0 then
  3120.     begin
  3121.       if Pos > FSize then
  3122.       begin
  3123.         if Pos > FCapacity then
  3124.           SetCapacity(Pos);
  3125.         FSize := Pos;
  3126.       end;
  3127.       System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
  3128.       FPosition := Pos;
  3129.       Result := Count;
  3130.       Exit;
  3131.     end;
  3132.   end;
  3133.   Result := 0;
  3134. end;
  3135.  
  3136. { TStringStream }
  3137.  
  3138. constructor TStringStream.Create(const AString: string);
  3139. begin
  3140.   inherited Create;
  3141.   FDataString := AString;
  3142. end;
  3143.  
  3144. function TStringStream.Read(var Buffer; Count: Longint): Longint;
  3145. begin
  3146.   Result := Length(FDataString) - FPosition;
  3147.   if Result > Count then Result := Count;
  3148.   Move(PChar(@FDataString[FPosition + 1])^, Buffer, Result);
  3149.   Inc(FPosition, Result);
  3150. end;
  3151.  
  3152. function TStringStream.Write(const Buffer; Count: Longint): Longint;
  3153. begin
  3154.   Result := Count;
  3155.   SetLength(FDataString, (FPosition + Result));
  3156.   Move(Buffer, PChar(@FDataString[FPosition + 1])^, Result);
  3157.   Inc(FPosition, Result);
  3158. end;
  3159.  
  3160. function TStringStream.Seek(Offset: Longint; Origin: Word): Longint;
  3161. begin
  3162.   case Origin of
  3163.     soFromBeginning: FPosition := Offset;
  3164.     soFromCurrent: FPosition := FPosition + Offset;
  3165.     soFromEnd: FPosition := Length(FDataString) - Offset;
  3166.   end;
  3167.   if FPosition > Length(FDataString) then
  3168.     FPosition := Length(FDataString)
  3169.   else if FPosition < 0 then FPosition := 0;
  3170.   Result := FPosition;
  3171. end;
  3172.  
  3173. function TStringStream.ReadString(Count: Longint): string;
  3174. var
  3175.   Len: Integer;
  3176. begin
  3177.   Len := Length(FDataString) - FPosition;
  3178.   if Len > Count then Len := Count;
  3179.   SetString(Result, PChar(@FDataString[FPosition + 1]), Len);
  3180.   Inc(FPosition, Len);
  3181. end;
  3182.  
  3183. procedure TStringStream.WriteString(const AString: string);
  3184. begin
  3185.   Write(PChar(AString)^, Length(AString));
  3186. end;
  3187.  
  3188. procedure TStringStream.SetSize(NewSize: Longint);
  3189. begin
  3190.   SetLength(FDataString, NewSize);
  3191.   if FPosition > NewSize then FPosition := NewSize;
  3192. end;
  3193.  
  3194. { TResourceStream }
  3195.  
  3196. constructor TResourceStream.Create(Instance: THandle; const ResName: string;
  3197.   ResType: PChar);
  3198. begin
  3199.   inherited Create;
  3200.   Initialize(Instance, PChar(ResName), ResType);
  3201. end;
  3202.  
  3203. constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer;
  3204.   ResType: PChar);
  3205. begin
  3206.   inherited Create;
  3207.   Initialize(Instance, PChar(ResID), ResType);
  3208. end;
  3209.  
  3210. procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
  3211.  
  3212.   procedure Error;
  3213.   begin
  3214.     raise EResNotFound.Create(Format(SResNotFound, [Name]));
  3215.   end;
  3216.  
  3217. begin
  3218.   HResInfo := FindResource(Instance, Name, ResType);
  3219.   if HResInfo = 0 then Error;
  3220.   HGlobal := LoadResource(Instance, HResInfo);
  3221.   if HGlobal = 0 then Error;
  3222.   SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo));
  3223. end;
  3224.  
  3225. destructor TResourceStream.Destroy;
  3226. begin
  3227.   UnlockResource(HGlobal);
  3228.   FreeResource(HGlobal);
  3229.   inherited Destroy;
  3230. end;
  3231.  
  3232. function TResourceStream.Write(const Buffer; Count: Longint): Longint;
  3233. begin
  3234.   raise EStreamError.Create(SCantWriteResourceStreamError);
  3235. end;
  3236.  
  3237. { TFiler }
  3238.  
  3239. constructor TFiler.Create(Stream: TStream; BufSize: Integer);
  3240. begin
  3241.   FStream := Stream;
  3242.   GetMem(FBuffer, BufSize);
  3243.   FBufSize := BufSize;
  3244. end;
  3245.  
  3246. destructor TFiler.Destroy;
  3247. begin
  3248.   if FBuffer <> nil then FreeMem(FBuffer, FBufSize);
  3249. end;
  3250.  
  3251. { TPropFixup }
  3252.  
  3253. type
  3254.   TPropFixup = class
  3255.     FInstance: TPersistent;
  3256.     FInstanceRoot: TComponent;
  3257.     FPropInfo: PPropInfo;
  3258.     FRootName: string;
  3259.     FName: string;
  3260.     constructor Create(Instance: TPersistent; InstanceRoot: TComponent;
  3261.       PropInfo: PPropInfo; const RootName, Name: string);
  3262.   end;
  3263.  
  3264. var
  3265.   GlobalFixupList: TList;
  3266.  
  3267. constructor TPropFixup.Create(Instance: TPersistent; InstanceRoot: TComponent;
  3268.   PropInfo: PPropInfo; const RootName, Name: string);
  3269. begin
  3270.   FInstance := Instance;
  3271.   FInstanceRoot := InstanceRoot;
  3272.   FPropInfo := PropInfo;
  3273.   FRootName := RootName;
  3274.   FName := Name;
  3275. end;
  3276.  
  3277. procedure GlobalFixupReferences;
  3278. var
  3279.   FinishedList: TList;
  3280.   NotFinishedList: TList;
  3281.   I: Integer;
  3282.   Root: TComponent;
  3283.   Instance: TPersistent;
  3284.   Reference: Pointer;
  3285.  
  3286.   procedure AddFinished(Instance: TPersistent);
  3287.   begin
  3288.     if (FinishedList.IndexOf(Instance) < 0) and
  3289.       (NotFinishedList.IndexOf(Instance) >= 0) then
  3290.       FinishedList.Add(Instance);
  3291.   end;
  3292.  
  3293.   procedure AddNotFinished(Instance: TPersistent);
  3294.   var
  3295.     Index: Integer;
  3296.   begin
  3297.     Index := FinishedList.IndexOf(Instance);
  3298.     if Index <> -1 then FinishedList.Delete(Index);
  3299.     if NotFinishedList.IndexOf(Instance) < 0 then
  3300.       NotFinishedList.Add(Instance);
  3301.   end;
  3302.  
  3303. begin
  3304.   if Assigned(FindGlobalComponent) and (GlobalFixupList.Count > 0) then
  3305.   begin
  3306.     FinishedList := TList.Create;
  3307.     try
  3308.       NotFinishedList := TList.Create;
  3309.       try
  3310.         I := 0;
  3311.         while I < GlobalFixupList.Count do
  3312.           with TPropFixup(GlobalFixupList[I]) do
  3313.           begin
  3314.             Root := FindGlobalComponent(FRootName);
  3315.             if (Root <> nil) or (GetOrdProp(FInstance, FPropInfo) <> 0) then
  3316.             begin
  3317.               if Root <> nil then
  3318.               begin
  3319.                 Reference := Root.FindComponent(FName);
  3320.                 if (Reference = nil) and (CompareText(FName, 'OWNER') = 0) then { Do not translate }
  3321.                   Reference := Root;
  3322.                 SetOrdProp(FInstance, FPropInfo, Longint(Reference));
  3323.               end;
  3324.               AddFinished(FInstance);
  3325.               GlobalFixupList.Delete(I);
  3326.               Free;
  3327.             end else
  3328.             begin
  3329.               AddNotFinished(FInstance);
  3330.               Inc(I);
  3331.             end;
  3332.           end;
  3333.       finally
  3334.         NotFinishedList.Free;
  3335.       end;
  3336.       for I := 0 to FinishedList.Count - 1 do
  3337.       begin
  3338.         Instance := FinishedList[I];
  3339.         if Instance is TComponent then
  3340.           Exclude(TComponent(Instance).FComponentState, csFixups);
  3341.       end;
  3342.     finally
  3343.       FinishedList.Free;
  3344.     end;
  3345.   end;
  3346. end;
  3347.  
  3348. function NameInStrings(Strings: TStrings; const Name: string): Boolean;
  3349. var
  3350.   I: Integer;
  3351. begin
  3352.   Result := True;
  3353.   for I := 0 to Strings.Count - 1 do
  3354.     if CompareText(Name, Strings[I]) = 0 then Exit;
  3355.   Result := False;
  3356. end;
  3357.  
  3358. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  3359. var
  3360.   I: Integer;
  3361.   Fixup: TPropFixup;
  3362. begin
  3363.   for I := 0 to GlobalFixupList.Count - 1 do
  3364.   begin
  3365.     Fixup := GlobalFixupList[I];
  3366.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  3367.       not NameInStrings(Names, Fixup.FRootName) then
  3368.       Names.Add(Fixup.FRootName);
  3369.   end;
  3370. end;
  3371.  
  3372. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  3373.   NewRootName: string);
  3374. var
  3375.   I: Integer;
  3376.   Fixup: TPropFixup;
  3377. begin
  3378.   for I := 0 to GlobalFixupList.Count - 1 do
  3379.   begin
  3380.     Fixup := GlobalFixupList[I];
  3381.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  3382.       (CompareText(OldRootName, Fixup.FRootName) = 0) then
  3383.       Fixup.FRootName := NewRootName;
  3384.   end;
  3385.   GlobalFixupReferences;
  3386. end;
  3387.  
  3388. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  3389. var
  3390.   I: Integer;
  3391.   Fixup: TPropFixup;
  3392. begin
  3393.   for I := GlobalFixupList.Count - 1 downto 0 do
  3394.   begin
  3395.     Fixup := GlobalFixupList[I];
  3396.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  3397.       ((RootName = '') or (CompareText(RootName, Fixup.FRootName) = 0)) then
  3398.     begin
  3399.       GlobalFixupList.Delete(I);
  3400.       Fixup.Free;
  3401.     end;
  3402.   end;
  3403. end;
  3404.  
  3405. procedure RemoveFixups(Instance: TPersistent);
  3406. var
  3407.   I: Integer;
  3408.   Fixup: TPropFixup;
  3409. begin
  3410.   for I := GlobalFixupList.Count - 1 downto 0 do
  3411.   begin
  3412.     Fixup := GlobalFixupList[I];
  3413.     if (Fixup.FInstance = Instance) then
  3414.     begin
  3415.       GlobalFixupList.Delete(I);
  3416.       Fixup.Free;
  3417.     end;
  3418.   end;
  3419. end;
  3420.  
  3421. procedure GetFixupInstanceNames(Root: TComponent;
  3422.   const ReferenceRootName: string; Names: TStrings);
  3423. var
  3424.   I: Integer;
  3425.   Fixup: TPropFixup;
  3426. begin
  3427.   for I := 0 to GlobalFixupList.Count - 1 do
  3428.   begin
  3429.     Fixup := GlobalFixupList[I];
  3430.     if (Fixup.FInstanceRoot = Root) and
  3431.       (CompareText(ReferenceRootName, Fixup.FRootName) = 0) and
  3432.       not NameInStrings(Names, Fixup.FName) then
  3433.       Names.Add(Fixup.FName);
  3434.   end;
  3435. end;
  3436.  
  3437. { TReader }
  3438.  
  3439. procedure ReadError(const Ident: string);
  3440. begin
  3441.   raise EReadError.Create(Ident);
  3442. end;
  3443.  
  3444. procedure PropValueError;
  3445. begin
  3446.   ReadError(SInvalidPropertyValue);
  3447. end;
  3448.  
  3449. procedure PropertyNotFound;
  3450. begin
  3451.   ReadError(SUnknownProperty);
  3452. end;
  3453.  
  3454. function EnumValue(EnumType: PTypeInfo; const EnumName: string): Integer;
  3455. begin
  3456.   Result := GetEnumValue(EnumType, EnumName);
  3457.   if Result = -1 then PropValueError;
  3458. end;
  3459.  
  3460. destructor TReader.Destroy;
  3461. begin
  3462.   FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), 1);
  3463.   inherited Destroy;
  3464. end;
  3465.  
  3466. procedure TReader.BeginReferences;
  3467. begin
  3468.   FLoaded := TList.Create;
  3469.   try
  3470.     FFixups := TList.Create;
  3471.   except
  3472.     FLoaded.Free;
  3473.     raise;
  3474.   end;
  3475. end;
  3476.  
  3477. procedure TReader.CheckValue(Value: TValueType);
  3478. begin
  3479.   if ReadValue <> Value then
  3480.   begin
  3481.     Dec(FBufPos);
  3482.     SkipValue;
  3483.     PropValueError;
  3484.   end;
  3485. end;
  3486.  
  3487. procedure TReader.DefineProperty(const Name: string;
  3488.   ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
  3489. begin
  3490.   if (CompareText(Name, FPropName) = 0) and Assigned(ReadData) then
  3491.   begin
  3492.     ReadData(Self);
  3493.     FPropName := '';
  3494.   end;
  3495. end;
  3496.  
  3497. procedure TReader.DefineBinaryProperty(const Name: string;
  3498.   ReadData, WriteData: TStreamProc; HasData: Boolean);
  3499. var
  3500.   Stream: TMemoryStream;
  3501.   Count: Longint;
  3502. begin
  3503.   if (CompareText(Name, FPropName) = 0) and Assigned(ReadData) then
  3504.   begin
  3505.     if ReadValue <> vaBinary then
  3506.     begin
  3507.       Dec(FBufPos);
  3508.       SkipValue;
  3509.       FCanHandleExcepts := True;
  3510.       PropValueError;
  3511.     end;
  3512.     Stream := TMemoryStream.Create;
  3513.     try
  3514.       Read(Count, SizeOf(Count));
  3515.       Stream.SetSize(Count);
  3516.       Read(Stream.Memory^, Count);
  3517.       FCanHandleExcepts := True;
  3518.       ReadData(Stream);
  3519.     finally
  3520.       Stream.Free;
  3521.     end;
  3522.     FPropName := '';
  3523.   end;
  3524. end;
  3525.  
  3526. function TReader.EndOfList: Boolean;
  3527. begin
  3528.   Result := ReadValue = vaNull;
  3529.   Dec(FBufPos);
  3530. end;
  3531.  
  3532. procedure TReader.EndReferences;
  3533. begin
  3534.   FreeFixups;
  3535.   FLoaded.Free;
  3536.   FLoaded := nil;
  3537. end;
  3538.  
  3539. function TReader.Error(const Message: string): Boolean;
  3540. begin
  3541.   Result := False;
  3542.   if Assigned(FOnError) then FOnError(Self, Message, Result);
  3543. end;
  3544.  
  3545. function TReader.FindMethod(Root: TComponent;
  3546.   const MethodName: string): Pointer;
  3547. var
  3548.   Error: Boolean;
  3549. begin
  3550.   Result := Root.MethodAddress(MethodName);
  3551.   Error := Result = nil;
  3552.   if Assigned(FOnFindMethod) then FOnFindMethod(Self, MethodName, Result, Error);
  3553.   if Error then PropValueError;
  3554. end;
  3555.  
  3556. procedure TReader.DoFixupReferences;
  3557. var
  3558.   I: Integer;
  3559.   CompName: string;
  3560.   Reference: Pointer;
  3561. begin
  3562.   if FFixups <> nil then
  3563.     try
  3564.       for I := 0 to FFixups.Count - 1 do
  3565.         with TPropFixup(FFixups[I]) do
  3566.         begin
  3567.           CompName := FName;
  3568.           ReferenceName(CompName);
  3569.           Reference := FRoot.FindComponent(CompName);
  3570.           if (Reference = nil) and (CompareText(CompName, 'OWNER') = 0) then    { Do not translate }
  3571.             Reference := FRoot;
  3572.           SetOrdProp(FInstance, FPropInfo, Longint(Reference));
  3573.         end;
  3574.     finally
  3575.       FreeFixups;
  3576.     end;
  3577. end;
  3578.  
  3579. procedure TReader.FixupReferences;
  3580. var
  3581.   I: Integer;
  3582. begin
  3583.   DoFixupReferences;
  3584.   GlobalFixupReferences;
  3585.   for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
  3586. end;
  3587.  
  3588. procedure TReader.FlushBuffer;
  3589. begin
  3590.   FStream.Position := Position;
  3591.   FBufPos := 0;
  3592.   FBufEnd := 0;
  3593. end;
  3594.  
  3595. procedure TReader.FreeFixups;
  3596. var
  3597.   I: Integer;
  3598. begin
  3599.   if FFixups <> nil then
  3600.   begin
  3601.     for I := 0 to FFixups.Count - 1 do TPropFixup(FFixups[I]).Free;
  3602.     FFixups.Free;
  3603.     FFixups := nil;
  3604.   end;
  3605. end;
  3606.  
  3607. function TReader.GetPosition: Longint;
  3608. begin
  3609.   Result := FStream.Position - (FBufEnd - FBufPos);
  3610. end;
  3611.  
  3612. function TReader.NextValue: TValueType;
  3613. begin
  3614.   Result := ReadValue;
  3615.   Dec(FBufPos);
  3616. end;
  3617.  
  3618. procedure TReader.PropertyError;
  3619. begin
  3620.   SkipValue;
  3621.   PropertyNotFound;
  3622. end;
  3623.  
  3624. procedure TReader.Read(var Buf; Count: Longint); assembler;
  3625. asm
  3626.         PUSH    ESI
  3627.         PUSH    EDI
  3628.         PUSH    EBX
  3629.         MOV     EDI,EDX
  3630.         MOV     EBX,ECX
  3631.         MOV     ESI,EAX
  3632.         JMP     @@6
  3633. @@1:    MOV     ECX,[ESI].TReader.FBufEnd
  3634.         SUB     ECX,[ESI].TReader.FBufPos
  3635.         JA      @@2
  3636.         MOV     EAX,ESI
  3637.         CALL    TReader.ReadBuffer
  3638.         MOV     ECX,[ESI].TReader.FBufEnd
  3639. @@2:    CMP     ECX,EBX
  3640.         JB      @@3
  3641.         MOV     ECX,EBX
  3642. @@3:    PUSH    ESI
  3643.         SUB     EBX,ECX
  3644.         MOV     EAX,[ESI].TReader.FBuffer
  3645.         ADD     EAX,[ESI].TReader.FBufPos
  3646.         ADD     [ESI].TReader.FBufPos,ECX
  3647.         MOV     ESI,EAX
  3648.         MOV     EDX,ECX
  3649.         SHR     ECX,2
  3650.         CLD
  3651.         REP     MOVSD
  3652.         MOV     ECX,EDX
  3653.         AND     ECX,3
  3654.         REP     MOVSB
  3655.         POP     ESI
  3656. @@6:    OR      EBX,EBX
  3657.         JNE     @@1
  3658.         POP     EBX
  3659.         POP     EDI
  3660.         POP     ESI
  3661. end;
  3662.  
  3663. procedure TReader.ReadBuffer;
  3664. begin
  3665.   FBufEnd := FStream.Read(FBuffer^, FBufSize);
  3666.   if FBufEnd = 0 then raise EReadError.Create(SReadError);
  3667.   FBufPos := 0;
  3668. end;
  3669.  
  3670. function TReader.ReadBoolean: Boolean;
  3671. begin
  3672.   Result := ReadValue = vaTrue;
  3673. end;
  3674.  
  3675. function TReader.ReadChar: Char;
  3676. begin
  3677.   CheckValue(vaString);
  3678.   Read(Result, 1);
  3679.   if Ord(Result) <> 1 then
  3680.   begin
  3681.     Dec(FBufPos);
  3682.     ReadStr;
  3683.     PropValueError;
  3684.   end;
  3685.   Read(Result, 1);
  3686. end;
  3687.  
  3688. procedure TReader.ReadCollection(Collection: TCollection);
  3689. var
  3690.   Item: TPersistent;
  3691. begin
  3692.   Collection.BeginUpdate;
  3693.   try
  3694.     if not EndOfList then Collection.Clear;
  3695.     while not EndOfList do
  3696.     begin
  3697.       if NextValue in [vaInt8, vaInt16, vaInt32] then ReadInteger;
  3698.       Item := Collection.Add;
  3699.       ReadListBegin;
  3700.       while not EndOfList do ReadProperty(Item);
  3701.       ReadListEnd;
  3702.     end;
  3703.     ReadListEnd;
  3704.   finally
  3705.     Collection.EndUpdate;
  3706.   end;
  3707. end;
  3708.  
  3709. function TReader.ReadComponent(Component: TComponent): TComponent;
  3710. var
  3711.   CompClass, CompName: string;
  3712.   Flags: TFilerFlags;
  3713.   Position: Integer;
  3714.   OldParent: TComponent;
  3715.  
  3716.   function ComponentCreated: Boolean;
  3717.   begin
  3718.     Result := not (ffInherited in Flags) and (Component = nil);
  3719.   end;
  3720.  
  3721.   function Recover(var Component: TComponent): Boolean;
  3722.   begin
  3723.     Result := False;
  3724.     if not (ExceptObject is Exception) then Exit;
  3725.     if ComponentCreated then Component.Free;
  3726.     Component := nil;
  3727.     SkipComponent(False);
  3728.     Result := Error(Exception(ExceptObject).Message);
  3729.   end;
  3730.  
  3731.   procedure CreateComponent;
  3732.   begin
  3733.     try
  3734.       Result := TComponentClass(FindFieldClass(Root, CompClass)).Create(Owner);
  3735.       Include(Result.FComponentState, csLoading);
  3736.     except
  3737.       if not Recover(Result) then raise;
  3738.     end;
  3739.   end;
  3740.  
  3741.   procedure SetCompName;
  3742.   begin
  3743.     try
  3744.       Result.SetParentComponent(Parent);
  3745.       SetName(Result, CompName);
  3746.     except
  3747.       if not Recover(Result) then raise;
  3748.     end;
  3749.   end;
  3750.  
  3751.   procedure FindExistingComponent;
  3752.   begin
  3753.     try
  3754.       Result := FindAncestorComponent(CompName, FindFieldClass(Root, CompClass));
  3755.       Parent := Result.GetParentComponent;
  3756.     except
  3757.       if not Recover(Result) then raise;
  3758.     end;
  3759.   end;
  3760.  
  3761.  
  3762. begin
  3763.   ReadPrefix(Flags, Position);
  3764.   CompClass := ReadStr;
  3765.   CompName := ReadStr;
  3766.   OldParent := Parent;
  3767.   try
  3768.     Result := Component;
  3769.     if Result = nil then
  3770.       if ffInherited in Flags then
  3771.         FindExistingComponent else
  3772.         CreateComponent;
  3773.     if Result <> nil then
  3774.       try
  3775.         Include(Result.FComponentState, csLoading);
  3776.         if not (ffInherited in Flags) then SetCompName;
  3777.         if Result = nil then Exit;
  3778.         Include(Result.FComponentState, csReading);
  3779.         Result.ReadState(Self);
  3780.         Exclude(Result.FComponentState, csReading);
  3781.         if ffChildPos in Flags then Parent.SetChildOrder(Result, Position);
  3782.         FLoaded.Add(Result);
  3783.       except
  3784.         if ComponentCreated then Result.Free;
  3785.         raise;
  3786.       end;
  3787.   finally
  3788.     Parent := OldParent;
  3789.   end;
  3790. end;
  3791.  
  3792. procedure TReader.ReadData(Instance: TComponent);
  3793. begin
  3794.   if FFixups = nil then
  3795.   begin
  3796.     FFixups := TList.Create;
  3797.     try
  3798.       ReadDataInner(Instance);
  3799.       DoFixupReferences;
  3800.     finally
  3801.       FreeFixups;
  3802.     end;
  3803.   end else
  3804.     ReadDataInner(Instance);
  3805. end;
  3806.  
  3807. procedure TReader.ReadDataInner(Instance: TComponent);
  3808. var
  3809.   OldParent, OldOwner: TComponent;
  3810. begin
  3811.   while not EndOfList do ReadProperty(Instance);
  3812.   ReadListEnd;
  3813.   OldParent := Parent;
  3814.   OldOwner := Owner;
  3815.   Parent := Instance.GetChildParent;
  3816.   try
  3817.     Owner := Instance.GetChildOwner;
  3818.     if not Assigned(Owner) then Owner := Root;
  3819.     while not EndOfList do ReadComponent(nil);
  3820.     ReadListEnd;
  3821.   finally
  3822.     Parent := OldParent;
  3823.     Owner := OldOwner;
  3824.   end;
  3825. end;
  3826.  
  3827. function TReader.ReadFloat: Extended;
  3828. begin
  3829.   if ReadValue = vaExtended then Read(Result, SizeOf(Result)) else
  3830.   begin
  3831.     Dec(FBufPos);
  3832.     Result := ReadInteger;
  3833.   end;
  3834. end;
  3835.  
  3836. function TReader.ReadIdent: string;
  3837. var
  3838.   L: Byte;
  3839. begin
  3840.   case ReadValue of
  3841.     vaIdent:
  3842.       begin
  3843.         Read(L, SizeOf(Byte));
  3844.         SetString(Result, PChar(nil), L);
  3845.         Read(Result[1], L);
  3846.       end;
  3847.     vaFalse:
  3848.       Result := 'False';
  3849.     vaTrue:
  3850.       Result := 'True';
  3851.     vaNil:
  3852.       Result := 'nil';
  3853.   else
  3854.     PropValueError;
  3855.   end;
  3856. end;
  3857.  
  3858. function TReader.ReadInteger: Longint;
  3859. var
  3860.   S: Shortint;
  3861.   I: Smallint;
  3862. begin
  3863.   case ReadValue of
  3864.     vaInt8:
  3865.       begin
  3866.         Read(S, SizeOf(Shortint));
  3867.         Result := S;
  3868.       end;
  3869.     vaInt16:
  3870.       begin
  3871.         Read(I, SizeOf(I));
  3872.         Result := I;
  3873.       end;
  3874.     vaInt32:
  3875.       Read(Result, SizeOf(Result));
  3876.   else
  3877.     PropValueError;
  3878.   end;
  3879. end;
  3880.  
  3881. procedure TReader.ReadListBegin;
  3882. begin
  3883.   CheckValue(vaList);
  3884. end;
  3885.  
  3886. procedure TReader.ReadListEnd;
  3887. begin
  3888.   CheckValue(vaNull);
  3889. end;
  3890.  
  3891. procedure TReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
  3892. var
  3893.   Prefix: Byte;
  3894. begin
  3895.   Flags := [];
  3896.   if Byte(NextValue) and $F0 = $F0 then
  3897.   begin
  3898.     Prefix := Byte(ReadValue);
  3899.     Byte(Flags) := Prefix and $0F;
  3900.     if ffChildPos in Flags then AChildPos := ReadInteger;
  3901.   end;
  3902. end;
  3903.  
  3904. procedure TReader.ReadProperty(AInstance: TPersistent);
  3905. var
  3906.   I, J, L: Integer;
  3907.   Instance: TPersistent;
  3908.   PropInfo: PPropInfo;
  3909.   PropValue: TObject;
  3910.   PropPath: string;
  3911.  
  3912.   procedure HandleException(E: Exception);
  3913.   var
  3914.     Name: string;
  3915.   begin
  3916.     Name := '';
  3917.     if AInstance is TComponent then
  3918.       Name := TComponent(AInstance).Name;
  3919.     if Name = '' then Name := AInstance.ClassName;
  3920.     raise EReadError.CreateFmt(SPropertyException, [Name, PropPath, E.Message]);
  3921.   end;
  3922.  
  3923.   procedure PropPathError;
  3924.   begin
  3925.     SkipValue;
  3926.     ReadError(SInvalidPropertyPath);
  3927.   end;
  3928.  
  3929. begin
  3930.   try
  3931.     PropPath := ReadStr;
  3932.     try
  3933.       I := 1;
  3934.       L := Length(PropPath);
  3935.       Instance := AInstance;
  3936.       FCanHandleExcepts := True;
  3937.       while True do
  3938.       begin
  3939.         J := I;
  3940.         while (I <= L) and (PropPath[I] <> '.') do Inc(I);
  3941.         FPropName := Copy(PropPath, J, I - J);
  3942.         if I > L then Break;
  3943.         PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
  3944.         if PropInfo = nil then PropertyError;
  3945.         PropValue := nil;
  3946.         if PropInfo^.PropType^.Kind = tkClass then
  3947.           PropValue := TObject(GetOrdProp(Instance, PropInfo));
  3948.         if not (PropValue is TPersistent) then PropPathError;
  3949.         Instance := TPersistent(PropValue);
  3950.         Inc(I);
  3951.       end;
  3952.       PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
  3953.       if PropInfo <> nil then ReadPropValue(Instance, PropInfo) else
  3954.       begin
  3955.         { Cannot reliably recover from an error in a defined property }
  3956.         FCanHandleExcepts := False;
  3957.         Instance.DefineProperties(Self);
  3958.         FCanHandleExcepts := True;
  3959.         if FPropName <> '' then PropertyError;
  3960.       end;
  3961.     except
  3962.       on E: Exception do HandleException(E);
  3963.     end;
  3964.   except
  3965.     on E: Exception do
  3966.       if not FCanHandleExcepts or not Error(E.Message) then raise;
  3967.   end;
  3968. end;
  3969.  
  3970. procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  3971. const
  3972.   NilMethod: TMethod = (Code: nil; Data: nil);
  3973. var
  3974.   PropType: PTypeInfo;
  3975.   Method: TMethod;
  3976.  
  3977.   procedure SetIntIdent(Instance: TPersistent; PropInfo: Pointer;
  3978.     const Ident: string);
  3979.   var
  3980.     I: Integer;
  3981.     V: Longint;
  3982.   begin
  3983.     for I := 0 to IntConstList.Count - 1 do
  3984.       with TIntConst(IntConstList[I]) do
  3985.         if PPropInfo(PropInfo)^.PropType^ = IntegerType then
  3986.           if IdentToInt(Ident, V) then
  3987.           begin
  3988.             SetOrdProp(Instance, PropInfo, V);
  3989.             Exit;
  3990.           end;
  3991.     PropValueError;
  3992.   end;
  3993.  
  3994.   procedure SetObjectIdent(Instance: TPersistent; PropInfo: Pointer;
  3995.     const Ident: string);
  3996.   var
  3997.     RootName, Name: string;
  3998.     P: Integer;
  3999.     Fixup: TPropFixup;
  4000.   begin
  4001.     RootName := '';
  4002.     Name := Ident;
  4003.     P := Pos('.', Ident);
  4004.     if P <> 0 then
  4005.     begin
  4006.       RootName := Copy(Ident, 1, P - 1);
  4007.       Name := Copy(Ident, P + 1, MaxInt);
  4008.     end;
  4009.     Fixup := TPropFixup.Create(Instance, Root, PropInfo, RootName, Name);
  4010.     if RootName = '' then
  4011.       FFixups.Add(Fixup) else
  4012.       GlobalFixupList.Add(Fixup);
  4013.   end;
  4014.  
  4015. begin
  4016.   if PPropInfo(PropInfo)^.SetProc = nil then ReadError(SReadOnlyProperty);
  4017.   PropType := PPropInfo(PropInfo)^.PropType^;
  4018.   case PropType^.Kind of
  4019.     tkInteger:
  4020.       if NextValue = vaIdent then
  4021.         SetIntIdent(Instance, PropInfo, ReadIdent) else
  4022.         SetOrdProp(Instance, PropInfo, ReadInteger);
  4023.     tkChar:
  4024.       SetOrdProp(Instance, PropInfo, Ord(ReadChar));
  4025.     tkEnumeration:
  4026.       SetOrdProp(Instance, PropInfo, EnumValue(PropType, ReadIdent));
  4027.     tkFloat:
  4028.       SetFloatProp(Instance, PropInfo, ReadFloat);
  4029.     tkString, tkLString, tkWString:
  4030.       SetStrProp(Instance, PropInfo, ReadString);
  4031.     tkSet:
  4032.       SetOrdProp(Instance, PropInfo, ReadSet(PropType));
  4033.     tkClass:
  4034.       case NextValue of
  4035.         vaNil:
  4036.           begin
  4037.             ReadValue;
  4038.             SetOrdProp(Instance, PropInfo, 0)
  4039.           end;
  4040.         vaCollection:
  4041.           begin
  4042.             ReadValue;
  4043.             ReadCollection(TCollection(GetOrdProp(Instance, PropInfo)));
  4044.           end
  4045.       else
  4046.         SetObjectIdent(Instance, PropInfo, ReadIdent);
  4047.       end;
  4048.     tkMethod:
  4049.       if NextValue = vaNil then
  4050.       begin
  4051.         ReadValue;
  4052.         SetMethodProp(Instance, PropInfo, NilMethod);
  4053.       end
  4054.       else
  4055.       begin
  4056.         Method.Code :=  FindMethod(Root, ReadIdent);
  4057.         Method.Data := Root;
  4058.         if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method);
  4059.       end;
  4060.   end;
  4061. end;
  4062.  
  4063. function TReader.ReadRootComponent(Root: TComponent): TComponent;
  4064.  
  4065.   function FindUniqueName(const Name: string): string;
  4066.   var
  4067.     I: Integer;
  4068.   begin
  4069.     I := 0;
  4070.     Result := '';
  4071.     if Assigned(FindGlobalComponent) then
  4072.     begin
  4073.       Result := Name;
  4074.       while FindGlobalComponent(Result) <> nil do
  4075.       begin
  4076.         Inc(I);
  4077.         Result := Format('%s_%d', [Name, I]);
  4078.       end;
  4079.     end;
  4080.   end;
  4081.  
  4082. var
  4083.   I: Integer;
  4084.   Flags: TFilerFlags;
  4085. begin
  4086.   ReadSignature;
  4087.   Result := nil;
  4088.   try
  4089.     ReadPrefix(Flags, I);
  4090.     if Root = nil then
  4091.     begin
  4092.       Result := TComponentClass(FindClass(ReadStr)).Create(nil);
  4093.       Result.Name := ReadStr;
  4094.     end else
  4095.     begin
  4096.       Result := Root;
  4097.       ReadStr; { Ignore class name }
  4098.       if csDesigning in Result.ComponentState then
  4099.         ReadStr else
  4100.         Result.Name := FindUniqueName(ReadStr);
  4101.     end;
  4102.     FRoot := Result;
  4103.     if GlobalLoaded <> nil then
  4104.       FLoaded := GlobalLoaded else
  4105.       FLoaded := TList.Create;
  4106.     try
  4107.       FLoaded.Add(FRoot);
  4108.       FOwner := FRoot;
  4109.       Include(FRoot.FComponentState, csLoading);
  4110.       Include(FRoot.FComponentState, csReading);
  4111.       FRoot.ReadState(Self);
  4112.       Exclude(FRoot.FComponentState, csReading);
  4113.       if GlobalLoaded = nil then
  4114.         for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
  4115.     finally
  4116.       if GlobalLoaded = nil then FLoaded.Free;
  4117.       FLoaded := nil;
  4118.     end;
  4119.     GlobalFixupReferences;
  4120.   except
  4121.     RemoveFixupReferences(Root, '');
  4122.     if Root = nil then Result.Free;
  4123.     raise;
  4124.   end;
  4125. end;
  4126.  
  4127. procedure TReader.ReadComponents(AOwner, AParent: TComponent;
  4128.   Proc: TReadComponentsProc);
  4129. var
  4130.   Component: TComponent;
  4131. begin
  4132.   Root := AOwner;
  4133.   Owner := AOwner;
  4134.   Parent := AParent;
  4135.   BeginReferences;
  4136.   try
  4137.     while not EndOfList do
  4138.     begin
  4139.       ReadSignature;
  4140.       Component := ReadComponent(nil);
  4141.       Proc(Component);
  4142.     end;
  4143.     ReadListEnd;
  4144.     FixupReferences;
  4145.   finally
  4146.     EndReferences;
  4147.   end;
  4148. end;
  4149.  
  4150. function TReader.ReadSet(SetType: Pointer): Integer;
  4151. var
  4152.   EnumType: PTypeInfo;
  4153.   EnumName: string;
  4154. begin
  4155.   try
  4156.     if ReadValue <> vaSet then PropValueError;
  4157.     EnumType := GetTypeData(SetType)^.CompType^;
  4158.     Result := 0;
  4159.     while True do
  4160.     begin
  4161.       EnumName := ReadStr;
  4162.       if EnumName = '' then Break;
  4163.       Include(TIntegerSet(Result), EnumValue(EnumType, EnumName));
  4164.     end;
  4165.   except
  4166.     SkipSetBody;
  4167.     raise;
  4168.   end;
  4169. end;
  4170.  
  4171. procedure TReader.ReadSignature;
  4172. var
  4173.   Signature: Longint;
  4174. begin
  4175.   Read(Signature, SizeOf(Signature));
  4176.   if Signature <> Longint(FilerSignature) then ReadError(SInvalidImage);
  4177. end;
  4178.  
  4179. function TReader.ReadStr: string;
  4180. var
  4181.   L: Byte;
  4182. begin
  4183.   Read(L, SizeOf(Byte));
  4184.   SetString(Result, PChar(nil), L);
  4185.   Read(Result[1], L);
  4186. end;
  4187.  
  4188. function TReader.ReadString: string;
  4189. var
  4190.   L: Integer;
  4191. begin
  4192.   L := 0;
  4193.   case ReadValue of
  4194.     vaString:
  4195.       Read(L, SizeOf(Byte));
  4196.     vaLString:
  4197.       Read(L, SizeOf(Integer));
  4198.   else
  4199.     PropValueError;
  4200.   end;
  4201.   SetString(Result, PChar(nil), L);
  4202.   Read(Pointer(Result)^, L);
  4203. end;
  4204.  
  4205. function TReader.ReadValue: TValueType;
  4206. begin
  4207.   Read(Result, SizeOf(Result));
  4208. end;
  4209.  
  4210. procedure TReader.SetPosition(Value: Longint);
  4211. begin
  4212.   FStream.Position := Value;
  4213.   FBufPos := 0;
  4214.   FBufEnd := 0;
  4215. end;
  4216.  
  4217. procedure TReader.SkipSetBody;
  4218. begin
  4219.   while ReadStr <> '' do begin end;
  4220. end;
  4221.  
  4222. procedure TReader.SkipValue;
  4223.  
  4224.   procedure SkipList;
  4225.   begin
  4226.     while not EndOfList do SkipValue;
  4227.     ReadListEnd;
  4228.   end;
  4229.  
  4230.   procedure SkipBytes(Count: Longint);
  4231.   var
  4232.     Bytes: array[0..255] of Char;
  4233.   begin
  4234.     while Count > 0 do
  4235.       if Count > SizeOf(Bytes) then
  4236.       begin
  4237.         Read(Bytes, SizeOf(Bytes));
  4238.         Dec(Count, SizeOf(Bytes));
  4239.       end
  4240.       else
  4241.       begin
  4242.         Read(Bytes, Count);
  4243.         Count := 0;
  4244.       end;
  4245.   end;
  4246.  
  4247.   procedure SkipBinary;
  4248.   var
  4249.     Count: Longint;
  4250.   begin
  4251.     Read(Count, SizeOf(Count));
  4252.     SkipBytes(Count);
  4253.   end;
  4254.  
  4255.   procedure SkipCollection;
  4256.   begin
  4257.     while not EndOfList do
  4258.     begin
  4259.       if NextValue in [vaInt8, vaInt16, vaInt32] then SkipValue;
  4260.       SkipBytes(1);
  4261.       while not EndOfList do SkipProperty;
  4262.       ReadListEnd;
  4263.     end;
  4264.     ReadListEnd;
  4265.   end;
  4266.  
  4267. begin
  4268.   case ReadValue of
  4269.     vaNull: begin end;
  4270.     vaList: SkipList;
  4271.     vaInt8: SkipBytes(1);
  4272.     vaInt16: SkipBytes(2);
  4273.     vaInt32: SkipBytes(4);
  4274.     vaExtended: SkipBytes(SizeOf(Extended));
  4275.     vaString, vaIdent: ReadStr;
  4276.     vaFalse, vaTrue: begin end;
  4277.     vaBinary: SkipBinary;
  4278.     vaSet: SkipSetBody;
  4279.     vaCollection: SkipCollection;
  4280.   end;
  4281. end;
  4282.  
  4283. procedure TReader.CopyValue(Writer: TWriter);
  4284.  
  4285.   procedure CopySetBody;
  4286.   var
  4287.     s: string;
  4288.   begin
  4289.     Writer.WriteValue(ReadValue);
  4290.     repeat
  4291.       s := ReadStr;
  4292.       Writer.WriteStr(s);
  4293.     until s = '';
  4294.   end;
  4295.  
  4296.   procedure CopyList;
  4297.   begin
  4298.     Writer.WriteValue(ReadValue);
  4299.     while not EndOfList do
  4300.       CopyValue(Writer);
  4301.     ReadListEnd;
  4302.     Writer.WriteListEnd;
  4303.   end;
  4304.  
  4305.   procedure CopyBytes(Count: Longint);
  4306.   var
  4307.     Bytes: array[0..8191] of Char;
  4308.   begin
  4309.     while Count > SizeOf(Bytes) do
  4310.     begin
  4311.       Read(Bytes, SizeOf(Bytes));
  4312.       Writer.Write(Bytes, SizeOf(Bytes));
  4313.       Dec(Count, SizeOf(Bytes));
  4314.     end;
  4315.     if Count > 0 then
  4316.     begin
  4317.       Read(Bytes, Count);
  4318.       Writer.Write(Bytes, Count);
  4319.     end;
  4320.   end;
  4321.  
  4322.   procedure CopyBinary;
  4323.   var
  4324.     Count: Longint;
  4325.   begin
  4326.     Writer.WriteValue(ReadValue);
  4327.     Read(Count, SizeOf(Count));
  4328.     Writer.Write(Count, SizeOf(Count));
  4329.     CopyBytes(Count);
  4330.   end;
  4331.  
  4332. begin
  4333.   case NextValue of
  4334.     vaNull, vaFalse, vaTrue, vaNil: Writer.WriteValue(ReadValue);
  4335.     vaList, vaCollection: CopyList;
  4336.     vaInt8, vaInt16, vaInt32: Writer.WriteInteger(ReadInteger);
  4337.     vaExtended: Writer.WriteFloat(ReadFloat);
  4338.     vaString, vaLString: Writer.WriteStr(ReadStr);
  4339.     vaIdent: Writer.WriteIdent(ReadIdent);
  4340.     vaBinary: CopyBinary;
  4341.     vaSet: CopySetBody;
  4342.   end;
  4343. end;
  4344.  
  4345. procedure TReader.SkipProperty;
  4346. begin
  4347.   ReadStr; { Skips property name }
  4348.   SkipValue;
  4349. end;
  4350.  
  4351. procedure TReader.SkipComponent(SkipHeader: Boolean);
  4352. var
  4353.   Flags: TFilerFlags;
  4354.   Position: Integer;
  4355. begin
  4356.   if SkipHeader then
  4357.   begin
  4358.     ReadPrefix(Flags, Position);
  4359.     ReadStr;
  4360.     ReadStr;
  4361.   end;
  4362.   while not EndOfList do SkipProperty;
  4363.   ReadListEnd;
  4364.   while not EndOfList do SkipComponent(True);
  4365.   ReadListEnd;
  4366. end;
  4367.  
  4368. function TReader.FindAncestorComponent(const Name: string;
  4369.   ComponentClass: TPersistentClass): TComponent;
  4370. var
  4371.   CompName: string;
  4372. begin
  4373.   CompName := Name;
  4374.   Result := Root.FindComponent(CompName);
  4375.   if Result = nil then
  4376.   begin
  4377.     if Assigned(FOnAncestorNotFound) then
  4378.       FOnAncestorNotFound(Self, CompName, ComponentClass, Result);
  4379.     if Result = nil then
  4380.       raise EReadError.CreateFmt(SAncestorNotFound, [CompName]);
  4381.   end;
  4382. end;
  4383.  
  4384. procedure TReader.ReferenceName(var Name: string);
  4385. begin
  4386.   if Assigned(FOnReferenceName) then FOnReferenceName(Self, Name);
  4387. end;
  4388.  
  4389. procedure TReader.SetName(Component: TComponent; var Name: string);
  4390. begin
  4391.   if Assigned(FOnSetName) then FOnSetName(Self, Component, Name);
  4392.   Component.Name := Name;
  4393. end;
  4394.  
  4395. { TWriter }
  4396.  
  4397. destructor TWriter.Destroy;
  4398. begin
  4399.   WriteBuffer;
  4400.   inherited Destroy;
  4401. end;
  4402.  
  4403. procedure TWriter.AddAncestor(Component: TComponent);
  4404. begin
  4405.   FAncestorList.Add(Component);
  4406. end;
  4407.  
  4408. procedure TWriter.DefineProperty(const Name: string;
  4409.   ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
  4410. begin
  4411.   if HasData and Assigned(WriteData) then
  4412.   begin
  4413.     WritePropName(Name);
  4414.     WriteData(Self);
  4415.   end;
  4416. end;
  4417.  
  4418. procedure TWriter.DefineBinaryProperty(const Name: string;
  4419.   ReadData, WriteData: TStreamProc; HasData: Boolean);
  4420. begin
  4421.   if HasData and Assigned(WriteData) then
  4422.   begin
  4423.     WritePropName(Name);
  4424.     WriteBinary(WriteData);
  4425.   end;
  4426. end;
  4427.  
  4428. function TWriter.GetPosition: Longint;
  4429. begin
  4430.   Result := FStream.Position + FBufPos;
  4431. end;
  4432.  
  4433. procedure TWriter.FlushBuffer;
  4434. begin
  4435.   WriteBuffer;
  4436. end;
  4437.  
  4438. procedure TWriter.SetPosition(Value: Longint);
  4439. var
  4440.   StreamPosition: Longint;
  4441. begin
  4442.   StreamPosition := FStream.Position;
  4443.   { Only flush the buffer if the repostion is outside the buffer range }
  4444.   if (Value < StreamPosition) or (Value > StreamPosition + FBufPos) then
  4445.   begin
  4446.     WriteBuffer;
  4447.     FStream.Position := Value;
  4448.   end
  4449.   else FBufPos := Value - StreamPosition;
  4450. end;
  4451.  
  4452. procedure TWriter.Write(const Buf; Count: Longint); assembler;
  4453. asm
  4454.         PUSH    ESI
  4455.         PUSH    EDI
  4456.         PUSH    EBX
  4457.         MOV     ESI,EDX
  4458.         MOV     EBX,ECX
  4459.         MOV     EDI,EAX
  4460.         JMP     @@6
  4461. @@1:    MOV     ECX,[EDI].TWriter.FBufSize
  4462.         SUB     ECX,[EDI].TWriter.FBufPos
  4463.         JA      @@2
  4464.         MOV     EAX,EDI
  4465.         CALL    TWriter.WriteBuffer
  4466.         MOV     ECX,[EDI].TWriter.FBufSize
  4467. @@2:    CMP     ECX,EBX
  4468.         JB      @@3
  4469.         MOV     ECX,EBX
  4470. @@3:    SUB     EBX,ECX
  4471.         PUSH    EDI
  4472.         MOV     EAX,[EDI].TWriter.FBuffer
  4473.         ADD     EAX,[EDI].TWriter.FBufPos
  4474.         ADD     [EDI].TWriter.FBufPos,ECX
  4475. @@5:    MOV     EDI,EAX
  4476.         MOV     EDX,ECX
  4477.         SHR     ECX,2
  4478.         CLD
  4479.         REP     MOVSD
  4480.         MOV     ECX,EDX
  4481.         AND     ECX,3
  4482.         REP     MOVSB
  4483.         POP     EDI
  4484. @@6:    OR      EBX,EBX
  4485.         JNE     @@1
  4486.         POP     EBX
  4487.         POP     EDI
  4488.         POP     ESI
  4489. end;
  4490.  
  4491. procedure TWriter.WriteBinary(WriteData: TStreamProc);
  4492. var
  4493.   Stream: TMemoryStream;
  4494.   Count: Longint;
  4495. begin
  4496.   Stream := TMemoryStream.Create;
  4497.   try
  4498.     WriteData(Stream);
  4499.     WriteValue(vaBinary);
  4500.     Count := Stream.Size;
  4501.     Write(Count, SizeOf(Count));
  4502.     Write(Stream.Memory^, Count);
  4503.   finally
  4504.     Stream.Free;
  4505.   end;
  4506. end;
  4507.  
  4508. procedure TWriter.WriteBuffer;
  4509. begin
  4510.   FStream.WriteBuffer(FBuffer^, FBufPos);
  4511.   FBufPos := 0;
  4512. end;
  4513.  
  4514. procedure TWriter.WriteBoolean(Value: Boolean);
  4515. begin
  4516.   if Value then
  4517.     WriteValue(vaTrue) else
  4518.     WriteValue(vaFalse);
  4519. end;
  4520.  
  4521. procedure TWriter.WriteChar(Value: Char);
  4522. begin
  4523.   WriteString(Value);
  4524. end;
  4525.  
  4526. procedure TWriter.WriteCollection(Value: TCollection);
  4527. var
  4528.   I: Integer;
  4529. begin
  4530.   WriteValue(vaCollection);
  4531.   for I := 0 to Value.Count - 1 do
  4532.   begin
  4533.     WriteListBegin;
  4534.     WriteProperties(Value.Items[I]);
  4535.     WriteListEnd;
  4536.   end;
  4537.   WriteListEnd;
  4538. end;
  4539.  
  4540. procedure TWriter.WriteComponent(Component: TComponent);
  4541.  
  4542.   function FindAncestor(const Name: string): TComponent;
  4543.   var
  4544.     I: Integer;
  4545.   begin
  4546.     for I := 0 to FAncestorList.Count - 1 do
  4547.     begin
  4548.       Result := FAncestorList[I];
  4549.       if CompareText(Result.Name, Name) = 0 then Exit;
  4550.     end;
  4551.     Result := nil;
  4552.   end;
  4553.  
  4554. begin
  4555.   Include(Component.FComponentState, csWriting);
  4556.   if Assigned(FAncestorList) then
  4557.     Ancestor := FindAncestor(Component.Name);
  4558.   Component.WriteState(Self);
  4559.   Exclude(Component.FComponentState, csWriting);
  4560. end;
  4561.  
  4562. procedure TWriter.WriteData(Instance: TComponent);
  4563. var
  4564.   PreviousPosition, PropertiesPosition: Longint;
  4565.   OldAncestorList: TList;
  4566.   OldAncestorPos, OldChildPos: Integer;
  4567.   Flags: TFilerFlags;
  4568. begin
  4569.   if FBufSize - FBufPos < Length(Instance.ClassName) +
  4570.     Length(Instance.Name) + 1+5+3 then WriteBuffer;
  4571.      { Prefix + vaInt + integer + 2 end lists }
  4572.   PreviousPosition := Position;
  4573.   Flags := [];
  4574.   if Ancestor <> nil then Include(Flags, ffInherited);
  4575.   if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) and
  4576.     ((Ancestor = nil) or (FAncestorList[FAncestorPos] <> Ancestor)) then
  4577.     Include(Flags, ffChildPos);
  4578.   WritePrefix(Flags, FChildPos);
  4579.   WriteStr(Instance.ClassName);
  4580.   WriteStr(Instance.Name);
  4581.   PropertiesPosition := Position;
  4582.   if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) then
  4583.   begin
  4584.     if Ancestor <> nil then Inc(FAncestorPos);
  4585.     Inc(FChildPos);
  4586.   end;
  4587.   WriteProperties(Instance);
  4588.   WriteListEnd;
  4589.   OldAncestorList := FAncestorList;
  4590.   OldAncestorPos := FAncestorPos;
  4591.   OldChildPos := FChildPos;
  4592.   try
  4593.     FAncestorList := nil;
  4594.     FAncestorPos := 0;
  4595.     FChildPos := 0;
  4596.     if not IgnoreChildren then
  4597.       try
  4598.         if (FAncestor <> nil) and (FAncestor is TComponent) then
  4599.         begin
  4600.           FAncestorList := TList.Create;
  4601.           TComponent(FAncestor).GetChildren(AddAncestor, FRootAncestor);
  4602.         end;
  4603.         Instance.GetChildren(WriteComponent, FRoot);
  4604.       finally
  4605.         FAncestorList.Free;
  4606.       end;
  4607.   finally
  4608.     FAncestorList := OldAncestorList;
  4609.     FAncestorPos := OldAncestorPos;
  4610.     FChildPos := OldChildPos;
  4611.   end;
  4612.   WriteListEnd;
  4613.   if (Instance <> Root) and (Flags = [ffInherited]) and
  4614.     (Position = PropertiesPosition + (1 + 1)) then { (1 + 1) is two end lists }
  4615.     Position := PreviousPosition;
  4616. end;
  4617.  
  4618. procedure TWriter.WriteDescendent(Root: TComponent; AAncestor: TComponent);
  4619. begin
  4620.   FRootAncestor := AAncestor;
  4621.   FAncestor := AAncestor;
  4622.   FRoot := Root;
  4623.   WriteSignature;
  4624.   WriteComponent(Root);
  4625. end;
  4626.  
  4627. procedure TWriter.WriteFloat(Value: Extended);
  4628. begin
  4629.   WriteValue(vaExtended);
  4630.   Write(Value, SizeOf(Extended));
  4631. end;
  4632.  
  4633. procedure TWriter.WriteIdent(const Ident: string);
  4634. begin
  4635.   if CompareText(Ident, 'False') = 0 then WriteValue(vaFalse) else
  4636.   if CompareText(Ident ,'True') = 0 then WriteValue(vaTrue) else
  4637.   if CompareText(Ident, 'nil') = 0 then WriteValue(vaNil) else
  4638.   begin
  4639.     WriteValue(vaIdent);
  4640.     WriteStr(Ident);
  4641.   end;
  4642. end;
  4643.  
  4644. procedure TWriter.WriteInteger(Value: Longint);
  4645. begin
  4646.   if (Value >= -128) and (Value <= 127) then
  4647.   begin
  4648.     WriteValue(vaInt8);
  4649.     Write(Value, SizeOf(Shortint));
  4650.   end else
  4651.   if (Value >= -32768) and (Value <= 32767) then
  4652.   begin
  4653.     WriteValue(vaInt16);
  4654.     Write(Value, SizeOf(Smallint));
  4655.   end else
  4656.   begin
  4657.     WriteValue(vaInt32);
  4658.     Write(Value, SizeOf(Longint));
  4659.   end;
  4660. end;
  4661.  
  4662. procedure TWriter.WriteListBegin;
  4663. begin
  4664.   WriteValue(vaList);
  4665. end;
  4666.  
  4667. procedure TWriter.WriteListEnd;
  4668. begin
  4669.   WriteValue(vaNull);
  4670. end;
  4671.  
  4672. procedure TWriter.WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  4673. var
  4674.   Prefix: Byte;
  4675. begin
  4676.   if Flags <> [] then
  4677.   begin
  4678.     Prefix := $F0 or Byte(Flags);
  4679.     Write(Prefix, SizeOf(Prefix));
  4680.     if ffChildPos in Flags then WriteInteger(AChildPos);
  4681.   end;
  4682. end;
  4683.  
  4684. procedure TWriter.WriteProperties(Instance: TPersistent);
  4685. var
  4686.   I, Count: Integer;
  4687.   PropInfo: PPropInfo;
  4688.   PropList: PPropList;
  4689. begin
  4690.   Count := GetTypeData(Instance.ClassInfo)^.PropCount;
  4691.   if Count > 0 then
  4692.   begin
  4693.     GetMem(PropList, Count * SizeOf(Pointer));
  4694.     try
  4695.       GetPropInfos(Instance.ClassInfo, PropList);
  4696.       for I := 0 to Count - 1 do
  4697.       begin
  4698.         PropInfo := PropList^[I];
  4699.         if IsStoredProp(Instance, PropInfo) then
  4700.           WriteProperty(Instance, PropInfo);
  4701.       end;
  4702.     finally
  4703.       FreeMem(PropList, Count * SizeOf(Pointer));
  4704.     end;
  4705.   end;
  4706.   Instance.DefineProperties(Self);
  4707. end;
  4708.  
  4709. procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  4710. var
  4711.   PropType: PTypeInfo;
  4712.  
  4713.   function AncestorValid: Boolean;
  4714.   begin
  4715.     Result := (Ancestor <> nil) and ((Instance.ClassType = Ancestor.ClassType) or
  4716.       (Instance = Root));
  4717.   end;
  4718.  
  4719.   procedure WritePropPath;
  4720.   begin
  4721.     WritePropName(PPropInfo(PropInfo)^.Name);
  4722.   end;
  4723.  
  4724.   procedure WriteSet(Value: Longint);
  4725.   var
  4726.     I: Integer;
  4727.     BaseType: PTypeInfo;
  4728.   begin
  4729.     BaseType := GetTypeData(PropType)^.CompType^;
  4730.     WriteValue(vaSet);
  4731.     for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do
  4732.       if I in TIntegerSet(Value) then WriteStr(GetEnumName(BaseType, I));
  4733.     WriteStr('');
  4734.   end;
  4735.  
  4736.   procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
  4737.   var
  4738.     I: Integer;
  4739.     Ident: string;
  4740.   begin
  4741.     for I := 0 to IntConstList.Count - 1 do
  4742.       with TIntConst(IntConstList[I]) do
  4743.         if IntType = IntegerType then
  4744.           if IntToIdent(Value, Ident) then
  4745.           begin
  4746.             WriteIdent(Ident);
  4747.             Exit;
  4748.           end
  4749.           else Break;
  4750.     WriteInteger(Value);
  4751.   end;
  4752.  
  4753.   procedure WriteCollectionProp(Collection: TCollection);
  4754.   var
  4755.     SavePropPath: string;
  4756.   begin
  4757.     WritePropPath;
  4758.     SavePropPath := FPropPath;
  4759.     try
  4760.       FPropPath := '';
  4761.       WriteCollection(Collection);
  4762.     finally
  4763.       FPropPath := SavePropPath;
  4764.     end;
  4765.   end;
  4766.  
  4767.   procedure WriteOrdProp;
  4768.   var
  4769.     Value: Longint;
  4770.  
  4771.     function IsDefaultValue: Boolean;
  4772.     begin
  4773.       if AncestorValid then
  4774.         Result := Value = GetOrdProp(Ancestor, PropInfo) else
  4775.         Result := Value = PPropInfo(PropInfo)^.Default;
  4776.     end;
  4777.  
  4778.   begin
  4779.     Value := GetOrdProp(Instance, PropInfo);
  4780.     if not IsDefaultValue then
  4781.     begin
  4782.       WritePropPath;
  4783.       case PropType^.Kind of
  4784.         tkInteger:
  4785.           WriteIntProp(PPropInfo(PropInfo)^.PropType^, Value);
  4786.         tkChar:
  4787.           WriteChar(Chr(Value));
  4788.         tkSet:
  4789.           WriteSet(Value);
  4790.         tkEnumeration:
  4791.           WriteIdent(GetEnumName(PropType, Value));
  4792.       end;
  4793.     end;
  4794.   end;
  4795.  
  4796.   procedure WriteFloatProp;
  4797.   var
  4798.     Value: Extended;
  4799.  
  4800.     function IsDefaultValue: Boolean;
  4801.     begin
  4802.       if AncestorValid then
  4803.         Result := Value = GetFloatProp(Ancestor, PropInfo) else
  4804.         Result := Value = 0;
  4805.     end;
  4806.  
  4807.   begin
  4808.     Value := GetFloatProp(Instance, PropInfo);
  4809.     if not IsDefaultValue then
  4810.     begin
  4811.       WritePropPath;
  4812.       WriteFloat(Value);
  4813.     end;
  4814.   end;
  4815.  
  4816.   procedure WriteStrProp;
  4817.   var
  4818.     Value: string;
  4819.  
  4820.     function IsDefault: Boolean;
  4821.     begin
  4822.       if AncestorValid then
  4823.         Result := Value = GetStrProp(Ancestor, PropInfo) else
  4824.         Result := Value = '';
  4825.     end;
  4826.  
  4827.   begin
  4828.     Value := GetStrProp(Instance, PropInfo);
  4829.     if not IsDefault then
  4830.     begin
  4831.       WritePropPath;
  4832.       WriteString(Value);
  4833.     end;
  4834.   end;
  4835.  
  4836.   procedure WriteObjectProp;
  4837.   var
  4838.     Value: TObject;
  4839.     OldAncestor: TPersistent;
  4840.     SavePropPath, ComponentValue: string;
  4841.  
  4842.     function IsDefault: Boolean;
  4843.     var
  4844.       AncestorValue: TObject;
  4845.     begin
  4846.       AncestorValue := nil;
  4847.       if AncestorValid then
  4848.       begin
  4849.         AncestorValue := TObject(GetOrdProp(Ancestor, PropInfo));
  4850.         if (AncestorValue <> nil) and (TComponent(AncestorValue).Owner = FRootAncestor) and
  4851.           (Value <> nil) and (TComponent(Value).Owner = Root) and
  4852.           (CompareText(TComponent(AncestorValue).Name, TComponent(Value).Name) = 0) then
  4853.           AncestorValue := Value;
  4854.       end;
  4855.       Result := Value = AncestorValue;
  4856.     end;
  4857.  
  4858.     function GetComponentValue(Component: TComponent): string;
  4859.     begin
  4860.       if Component.Owner = Root then
  4861.         Result := Component.Name
  4862.       else if Component = Root then
  4863.         Result := 'Owner'                                                       { Do not translate }
  4864.       else if Component.Owner <> nil then
  4865.         Result := Component.Owner.Name + '.' + Component.Name
  4866.       else Result := Component.Name + '.Owner';                                 { Do not translate }
  4867.     end;
  4868.  
  4869.   begin
  4870.     Value := TObject(GetOrdProp(Instance, PropInfo));
  4871.     if (Value = nil) and not IsDefault then
  4872.     begin
  4873.       WritePropPath;
  4874.       WriteValue(vaNil);
  4875.     end
  4876.     else if Value is TPersistent then
  4877.       if Value is TComponent then
  4878.       begin
  4879.         if not IsDefault then
  4880.         begin
  4881.           ComponentValue := GetComponentValue(TComponent(Value));
  4882.           if ComponentValue <> '' then
  4883.           begin
  4884.             WritePropPath;
  4885.             WriteIdent(ComponentValue);
  4886.           end
  4887.         end
  4888.       end else if Value is TCollection then
  4889.       begin
  4890.         if not AncestorValid or
  4891.           not CollectionsEqual(TCollection(Value),
  4892.             TCollection(GetOrdProp(Ancestor, PropInfo))) then
  4893.             WriteCollectionProp(TCollection(Value));
  4894.       end else
  4895.       begin
  4896.         OldAncestor := Ancestor;
  4897.         SavePropPath := FPropPath;
  4898.         try
  4899.           FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';
  4900.           if AncestorValid then
  4901.             Ancestor := TPersistent(GetOrdProp(Ancestor, PropInfo));
  4902.           WriteProperties(TPersistent(Value));
  4903.         finally
  4904.           Ancestor := OldAncestor;
  4905.           FPropPath := SavePropPath;
  4906.         end;
  4907.       end
  4908.   end;
  4909.  
  4910.   procedure WriteMethodProp;
  4911.   var
  4912.     Value: TMethod;
  4913.  
  4914.     function IsDefaultValue: Boolean;
  4915.     var
  4916.       DefaultCode: Pointer;
  4917.     begin
  4918.       DefaultCode := nil;
  4919.       if AncestorValid then DefaultCode := GetMethodProp(Ancestor, PropInfo).Code;
  4920.       Result := (Value.Code = DefaultCode) or
  4921.         ((Value.Code <> nil) and (Root.MethodName(Value.Code) = ''));
  4922.     end;
  4923.  
  4924.   begin
  4925.     Value := GetMethodProp(Instance, PropInfo);
  4926.     if not IsDefaultValue then
  4927.     begin
  4928.       WritePropPath;
  4929.       if Value.Code = nil then
  4930.         WriteValue(vaNil) else
  4931.         WriteIdent(Root.MethodName(Value.Code));
  4932.     end;
  4933.   end;
  4934.  
  4935. begin
  4936.   if PPropInfo(PropInfo)^.SetProc <> nil then
  4937.   begin
  4938.     PropType := PPropInfo(PropInfo)^.PropType^;
  4939.     case PropType^.Kind of
  4940.       tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp;
  4941.       tkFloat: WriteFloatProp;
  4942.       tkString, tkLString, tkWString: WriteStrProp;
  4943.       tkClass: WriteObjectProp;
  4944.       tkMethod: WriteMethodProp;
  4945.     end;
  4946.   end;
  4947. end;
  4948.  
  4949. procedure TWriter.WritePropName(const PropName: string);
  4950. begin
  4951.   WriteStr(FPropPath + PropName);
  4952. end;
  4953.  
  4954. procedure TWriter.WriteRootComponent(Root: TComponent);
  4955. begin
  4956.   WriteDescendent(Root, nil);
  4957. end;
  4958.  
  4959. procedure TWriter.WriteSignature;
  4960. begin
  4961.   Write(FilerSignature, SizeOf(FilerSignature));
  4962. end;
  4963.  
  4964. procedure TWriter.WriteStr(const Value: string);
  4965. var
  4966.   L: Integer;
  4967. begin
  4968.   L := Length(Value);
  4969.   if L > 255 then L := 255;
  4970.   Write(L, SizeOf(Byte));
  4971.   Write(Value[1], L);
  4972. end;
  4973.  
  4974. procedure TWriter.WriteString(const Value: string);
  4975. var
  4976.   L: Integer;
  4977. begin
  4978.   L := Length(Value);
  4979.   if L <= 255 then
  4980.   begin
  4981.     WriteValue(vaString);
  4982.     Write(L, SizeOf(Byte));
  4983.   end else
  4984.   begin
  4985.     WriteValue(vaLString);
  4986.     Write(L, SizeOf(Integer));
  4987.   end;
  4988.   Write(Pointer(Value)^, L);
  4989. end;
  4990.  
  4991. procedure TWriter.WriteValue(Value: TValueType);
  4992. begin
  4993.   Write(Value, SizeOf(Value));
  4994. end;
  4995.  
  4996. { TParser }
  4997.  
  4998. const
  4999.   ParseBufSize = 4096;
  5000.  
  5001. procedure BinToHex(Buffer, Text: PChar; BufSize: Integer); assembler;
  5002. asm
  5003.         PUSH    ESI
  5004.         PUSH    EDI
  5005.         MOV     ESI,EAX
  5006.         MOV     EDI,EDX
  5007.         MOV     EDX,0
  5008.         JMP     @@1
  5009. @@0:    DB      '0123456789ABCDEF'
  5010. @@1:    LODSB
  5011.         MOV     DL,AL
  5012.         AND     DL,0FH
  5013.         MOV     AH,@@0.Byte[EDX]
  5014.         MOV     DL,AL
  5015.         SHR     DL,4
  5016.         MOV     AL,@@0.Byte[EDX]
  5017.         STOSW
  5018.         DEC     ECX
  5019.         JNE     @@1
  5020.         POP     EDI
  5021.         POP     ESI
  5022. end;
  5023.  
  5024. function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer; assembler;
  5025. asm
  5026.         PUSH    ESI
  5027.         PUSH    EDI
  5028.         PUSH    EBX
  5029.         MOV     ESI,EAX
  5030.         MOV     EDI,EDX
  5031.         MOV     EBX,EDX
  5032.         MOV     EDX,0
  5033.         JMP     @@1
  5034. @@0:    DB       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1
  5035.         DB      -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1
  5036.         DB      -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1
  5037.         DB      -1,10,11,12,13,14,15
  5038. @@1:    LODSW
  5039.         CMP     AL,'0'
  5040.         JB      @@2
  5041.         CMP     AL,'f'
  5042.         JA      @@2
  5043.         MOV     DL,AL
  5044.         MOV     AL,@@0.Byte[EDX-'0']
  5045.         CMP     AL,-1
  5046.         JE      @@2
  5047.         SHL     AL,4
  5048.         CMP     AH,'0'
  5049.         JB      @@2
  5050.         CMP     AH,'f'
  5051.         JA      @@2
  5052.         MOV     DL,AH
  5053.         MOV     AH,@@0.Byte[EDX-'0']
  5054.         CMP     AH,-1
  5055.         JE      @@2
  5056.         OR      AL,AH
  5057.         STOSB
  5058.         DEC     ECX
  5059.         JNE     @@1
  5060. @@2:    MOV     EAX,EDI
  5061.         SUB     EAX,EBX
  5062.         POP     EBX
  5063.         POP     EDI
  5064.         POP     ESI
  5065. end;
  5066.  
  5067. constructor TParser.Create(Stream: TStream);
  5068. begin
  5069.   FStream := Stream;
  5070.   GetMem(FBuffer, ParseBufSize);
  5071.   FBuffer[0] := #0;
  5072.   FBufPtr := FBuffer;
  5073.   FBufEnd := FBuffer + ParseBufSize;
  5074.   FSourcePtr := FBuffer;
  5075.   FSourceEnd := FBuffer;
  5076.   FTokenPtr := FBuffer;
  5077.   FSourceLine := 1;
  5078.   NextToken;
  5079. end;
  5080.  
  5081. destructor TParser.Destroy;
  5082. begin
  5083.   if FBuffer <> nil then
  5084.   begin
  5085.     FStream.Seek(Longint(FTokenPtr) - Longint(FBufPtr), 1);
  5086.     FreeMem(FBuffer, ParseBufSize);
  5087.   end;
  5088. end;
  5089.  
  5090. procedure TParser.CheckToken(T: Char);
  5091. begin
  5092.   if Token <> T then
  5093.     case T of
  5094.       toSymbol:
  5095.         Error(SIdentifierExpected);
  5096.       toString:
  5097.         Error(SStringExpected);
  5098.       toInteger, toFloat:
  5099.         Error(SNumberExpected);
  5100.     else
  5101.       ErrorFmt(SCharExpected, [T]);
  5102.     end;
  5103. end;
  5104.  
  5105. procedure TParser.CheckTokenSymbol(const S: string);
  5106. begin
  5107.   if not TokenSymbolIs(S) then ErrorFmt(SSymbolExpected, [S]);
  5108. end;
  5109.  
  5110. procedure TParser.Error(const Ident: string);
  5111. begin
  5112.   ErrorStr(Ident);
  5113. end;
  5114.  
  5115. procedure TParser.ErrorFmt(const Ident: string; const Args: array of const);
  5116. begin
  5117.   ErrorStr(Format(Ident, Args));
  5118. end;
  5119.  
  5120. procedure TParser.ErrorStr(const Message: string);
  5121. begin
  5122.   raise EParserError.CreateFmt(SParseError, [Message, FSourceLine]);
  5123. end;
  5124.  
  5125. procedure TParser.HexToBinary(Stream: TStream);
  5126. var
  5127.   Count: Integer;
  5128.   Buffer: array[0..255] of Char;
  5129. begin
  5130.   SkipBlanks;
  5131.   while FSourcePtr^ <> '}' do
  5132.   begin
  5133.     Count := HexToBin(FSourcePtr, Buffer, SizeOf(Buffer));
  5134.     if Count = 0 then Error(SInvalidBinary);
  5135.     Stream.Write(Buffer, Count);
  5136.     Inc(FSourcePtr, Count * 2);
  5137.     SkipBlanks;
  5138.   end;
  5139.   NextToken;
  5140. end;
  5141.  
  5142. function TParser.NextToken: Char;
  5143. var
  5144.   I: Integer;
  5145.   P, S: PChar;
  5146. begin
  5147.   SkipBlanks;
  5148.   P := FSourcePtr;
  5149.   FTokenPtr := P;
  5150.   case P^ of
  5151.     'A'..'Z', 'a'..'z', '_':
  5152.       begin
  5153.         Inc(P);
  5154.         while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
  5155.         Result := toSymbol;
  5156.       end;
  5157.     '#', '''':
  5158.       begin
  5159.         S := P;
  5160.         while True do
  5161.           case P^ of
  5162.             '#':
  5163.               begin
  5164.                 Inc(P);
  5165.                 I := 0;
  5166.                 while P^ in ['0'..'9'] do
  5167.                 begin
  5168.                   I := I * 10 + (Ord(P^) - Ord('0'));
  5169.                   Inc(P);
  5170.                 end;
  5171.                 S^ := Chr(I);
  5172.                 Inc(S);
  5173.               end;
  5174.             '''':
  5175.               begin
  5176.                 Inc(P);
  5177.                 while True do
  5178.                 begin
  5179.                   case P^ of
  5180.                     #0, #10, #13:
  5181.                       Error(SInvalidString);
  5182.                     '''':
  5183.                       begin
  5184.                         Inc(P);
  5185.                         if P^ <> '''' then Break;
  5186.                       end;
  5187.                   end;
  5188.                   S^ := P^;
  5189.                   Inc(S);
  5190.                   Inc(P);
  5191.                 end;
  5192.               end;
  5193.           else
  5194.             Break;
  5195.           end;
  5196.         FStringPtr := S;
  5197.         Result := toString;
  5198.       end;
  5199.     '$':
  5200.       begin
  5201.         Inc(P);
  5202.         while P^ in ['0'..'9', 'A'..'F', 'a'..'f'] do Inc(P);
  5203.         Result := toInteger;
  5204.       end;
  5205.     '-', '0'..'9':
  5206.       begin
  5207.         Inc(P);
  5208.         while P^ in ['0'..'9'] do Inc(P);
  5209.         Result := toInteger;
  5210.         while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do
  5211.         begin
  5212.           Inc(P);
  5213.           Result := toFloat;
  5214.         end;
  5215.       end;
  5216.   else
  5217.     Result := P^;
  5218.     if Result <> toEOF then Inc(P);
  5219.   end;
  5220.   FSourcePtr := P;
  5221.   FToken := Result;
  5222. end;
  5223.  
  5224. procedure TParser.ReadBuffer;
  5225. var
  5226.   Count: Integer;
  5227. begin
  5228.   Inc(FOrigin, FSourcePtr - FBuffer);
  5229.   FSourceEnd[0] := FSaveChar;
  5230.   Count := FBufPtr - FSourcePtr;
  5231.   if Count <> 0 then Move(FSourcePtr[0], FBuffer[0], Count);
  5232.   FBufPtr := FBuffer + Count;
  5233.   Inc(FBufPtr, FStream.Read(FBufPtr[0], FBufEnd - FBufPtr));
  5234.   FSourcePtr := FBuffer;
  5235.   FSourceEnd := FBufPtr;
  5236.   if FSourceEnd = FBufEnd then
  5237.   begin
  5238.     FSourceEnd := LineStart(FBuffer, FSourceEnd - 1);
  5239.     if FSourceEnd = FBuffer then Error(SLineTooLong);
  5240.   end;
  5241.   FSaveChar := FSourceEnd[0];
  5242.   FSourceEnd[0] := #0;
  5243. end;
  5244.  
  5245. procedure TParser.SkipBlanks;
  5246. begin
  5247.   while True do
  5248.   begin
  5249.     case FSourcePtr^ of
  5250.       #0:
  5251.         begin
  5252.           ReadBuffer;
  5253.           if FSourcePtr^ = #0 then Exit;
  5254.           Continue;
  5255.         end;
  5256.       #10:
  5257.         Inc(FSourceLine);
  5258.       #33..#255:
  5259.         Exit;
  5260.     end;
  5261.     Inc(FSourcePtr);
  5262.   end;
  5263. end;
  5264.  
  5265. function TParser.SourcePos: Longint;
  5266. begin
  5267.   Result := FOrigin + (FTokenPtr - FBuffer);
  5268. end;
  5269.  
  5270. function TParser.TokenFloat: Extended;
  5271. begin
  5272.   Result := StrToFloat(TokenString);
  5273. end;
  5274.  
  5275. function TParser.TokenInt: Longint;
  5276. begin
  5277.   Result := StrToInt(TokenString);
  5278. end;
  5279.  
  5280. function TParser.TokenString: string;
  5281. var
  5282.   L: Integer;
  5283. begin
  5284.   if FToken = toString then
  5285.     L := FStringPtr - FTokenPtr else
  5286.     L := FSourcePtr - FTokenPtr;
  5287.   SetString(Result, FTokenPtr, L);
  5288. end;
  5289.  
  5290. function TParser.TokenSymbolIs(const S: string): Boolean;
  5291. begin
  5292.   Result := (Token = toSymbol) and (CompareText(S, TokenString) = 0);
  5293. end;
  5294.  
  5295. function TParser.TokenComponentIdent: String;
  5296. var
  5297.   P: PChar;
  5298. begin
  5299.   CheckToken(toSymbol);
  5300.   P := FSourcePtr;
  5301.   while P^ = '.' do
  5302.   begin
  5303.     Inc(P);
  5304.     if not (P^ in ['A'..'Z', 'a'..'z', '_']) then
  5305.       Error(SIdentifierExpected);
  5306.     repeat
  5307.       Inc(P)
  5308.     until not (P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
  5309.   end;
  5310.   FSourcePtr := P;
  5311.   Result := TokenString;
  5312. end;
  5313.  
  5314. { Binary to text conversion }
  5315.  
  5316. procedure ObjectBinaryToText(Input, Output: TStream);
  5317. var
  5318.   NestingLevel: Integer;
  5319.   SaveSeparator: Char;
  5320.   Reader: TReader;
  5321.   Writer: TWriter;
  5322.  
  5323.   procedure WriteIndent;
  5324.   const
  5325.     Blanks: array[0..1] of Char = '  ';
  5326.   var
  5327.     I: Integer;
  5328.   begin
  5329.     for I := 1 to NestingLevel do Writer.Write(Blanks, SizeOf(Blanks));
  5330.   end;
  5331.  
  5332.   procedure WriteStr(const S: string);
  5333.   begin
  5334.     Writer.Write(S[1], Length(S));
  5335.   end;
  5336.  
  5337.   procedure NewLine;
  5338.   begin
  5339.     WriteStr(#13#10);
  5340.     WriteIndent;
  5341.   end;
  5342.  
  5343.   procedure ConvertValue; forward;
  5344.  
  5345.   procedure ConvertHeader;
  5346.   var
  5347.     ClassName, ObjectName: string;
  5348.     Flags: TFilerFlags;
  5349.     Position: Integer;
  5350.   begin
  5351.     Reader.ReadPrefix(Flags, Position);
  5352.     ClassName := Reader.ReadStr;
  5353.     ObjectName := Reader.ReadStr;
  5354.     WriteIndent;
  5355.     if ffInherited in Flags then
  5356.       WriteStr('inherited ')
  5357.     else
  5358.       WriteStr('object ');
  5359.     if ObjectName <> '' then
  5360.     begin
  5361.       WriteStr(ObjectName);
  5362.       WriteStr(': ');
  5363.     end;
  5364.     WriteStr(ClassName);
  5365.     if ffChildPos in Flags then
  5366.     begin
  5367.       WriteStr(' [');
  5368.       WriteStr(IntToStr(Position));
  5369.       WriteStr(']');
  5370.     end;
  5371.     WriteStr(#13#10);
  5372.   end;
  5373.  
  5374.   procedure ConvertBinary;
  5375.   const
  5376.     BytesPerLine = 32;
  5377.   var
  5378.     MultiLine: Boolean;
  5379.     I: Integer;
  5380.     Count: Longint;
  5381.     Buffer: array[0..BytesPerLine - 1] of Char;
  5382.     Text: array[0..BytesPerLine * 2 - 1] of Char;
  5383.   begin
  5384.     Reader.ReadValue;
  5385.     WriteStr('{');
  5386.     Inc(NestingLevel);
  5387.     Reader.Read(Count, SizeOf(Count));
  5388.     MultiLine := Count >= BytesPerLine;
  5389.     while Count > 0 do
  5390.     begin
  5391.       if MultiLine then NewLine;
  5392.       if Count >= 32 then I := 32 else I := Count;
  5393.       Reader.Read(Buffer, I);
  5394.       BinToHex(Buffer, Text, I);
  5395.       Writer.Write(Text, I * 2);
  5396.       Dec(Count, I);
  5397.     end;
  5398.     Dec(NestingLevel);
  5399.     WriteStr('}');
  5400.   end;
  5401.  
  5402.   procedure ConvertProperty; forward;
  5403.  
  5404.   procedure ConvertValue;
  5405.   const
  5406.     LineLength = 64;
  5407.   var
  5408.     I, J, K, L: Integer;
  5409.     S: string;
  5410.     LineBreak: Boolean;
  5411.   begin
  5412.     case Reader.NextValue of
  5413.       vaList:
  5414.         begin
  5415.           Reader.ReadValue;
  5416.           WriteStr('(');
  5417.           Inc(NestingLevel);
  5418.           while not Reader.EndOfList do
  5419.           begin
  5420.             NewLine;
  5421.             ConvertValue;
  5422.           end;
  5423.           Reader.ReadListEnd;
  5424.           Dec(NestingLevel);
  5425.           WriteStr(')');
  5426.         end;
  5427.       vaInt8, vaInt16, vaInt32:
  5428.         WriteStr(IntToStr(Reader.ReadInteger));
  5429.       vaExtended:
  5430.         WriteStr(FloatToStr(Reader.ReadFloat));
  5431.       vaString, vaLString:
  5432.         begin
  5433.           S := Reader.ReadString;
  5434.           L := Length(S);
  5435.           if L = 0 then WriteStr('''''') else
  5436.           begin
  5437.             I := 1;
  5438.             Inc(NestingLevel);
  5439.             try
  5440.               if L > LineLength then NewLine;
  5441.               K := I;
  5442.               repeat
  5443.                 LineBreak := False;
  5444.                 if (S[I] >= ' ') and (S[I] <> '''') then
  5445.                 begin
  5446.                   J := I;
  5447.                   repeat
  5448.                     Inc(I)
  5449.                   until (I > L) or (S[I] < ' ') or (S[I] = '''') or
  5450.                     ((I - K) >= LineLength);
  5451.                   if ((I - K) >= LineLength) then
  5452.                   begin
  5453.                     LIneBreak := True;
  5454.                     if ByteType(S, I) = mbTrailByte then Dec(I);
  5455.                   end;
  5456.                   WriteStr('''');
  5457.                   Writer.Write(S[J], I - J);
  5458.                   WriteStr('''');
  5459.                 end else
  5460.                 begin
  5461.                   WriteStr('#');
  5462.                   WriteStr(IntToStr(Ord(S[I])));
  5463.                   Inc(I);
  5464.                   if ((I - K) >= LineLength) then LineBreak := True;
  5465.                 end;
  5466.                 if LineBreak and (I <= L) then
  5467.                 begin
  5468.                   WriteStr(' +');
  5469.                   NewLine;
  5470.                   K := I;
  5471.                 end;
  5472.               until I > L;
  5473.             finally
  5474.               Dec(NestingLevel);
  5475.             end;
  5476.           end;
  5477.         end;
  5478.       vaIdent, vaFalse, vaTrue, vaNil:
  5479.         WriteStr(Reader.ReadIdent);
  5480.       vaBinary:
  5481.         ConvertBinary;
  5482.       vaSet:
  5483.         begin
  5484.           Reader.ReadValue;
  5485.           WriteStr('[');
  5486.           I := 0;
  5487.           while True do
  5488.           begin
  5489.             S := Reader.ReadStr;
  5490.             if S = '' then Break;
  5491.             if I > 0 then WriteStr(', ');
  5492.             WriteStr(S);
  5493.             Inc(I);
  5494.           end;
  5495.           WriteStr(']');
  5496.         end;
  5497.       vaCollection:
  5498.         begin
  5499.           Reader.ReadValue;
  5500.           WriteStr('<');
  5501.           Inc(NestingLevel);
  5502.           while not Reader.EndOfList do
  5503.           begin
  5504.             NewLine;
  5505.             WriteStr('item');
  5506.             if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
  5507.             begin
  5508.               WriteStr(' [');
  5509.               ConvertValue;
  5510.               WriteStr(']');
  5511.             end;
  5512.             WriteStr(#13#10);
  5513.             Reader.CheckValue(vaList);
  5514.             Inc(NestingLevel);
  5515.             while not Reader.EndOfList do ConvertProperty;
  5516.             Reader.ReadListEnd;
  5517.             Dec(NestingLevel);
  5518.             WriteIndent;
  5519.             WriteStr('end');
  5520.           end;
  5521.           Reader.ReadListEnd;
  5522.           Dec(NestingLevel);
  5523.           WriteStr('>');
  5524.         end;
  5525.     end;
  5526.   end;
  5527.  
  5528.   procedure ConvertProperty;
  5529.   begin
  5530.     WriteIndent;
  5531.     WriteStr(Reader.ReadStr);
  5532.     WriteStr(' = ');
  5533.     ConvertValue;
  5534.     WriteStr(#13#10);
  5535.   end;
  5536.  
  5537.   procedure ConvertObject;
  5538.   begin
  5539.     ConvertHeader;
  5540.     Inc(NestingLevel);
  5541.     while not Reader.EndOfList do ConvertProperty;
  5542.     Reader.ReadListEnd;
  5543.     while not Reader.EndOfList do ConvertObject;
  5544.     Reader.ReadListEnd;
  5545.     Dec(NestingLevel);
  5546.     WriteIndent;
  5547.     WriteStr('end'#13#10);
  5548.   end;
  5549.  
  5550. begin
  5551.   NestingLevel := 0;
  5552.   Reader := TReader.Create(Input, 4096);
  5553.   SaveSeparator := DecimalSeparator;
  5554.   DecimalSeparator := '.';
  5555.   try
  5556.     Writer := TWriter.Create(Output, 4096);
  5557.     try
  5558.       Reader.ReadSignature;
  5559.       ConvertObject;
  5560.     finally
  5561.       Writer.Free;
  5562.     end;
  5563.   finally
  5564.     DecimalSeparator := SaveSeparator;
  5565.     Reader.Free;
  5566.   end;
  5567. end;
  5568.  
  5569.  
  5570. { Text to binary conversion }
  5571.  
  5572. procedure ObjectTextToBinary(Input, Output: TStream);
  5573. var
  5574.   SaveSeparator: Char;
  5575.   Parser: TParser;
  5576.   Writer: TWriter;
  5577.  
  5578.   function ConvertOrderModifier: Integer;
  5579.   begin
  5580.     Result := -1;
  5581.     if Parser.Token = '[' then
  5582.     begin
  5583.       Parser.NextToken;
  5584.       Parser.CheckToken(toInteger);
  5585.       Result := Parser.TokenInt;
  5586.       Parser.NextToken;
  5587.       Parser.CheckToken(']');
  5588.       Parser.NextToken;
  5589.     end;
  5590.   end;
  5591.  
  5592.   procedure ConvertHeader(IsInherited: Boolean);
  5593.   var
  5594.     ClassName, ObjectName: string;
  5595.     Flags: TFilerFlags;
  5596.     Position: Integer;
  5597.   begin
  5598.     Parser.CheckToken(toSymbol);
  5599.     ClassName := Parser.TokenString;
  5600.     ObjectName := '';
  5601.     if Parser.NextToken = ':' then
  5602.     begin
  5603.       Parser.NextToken;
  5604.       Parser.CheckToken(toSymbol);
  5605.       ObjectName := ClassName;
  5606.       ClassName := Parser.TokenString;
  5607.       Parser.NextToken;
  5608.     end;
  5609.     Flags := [];
  5610.     Position := ConvertOrderModifier;
  5611.     if IsInherited then
  5612.       Include(Flags, ffInherited);
  5613.     if Position > 0 then
  5614.       Include(Flags, ffChildPos);
  5615.     Writer.WritePrefix(Flags, Position);
  5616.     Writer.WriteStr(ClassName);
  5617.     Writer.WriteStr(ObjectName);
  5618.   end;
  5619.  
  5620.   procedure ConvertProperty; forward;
  5621.  
  5622.   procedure ConvertValue;
  5623.   var
  5624.     Order: Integer;
  5625.  
  5626.     function CombineString: string;
  5627.     begin
  5628.       Result := Parser.TokenString;
  5629.       while Parser.NextToken = '+' do
  5630.       begin
  5631.         Parser.NextToken;
  5632.         Parser.CheckToken(toString);
  5633.         Result := Result + Parser.TokenString;
  5634.       end;
  5635.     end;
  5636.  
  5637.   begin
  5638.     if Parser.Token = toString then
  5639.       Writer.WriteString(CombineString)
  5640.     else
  5641.     begin
  5642.       case Parser.Token of
  5643.         toSymbol:
  5644.           Writer.WriteIdent(Parser.TokenComponentIdent);
  5645.         toInteger:
  5646.           Writer.WriteInteger(Parser.TokenInt);
  5647.         toFloat:
  5648.           Writer.WriteFloat(Parser.TokenFloat);
  5649.         '[':
  5650.           begin
  5651.             Parser.NextToken;
  5652.             Writer.WriteValue(vaSet);
  5653.             if Parser.Token <> ']' then
  5654.               while True do
  5655.               begin
  5656.                 Parser.CheckToken(toSymbol);
  5657.                 Writer.WriteStr(Parser.TokenString);
  5658.                 if Parser.NextToken = ']' then Break;
  5659.                 Parser.CheckToken(',');
  5660.                 Parser.NextToken;
  5661.               end;
  5662.             Writer.WriteStr('');
  5663.           end;
  5664.         '(':
  5665.           begin
  5666.             Parser.NextToken;
  5667.             Writer.WriteListBegin;
  5668.             while Parser.Token <> ')' do ConvertValue;
  5669.             Writer.WriteListEnd;
  5670.           end;
  5671.         '{':
  5672.           Writer.WriteBinary(Parser.HexToBinary);
  5673.         '<':
  5674.           begin
  5675.             Parser.NextToken;
  5676.             Writer.WriteValue(vaCollection);
  5677.             while Parser.Token <> '>' do
  5678.             begin
  5679.               Parser.CheckTokenSymbol('item');
  5680.               Parser.NextToken;
  5681.               Order := ConvertOrderModifier;
  5682.               if Order <> -1 then Writer.WriteInteger(Order);
  5683.               Writer.WriteListBegin;
  5684.               while not Parser.TokenSymbolIs('end') do ConvertProperty;
  5685.               Writer.WriteListEnd;
  5686.               Parser.NextToken;
  5687.             end;
  5688.             Writer.WriteListEnd;
  5689.           end;
  5690.       else
  5691.         Parser.Error(SInvalidProperty);
  5692.       end;
  5693.       Parser.NextToken;
  5694.     end;
  5695.   end;
  5696.  
  5697.   procedure ConvertProperty;
  5698.   var
  5699.     PropName: string;
  5700.   begin
  5701.     Parser.CheckToken(toSymbol);
  5702.     PropName := Parser.TokenString;
  5703.     Parser.NextToken;
  5704.     while Parser.Token = '.' do
  5705.     begin
  5706.       Parser.NextToken;
  5707.       Parser.CheckToken(toSymbol);
  5708.       PropName := PropName + '.' + Parser.TokenString;
  5709.       Parser.NextToken;
  5710.     end;
  5711.     Writer.WriteStr(PropName);
  5712.     Parser.CheckToken('=');
  5713.     Parser.NextToken;
  5714.     ConvertValue;
  5715.   end;
  5716.  
  5717.   procedure ConvertObject;
  5718.   var
  5719.     InheritedObject: Boolean;
  5720.   begin
  5721.     InheritedObject := False;
  5722.     if Parser.TokenSymbolIs('INHERITED') then
  5723.       InheritedObject := True else
  5724.       Parser.CheckTokenSymbol('OBJECT');
  5725.     Parser.NextToken;
  5726.     ConvertHeader(InheritedObject);
  5727.     while not Parser.TokenSymbolIs('END') and
  5728.       not Parser.TokenSymbolIs('OBJECT') and
  5729.       not Parser.TokenSymbolIs('INHERITED') do ConvertProperty;
  5730.     Writer.WriteListEnd;
  5731.     while not Parser.TokenSymbolIs('END') do ConvertObject;
  5732.     Writer.WriteListEnd;
  5733.     Parser.NextToken;
  5734.   end;
  5735.  
  5736. begin
  5737.   Parser := TParser.Create(Input);
  5738.   SaveSeparator := DecimalSeparator;
  5739.   DecimalSeparator := '.';
  5740.   try
  5741.     Writer := TWriter.Create(Output, 4096);
  5742.     try
  5743.       Writer.WriteSignature;
  5744.       ConvertObject;
  5745.     finally
  5746.       Writer.Free;
  5747.     end;
  5748.   finally
  5749.     DecimalSeparator := SaveSeparator;
  5750.     Parser.Free;
  5751.   end;
  5752. end;
  5753.  
  5754. { Resource to text conversion }
  5755.  
  5756. procedure ObjectResourceToText(Input, Output: TStream);
  5757. begin
  5758.   Input.ReadResHeader;
  5759.   ObjectBinaryToText(Input, Output);
  5760. end;
  5761.  
  5762. { Text to resource conversion }
  5763.  
  5764. procedure ObjectTextToResource(Input, Output: TStream);
  5765. var
  5766.   Len: Byte;
  5767.   Tmp: Longint;
  5768.   MemoryStream: TMemoryStream;
  5769.   MemorySize: Longint;
  5770.   Header: array[0..79] of Char;
  5771. begin
  5772.   MemoryStream := TMemoryStream.Create;
  5773.   try
  5774.     ObjectTextToBinary(Input, MemoryStream);
  5775.     MemorySize := MemoryStream.Size;
  5776.     FillChar(Header, SizeOf(Header), 0);
  5777.     MemoryStream.Position := SizeOf(Longint); { Skip header }
  5778.     MemoryStream.Read(Len, 1);
  5779.  
  5780.     { Skip over object prefix if it is present }
  5781.     if Len and $F0 = $F0 then
  5782.     begin
  5783.       if ffChildPos in TFilerFlags((Len and $F0)) then
  5784.       begin
  5785.         MemoryStream.Read(Len, 1);
  5786.         case TValueType(Len) of
  5787.           vaInt8: Len := 1;
  5788.           vaInt16: Len := 2;
  5789.           vaInt32: Len := 4;
  5790.         end;
  5791.         MemoryStream.Read(Tmp, Len);
  5792.       end;
  5793.       MemoryStream.Read(Len, 1);
  5794.     end;
  5795.  
  5796.     MemoryStream.Read(Header[3], Len);
  5797.     StrUpper(@Header[3]);
  5798.     Byte((@Header[0])^) := $FF;
  5799.     Word((@Header[1])^) := 10;
  5800.     Word((@Header[Len + 4])^) := $1030;
  5801.     Longint((@Header[Len + 6])^) := MemorySize;
  5802.     Output.Write(Header, Len + 10);
  5803.     Output.Write(MemoryStream.Memory^, MemorySize);
  5804.   finally
  5805.     MemoryStream.Free;
  5806.   end;
  5807. end;
  5808.  
  5809. { Thread management routines }
  5810.  
  5811. const
  5812.   CM_EXECPROC = $8FFF;
  5813.   CM_DESTROYWINDOW = $8FFE;
  5814.  
  5815. type
  5816.   PRaiseFrame = ^TRaiseFrame;
  5817.   TRaiseFrame = record
  5818.     NextRaise: PRaiseFrame;
  5819.     ExceptAddr: Pointer;
  5820.     ExceptObject: TObject;
  5821.     ExceptionRecord: PExceptionRecord;
  5822.   end;
  5823.  
  5824. var
  5825.   ThreadWindow: HWND;
  5826.   ThreadCount: Integer;
  5827.  
  5828. function ThreadWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall;
  5829. begin
  5830.   case Message of
  5831.     CM_EXECPROC:
  5832.       with TThread(lParam) do
  5833.       begin
  5834.         Result := 0;
  5835.         try
  5836.           FSynchronizeException := nil;
  5837.           FMethod;
  5838.         except
  5839.           if RaiseList <> nil then
  5840.           begin
  5841.             FSynchronizeException := PRaiseFrame(RaiseList)^.ExceptObject;
  5842.             PRaiseFrame(RaiseList)^.ExceptObject := nil;
  5843.           end;
  5844.         end;
  5845.       end;
  5846.     CM_DESTROYWINDOW:
  5847.       begin
  5848.         DestroyWindow(Window);
  5849.         Result := 0;
  5850.       end;
  5851.   else
  5852.     Result := DefWindowProc(Window, Message, wParam, lParam);
  5853.   end;
  5854. end;
  5855.  
  5856. var
  5857.   ThreadWindowClass: TWndClass = (
  5858.     style: 0;
  5859.     lpfnWndProc: @ThreadWndProc;
  5860.     cbClsExtra: 0;
  5861.     cbWndExtra: 0;
  5862.     hInstance: 0;
  5863.     hIcon: 0;
  5864.     hCursor: 0;
  5865.     hbrBackground: 0;
  5866.     lpszMenuName: nil;
  5867.     lpszClassName: 'TThreadWindow');
  5868.  
  5869. procedure AddThread;
  5870.  
  5871.   function AllocateWindow: HWND;
  5872.   var
  5873.     TempClass: TWndClass;
  5874.     ClassRegistered: Boolean;
  5875.   begin
  5876.     ThreadWindowClass.hInstance := HInstance;
  5877.     ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName,
  5878.       TempClass);
  5879.     if not ClassRegistered or (TempClass.lpfnWndProc <> @ThreadWndProc) then
  5880.     begin
  5881.       if ClassRegistered then
  5882.         Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance);
  5883.       Windows.RegisterClass(ThreadWindowClass);
  5884.     end;
  5885.     Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0,
  5886.       0, 0, 0, 0, 0, 0, HInstance, nil);
  5887.   end;
  5888.  
  5889. begin
  5890.   if ThreadCount = 0 then
  5891.     ThreadWindow := AllocateWindow;
  5892.   Inc(ThreadCount);
  5893. end;
  5894.  
  5895. procedure RemoveThread;
  5896. begin
  5897.   Dec(ThreadCount);
  5898.   if ThreadCount = 0 then
  5899.     PostMessage(ThreadWindow, CM_DESTROYWINDOW, 0, 0);
  5900. end;
  5901.  
  5902. { TThread }
  5903.  
  5904. function ThreadProc(Thread: TThread): Integer;
  5905. var
  5906.   FreeThread: Boolean;
  5907. begin
  5908.   Thread.Execute;
  5909.   FreeThread := Thread.FFreeOnTerminate;
  5910.   Result := Thread.FReturnValue;
  5911.   Thread.FFinished := True;
  5912.   Thread.DoTerminate;
  5913.   if FreeThread then Thread.Free;
  5914.   EndThread(Result);
  5915. end;
  5916.  
  5917. constructor TThread.Create(CreateSuspended: Boolean);
  5918. var
  5919.   Flags: Integer;
  5920. begin
  5921.   inherited Create;
  5922.   AddThread;
  5923.   FSuspended := CreateSuspended;
  5924.   Flags := 0;
  5925.   if CreateSuspended then Flags := CREATE_SUSPENDED;
  5926.   FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
  5927. end;
  5928.  
  5929. destructor TThread.Destroy;
  5930. begin
  5931.   if not FFinished and not Suspended then
  5932.   begin
  5933.     Terminate;
  5934.     WaitFor;
  5935.   end;
  5936.   if FHandle <> 0 then CloseHandle(FHandle);
  5937.   inherited Destroy;
  5938.   RemoveThread;
  5939. end;
  5940.  
  5941. procedure TThread.CallOnTerminate;
  5942. begin
  5943.   FOnTerminate(Self);
  5944. end;
  5945.  
  5946. procedure TThread.DoTerminate;
  5947. begin
  5948.   if Assigned(FOnTerminate) then Synchronize(CallOnTerminate);
  5949. end;
  5950.  
  5951. const
  5952.   Priorities: array [TThreadPriority] of Integer =
  5953.    (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
  5954.     THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
  5955.     THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
  5956.  
  5957. function TThread.GetPriority: TThreadPriority;
  5958. var
  5959.   P: Integer;
  5960.   I: TThreadPriority;
  5961. begin
  5962.   P := GetThreadPriority(FHandle);
  5963.   Result := tpNormal;
  5964.   for I := Low(TThreadPriority) to High(TThreadPriority) do
  5965.     if Priorities[I] = P then Result := I;
  5966. end;
  5967.  
  5968. procedure TThread.SetPriority(Value: TThreadPriority);
  5969. begin
  5970.   SetThreadPriority(FHandle, Priorities[Value]);
  5971. end;
  5972.  
  5973. procedure TThread.Synchronize(Method: TThreadMethod);
  5974. begin
  5975.   FSynchronizeException := nil;
  5976.   FMethod := Method;
  5977.   SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
  5978.   if Assigned(FSynchronizeException) then raise FSynchronizeException;
  5979. end;
  5980.  
  5981. procedure TThread.SetSuspended(Value: Boolean);
  5982. begin
  5983.   if Value <> FSuspended then
  5984.     if Value then
  5985.       Suspend else
  5986.       Resume;
  5987. end;
  5988.  
  5989. procedure TThread.Suspend;
  5990. begin
  5991.   FSuspended := True;
  5992.   SuspendThread(FHandle);
  5993. end;
  5994.  
  5995. procedure TThread.Resume;
  5996. begin
  5997.   if ResumeThread(FHandle) = 1 then FSuspended := False;
  5998. end;
  5999.  
  6000. procedure TThread.Terminate;
  6001. begin
  6002.   FTerminated := True;
  6003. end;
  6004.  
  6005. function TThread.WaitFor: Integer;
  6006. var
  6007.   Msg: TMsg;
  6008. begin
  6009.   if GetCurrentThreadID = MainThreadID then
  6010.     while MsgWaitForMultipleObjects(1, FHandle, False, INFINITE,
  6011.       QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
  6012.   else WaitForSingleObject(FHandle, INFINITE);
  6013.   GetExitCodeThread(FHandle, Result);
  6014. end;
  6015.  
  6016. { TComponent }
  6017.  
  6018. constructor TComponent.Create(AOwner: TComponent);
  6019. begin
  6020.   FComponentStyle := [csInheritable];
  6021.   if AOwner <> nil then AOwner.InsertComponent(Self);
  6022. end;
  6023.  
  6024. destructor TComponent.Destroy;
  6025. var
  6026.   I: Integer;
  6027. begin
  6028.   if FFreeNotifies <> nil then
  6029.   begin
  6030.     for I := 0 to FFreeNotifies.Count - 1 do
  6031.       TComponent(FFreeNotifies[I]).Notification(Self, opRemove);
  6032.     FFreeNotifies.Free;
  6033.     FFreeNotifies := nil;
  6034.   end;
  6035.   Destroying;
  6036.   DestroyComponents;
  6037.   if FOwner <> nil then FOwner.RemoveComponent(Self);
  6038.   inherited Destroy;
  6039. end;
  6040.  
  6041. procedure TComponent.FreeNotification(AComponent: TComponent);
  6042. begin
  6043.   if (Owner = nil) or (AComponent.Owner <> Owner) then
  6044.   begin
  6045.     if not Assigned(FFreeNotifies) then FFreeNotifies := TList.Create;
  6046.     if FFreeNotifies.IndexOf(AComponent) < 0 then
  6047.     begin
  6048.       FFreeNotifies.Add(AComponent);
  6049.       AComponent.FreeNotification(Self);
  6050.     end;
  6051.   end;
  6052. end;
  6053.  
  6054. procedure TComponent.ReadLeft(Reader: TReader);
  6055. begin
  6056.   LongRec(FDesignInfo).Lo := Reader.ReadInteger;
  6057. end;
  6058.  
  6059. procedure TComponent.ReadTop(Reader: TReader);
  6060. begin
  6061.   LongRec(FDesignInfo).Hi := Reader.ReadInteger;
  6062. end;
  6063.  
  6064. procedure TComponent.WriteLeft(Writer: TWriter);
  6065. begin
  6066.   Writer.WriteInteger(LongRec(FDesignInfo).Lo);
  6067. end;
  6068.  
  6069. procedure TComponent.WriteTop(Writer: TWriter);
  6070. begin
  6071.   Writer.WriteInteger(LongRec(FDesignInfo).Hi);
  6072. end;
  6073.  
  6074. procedure TComponent.Insert(AComponent: TComponent);
  6075. begin
  6076.   if FComponents = nil then FComponents := TList.Create;
  6077.   FComponents.Add(AComponent);
  6078.   AComponent.FOwner := Self;
  6079. end;
  6080.  
  6081. procedure TComponent.Remove(AComponent: TComponent);
  6082. begin
  6083.   AComponent.FOwner := nil;
  6084.   FComponents.Remove(AComponent);
  6085.   if FComponents.Count = 0 then
  6086.   begin
  6087.     FComponents.Free;
  6088.     FComponents := nil;
  6089.   end;
  6090. end;
  6091.  
  6092. procedure TComponent.InsertComponent(AComponent: TComponent);
  6093. begin
  6094.   AComponent.ValidateContainer(Self);
  6095.   ValidateRename(AComponent, '', AComponent.FName);
  6096.   Insert(AComponent);
  6097.   AComponent.SetReference(True);
  6098.   if csDesigning in ComponentState then
  6099.     AComponent.SetDesigning(True);
  6100.   Notification(AComponent, opInsert);
  6101. end;
  6102.  
  6103. procedure TComponent.RemoveComponent(AComponent: TComponent);
  6104. begin
  6105.   Notification(AComponent, opRemove);
  6106.   AComponent.SetReference(False);
  6107.   Remove(AComponent);
  6108.   AComponent.SetDesigning(False);
  6109.   ValidateRename(AComponent, AComponent.FName, '');
  6110. end;
  6111.  
  6112. procedure TComponent.DestroyComponents;
  6113. var
  6114.   Instance: TComponent;
  6115. begin
  6116.   while FComponents <> nil do
  6117.   begin
  6118.     Instance := FComponents.Last;
  6119.     Remove(Instance);
  6120.     Instance.Destroy;
  6121.   end;
  6122. end;
  6123.  
  6124. procedure TComponent.Destroying;
  6125. var
  6126.   I: Integer;
  6127. begin
  6128.   if not (csDestroying in FComponentState) then
  6129.   begin
  6130.     Include(FComponentState, csDestroying);
  6131.     if FComponents <> nil then
  6132.       for I := 0 to FComponents.Count - 1 do
  6133.         TComponent(FComponents[I]).Destroying;
  6134.   end;
  6135. end;
  6136.  
  6137. procedure TComponent.Notification(AComponent: TComponent;
  6138.   Operation: TOperation);
  6139. var
  6140.   I: Integer;
  6141. begin
  6142.   if (FFreeNotifies <> nil) and (Operation = opRemove) then
  6143.   begin
  6144.     FFreeNotifies.Remove(AComponent);
  6145.     if FFreeNotifies.Count = 0 then
  6146.     begin
  6147.       FFreeNotifies.Free;
  6148.       FFreeNotifies := nil;
  6149.     end;
  6150.   end;
  6151.   if FComponents <> nil then
  6152.     for I := 0 to FComponents.Count - 1 do
  6153.       TComponent(FComponents[I]).Notification(AComponent, Operation);
  6154. end;
  6155.  
  6156. procedure TComponent.DefineProperties(Filer: TFiler);
  6157. var
  6158.   Ancestor: TComponent;
  6159.   Info: Longint;
  6160. begin
  6161.   Info := 0;
  6162.   Ancestor := TComponent(Filer.Ancestor);
  6163.   if Ancestor <> nil then Info := Ancestor.FDesignInfo;
  6164.   Filer.DefineProperty('Left', ReadLeft, WriteLeft,
  6165.     LongRec(FDesignInfo).Lo <> LongRec(Info).Lo);
  6166.   Filer.DefineProperty('Top', ReadTop, WriteTop,
  6167.     LongRec(FDesignInfo).Hi <> LongRec(Info).Hi);
  6168. end;
  6169.  
  6170. function TComponent.HasParent: Boolean;
  6171. begin
  6172.   Result := False;
  6173. end;
  6174.  
  6175. procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent);
  6176. begin
  6177. end;
  6178.  
  6179. function TComponent.GetChildOwner: TComponent;
  6180. begin
  6181.   Result := nil;
  6182. end;
  6183.  
  6184. function TComponent.GetChildParent: TComponent;
  6185. begin
  6186.   Result := Self;
  6187. end;
  6188.  
  6189. function TComponent.GetNamePath: string;
  6190. begin
  6191.   Result := FName;
  6192. end;
  6193.  
  6194. function TComponent.GetOwner: TPersistent;
  6195. begin
  6196.   Result := FOwner;
  6197. end;
  6198.  
  6199. procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer);
  6200. begin
  6201. end;
  6202.  
  6203. function TComponent.GetParentComponent: TComponent;
  6204. begin
  6205.   Result := nil;
  6206. end;
  6207.  
  6208. procedure TComponent.SetParentComponent(Value: TComponent);
  6209. begin
  6210. end;
  6211.  
  6212. procedure TComponent.Updating;
  6213. begin
  6214.   Include(FComponentState, csUpdating);
  6215. end;
  6216.  
  6217. procedure TComponent.Updated;
  6218. begin
  6219.   Exclude(FComponentState, csUpdating);
  6220. end;
  6221.  
  6222. procedure TComponent.Loaded;
  6223. begin
  6224.   Exclude(FComponentState, csLoading);
  6225. end;
  6226.  
  6227. procedure TComponent.ReadState(Reader: TReader);
  6228. begin
  6229.   Reader.ReadData(Self);
  6230. end;
  6231.  
  6232. procedure TComponent.WriteState(Writer: TWriter);
  6233. begin
  6234.   Writer.WriteData(Self);
  6235. end;
  6236.  
  6237. procedure TComponent.ValidateRename(AComponent: TComponent;
  6238.   const CurName, NewName: string);
  6239. begin
  6240.   if (AComponent <> nil) and (CompareText(CurName, NewName) <> 0) and
  6241.     (FindComponent(NewName) <> nil) then
  6242.     raise EComponentError.CreateFmt(SDuplicateName, [NewName]);
  6243.   if (csDesigning in ComponentState) and (Owner <> nil) then
  6244.     Owner.ValidateRename(AComponent, CurName, NewName);
  6245. end;
  6246.  
  6247. procedure TComponent.ValidateContainer(AComponent: TComponent);
  6248. begin
  6249.   AComponent.ValidateInsert(Self);
  6250. end;
  6251.  
  6252. procedure TComponent.ValidateInsert(AComponent: TComponent);
  6253. begin
  6254. end;
  6255.  
  6256. function TComponent.FindComponent(const AName: string): TComponent;
  6257. var
  6258.   I: Integer;
  6259. begin
  6260.   if (AName <> '') and (FComponents <> nil) then
  6261.     for I := 0 to FComponents.Count - 1 do
  6262.     begin
  6263.       Result := FComponents[I];
  6264.       if CompareText(Result.FName, AName) = 0 then Exit;
  6265.     end;
  6266.   Result := nil;
  6267. end;
  6268.  
  6269. procedure TComponent.SetName(const NewName: TComponentName);
  6270. begin
  6271.   if FName <> NewName then
  6272.   begin
  6273.     if (NewName <> '') and not IsValidIdent(NewName) then
  6274.       raise EComponentError.CreateFmt(SInvalidName, [NewName]);
  6275.     if FOwner <> nil then
  6276.       FOwner.ValidateRename(Self, FName, NewName) else
  6277.       ValidateRename(nil, FName, NewName);
  6278.     SetReference(False);
  6279.     ChangeName(NewName);
  6280.     SetReference(True);
  6281.   end;
  6282. end;
  6283.  
  6284. procedure TComponent.ChangeName(const NewName: TComponentName);
  6285. begin
  6286.   FName := NewName;
  6287. end;
  6288.  
  6289. function TComponent.GetComponentIndex: Integer;
  6290. begin
  6291.   if (FOwner <> nil) and (FOwner.FComponents <> nil) then
  6292.     Result := FOwner.FComponents.IndexOf(Self) else
  6293.     Result := -1;
  6294. end;
  6295.  
  6296. function TComponent.GetComponent(AIndex: Integer): TComponent;
  6297. begin
  6298.   if FComponents = nil then TList.Error(SListIndexError, AIndex);
  6299.   Result := FComponents[AIndex];
  6300. end;
  6301.  
  6302. function TComponent.GetComponentCount: Integer;
  6303. begin
  6304.   if FComponents <> nil then
  6305.     Result := FComponents.Count else
  6306.     Result := 0;
  6307. end;
  6308.  
  6309. procedure TComponent.SetComponentIndex(Value: Integer);
  6310. var
  6311.   I, Count: Integer;
  6312. begin
  6313.   if FOwner <> nil then
  6314.   begin
  6315.     I := FOwner.FComponents.IndexOf(Self);
  6316.     if I >= 0 then
  6317.     begin
  6318.       Count := FOwner.FComponents.Count;
  6319.       if Value < 0 then Value := 0;
  6320.       if Value >= Count then Value := Count - 1;
  6321.       if Value <> I then
  6322.       begin
  6323.         FOwner.FComponents.Delete(I);
  6324.         FOwner.FComponents.Insert(Value, Self);
  6325.       end;
  6326.     end;
  6327.   end;
  6328. end;
  6329.  
  6330. procedure TComponent.SetAncestor(Value: Boolean);
  6331. var
  6332.   I: Integer;
  6333. begin
  6334.   if Value then
  6335.     Include(FComponentState, csAncestor) else
  6336.     Exclude(FComponentState, csAncestor);
  6337.   for I := 0 to ComponentCount - 1 do
  6338.     Components[I].SetAncestor(Value);
  6339. end;
  6340.  
  6341. procedure TComponent.SetDesigning(Value: Boolean);
  6342. var
  6343.   I: Integer;
  6344. begin
  6345.   if Value then
  6346.     Include(FComponentState, csDesigning) else
  6347.     Exclude(FComponentState, csDesigning);
  6348.   for I := 0 to ComponentCount - 1 do Components[I].SetDesigning(Value);
  6349. end;
  6350.  
  6351. procedure TComponent.SetReference(Enable: Boolean);
  6352. var
  6353.   Field: ^TComponent;
  6354. begin
  6355.   if FOwner <> nil then
  6356.   begin
  6357.     Field := FOwner.FieldAddress(FName);
  6358.     if Field <> nil then
  6359.       if Enable then Field^ := Self else Field^ := nil;
  6360.   end;
  6361. end;
  6362.  
  6363. function TComponent.GetComObject: IUnknown;
  6364. begin
  6365.   if FVCLComObject = nil then
  6366.   begin
  6367.     if Assigned(CreateVCLComObjectProc) then CreateVCLComObjectProc(Self);
  6368.     if FVCLComObject = nil then
  6369.       raise EComponentError.CreateFmt(SNoComSupport, [ClassName]);
  6370.   end;
  6371.   IVCLComObject(FVCLComObject).QueryInterface(IUnknown, Result);
  6372. end;
  6373.  
  6374. function TComponent.SafeCallException(ExceptObject: TObject;
  6375.   ExceptAddr: Pointer): Integer;
  6376. begin
  6377.   if FVCLComObject <> nil then
  6378.     Result := IVCLComObject(FVCLComObject).SafeCallException(
  6379.       ExceptObject, ExceptAddr)
  6380.   else
  6381.     Result := inherited SafeCallException(ExceptObject, ExceptAddr);
  6382. end;
  6383.  
  6384. procedure TComponent.FreeOnRelease;
  6385. begin
  6386.   if FVCLComObject <> nil then IVCLComObject(FVCLComObject).FreeOnRelease;
  6387. end;
  6388.  
  6389. class procedure TComponent.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
  6390. begin
  6391. end;
  6392.  
  6393. { TComponent.IUnknown }
  6394.  
  6395. function TComponent.QueryInterface(const IID: TGUID; out Obj): Integer;
  6396. begin
  6397.   Result := IVCLComObject(FVCLComObject).QueryInterface(IID, Obj);
  6398. end;
  6399.  
  6400. function TComponent._AddRef: Integer;
  6401. begin
  6402.   Result := IVCLComObject(FVCLComObject)._AddRef;
  6403. end;
  6404.  
  6405. function TComponent._Release: Integer;
  6406. begin
  6407.   Result := IVCLComObject(FVCLComObject)._Release;
  6408. end;
  6409.  
  6410. { TComponent.IDispatch }
  6411.  
  6412. function TComponent.GetTypeInfoCount(out Count: Integer): Integer;
  6413. begin
  6414.   Result := IVCLComObject(FVCLComObject).GetTypeInfoCount(Count);
  6415. end;
  6416.  
  6417. function TComponent.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): Integer;
  6418. begin
  6419.   Result := IVCLComObject(FVCLComObject).GetTypeInfo(
  6420.     Index, LocaleID, TypeInfo);
  6421. end;
  6422.  
  6423. function TComponent.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  6424.   NameCount, LocaleID: Integer; DispIDs: Pointer): Integer;
  6425. begin
  6426.   Result := IVCLComObject(FVCLComObject).GetIDsOfNames(IID, Names,
  6427.     NameCount, LocaleID, DispIDs);
  6428. end;
  6429.  
  6430. function TComponent.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  6431.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): Integer;
  6432. begin
  6433.   Result := IVCLComObject(FVCLComObject).Invoke(DispID, IID, LocaleID,
  6434.     Flags, Params, VarResult, ExcepInfo, ArgErr);
  6435. end;
  6436.  
  6437.  
  6438. { TStreamAdapter }
  6439.  
  6440. constructor TStreamAdapter.Create(Stream: TStream);
  6441. begin
  6442.   inherited Create;
  6443.   FStream := Stream;
  6444. end;
  6445.  
  6446. function TStreamAdapter.Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult;
  6447. var
  6448.   NumRead: Longint;
  6449. begin
  6450.   try
  6451.     if pv = Nil then
  6452.     begin
  6453.       Result := STG_E_INVALIDPOINTER;
  6454.       Exit;
  6455.     end;
  6456.     NumRead := FStream.Read(pv^, cb);
  6457.     if pcbRead <> Nil then pcbRead^ := NumRead;
  6458.     Result := S_OK;
  6459.   except
  6460.     Result := S_FALSE;
  6461.   end;
  6462. end;
  6463.  
  6464. function TStreamAdapter.Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult;
  6465. var
  6466.   NumWritten: Longint;
  6467. begin
  6468.   try
  6469.     if pv = Nil then
  6470.     begin
  6471.       Result := STG_E_INVALIDPOINTER;
  6472.       Exit;
  6473.     end;
  6474.     NumWritten := FStream.Write(pv^, cb);
  6475.     if pcbWritten <> Nil then pcbWritten^ := NumWritten;
  6476.     Result := S_OK;
  6477.   except
  6478.     Result := STG_E_CANTSAVE;
  6479.   end;
  6480. end;
  6481.  
  6482. function TStreamAdapter.Seek(dlibMove: Largeint; dwOrigin: Longint;
  6483.   out libNewPosition: Largeint): HResult;
  6484. var
  6485.   NewPos: Integer;
  6486. begin
  6487.   try
  6488.     if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then
  6489.     begin
  6490.       Result := STG_E_INVALIDFUNCTION;
  6491.       Exit;
  6492.     end;
  6493.     NewPos := FStream.Seek(Trunc(dlibMove), dwOrigin);
  6494.     if @libNewPosition <> nil then libNewPosition := NewPos;
  6495.     Result := S_OK;
  6496.   except
  6497.     Result := STG_E_INVALIDPOINTER;
  6498.   end;
  6499. end;
  6500.  
  6501. function TStreamAdapter.SetSize(libNewSize: Largeint): HResult;
  6502. begin
  6503.   try
  6504.     FStream.Size := Trunc(libNewSize);
  6505.     if libNewSize <> FStream.Size then
  6506.       Result := E_FAIL
  6507.     else
  6508.       Result := S_OK;
  6509.   except
  6510.     Result := E_UNEXPECTED;
  6511.   end;
  6512. end;
  6513.  
  6514. function TStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  6515.   out cbWritten: Largeint): HResult;
  6516. var
  6517.   Buffer: Pointer;
  6518.   Size, Read, Written: Longint;
  6519. begin
  6520.   try
  6521.     Size := Trunc(cb);
  6522.     GetMem(Buffer, Size);
  6523.     try
  6524.       Read := FStream.Read(Buffer^, Size);
  6525.       if @cbRead <> nil then cbRead := Read;
  6526.       Result := stm.Write(Buffer, Size, @Written);
  6527.     finally
  6528.       FreeMem(Buffer, Size);
  6529.     end;
  6530.     if (Result = S_OK) and (@cbWritten <> nil) then cbWritten := Written;
  6531.   except
  6532.     Result := E_UNEXPECTED;
  6533.   end;
  6534. end;
  6535.  
  6536. function TStreamAdapter.Commit(grfCommitFlags: Longint): HResult;
  6537. begin
  6538.   Result := S_OK;
  6539. end;
  6540.  
  6541. function TStreamAdapter.Revert: HResult;
  6542. begin
  6543.   Result := STG_E_REVERTED;
  6544. end;
  6545.  
  6546. function TStreamAdapter.LockRegion(libOffset: Largeint; cb: Largeint;
  6547.   dwLockType: Longint): HResult;
  6548. begin
  6549.   Result := STG_E_INVALIDFUNCTION;
  6550. end;
  6551.  
  6552. function TStreamAdapter.UnlockRegion(libOffset: Largeint; cb: Largeint;
  6553.   dwLockType: Longint): HResult;
  6554. begin
  6555.   Result := STG_E_INVALIDFUNCTION;
  6556. end;
  6557.  
  6558. function TStreamAdapter.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
  6559. begin
  6560.   Result := S_OK;
  6561.   try
  6562.     if (@statstg <> nil) then
  6563.       with statstg do
  6564.       begin
  6565.         dwType := STGTY_STREAM;
  6566.         cbSize := FStream.Size;
  6567.         mTime.dwLowDateTime := 0;
  6568.         mTime.dwHighDateTime := 0;
  6569.         cTime.dwLowDateTime := 0;
  6570.         cTime.dwHighDateTime := 0;
  6571.         aTime.dwLowDateTime := 0;
  6572.         aTime.dwHighDateTime := 0;
  6573.         grfLocksSupported := LOCK_WRITE;
  6574.       end;
  6575.   except
  6576.     Result := E_UNEXPECTED;
  6577.   end;
  6578. end;
  6579.  
  6580. function TStreamAdapter.Clone(out stm: IStream): HResult;
  6581. begin
  6582.   Result := E_NOTIMPL;
  6583. end;
  6584.  
  6585.  
  6586. procedure FreeIntConstList;
  6587. var
  6588.   I: Integer;
  6589. begin
  6590.   for I := 0 to IntConstList.Count - 1 do
  6591.     TIntConst(IntConstList[I]).Free;
  6592.   IntConstList.Free;
  6593. end;
  6594.  
  6595. procedure ModuleUnload(Instance: Longint);
  6596. begin
  6597.   UnregisterModuleClasses(HMODULE(Instance));
  6598. end;
  6599.  
  6600. initialization
  6601.   AddModuleUnloadProc(ModuleUnload);
  6602.   ClassList := TList.Create;
  6603.   ClassAliasList := TStringList.Create;
  6604.   IntConstList := TList.Create;
  6605.   GlobalFixupList := TList.Create;
  6606.   MainThreadID := GetCurrentThreadID;
  6607.   GlobalLists := TList.Create;
  6608.  
  6609. finalization
  6610.   UnRegisterModuleClasses(HInstance);
  6611.   ClassList.Free;
  6612.   ClassAliasList.Free;
  6613.   FreeIntConstList;
  6614.   RemoveFixupReferences(nil, '');
  6615.   GlobalFixupList.Free;
  6616.   GlobalLists.Free;
  6617.   RemoveModuleUnloadProc(ModuleUnload);
  6618.  
  6619. end.
  6620.