home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / CLASSES.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  213.7 KB  |  8,364 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,99 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Classes;
  11.  
  12. {$R-,T-,X+,H+}
  13.  
  14. { ACTIVEX.HPP is not required by CLASSES.HPP }
  15. (*$NOINCLUDE ActiveX*)
  16.  
  17.  
  18. interface
  19.  
  20. uses SysUtils, Windows, ActiveX;
  21.  
  22. const
  23.  
  24. { Maximum TList size }
  25.  
  26.   MaxListSize = Maxint div 16;
  27.  
  28. { TStream seek origins }
  29.  
  30.   soFromBeginning = 0;
  31.   soFromCurrent = 1;
  32.   soFromEnd = 2;
  33.  
  34. { TFileStream create mode }
  35.  
  36.   fmCreate = $FFFF;
  37.  
  38. { TParser special tokens }
  39.  
  40.   toEOF     = Char(0);
  41.   toSymbol  = Char(1);
  42.   toString  = Char(2);
  43.   toInteger = Char(3);
  44.   toFloat   = Char(4);
  45.   toWString = Char(5);
  46.  
  47.   {!! Moved here from menus.pas !!}
  48.   { TShortCut special values }
  49.  
  50.   scShift = $2000;
  51.   scCtrl = $4000;
  52.   scAlt = $8000;
  53.   scNone = 0;
  54.  
  55. type
  56.  
  57. { Text alignment types }
  58.  
  59.   TAlignment = (taLeftJustify, taRightJustify, taCenter);
  60.   TLeftRight = taLeftJustify..taRightJustify;
  61.   TBiDiMode = (bdLeftToRight, bdRightToLeft, bdRightToLeftNoAlign,
  62.     bdRightToLeftReadingOnly);
  63.  
  64. { Types used by standard events }
  65.  
  66.   TShiftState = set of (ssShift, ssAlt, ssCtrl,
  67.     ssLeft, ssRight, ssMiddle, ssDouble);
  68.  
  69.   THelpContext = -MaxLongint..MaxLongint;
  70.  
  71.   {!! Moved here from menus.pas !!}
  72.   TShortCut = Low(Word)..High(Word);
  73.  
  74. { Standard events }
  75.  
  76.   TNotifyEvent = procedure(Sender: TObject) of object;
  77.   THelpEvent = function (Command: Word; Data: Longint;
  78.     var CallHelp: Boolean): Boolean of object;
  79.   TGetStrProc = procedure(const S: string) of object;
  80.  
  81. { Exception classes }
  82.  
  83.   EStreamError = class(Exception);
  84.   EFCreateError = class(EStreamError);
  85.   EFOpenError = class(EStreamError);
  86.   EFilerError = class(EStreamError);
  87.   EReadError = class(EFilerError);
  88.   EWriteError = class(EFilerError);
  89.   EClassNotFound = class(EFilerError);
  90.   EMethodNotFound = class(EFilerError);
  91.   EInvalidImage = class(EFilerError);
  92.   EResNotFound = class(Exception);
  93.   EListError = class(Exception);
  94.   EBitsError = class(Exception);
  95.   EStringListError = class(Exception);
  96.   EComponentError = class(Exception);
  97.   EParserError = class(Exception);
  98.   EOutOfResources = class(EOutOfMemory);
  99.   EInvalidOperation = class(Exception);
  100.  
  101. { Duplicate management }
  102.  
  103.   TDuplicates = (dupIgnore, dupAccept, dupError);
  104.  
  105. { Forward class declarations }
  106.  
  107.   TStream = class;
  108.   TFiler = class;
  109.   TReader = class;
  110.   TWriter = class;
  111.   TComponent = class;
  112.  
  113. { TList class }
  114.  
  115.   PPointerList = ^TPointerList;
  116.   TPointerList = array[0..MaxListSize - 1] of Pointer;
  117.   TListSortCompare = function (Item1, Item2: Pointer): Integer;
  118.   TListNotification = (lnAdded, lnExtracted, lnDeleted);
  119.  
  120.   TList = class(TObject)
  121.   private
  122.     FList: PPointerList;
  123.     FCount: Integer;
  124.     FCapacity: Integer;
  125.   protected
  126.     function Get(Index: Integer): Pointer;
  127.     procedure Grow; virtual;
  128.     procedure Put(Index: Integer; Item: Pointer);
  129.     procedure Notify(Ptr: Pointer; Action: TListNotification); virtual;
  130.     procedure SetCapacity(NewCapacity: Integer);
  131.     procedure SetCount(NewCount: Integer);
  132.   public
  133.     destructor Destroy; override;
  134.     function Add(Item: Pointer): Integer;
  135.     procedure Clear; virtual;
  136.     procedure Delete(Index: Integer);
  137.     class procedure Error(const Msg: string; Data: Integer); overload; virtual;
  138.     class procedure Error(Msg: PResStringRec; Data: Integer); overload;
  139.     procedure Exchange(Index1, Index2: Integer);
  140.     function Expand: TList;
  141.     function Extract(Item: Pointer): Pointer;
  142.     function First: Pointer;
  143.     function IndexOf(Item: Pointer): Integer;
  144.     procedure Insert(Index: Integer; Item: Pointer);
  145.     function Last: Pointer;
  146.     procedure Move(CurIndex, NewIndex: Integer);
  147.     function Remove(Item: Pointer): Integer;
  148.     procedure Pack;
  149.     procedure Sort(Compare: TListSortCompare);
  150.     property Capacity: Integer read FCapacity write SetCapacity;
  151.     property Count: Integer read FCount write SetCount;
  152.     property Items[Index: Integer]: Pointer read Get write Put; default;
  153.     property List: PPointerList read FList;
  154.   end;
  155.  
  156. { TThreadList class }
  157.  
  158.   TThreadList = class
  159.   private
  160.     FList: TList;
  161.     FLock: TRTLCriticalSection;
  162.     FDuplicates: TDuplicates;
  163.   public
  164.     constructor Create;
  165.     destructor Destroy; override;
  166.     procedure Add(Item: Pointer);
  167.     procedure Clear;
  168.     function  LockList: TList;
  169.     procedure Remove(Item: Pointer);
  170.     procedure UnlockList;
  171.     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  172.   end;
  173.  
  174. { IInterfaceList interface }
  175.  
  176.   IInterfaceList = interface
  177.   ['{285DEA8A-B865-11D1-AAA7-00C04FB17A72}']
  178.     function Get(Index: Integer): IUnknown;
  179.     function GetCapacity: Integer;
  180.     function GetCount: Integer;
  181.     procedure Put(Index: Integer; Item: IUnknown);
  182.     procedure SetCapacity(NewCapacity: Integer);
  183.     procedure SetCount(NewCount: Integer);
  184.  
  185.     procedure Clear;
  186.     procedure Delete(Index: Integer);
  187.     procedure Exchange(Index1, Index2: Integer);
  188.     function First: IUnknown;
  189.     function IndexOf(Item: IUnknown): Integer;
  190.     function Add(Item: IUnknown): Integer;
  191.     procedure Insert(Index: Integer; Item: IUnknown);
  192.     function Last: IUnknown;
  193.     function Remove(Item: IUnknown): Integer;
  194.     procedure Lock;
  195.     procedure Unlock;
  196.     property Capacity: Integer read GetCapacity write SetCapacity;
  197.     property Count: Integer read GetCount write SetCount;
  198.     property Items[Index: Integer]: IUnknown read Get write Put; default;
  199.   end;
  200.  
  201. { EXTERNALSYM IInterfaceList}
  202.  
  203. { TInterfaceList class }
  204.  
  205.   TInterfaceList = class(TInterfacedObject, IInterfaceList)
  206.   private
  207.     FList: TThreadList;
  208.   protected
  209.     { IInterfaceList }
  210.     function Get(Index: Integer): IUnknown;
  211.     function GetCapacity: Integer;
  212.     function GetCount: Integer;
  213.     procedure Put(Index: Integer; Item: IUnknown);
  214.     procedure SetCapacity(NewCapacity: Integer);
  215.     procedure SetCount(NewCount: Integer);
  216.   public
  217.     constructor Create;
  218.     destructor Destroy; override;
  219.     procedure Clear;
  220.     procedure Delete(Index: Integer);
  221.     procedure Exchange(Index1, Index2: Integer);
  222.     function Expand: TInterfaceList;
  223.     function First: IUnknown;
  224.     function IndexOf(Item: IUnknown): Integer;
  225.     function Add(Item: IUnknown): Integer;
  226.     procedure Insert(Index: Integer; Item: IUnknown);
  227.     function Last: IUnknown;
  228.     function Remove(Item: IUnknown): Integer;
  229.     procedure Lock;
  230.     procedure Unlock;
  231.     property Capacity: Integer read GetCapacity write SetCapacity;
  232.     property Count: Integer read GetCount write SetCount;
  233.     property Items[Index: Integer]: IUnknown read Get write Put; default;
  234.   end;
  235.  
  236. { EXTERNALSYM TInterfaceList}
  237.  
  238. { TBits class }
  239.  
  240.   TBits = class
  241.   private
  242.     FSize: Integer;
  243.     FBits: Pointer;
  244.     procedure Error;
  245.     procedure SetSize(Value: Integer);
  246.     procedure SetBit(Index: Integer; Value: Boolean);
  247.     function GetBit(Index: Integer): Boolean;
  248.   public
  249.     destructor Destroy; override;
  250.     function OpenBit: Integer;
  251.     property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
  252.     property Size: Integer read FSize write SetSize;
  253.   end;
  254.  
  255. { TPersistent abstract class }
  256.  
  257. {$M+}
  258.  
  259.   TPersistent = class(TObject)
  260.   private
  261.     procedure AssignError(Source: TPersistent);
  262.   protected
  263.     procedure AssignTo(Dest: TPersistent); virtual;
  264.     procedure DefineProperties(Filer: TFiler); virtual;
  265.     function  GetOwner: TPersistent; dynamic;
  266.   public
  267.     destructor Destroy; override;
  268.     procedure Assign(Source: TPersistent); virtual;
  269.     function  GetNamePath: string; dynamic;
  270.   end;
  271.  
  272. {$M-}
  273.  
  274. { TPersistent class reference type }
  275.  
  276.   TPersistentClass = class of TPersistent;
  277.  
  278. { TCollection class }
  279.  
  280.   TCollection = class;
  281.  
  282.   TCollectionItem = class(TPersistent)
  283.   private
  284.     FCollection: TCollection;
  285.     FID: Integer;
  286.     function GetIndex: Integer;
  287.     procedure SetCollection(Value: TCollection);
  288.   protected
  289.     procedure Changed(AllItems: Boolean);
  290.     function GetOwner: TPersistent; override;
  291.     function GetDisplayName: string; virtual;
  292.     procedure SetIndex(Value: Integer); virtual;
  293.     procedure SetDisplayName(const Value: string); virtual;
  294.   public
  295.     constructor Create(Collection: TCollection); virtual;
  296.     destructor Destroy; override;
  297.     function GetNamePath: string; override;
  298.     property Collection: TCollection read FCollection write SetCollection;
  299.     property ID: Integer read FID;
  300.     property Index: Integer read GetIndex write SetIndex;
  301.     property DisplayName: string read GetDisplayName write SetDisplayName;
  302.   end;
  303.  
  304.   TCollectionItemClass = class of TCollectionItem;
  305.  
  306.   TCollection = class(TPersistent)
  307.   private
  308.     FItemClass: TCollectionItemClass;
  309.     FItems: TList;
  310.     FUpdateCount: Integer;
  311.     FNextID: Integer;
  312.     FPropName: string;
  313.     function GetCount: Integer;
  314.     function GetPropName: string;   
  315.     procedure InsertItem(Item: TCollectionItem);
  316.     procedure RemoveItem(Item: TCollectionItem);
  317.   protected
  318.     property NextID: Integer read FNextID;
  319.     { Design-time editor support }
  320.     function GetAttrCount: Integer; dynamic;
  321.     function GetAttr(Index: Integer): string; dynamic;
  322.     function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
  323.     procedure Changed;
  324.     function GetItem(Index: Integer): TCollectionItem;
  325.     procedure SetItem(Index: Integer; Value: TCollectionItem);
  326.     procedure SetItemName(Item: TCollectionItem); virtual;
  327.     procedure Update(Item: TCollectionItem); virtual;
  328.     property PropName: string read GetPropName write FPropName;
  329.     property UpdateCount: Integer read FUpdateCount;
  330.   public
  331.     constructor Create(ItemClass: TCollectionItemClass);
  332.     destructor Destroy; override;
  333.     function Add: TCollectionItem;
  334.     procedure Assign(Source: TPersistent); override;
  335.     procedure BeginUpdate; virtual;
  336.     procedure Clear;
  337.     procedure Delete(Index: Integer);
  338.     procedure EndUpdate; virtual;
  339.     function FindItemID(ID: Integer): TCollectionItem;
  340.     function GetNamePath: string; override;
  341.     function Insert(Index: Integer): TCollectionItem;
  342.     property Count: Integer read GetCount;
  343.     property ItemClass: TCollectionItemClass read FItemClass;
  344.     property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
  345.   end;
  346.  
  347. { Collection class that maintains an "Owner" in order to obtain property
  348.   path information at design-time }
  349.  
  350.   TOwnedCollection = class(TCollection)
  351.   private
  352.     FOwner: TPersistent;
  353.   protected
  354.     function GetOwner: TPersistent; override;
  355.   public
  356.     constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
  357.   end;
  358.  
  359.   TStrings = class;
  360.  
  361. { TGetModuleProc }
  362. { Used in the TFormDesigner class to allow component/property editors access
  363.   to project specific information }
  364.  
  365.   TGetModuleProc = procedure(const FileName, UnitName, FormName,
  366.     DesignClass: string; CoClasses: TStrings) of object;
  367.  
  368. { IStringsAdapter interface }
  369. { Maintains link between TStrings and IStrings implementations }
  370.  
  371.   IStringsAdapter = interface
  372.     ['{739C2F34-52EC-11D0-9EA6-0020AF3D82DA}']
  373.     procedure ReferenceStrings(S: TStrings);
  374.     procedure ReleaseStrings;
  375.   end;
  376.  
  377. { TStrings class }
  378.  
  379.   TStrings = class(TPersistent)
  380.   private
  381.     FUpdateCount: Integer;
  382.     FAdapter: IStringsAdapter;
  383.     function GetCommaText: string;
  384.     function GetName(Index: Integer): string;
  385.     function GetValue(const Name: string): string;
  386.     procedure ReadData(Reader: TReader);
  387.     procedure SetCommaText(const Value: string);
  388.     procedure SetStringsAdapter(const Value: IStringsAdapter);
  389.     procedure SetValue(const Name, Value: string);
  390.     procedure WriteData(Writer: TWriter);
  391.   protected
  392.     procedure DefineProperties(Filer: TFiler); override;
  393.     procedure Error(const Msg: string; Data: Integer); overload;
  394.     procedure Error(Msg: PResStringRec; Data: Integer); overload;
  395.     function Get(Index: Integer): string; virtual; abstract;
  396.     function GetCapacity: Integer; virtual;
  397.     function GetCount: Integer; virtual; abstract;
  398.     function GetObject(Index: Integer): TObject; virtual;
  399.     function GetTextStr: string; virtual;
  400.     procedure Put(Index: Integer; const S: string); virtual;
  401.     procedure PutObject(Index: Integer; AObject: TObject); virtual;
  402.     procedure SetCapacity(NewCapacity: Integer); virtual;
  403.     procedure SetTextStr(const Value: string); virtual;
  404.     procedure SetUpdateState(Updating: Boolean); virtual;
  405.   public
  406.     destructor Destroy; override;
  407.     function Add(const S: string): Integer; virtual;
  408.     function AddObject(const S: string; AObject: TObject): Integer; virtual;
  409.     procedure Append(const S: string);
  410.     procedure AddStrings(Strings: TStrings); virtual;
  411.     procedure Assign(Source: TPersistent); override;
  412.     procedure BeginUpdate;
  413.     procedure Clear; virtual; abstract;
  414.     procedure Delete(Index: Integer); virtual; abstract;
  415.     procedure EndUpdate;
  416.     function Equals(Strings: TStrings): Boolean;
  417.     procedure Exchange(Index1, Index2: Integer); virtual;
  418.     function GetText: PChar; virtual;
  419.     function IndexOf(const S: string): Integer; virtual;
  420.     function IndexOfName(const Name: string): Integer;
  421.     function IndexOfObject(AObject: TObject): Integer;
  422.     procedure Insert(Index: Integer; const S: string); virtual; abstract;
  423.     procedure InsertObject(Index: Integer; const S: string;
  424.       AObject: TObject);
  425.     procedure LoadFromFile(const FileName: string); virtual;
  426.     procedure LoadFromStream(Stream: TStream); virtual;
  427.     procedure Move(CurIndex, NewIndex: Integer); virtual;
  428.     procedure SaveToFile(const FileName: string); virtual;
  429.     procedure SaveToStream(Stream: TStream); virtual;
  430.     procedure SetText(Text: PChar); virtual;
  431.     property Capacity: Integer read GetCapacity write SetCapacity;
  432.     property CommaText: string read GetCommaText write SetCommaText;
  433.     property Count: Integer read GetCount;
  434.     property Names[Index: Integer]: string read GetName;
  435.     property Objects[Index: Integer]: TObject read GetObject write PutObject;
  436.     property Values[const Name: string]: string read GetValue write SetValue;
  437.     property Strings[Index: Integer]: string read Get write Put; default;
  438.     property Text: string read GetTextStr write SetTextStr;
  439.     property StringsAdapter: IStringsAdapter read FAdapter write SetStringsAdapter;
  440.   end;
  441.  
  442. { TStringList class }
  443.  
  444.   TStringList = class;
  445.  
  446.   PStringItem = ^TStringItem;
  447.   TStringItem = record
  448.     FString: string;
  449.     FObject: TObject;
  450.   end;
  451.  
  452.   PStringItemList = ^TStringItemList;
  453.   TStringItemList = array[0..MaxListSize] of TStringItem;
  454.   TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
  455.  
  456.   TStringList = class(TStrings)
  457.   private
  458.     FList: PStringItemList;
  459.     FCount: Integer;
  460.     FCapacity: Integer;
  461.     FSorted: Boolean;
  462.     FDuplicates: TDuplicates;
  463.     FOnChange: TNotifyEvent;
  464.     FOnChanging: TNotifyEvent;
  465.     procedure ExchangeItems(Index1, Index2: Integer);
  466.     procedure Grow;
  467.     procedure QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
  468.     procedure InsertItem(Index: Integer; const S: string);
  469.     procedure SetSorted(Value: Boolean);
  470.   protected
  471.     procedure Changed; virtual;
  472.     procedure Changing; virtual;
  473.     function Get(Index: Integer): string; override;
  474.     function GetCapacity: Integer; override;
  475.     function GetCount: Integer; override;
  476.     function GetObject(Index: Integer): TObject; override;
  477.     procedure Put(Index: Integer; const S: string); override;
  478.     procedure PutObject(Index: Integer; AObject: TObject); override;
  479.     procedure SetCapacity(NewCapacity: Integer); override;
  480.     procedure SetUpdateState(Updating: Boolean); override;
  481.   public
  482.     destructor Destroy; override;
  483.     function Add(const S: string): Integer; override;
  484.     procedure Clear; override;
  485.     procedure Delete(Index: Integer); override;
  486.     procedure Exchange(Index1, Index2: Integer); override;
  487.     function Find(const S: string; var Index: Integer): Boolean; virtual;
  488.     function IndexOf(const S: string): Integer; override;
  489.     procedure Insert(Index: Integer; const S: string); override;
  490.     procedure Sort; virtual;
  491.     procedure CustomSort(Compare: TStringListSortCompare); virtual;
  492.     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  493.     property Sorted: Boolean read FSorted write SetSorted;
  494.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  495.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  496.   end;
  497.  
  498. { TStream abstract class }
  499.  
  500.   TStream = class(TObject)
  501.   private
  502.     function GetPosition: Longint;
  503.     procedure SetPosition(Pos: Longint);
  504.     function GetSize: Longint;
  505.   protected
  506.     procedure SetSize(NewSize: Longint); virtual;
  507.   public
  508.     function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
  509.     function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
  510.     function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
  511.     procedure ReadBuffer(var Buffer; Count: Longint);
  512.     procedure WriteBuffer(const Buffer; Count: Longint);
  513.     function CopyFrom(Source: TStream; Count: Longint): Longint;
  514.     function ReadComponent(Instance: TComponent): TComponent;
  515.     function ReadComponentRes(Instance: TComponent): TComponent;
  516.     procedure WriteComponent(Instance: TComponent);
  517.     procedure WriteComponentRes(const ResName: string; Instance: TComponent);
  518.     procedure WriteDescendent(Instance, Ancestor: TComponent);
  519.     procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
  520.     procedure WriteResourceHeader(const ResName: string; out FixupInfo: Integer);
  521.     procedure FixupResourceHeader(FixupInfo: Integer);
  522.     procedure ReadResHeader;
  523.     property Position: Longint read GetPosition write SetPosition;
  524.     property Size: Longint read GetSize write SetSize;
  525.   end;
  526.  
  527. { THandleStream class }
  528.  
  529.   THandleStream = class(TStream)
  530.   private
  531.     FHandle: Integer;
  532.   protected
  533.     procedure SetSize(NewSize: Longint); override;
  534.   public
  535.     constructor Create(AHandle: Integer);
  536.     function Read(var Buffer; Count: Longint): Longint; override;
  537.     function Write(const Buffer; Count: Longint): Longint; override;
  538.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  539.     property Handle: Integer read FHandle;
  540.   end;
  541.  
  542. { TFileStream class }
  543.  
  544.   TFileStream = class(THandleStream)
  545.   public
  546.     constructor Create(const FileName: string; Mode: Word);
  547.     destructor Destroy; override;
  548.   end;
  549.  
  550. { TCustomMemoryStream abstract class }
  551.  
  552.   TCustomMemoryStream = class(TStream)
  553.   private
  554.     FMemory: Pointer;
  555.     FSize, FPosition: Longint;
  556.   protected
  557.     procedure SetPointer(Ptr: Pointer; Size: Longint);
  558.   public
  559.     function Read(var Buffer; Count: Longint): Longint; override;
  560.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  561.     procedure SaveToStream(Stream: TStream);
  562.     procedure SaveToFile(const FileName: string);
  563.     property Memory: Pointer read FMemory;
  564.   end;
  565.  
  566. { TMemoryStream }
  567.  
  568.   TMemoryStream = class(TCustomMemoryStream)
  569.   private
  570.     FCapacity: Longint;
  571.     procedure SetCapacity(NewCapacity: Longint);
  572.   protected
  573.     function Realloc(var NewCapacity: Longint): Pointer; virtual;
  574.     property Capacity: Longint read FCapacity write SetCapacity;
  575.   public
  576.     destructor Destroy; override;
  577.     procedure Clear;
  578.     procedure LoadFromStream(Stream: TStream);
  579.     procedure LoadFromFile(const FileName: string);
  580.     procedure SetSize(NewSize: Longint); override;
  581.     function Write(const Buffer; Count: Longint): Longint; override;
  582.   end;
  583.  
  584. { TStringStream }
  585.  
  586.   TStringStream = class(TStream)
  587.   private
  588.     FDataString: string;
  589.     FPosition: Integer;
  590.   protected
  591.     procedure SetSize(NewSize: Longint); override;
  592.   public
  593.     constructor Create(const AString: string);
  594.     function Read(var Buffer; Count: Longint): Longint; override;
  595.     function ReadString(Count: Longint): string;
  596.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  597.     function Write(const Buffer; Count: Longint): Longint; override;
  598.     procedure WriteString(const AString: string);
  599.     property DataString: string read FDataString;
  600.   end;
  601.  
  602. { TResourceStream }
  603.  
  604.   TResourceStream = class(TCustomMemoryStream)
  605.   private
  606.     HResInfo: HRSRC;
  607.     HGlobal: THandle;
  608.     procedure Initialize(Instance: THandle; Name, ResType: PChar);
  609.   public
  610.     constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
  611.     constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
  612.     destructor Destroy; override;
  613.     function Write(const Buffer; Count: Longint): Longint; override;
  614.   end;
  615.  
  616. { TStreamAdapter }
  617. { Implements OLE IStream on VCL TStream }
  618.  
  619.   TStreamOwnership = (soReference, soOwned);
  620.  
  621.   TStreamAdapter = class(TInterfacedObject, IStream)
  622.   private
  623.     FStream: TStream;
  624.     FOwnership: TStreamOwnership;
  625.   public
  626.     constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference);
  627.     destructor Destroy; override;
  628.     function Read(pv: Pointer; cb: Longint;
  629.       pcbRead: PLongint): HResult; virtual; stdcall;
  630.     function Write(pv: Pointer; cb: Longint;
  631.       pcbWritten: PLongint): HResult; virtual; stdcall;
  632.     function Seek(dlibMove: Largeint; dwOrigin: Longint;
  633.       out libNewPosition: Largeint): HResult; virtual; stdcall;
  634.     function SetSize(libNewSize: Largeint): HResult; virtual; stdcall;
  635.     function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  636.       out cbWritten: Largeint): HResult; virtual; stdcall;
  637.     function Commit(grfCommitFlags: Longint): HResult; virtual; stdcall;
  638.     function Revert: HResult; virtual; stdcall;
  639.     function LockRegion(libOffset: Largeint; cb: Largeint;
  640.       dwLockType: Longint): HResult; virtual; stdcall;
  641.     function UnlockRegion(libOffset: Largeint; cb: Largeint;
  642.       dwLockType: Longint): HResult; virtual; stdcall;
  643.     function Stat(out statstg: TStatStg;
  644.       grfStatFlag: Longint): HResult; virtual; stdcall;
  645.     function Clone(out stm: IStream): HResult; virtual; stdcall;
  646.     property Stream: TStream read FStream;
  647.     property StreamOwnership: TStreamOwnership read FOwnership write FOwnership;
  648.   end;
  649.  
  650. { TFiler }
  651.  
  652.   TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
  653.     vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
  654.     vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64);
  655.  
  656.   TFilerFlag = (ffInherited, ffChildPos, ffInline);
  657.   TFilerFlags = set of TFilerFlag;
  658.  
  659.   TReaderProc = procedure(Reader: TReader) of object;
  660.   TWriterProc = procedure(Writer: TWriter) of object;
  661.   TStreamProc = procedure(Stream: TStream) of object;
  662.  
  663.   TFiler = class(TObject)
  664.   private
  665.     FStream: TStream;
  666.     FBuffer: Pointer;
  667.     FBufSize: Integer;
  668.     FBufPos: Integer;
  669.     FBufEnd: Integer;
  670.     FRoot: TComponent;
  671.     FLookupRoot: TComponent;
  672.     FAncestor: TPersistent;
  673.     FIgnoreChildren: Boolean;
  674.   protected
  675.     procedure SetRoot(Value: TComponent); virtual;
  676.   public
  677.     constructor Create(Stream: TStream; BufSize: Integer);
  678.     destructor Destroy; override;
  679.     procedure DefineProperty(const Name: string;
  680.       ReadData: TReaderProc; WriteData: TWriterProc;
  681.       HasData: Boolean); virtual; abstract;
  682.     procedure DefineBinaryProperty(const Name: string;
  683.       ReadData, WriteData: TStreamProc;
  684.       HasData: Boolean); virtual; abstract;
  685.     procedure FlushBuffer; virtual; abstract;
  686.     property Root: TComponent read FRoot write SetRoot;
  687.     property LookupRoot: TComponent read FLookupRoot;
  688.     property Ancestor: TPersistent read FAncestor write FAncestor;
  689.     property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
  690.   end;
  691.  
  692. { TComponent class reference type }
  693.  
  694.   TComponentClass = class of TComponent;
  695.  
  696. { TReader }
  697.  
  698.   TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
  699.     var Address: Pointer; var Error: Boolean) of object;
  700.   TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
  701.     var Name: string) of object;
  702.   TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object;
  703.   TAncestorNotFoundEvent = procedure(Reader: TReader; const ComponentName: string;
  704.     ComponentClass: TPersistentClass; var Component: TComponent) of object;
  705.   TReadComponentsProc = procedure(Component: TComponent) of object;
  706.   TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;
  707.   TFindComponentClassEvent = procedure(Reader: TReader; const ClassName: string;
  708.     var ComponentClass: TComponentClass) of object;
  709.   TCreateComponentEvent = procedure(Reader: TReader;
  710.     ComponentClass: TComponentClass; var Component: TComponent) of object;
  711.  
  712.   TReader = class(TFiler)
  713.   private
  714.     FOwner: TComponent;
  715.     FParent: TComponent;
  716.     FFixups: TList;
  717.     FLoaded: TList;
  718.     FOnFindMethod: TFindMethodEvent;
  719.     FOnSetName: TSetNameEvent;
  720.     FOnReferenceName: TReferenceNameEvent;
  721.     FOnAncestorNotFound: TAncestorNotFoundEvent;
  722.     FOnError: TReaderError;
  723.     FOnFindComponentClass: TFindComponentClassEvent;
  724.     FOnCreateComponent: TCreateComponentEvent;
  725.     FPropName: string;
  726.     FCanHandleExcepts: Boolean;
  727.     procedure DoFixupReferences;
  728.     procedure FreeFixups;
  729.     function GetPosition: Longint;
  730.     procedure ReadBuffer;
  731.     procedure ReadDataInner(Instance: TComponent);
  732.     function FindComponentClass(const ClassName: string): TComponentClass;
  733.   protected
  734.     function Error(const Message: string): Boolean; virtual;
  735.     function FindAncestorComponent(const Name: string;
  736.       ComponentClass: TPersistentClass): TComponent; virtual;
  737.     function FindMethod(Root: TComponent; const MethodName: string): Pointer; virtual;
  738.     procedure SetName(Component: TComponent; var Name: string); virtual;
  739.     procedure ReadProperty(AInstance: TPersistent);
  740.     procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  741.     procedure ReferenceName(var Name: string); virtual;
  742.     procedure PropertyError;
  743.     procedure ReadData(Instance: TComponent);
  744.     function ReadSet(SetType: Pointer): Integer;
  745.     procedure SetPosition(Value: Longint);
  746.     procedure SkipSetBody;
  747.     procedure SkipValue;
  748.     procedure SkipProperty;
  749.     procedure SkipComponent(SkipHeader: Boolean);
  750.     property PropName: string read FPropName;
  751.     property CanHandleExceptions: Boolean read FCanHandleExcepts;
  752.   public
  753.     destructor Destroy; override;
  754.     procedure BeginReferences;
  755.     procedure CheckValue(Value: TValueType);
  756.     procedure DefineProperty(const Name: string;
  757.       ReadData: TReaderProc; WriteData: TWriterProc;
  758.       HasData: Boolean); override;
  759.     procedure DefineBinaryProperty(const Name: string;
  760.       ReadData, WriteData: TStreamProc;
  761.       HasData: Boolean); override;
  762.     function EndOfList: Boolean;
  763.     procedure EndReferences;
  764.     procedure FixupReferences;
  765.     procedure FlushBuffer; override;
  766.     function NextValue: TValueType;
  767.     procedure Read(var Buf; Count: Longint);
  768.     function ReadBoolean: Boolean;
  769.     function ReadChar: Char;
  770.     procedure ReadCollection(Collection: TCollection);
  771.     function ReadComponent(Component: TComponent): TComponent;
  772.     procedure ReadComponents(AOwner, AParent: TComponent;
  773.       Proc: TReadComponentsProc);
  774.     function ReadFloat: Extended;
  775.     function ReadSingle: Single;
  776.     function ReadCurrency: Currency;
  777.     function ReadDate: TDateTime;
  778.     function ReadIdent: string;
  779.     function ReadInteger: Longint;
  780.     function ReadInt64: Int64;
  781.     procedure ReadListBegin;
  782.     procedure ReadListEnd;
  783.     procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); virtual;
  784.     function ReadRootComponent(Root: TComponent): TComponent;
  785.     procedure ReadSignature;
  786.     function ReadStr: string;
  787.     function ReadString: string;
  788.     function ReadWideString: WideString;
  789.     function ReadValue: TValueType;
  790.     procedure CopyValue(Writer: TWriter);
  791.     property Owner: TComponent read FOwner write FOwner;
  792.     property Parent: TComponent read FParent write FParent;
  793.     property Position: Longint read GetPosition write SetPosition;
  794.     property OnError: TReaderError read FOnError write FOnError;
  795.     property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
  796.     property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
  797.     property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName;
  798.     property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound;
  799.     property OnCreateComponent: TCreateComponentEvent read FOnCreateComponent write FOnCreateComponent;
  800.     property OnFindComponentClass: TFindComponentClassEvent read FOnFindComponentClass write FOnFindComponentClass;
  801.   end;
  802.  
  803. { TWriter }
  804.  
  805.   TFindAncestorEvent = procedure (Writer: TWriter; Component: TComponent;
  806.     const Name: string; var Ancestor, RootAncestor: TComponent) of object;
  807.  
  808.   TWriter = class(TFiler)
  809.   private
  810.     FRootAncestor: TComponent;
  811.     FPropPath: string;
  812.     FAncestorList: TList;
  813.     FAncestorPos: Integer;
  814.     FChildPos: Integer;
  815.     FOnFindAncestor: TFindAncestorEvent;
  816.     procedure AddAncestor(Component: TComponent);
  817.     function GetPosition: Longint;
  818.     procedure SetPosition(Value: Longint);
  819.     procedure WriteBuffer;
  820.     procedure WriteData(Instance: TComponent); virtual; // linker optimization
  821.   protected
  822.     procedure SetRoot(Value: TComponent); override;
  823.     procedure WriteBinary(WriteData: TStreamProc);
  824.     procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  825.     procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  826.     procedure WriteProperties(Instance: TPersistent);
  827.     procedure WritePropName(const PropName: string);
  828.     procedure WriteValue(Value: TValueType);
  829.   public
  830.     destructor Destroy; override;
  831.     procedure DefineProperty(const Name: string;
  832.       ReadData: TReaderProc; WriteData: TWriterProc;
  833.       HasData: Boolean); override;
  834.     procedure DefineBinaryProperty(const Name: string;
  835.       ReadData, WriteData: TStreamProc;
  836.       HasData: Boolean); override;
  837.     procedure FlushBuffer; override;
  838.     procedure Write(const Buf; Count: Longint);
  839.     procedure WriteBoolean(Value: Boolean);
  840.     procedure WriteCollection(Value: TCollection);
  841.     procedure WriteComponent(Component: TComponent);
  842.     procedure WriteChar(Value: Char);
  843.     procedure WriteDescendent(Root: TComponent; AAncestor: TComponent);
  844.     procedure WriteFloat(const Value: Extended);
  845.     procedure WriteSingle(const Value: Single);
  846.     procedure WriteCurrency(const Value: Currency);
  847.     procedure WriteDate(const Value: TDateTime);
  848.     procedure WriteIdent(const Ident: string);
  849.     procedure WriteInteger(Value: Longint); overload;
  850.     procedure WriteInteger(Value: Int64); overload;
  851.     procedure WriteListBegin;
  852.     procedure WriteListEnd;
  853.     procedure WriteRootComponent(Root: TComponent);
  854.     procedure WriteSignature;
  855.     procedure WriteStr(const Value: string);
  856.     procedure WriteString(const Value: string);
  857.     procedure WriteWideString(const Value: WideString);
  858.     property Position: Longint read GetPosition write SetPosition;
  859.     property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
  860.     property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor;
  861.   end;
  862.  
  863. { TParser }
  864.  
  865.   TParser = class(TObject)
  866.   private
  867.     FStream: TStream;
  868.     FOrigin: Longint;
  869.     FBuffer: PChar;
  870.     FBufPtr: PChar;
  871.     FBufEnd: PChar;
  872.     FSourcePtr: PChar;
  873.     FSourceEnd: PChar;
  874.     FTokenPtr: PChar;
  875.     FStringPtr: PChar;
  876.     FSourceLine: Integer;
  877.     FSaveChar: Char;
  878.     FToken: Char;
  879.     FFloatType: Char;
  880.     FWideStr: WideString;
  881.     procedure ReadBuffer;
  882.     procedure SkipBlanks;
  883.   public
  884.     constructor Create(Stream: TStream);
  885.     destructor Destroy; override;
  886.     procedure CheckToken(T: Char);
  887.     procedure CheckTokenSymbol(const S: string);
  888.     procedure Error(const Ident: string);
  889.     procedure ErrorFmt(const Ident: string; const Args: array of const);
  890.     procedure ErrorStr(const Message: string);
  891.     procedure HexToBinary(Stream: TStream);
  892.     function NextToken: Char;
  893.     function SourcePos: Longint;
  894.     function TokenComponentIdent: string;
  895.     function TokenFloat: Extended;
  896.     function TokenInt: Int64;
  897.     function TokenString: string;
  898.     function TokenWideString: WideString;
  899.     function TokenSymbolIs(const S: string): Boolean;
  900.     property FloatType: Char read FFloatType;
  901.     property SourceLine: Integer read FSourceLine;
  902.     property Token: Char read FToken;
  903.   end;
  904.  
  905. { TThread }
  906.  
  907.   EThread = class(Exception);
  908.  
  909.   TThreadMethod = procedure of object;
  910.   TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  911.     tpTimeCritical);
  912.  
  913.   TThread = class
  914.   private
  915.     FHandle: THandle;
  916.     FThreadID: THandle;
  917.     FTerminated: Boolean;
  918.     FSuspended: Boolean;
  919.     FFreeOnTerminate: Boolean;
  920.     FFinished: Boolean;
  921.     FReturnValue: Integer;
  922.     FOnTerminate: TNotifyEvent;
  923.     FMethod: TThreadMethod;
  924.     FSynchronizeException: TObject;
  925.     procedure CallOnTerminate;
  926.     function GetPriority: TThreadPriority;
  927.     procedure SetPriority(Value: TThreadPriority);
  928.     procedure SetSuspended(Value: Boolean);
  929.   protected
  930.     procedure DoTerminate; virtual;
  931.     procedure Execute; virtual; abstract;
  932.     procedure Synchronize(Method: TThreadMethod);
  933.     property ReturnValue: Integer read FReturnValue write FReturnValue;
  934.     property Terminated: Boolean read FTerminated;
  935.   public
  936.     constructor Create(CreateSuspended: Boolean);
  937.     destructor Destroy; override;
  938.     procedure Resume;
  939.     procedure Suspend;
  940.     procedure Terminate;
  941.     function WaitFor: LongWord;
  942.     property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  943.     property Handle: THandle read FHandle;
  944.     property Priority: TThreadPriority read GetPriority write SetPriority;
  945.     property Suspended: Boolean read FSuspended write SetSuspended;
  946.     property ThreadID: THandle read FThreadID;
  947.     property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
  948.   end;
  949.  
  950. { TComponent class }
  951.  
  952.   TOperation = (opInsert, opRemove);
  953.   TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
  954.     csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification,
  955.     csInline, csDesignInstance);
  956.   TComponentStyle = set of (csInheritable, csCheckPropAvail);
  957.   TGetChildProc = procedure (Child: TComponent) of object;
  958.  
  959.   TComponentName = type string;
  960.  
  961.   IVCLComObject = interface
  962.     ['{E07892A0-F52F-11CF-BD2F-0020AF0E5B81}']
  963.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  964.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  965.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  966.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  967.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  968.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  969.     function SafeCallException(ExceptObject: TObject;
  970.       ExceptAddr: Pointer): HResult;
  971.     procedure FreeOnRelease;
  972.   end;
  973.  
  974.   IDesignerNotify = interface
  975.     ['{B971E807-E3A6-11D1-AAB1-00C04FB16FBC}']
  976.     procedure Modified;
  977.     procedure Notification(AnObject: TPersistent; Operation: TOperation);
  978.   end;  
  979.  
  980.   TBasicAction = class;
  981.  
  982.   TComponent = class(TPersistent)
  983.   private
  984.     FOwner: TComponent;
  985.     FName: TComponentName;
  986.     FTag: Longint;
  987.     FComponents: TList;
  988.     FFreeNotifies: TList;
  989.     FDesignInfo: Longint;
  990.     FVCLComObject: Pointer;
  991.     FComponentState: TComponentState;
  992.     function GetComObject: IUnknown;
  993.     function GetComponent(AIndex: Integer): TComponent;
  994.     function GetComponentCount: Integer;
  995.     function GetComponentIndex: Integer;
  996.     procedure Insert(AComponent: TComponent);
  997.     procedure ReadLeft(Reader: TReader);
  998.     procedure ReadTop(Reader: TReader);
  999.     procedure Remove(AComponent: TComponent);
  1000.     procedure RemoveNotification(AComponent: TComponent);
  1001.     procedure SetComponentIndex(Value: Integer);
  1002.     procedure SetReference(Enable: Boolean);
  1003.     procedure WriteLeft(Writer: TWriter);
  1004.     procedure WriteTop(Writer: TWriter);
  1005.   protected
  1006.     FComponentStyle: TComponentStyle;
  1007.     procedure ChangeName(const NewName: TComponentName);
  1008.     procedure DefineProperties(Filer: TFiler); override;
  1009.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic;
  1010.     function GetChildOwner: TComponent; dynamic;
  1011.     function GetChildParent: TComponent; dynamic;
  1012.     function GetOwner: TPersistent; override;
  1013.     procedure Loaded; virtual;
  1014.     procedure Notification(AComponent: TComponent;
  1015.       Operation: TOperation); virtual;
  1016.     procedure ReadState(Reader: TReader); virtual;
  1017.     procedure SetAncestor(Value: Boolean);
  1018.     procedure SetDesigning(Value: Boolean; SetChildren: Boolean = True);
  1019.     procedure SetInline(Value: Boolean);
  1020.     procedure SetDesignInstance(Value: Boolean);
  1021.     procedure SetName(const NewName: TComponentName); virtual;
  1022.     procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic;
  1023.     procedure SetParentComponent(Value: TComponent); dynamic;
  1024.     procedure Updating; dynamic;
  1025.     procedure Updated; dynamic;
  1026.     class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); virtual;
  1027.     procedure ValidateRename(AComponent: TComponent;
  1028.       const CurName, NewName: string); virtual;
  1029.     procedure ValidateContainer(AComponent: TComponent); dynamic;
  1030.     procedure ValidateInsert(AComponent: TComponent); dynamic;
  1031.     procedure WriteState(Writer: TWriter); virtual;
  1032.     { IUnknown }
  1033.     function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  1034.     function _AddRef: Integer; stdcall;
  1035.     function _Release: Integer; stdcall;
  1036.     { IDispatch }
  1037.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  1038.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  1039.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  1040.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  1041.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  1042.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  1043.   public
  1044.     constructor Create(AOwner: TComponent); virtual;
  1045.     destructor Destroy; override;
  1046.     procedure BeforeDestruction; override;
  1047.     procedure DestroyComponents;
  1048.     procedure Destroying;
  1049.     function ExecuteAction(Action: TBasicAction): Boolean; dynamic;
  1050.     function FindComponent(const AName: string): TComponent;
  1051.     procedure FreeNotification(AComponent: TComponent);
  1052.     procedure RemoveFreeNotification(AComponent: TComponent);
  1053.     procedure FreeOnRelease;
  1054.     function GetParentComponent: TComponent; dynamic;
  1055.     function GetNamePath: string; override;
  1056.     function HasParent: Boolean; dynamic;
  1057.     procedure InsertComponent(AComponent: TComponent);
  1058.     procedure RemoveComponent(AComponent: TComponent);
  1059.     function SafeCallException(ExceptObject: TObject;
  1060.       ExceptAddr: Pointer): HResult; override;
  1061.     function UpdateAction(Action: TBasicAction): Boolean; dynamic;
  1062.     property ComObject: IUnknown read GetComObject;
  1063.     property Components[Index: Integer]: TComponent read GetComponent;
  1064.     property ComponentCount: Integer read GetComponentCount;
  1065.     property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
  1066.     property ComponentState: TComponentState read FComponentState;
  1067.     property ComponentStyle: TComponentStyle read FComponentStyle;
  1068.     property DesignInfo: Longint read FDesignInfo write FDesignInfo;
  1069.     property Owner: TComponent read FOwner;
  1070.     property VCLComObject: Pointer read FVCLComObject write FVCLComObject;
  1071.   published
  1072.     property Name: TComponentName read FName write SetName stored False;
  1073.     property Tag: Longint read FTag write FTag default 0;
  1074.   end;
  1075.  
  1076. { TBasicActionLink }
  1077.  
  1078.   TBasicActionLink = class(TObject)
  1079.   private
  1080.     FOnChange: TNotifyEvent;
  1081.   protected
  1082.     FAction: TBasicAction;
  1083.     procedure AssignClient(AClient: TObject); virtual;
  1084.     procedure Change; virtual;
  1085.     function IsOnExecuteLinked: Boolean; virtual;
  1086.     procedure SetAction(Value: TBasicAction); virtual;
  1087.     procedure SetOnExecute(Value: TNotifyEvent); virtual;
  1088.   public
  1089.     constructor Create(AClient: TObject); virtual;
  1090.     destructor Destroy; override;
  1091.     function Execute: Boolean; virtual;
  1092.     function Update: Boolean; virtual;
  1093.     property Action: TBasicAction read FAction write SetAction;
  1094.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  1095.   end;
  1096.  
  1097.   TBasicActionLinkClass = class of TBasicActionLink;
  1098.  
  1099. { TBasicAction }
  1100.  
  1101.   TBasicAction = class(TComponent)
  1102.   private
  1103.     FOnChange: TNotifyEvent;
  1104.     FOnExecute: TNotifyEvent;
  1105.     FOnUpdate: TNotifyEvent;
  1106.   protected
  1107.     FClients: TList;
  1108.     procedure Change; virtual;
  1109.     procedure SetOnExecute(Value: TNotifyEvent); virtual;
  1110.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  1111.   public
  1112.     constructor Create(AOwner: TComponent); override;
  1113.     destructor Destroy; override;
  1114.     function HandlesTarget(Target: TObject): Boolean; virtual;
  1115.     procedure UpdateTarget(Target: TObject); virtual;
  1116.     procedure ExecuteTarget(Target: TObject); virtual;
  1117.     function Execute: Boolean; dynamic;
  1118.     procedure RegisterChanges(Value: TBasicActionLink);
  1119.     procedure UnRegisterChanges(Value: TBasicActionLink);
  1120.     function Update: Boolean; virtual;
  1121.     property OnExecute: TNotifyEvent read FOnExecute write SetOnExecute;
  1122.     property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate;
  1123.   end;
  1124.  
  1125. { TBasicAction class reference type }
  1126.  
  1127.   TBasicActionClass = class of TBasicAction;
  1128.  
  1129. { Component registration handlers }
  1130.  
  1131.   TActiveXRegType = (axrComponentOnly, axrIncludeDescendants);
  1132.  
  1133. var
  1134.   RegisterComponentsProc: procedure(const Page: string;
  1135.     ComponentClasses: array of TComponentClass) = nil;
  1136.   RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass) = nil;
  1137.   RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
  1138.     AxRegType: TActiveXRegType) = nil;
  1139.   CurrentGroup: Integer = -1; { Current design group }
  1140.   CreateVCLComObjectProc: procedure(Component: TComponent) = nil;
  1141.  
  1142. { Point and rectangle constructors }
  1143.  
  1144. function Point(AX, AY: Integer): TPoint;
  1145. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  1146. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  1147. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  1148.  
  1149. { Class registration routines }
  1150.  
  1151. procedure RegisterClass(AClass: TPersistentClass);
  1152. procedure RegisterClasses(AClasses: array of TPersistentClass);
  1153. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  1154. procedure UnRegisterClass(AClass: TPersistentClass);
  1155. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  1156. procedure UnRegisterModuleClasses(Module: HMODULE);
  1157. function FindClass(const ClassName: string): TPersistentClass;
  1158. function GetClass(const AClassName: string): TPersistentClass;
  1159.  
  1160. { Component registration routines }
  1161.  
  1162. procedure RegisterComponents(const Page: string;
  1163.   ComponentClasses: array of TComponentClass);
  1164. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  1165. procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
  1166.   AxRegType: TActiveXRegType);
  1167.  
  1168. var
  1169.   GlobalNameSpace: TMultiReadExclusiveWriteSynchronizer;
  1170.  
  1171. { Object filing routines }
  1172.  
  1173. type
  1174.   TIdentMapEntry = record
  1175.     Value: Integer;
  1176.     Name: String;
  1177.   end;
  1178.  
  1179.   TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
  1180.   TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
  1181.   TFindGlobalComponent = function(const Name: string): TComponent;
  1182.  
  1183. var
  1184.   FindGlobalComponent: TFindGlobalComponent;
  1185.  
  1186. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  1187.   IntToIdent: TIntToIdent);
  1188. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  1189. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  1190. function FindIntToIdent(AIntegerType: Pointer): TIntToIdent;
  1191. function FindIdentToInt(AIntegerType: Pointer): TIdentToInt;
  1192.  
  1193. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  1194. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  1195. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  1196. function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
  1197. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  1198. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  1199.  
  1200. procedure GlobalFixupReferences;
  1201. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  1202. procedure GetFixupInstanceNames(Root: TComponent;
  1203.   const ReferenceRootName: string; Names: TStrings);
  1204. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  1205.   NewRootName: string);
  1206. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  1207. procedure RemoveFixups(Instance: TPersistent);
  1208. function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent;
  1209.  
  1210. procedure BeginGlobalLoading;
  1211. procedure NotifyGlobalLoading;
  1212. procedure EndGlobalLoading;
  1213.  
  1214. function CollectionsEqual(C1, C2: TCollection): Boolean;
  1215.  
  1216. { Object conversion routines }
  1217.  
  1218. type
  1219.   TStreamOriginalFormat = (sofUnknown, sofBinary, sofText);
  1220.  
  1221. procedure ObjectBinaryToText(Input, Output: TStream); overload;
  1222. procedure ObjectBinaryToText(Input, Output: TStream;
  1223.   var OriginalFormat: TStreamOriginalFormat); overload;
  1224. procedure ObjectTextToBinary(Input, Output: TStream); overload;
  1225. procedure ObjectTextToBinary(Input, Output: TStream;
  1226.   var OriginalFormat: TStreamOriginalFormat); overload;
  1227.  
  1228. procedure ObjectResourceToText(Input, Output: TStream); overload;
  1229. procedure ObjectResourceToText(Input, Output: TStream;
  1230.   var OriginalFormat: TStreamOriginalFormat); overload;
  1231. procedure ObjectTextToResource(Input, Output: TStream); overload;
  1232. procedure ObjectTextToResource(Input, Output: TStream;
  1233.   var OriginalFormat: TStreamOriginalFormat); overload;
  1234.  
  1235. function TestStreamFormat(Stream: TStream): TStreamOriginalFormat;
  1236.  
  1237. { Utility routines }
  1238.  
  1239. function LineStart(Buffer, BufPos: PChar): PChar;
  1240. function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  1241.   Strings: TStrings): Integer;
  1242.  
  1243. procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);
  1244. function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer;
  1245.  
  1246. function FindRootDesigner(Obj: TPersistent): IDesignerNotify;
  1247.  
  1248. implementation
  1249.  
  1250. uses Consts, TypInfo;
  1251.  
  1252. const
  1253.   FilerSignature: array[1..4] of Char = 'TPF0';
  1254.  
  1255. var
  1256.   ClassList: TThreadList;
  1257.   ClassAliasList: TStringList;
  1258.   IntConstList: TThreadList;
  1259.  
  1260. { Point and rectangle constructors }
  1261.  
  1262. function Point(AX, AY: Integer): TPoint;
  1263. begin
  1264.   with Result do
  1265.   begin
  1266.     X := AX;
  1267.     Y := AY;
  1268.   end;
  1269. end;
  1270.  
  1271. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  1272. begin
  1273.   with Result do
  1274.   begin
  1275.     X := AX;
  1276.     Y := AY;
  1277.   end;
  1278. end;
  1279.  
  1280. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  1281. begin
  1282.   with Result do
  1283.   begin
  1284.     Left := ALeft;
  1285.     Top := ATop;
  1286.     Right := ARight;
  1287.     Bottom := ABottom;
  1288.   end;
  1289. end;
  1290.  
  1291. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  1292. begin
  1293.   with Result do
  1294.   begin
  1295.     Left := ALeft;
  1296.     Top := ATop;
  1297.     Right := ALeft + AWidth;
  1298.     Bottom :=  ATop + AHeight;
  1299.   end;
  1300. end;
  1301.  
  1302. { Class registration routines }
  1303.  
  1304. type
  1305.   PFieldClassTable = ^TFieldClassTable;
  1306.   TFieldClassTable = packed record
  1307.     Count: Smallint;
  1308.     Classes: array[0..8191] of ^TPersistentClass;
  1309.   end;
  1310.  
  1311. function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler;
  1312. asm
  1313.         MOV     EAX,[EAX].vmtFieldTable
  1314.         OR      EAX,EAX
  1315.         JE      @@1
  1316.         MOV     EAX,[EAX+2].Integer
  1317. @@1:
  1318. end;
  1319.  
  1320. procedure ClassNotFound(const ClassName: string);
  1321. begin
  1322.   raise EClassNotFound.CreateFmt(SClassNotFound, [ClassName]);
  1323. end;
  1324.  
  1325. function GetClass(const AClassName: string): TPersistentClass;
  1326. var
  1327.   I: Integer;
  1328. begin
  1329.   with ClassList.LockList do
  1330.   try     // ClassAliasList protected by ClassList lock
  1331.     for I := 0 to Count - 1 do
  1332.     begin
  1333.       Result := Items[I];
  1334.       if Result.ClassNameIs(AClassName) then Exit;
  1335.     end;
  1336.     I := ClassAliasList.IndexOf(AClassName);
  1337.     if I >= 0 then
  1338.     begin
  1339.       Result := TPersistentClass(ClassAliasList.Objects[I]);
  1340.       Exit;
  1341.     end;
  1342.     Result := nil;
  1343.   finally
  1344.     ClassList.UnlockList;
  1345.   end;
  1346. end;
  1347.  
  1348. function FindClass(const ClassName: string): TPersistentClass;
  1349. begin
  1350.   Result := GetClass(ClassName);
  1351.   if Result = nil then ClassNotFound(ClassName);
  1352. end;
  1353.  
  1354. function GetFieldClass(Instance: TObject;
  1355.   const ClassName: string): TPersistentClass;
  1356. var
  1357.   I: Integer;
  1358.   ClassTable: PFieldClassTable;
  1359.   ClassType: TClass;
  1360. begin
  1361.   ClassType := Instance.ClassType;
  1362.   while ClassType <> TPersistent do
  1363.   begin
  1364.     ClassTable := GetFieldClassTable(ClassType);
  1365.     if ClassTable <> nil then
  1366.       for I := 0 to ClassTable^.Count - 1 do
  1367.       begin
  1368.         Result := ClassTable^.Classes[I]^;
  1369.         if SameText(Result.ClassName, ClassName) then Exit;
  1370.       end;
  1371.     ClassType := ClassType.ClassParent;
  1372.   end;
  1373.   Result := GetClass(ClassName);
  1374. end;
  1375.  
  1376. procedure RegisterClass(AClass: TPersistentClass);
  1377. var
  1378.   AClassName: string;
  1379. begin
  1380.   with ClassList.LockList do
  1381.   try
  1382.     while IndexOf(AClass) = -1 do
  1383.     begin
  1384.       AClassName := AClass.ClassName;
  1385.       if GetClass(AClassName) <> nil then
  1386.         raise EFilerError.CreateResFmt(@SDuplicateClass, [AClassName]);
  1387.       Add(AClass);
  1388.       if AClass = TPersistent then Break;
  1389.       AClass := TPersistentClass(AClass.ClassParent);
  1390.     end;
  1391.   finally
  1392.     ClassList.UnlockList;
  1393.   end;
  1394. end;
  1395.  
  1396. procedure RegisterClasses(AClasses: array of TPersistentClass);
  1397. var
  1398.   I: Integer;
  1399. begin
  1400.   for I := Low(AClasses) to High(AClasses) do RegisterClass(AClasses[I]);
  1401. end;
  1402.  
  1403. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  1404. begin
  1405.   ClassList.LockList; // ClassAliasList protected by ClassList lock
  1406.   try
  1407.     RegisterClass(AClass);
  1408.     ClassAliasList.AddObject(Alias, TObject(AClass));
  1409.   finally
  1410.     ClassList.UnlockList;
  1411.   end;
  1412. end;
  1413.  
  1414. procedure UnRegisterClass(AClass: TPersistentClass);
  1415. begin
  1416.   ClassList.Remove(AClass);
  1417. end;
  1418.  
  1419. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  1420. var
  1421.   I: Integer;
  1422. begin
  1423.   for I := Low(AClasses) to High(AClasses) do UnRegisterClass(AClasses[I]);
  1424. end;
  1425.  
  1426. procedure UnRegisterModuleClasses(Module: HMODULE);
  1427. var
  1428.   I: Integer;
  1429.   M: TMemoryBasicInformation;
  1430. begin
  1431.   with ClassList.LockList do
  1432.   try
  1433.     for I := Count - 1 downto 0 do
  1434.     begin
  1435.       VirtualQuery(Items[I], M, SizeOf(M));
  1436.       if (Module = 0) or (HMODULE(M.AllocationBase) = Module) then
  1437.         Delete(I);
  1438.     end;
  1439.     // ClassAliasList protected by ClassList lock
  1440.     for I := ClassAliasList.Count - 1 downto 0 do
  1441.     begin
  1442.       VirtualQuery(Pointer(ClassAliasList.Objects[I]), M, SizeOf(M));
  1443.       if (Module = 0) or (HMODULE(M.AllocationBase) = Module) then
  1444.         ClassAliasList.Delete(I);
  1445.     end;
  1446.   finally
  1447.     ClassList.UnlockList;
  1448.   end;
  1449. end;
  1450.  
  1451. { Component registration routines }
  1452.  
  1453. procedure RegisterComponents(const Page: string;
  1454.   ComponentClasses: array of TComponentClass);
  1455. begin
  1456.   if Assigned(RegisterComponentsProc) then
  1457.     RegisterComponentsProc(Page, ComponentClasses)
  1458.   else
  1459.     raise EComponentError.CreateRes(@SRegisterError);
  1460. end;
  1461.  
  1462. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  1463. begin
  1464.   if Assigned(RegisterNoIconProc) then
  1465.     RegisterNoIconProc(ComponentClasses)
  1466.   else
  1467.     raise EComponentError.CreateRes(@SRegisterError);
  1468. end;
  1469.  
  1470. procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
  1471.   AxRegType: TActiveXRegType);
  1472. begin
  1473.   if not Assigned(RegisterNonActiveXProc) then
  1474.     raise EComponentError.CreateRes(@SRegisterError);
  1475.   RegisterNonActiveXProc(ComponentClasses, AxRegType)
  1476. end;
  1477.  
  1478. { Component filing }
  1479.  
  1480. type
  1481.   TIntConst = class
  1482.     IntegerType: PTypeInfo;
  1483.     IdentToInt: TIdentToInt;
  1484.     IntToIdent: TIntToIdent;
  1485.     constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  1486.       AIntToIdent: TIntToIdent);
  1487.   end;
  1488.  
  1489. constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt;
  1490.   AIntToIdent: TIntToIdent);
  1491. begin
  1492.   IntegerType := AIntegerType;
  1493.   IdentToInt := AIdentToInt;
  1494.   IntToIdent := AIntToIdent;
  1495. end;
  1496.  
  1497. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  1498.   IntToIdent: TIntToIdent);
  1499. begin
  1500.   IntConstList.Add(TIntConst.Create(IntegerType, IdentToInt, IntToIdent));
  1501. end;
  1502.  
  1503. function FindIntToIdent(AIntegerType: Pointer): TIntToIdent;
  1504. var
  1505.   I: Integer;
  1506. begin
  1507.   Result := nil;
  1508.   with IntConstList.LockList do
  1509.   try
  1510.     for I := 0 to Count - 1 do
  1511.       with TIntConst(Items[I]) do
  1512.         if AIntegerType = IntegerType then
  1513.         begin
  1514.           Result := @IntToIdent;
  1515.           Exit;
  1516.         end;
  1517.   finally
  1518.     IntConstList.UnlockList;
  1519.   end;
  1520. end;
  1521.  
  1522. function FindIdentToInt(AIntegerType: Pointer): TIdentToInt;
  1523. var
  1524.   I: Integer;
  1525. begin
  1526.   Result := nil;
  1527.   with IntConstList.LockList do
  1528.   try
  1529.     for I := 0 to Count - 1 do
  1530.       with TIntConst(Items[I]) do
  1531.         if AIntegerType = IntegerType then
  1532.         begin
  1533.           Result := @IdentToInt;
  1534.           Exit;
  1535.         end;
  1536.   finally
  1537.     IntConstList.UnlockList;
  1538.   end;
  1539. end;
  1540.  
  1541. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  1542. var
  1543.   I: Integer;
  1544. begin
  1545.   for I := Low(Map) to High(Map) do
  1546.     if SameText(Map[I].Name, Ident) then
  1547.     begin
  1548.       Result := True;
  1549.       Int := Map[I].Value;
  1550.       Exit;
  1551.     end;
  1552.   Result := False;
  1553. end;
  1554.  
  1555. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  1556. var
  1557.   I: Integer;
  1558. begin
  1559.   for I := Low(Map) to High(Map) do
  1560.     if Map[I].Value = Int then
  1561.     begin
  1562.       Result := True;
  1563.       Ident := Map[I].Name;
  1564.       Exit;
  1565.     end;
  1566.   Result := False;
  1567. end;
  1568.  
  1569.  
  1570. function InternalReadComponentRes(const ResName: string; HInst: THandle; var Instance: TComponent): Boolean;
  1571. var
  1572.   HRsrc: THandle;
  1573. begin                   { avoid possible EResNotFound exception }
  1574.   if HInst = 0 then HInst := HInstance;
  1575.   HRsrc := FindResource(HInst, PChar(ResName), RT_RCDATA);
  1576.   Result := HRsrc <> 0;
  1577.   if not Result then Exit;
  1578.   with TResourceStream.Create(HInst, ResName, RT_RCDATA) do
  1579.   try
  1580.     Instance := ReadComponent(Instance);
  1581.   finally
  1582.     Free;
  1583.   end;
  1584.   Result := True;
  1585. end;
  1586.  
  1587. threadvar
  1588.   GlobalLoaded: TList;
  1589.   GlobalLists: TList;
  1590.  
  1591. procedure BeginGlobalLoading;
  1592. begin
  1593.   if GlobalLists = nil then GlobalLists := TList.Create;
  1594.   GlobalLists.Add(GlobalLoaded);
  1595.   GlobalLoaded := TList.Create;
  1596. end;
  1597.  
  1598. procedure NotifyGlobalLoading;
  1599. var
  1600.   I: Integer;
  1601.   G: TList;
  1602. begin
  1603.   G := GlobalLoaded;  // performance:  eliminate repeated trips through TLS lookup
  1604.   for I := 0 to G.Count - 1 do
  1605.     TComponent(G[I]).Loaded;
  1606. end;
  1607.  
  1608. procedure EndGlobalLoading;
  1609. begin
  1610.   GlobalLoaded.Free;
  1611.   GlobalLoaded := GlobalLists.Last;
  1612.   GlobalLists.Delete(GlobalLists.Count - 1);
  1613.   if GlobalLists.Count = 0 then
  1614.     FreeAndNil(GlobalLists);
  1615. end;
  1616.  
  1617. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  1618.  
  1619.   function InitComponent(ClassType: TClass): Boolean;
  1620.   begin
  1621.     Result := False;
  1622.     if (ClassType = TComponent) or (ClassType = RootAncestor) then Exit;
  1623.     Result := InitComponent(ClassType.ClassParent);
  1624.     Result := InternalReadComponentRes(ClassType.ClassName, FindResourceHInstance(
  1625.       FindClassHInstance(ClassType)), Instance) or Result;
  1626.   end;
  1627.  
  1628. var
  1629.   LocalizeLoading: Boolean;
  1630. begin
  1631.   GlobalNameSpace.BeginWrite;  // hold lock across all ancestor loads (performance)
  1632.   try
  1633.     LocalizeLoading := (Instance.ComponentState * [csInline, csLoading]) = [];
  1634.     if LocalizeLoading then BeginGlobalLoading;  // push new loadlist onto stack
  1635.     try
  1636.       Result := InitComponent(Instance.ClassType);
  1637.       if LocalizeLoading then NotifyGlobalLoading;  // call Loaded
  1638.     finally
  1639.       if LocalizeLoading then EndGlobalLoading;  // pop loadlist off stack
  1640.     end;
  1641.   finally
  1642.     GlobalNameSpace.EndWrite;
  1643.   end;
  1644. end;
  1645.  
  1646. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  1647. begin
  1648.   Result := InternalReadComponentRes(ResName, FindResourceHInstance(
  1649.     FindClassHInstance(Instance.ClassType)), Instance);
  1650. end;
  1651.  
  1652. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  1653. var
  1654.   HInstance: THandle;
  1655. begin
  1656.   if Instance <> nil then
  1657.     HInstance := FindResourceHInstance(FindClassHInstance(Instance.ClassType))
  1658.   else HInstance := 0;
  1659.   if InternalReadComponentRes(ResName, HInstance, Instance) then
  1660.     Result := Instance else
  1661.     raise EResNotFound.CreateFmt(SResNotFound, [ResName]);
  1662. end;
  1663.  
  1664. function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
  1665. var
  1666.   Instance: TComponent;
  1667. begin
  1668.   Instance := nil;
  1669.   if InternalReadComponentRes(ResName, HInstance, Instance) then
  1670.     Result := Instance else
  1671.     raise EResNotFound.CreateFmt(SResNotFound, [ResName]);
  1672. end;
  1673.  
  1674. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  1675. var
  1676.   Stream: TStream;
  1677. begin
  1678.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  1679.   try
  1680.     Result := Stream.ReadComponentRes(Instance);
  1681.   finally
  1682.     Stream.Free;
  1683.   end;
  1684. end;
  1685.  
  1686. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  1687. var
  1688.   Stream: TStream;
  1689. begin
  1690.   Stream := TFileStream.Create(FileName, fmCreate);
  1691.   try
  1692.     Stream.WriteComponentRes(Instance.ClassName, Instance);
  1693.   finally
  1694.     Stream.Free;
  1695.   end;
  1696. end;
  1697.  
  1698. function CollectionsEqual(C1, C2: TCollection): Boolean;
  1699. var
  1700.   S1, S2: TMemoryStream;
  1701.  
  1702.   procedure WriteCollection(Stream: TStream; Collection: TCollection);
  1703.   var
  1704.     Writer: TWriter;
  1705.   begin
  1706.     Writer := TWriter.Create(Stream, 1024);
  1707.     try
  1708.       Writer.WriteCollection(Collection);
  1709.     finally
  1710.       Writer.Free;
  1711.     end;
  1712.   end;
  1713.  
  1714. begin
  1715.   Result := False;
  1716.   if C1.ClassType <> C2.ClassType then Exit;
  1717.   if C1.Count <> C2.Count then Exit;
  1718.   S1 := TMemoryStream.Create;
  1719.   try
  1720.     WriteCollection(S1, C1);
  1721.     S2 := TMemoryStream.Create;
  1722.     try
  1723.       WriteCollection(S2, C2);
  1724.       Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
  1725.     finally
  1726.       S2.Free;
  1727.     end;
  1728.   finally
  1729.     S1.Free;
  1730.   end;
  1731. end;
  1732.  
  1733. { Utility routines }
  1734.  
  1735. function LineStart(Buffer, BufPos: PChar): PChar; assembler;
  1736. asm
  1737.         PUSH    EDI
  1738.         MOV     EDI,EDX
  1739.         MOV     ECX,EDX
  1740.         SUB     ECX,EAX
  1741.         SUB     ECX,1
  1742.         JBE     @@1
  1743.         MOV     EDX,EAX
  1744.         DEC     EDI
  1745.         MOV     AL,0AH
  1746.         STD
  1747.         REPNE   SCASB
  1748.         CLD
  1749.         MOV     EAX,EDX
  1750.         JNE     @@1
  1751.         LEA     EAX,[EDI+2]
  1752. @@1:    POP     EDI
  1753. end;
  1754.  
  1755. function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  1756.   Strings: TStrings): Integer;
  1757. var
  1758.   Head, Tail: PChar;
  1759.   EOS, InQuote: Boolean;
  1760.   QuoteChar: Char;
  1761.   Item: string;
  1762. begin
  1763.   Result := 0;
  1764.   if (Content = nil) or (Content^=#0) or (Strings = nil) then Exit;
  1765.   Tail := Content;
  1766.   InQuote := False;
  1767.   QuoteChar := #0;
  1768.   Strings.BeginUpdate;
  1769.   try
  1770.     repeat
  1771.       while Tail^ in WhiteSpace + [#13, #10] do Inc(Tail);
  1772.       Head := Tail;
  1773.       while True do
  1774.       begin
  1775.         while (InQuote and not (Tail^ in ['''', '"', #0])) or
  1776.           not (Tail^ in Separators + [#0, #13, #10, '''', '"']) do Inc(Tail);
  1777.         if Tail^ in ['''', '"'] then
  1778.         begin
  1779.           if (QuoteChar <> #0) and (QuoteChar = Tail^) then
  1780.             QuoteChar := #0
  1781.           else QuoteChar := Tail^;
  1782.           InQuote := QuoteChar <> #0;
  1783.           Inc(Tail);
  1784.         end else Break;
  1785.       end;
  1786.       EOS := Tail^ = #0;
  1787.       if (Head <> Tail) and (Head^ <> #0) then
  1788.       begin
  1789.         if Strings <> nil then
  1790.         begin
  1791.           SetString(Item, Head, Tail - Head);
  1792.           Strings.Add(Item);
  1793.         end;
  1794.         Inc(Result);
  1795.       end;
  1796.       Inc(Tail);
  1797.     until EOS;
  1798.   finally
  1799.     Strings.EndUpdate;
  1800.   end;
  1801. end;
  1802.  
  1803. { TList }
  1804.  
  1805. destructor TList.Destroy;
  1806. begin
  1807.   Clear;
  1808. end;
  1809.  
  1810. function TList.Add(Item: Pointer): Integer;
  1811. begin
  1812.   Result := FCount;
  1813.   if Result = FCapacity then
  1814.     Grow;
  1815.   FList^[Result] := Item;
  1816.   Inc(FCount);
  1817.   if Item <> nil then
  1818.     Notify(Item, lnAdded);
  1819. end;
  1820.  
  1821. procedure TList.Clear;
  1822. begin
  1823.   SetCount(0);
  1824.   SetCapacity(0);
  1825. end;
  1826.  
  1827. procedure TList.Delete(Index: Integer);
  1828. var
  1829.   Temp: Pointer;
  1830. begin
  1831.   if (Index < 0) or (Index >= FCount) then
  1832.     Error(@SListIndexError, Index);
  1833.   Temp := Items[Index];
  1834.   Dec(FCount);
  1835.   if Index < FCount then
  1836.     System.Move(FList^[Index + 1], FList^[Index],
  1837.       (FCount - Index) * SizeOf(Pointer));
  1838.   if Temp <> nil then
  1839.     Notify(Temp, lnDeleted);
  1840. end;
  1841.  
  1842. class procedure TList.Error(const Msg: string; Data: Integer);
  1843.  
  1844.   function ReturnAddr: Pointer;
  1845.   asm
  1846.           MOV     EAX,[EBP+4]
  1847.   end;
  1848.  
  1849. begin
  1850.   raise EListError.CreateFmt(Msg, [Data]) at ReturnAddr;
  1851. end;
  1852.  
  1853. class procedure TList.Error(Msg: PResStringRec; Data: Integer);
  1854. begin
  1855.   TList.Error(LoadResString(Msg), Data);
  1856. end;
  1857.  
  1858. procedure TList.Exchange(Index1, Index2: Integer);
  1859. var
  1860.   Item: Pointer;
  1861. begin
  1862.   if (Index1 < 0) or (Index1 >= FCount) then
  1863.     Error(@SListIndexError, Index1);
  1864.   if (Index2 < 0) or (Index2 >= FCount) then
  1865.     Error(@SListIndexError, Index2);
  1866.   Item := FList^[Index1];
  1867.   FList^[Index1] := FList^[Index2];
  1868.   FList^[Index2] := Item;
  1869. end;
  1870.  
  1871. function TList.Expand: TList;
  1872. begin
  1873.   if FCount = FCapacity then
  1874.     Grow;
  1875.   Result := Self;
  1876. end;
  1877.  
  1878. function TList.First: Pointer;
  1879. begin
  1880.   Result := Get(0);
  1881. end;
  1882.  
  1883. function TList.Get(Index: Integer): Pointer;
  1884. begin
  1885.   if (Index < 0) or (Index >= FCount) then
  1886.     Error(@SListIndexError, Index);
  1887.   Result := FList^[Index];
  1888. end;
  1889.  
  1890. procedure TList.Grow;
  1891. var
  1892.   Delta: Integer;
  1893. begin
  1894.   if FCapacity > 64 then
  1895.     Delta := FCapacity div 4
  1896.   else
  1897.     if FCapacity > 8 then
  1898.       Delta := 16
  1899.     else
  1900.       Delta := 4;
  1901.   SetCapacity(FCapacity + Delta);
  1902. end;
  1903.  
  1904. function TList.IndexOf(Item: Pointer): Integer;
  1905. begin
  1906.   Result := 0;
  1907.   while (Result < FCount) and (FList^[Result] <> Item) do
  1908.     Inc(Result);
  1909.   if Result = FCount then
  1910.     Result := -1;
  1911. end;
  1912.  
  1913. procedure TList.Insert(Index: Integer; Item: Pointer);
  1914. begin
  1915.   if (Index < 0) or (Index > FCount) then
  1916.     Error(@SListIndexError, Index);
  1917.   if FCount = FCapacity then
  1918.     Grow;
  1919.   if Index < FCount then
  1920.     System.Move(FList^[Index], FList^[Index + 1],
  1921.       (FCount - Index) * SizeOf(Pointer));
  1922.   FList^[Index] := Item;
  1923.   Inc(FCount);
  1924.   if Item <> nil then
  1925.     Notify(Item, lnAdded);
  1926. end;
  1927.  
  1928. function TList.Last: Pointer;
  1929. begin
  1930.   Result := Get(FCount - 1);
  1931. end;
  1932.  
  1933. procedure TList.Move(CurIndex, NewIndex: Integer);
  1934. var
  1935.   Item: Pointer;
  1936. begin
  1937.   if CurIndex <> NewIndex then
  1938.   begin
  1939.     if (NewIndex < 0) or (NewIndex >= FCount) then
  1940.       Error(@SListIndexError, NewIndex);
  1941.     Item := Get(CurIndex);
  1942.     FList^[CurIndex] := nil;
  1943.     Delete(CurIndex);
  1944.     Insert(NewIndex, nil);
  1945.     FList^[NewIndex] := Item;
  1946.   end;
  1947. end;
  1948.  
  1949. procedure TList.Put(Index: Integer; Item: Pointer);
  1950. var
  1951.   Temp: Pointer;
  1952. begin
  1953.   if (Index < 0) or (Index >= FCount) then
  1954.     Error(@SListIndexError, Index);
  1955.   Temp := FList^[Index];
  1956.   FList^[Index] := Item;
  1957.   if Temp <> nil then
  1958.     Notify(Item, lnDeleted);
  1959.   if Item <> nil then
  1960.     Notify(Item, lnAdded);
  1961. end;
  1962.  
  1963. function TList.Remove(Item: Pointer): Integer;
  1964. begin
  1965.   Result := IndexOf(Item);
  1966.   if Result >= 0 then
  1967.     Delete(Result);
  1968. end;
  1969.  
  1970. procedure TList.Pack;
  1971. var
  1972.   I: Integer;
  1973. begin
  1974.   for I := FCount - 1 downto 0 do
  1975.     if Items[I] = nil then
  1976.       Delete(I);
  1977. end;
  1978.  
  1979. procedure TList.SetCapacity(NewCapacity: Integer);
  1980. begin
  1981.   if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then
  1982.     Error(@SListCapacityError, NewCapacity);
  1983.   if NewCapacity <> FCapacity then
  1984.   begin
  1985.     ReallocMem(FList, NewCapacity * SizeOf(Pointer));
  1986.     FCapacity := NewCapacity;
  1987.   end;
  1988. end;
  1989.  
  1990. procedure TList.SetCount(NewCount: Integer);
  1991. var
  1992.   I: Integer;
  1993. begin
  1994.   if (NewCount < 0) or (NewCount > MaxListSize) then
  1995.     Error(@SListCountError, NewCount);
  1996.   if NewCount > FCapacity then
  1997.     SetCapacity(NewCount);
  1998.   if NewCount > FCount then
  1999.     FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0)
  2000.   else
  2001.     for I := FCount - 1 downto NewCount do
  2002.       Delete(I);
  2003.   FCount := NewCount;
  2004. end;
  2005.  
  2006. procedure QuickSort(SortList: PPointerList; L, R: Integer;
  2007.   SCompare: TListSortCompare);
  2008. var
  2009.   I, J: Integer;
  2010.   P, T: Pointer;
  2011. begin
  2012.   repeat
  2013.     I := L;
  2014.     J := R;
  2015.     P := SortList^[(L + R) shr 1];
  2016.     repeat
  2017.       while SCompare(SortList^[I], P) < 0 do
  2018.         Inc(I);
  2019.       while SCompare(SortList^[J], P) > 0 do
  2020.         Dec(J);
  2021.       if I <= J then
  2022.       begin
  2023.         T := SortList^[I];
  2024.         SortList^[I] := SortList^[J];
  2025.         SortList^[J] := T;
  2026.         Inc(I);
  2027.         Dec(J);
  2028.       end;
  2029.     until I > J;
  2030.     if L < J then
  2031.       QuickSort(SortList, L, J, SCompare);
  2032.     L := I;
  2033.   until I >= R;
  2034. end;
  2035.  
  2036. procedure TList.Sort(Compare: TListSortCompare);
  2037. begin
  2038.   if (FList <> nil) and (Count > 0) then
  2039.     QuickSort(FList, 0, Count - 1, Compare);
  2040. end;
  2041.  
  2042. function TList.Extract(Item: Pointer): Pointer;
  2043. var
  2044.   I: Integer;
  2045. begin
  2046.   Result := nil;
  2047.   I := IndexOf(Item);
  2048.   if I >= 0 then
  2049.   begin
  2050.     Result := Item;
  2051.     FList^[I] := nil;
  2052.     Delete(I);
  2053.     Notify(Result, lnExtracted);
  2054.   end;
  2055. end;
  2056.  
  2057. procedure TList.Notify(Ptr: Pointer; Action: TListNotification);
  2058. begin
  2059. end;
  2060.  
  2061. { TThreadList }
  2062.  
  2063. constructor TThreadList.Create;
  2064. begin
  2065.   inherited Create;
  2066.   InitializeCriticalSection(FLock);
  2067.   FList := TList.Create;
  2068.   FDuplicates := dupIgnore;
  2069. end;
  2070.  
  2071. destructor TThreadList.Destroy;
  2072. begin
  2073.   LockList;    // Make sure nobody else is inside the list.
  2074.   try
  2075.     FList.Free;
  2076.     inherited Destroy;
  2077.   finally
  2078.     UnlockList;
  2079.     DeleteCriticalSection(FLock);
  2080.   end;
  2081. end;
  2082.  
  2083. procedure TThreadList.Add(Item: Pointer);
  2084. begin
  2085.   LockList;
  2086.   try
  2087.     if (Duplicates = dupAccept) or
  2088.        (FList.IndexOf(Item) = -1) then
  2089.       FList.Add(Item)
  2090.     else if Duplicates = dupError then
  2091.       FList.Error(@SDuplicateItem, Integer(Item));
  2092.   finally
  2093.     UnlockList;
  2094.   end;
  2095. end;
  2096.  
  2097. procedure TThreadList.Clear;
  2098. begin
  2099.   LockList;
  2100.   try
  2101.     FList.Clear;
  2102.   finally
  2103.     UnlockList;
  2104.   end;
  2105. end;
  2106.  
  2107. function  TThreadList.LockList: TList;
  2108. begin
  2109.   EnterCriticalSection(FLock);
  2110.   Result := FList;
  2111. end;
  2112.  
  2113. procedure TThreadList.Remove(Item: Pointer);
  2114. begin
  2115.   LockList;
  2116.   try
  2117.     FList.Remove(Item);
  2118.   finally
  2119.     UnlockList;
  2120.   end;
  2121. end;
  2122.  
  2123. procedure TThreadList.UnlockList;
  2124. begin
  2125.   LeaveCriticalSection(FLock);
  2126. end;
  2127.  
  2128. { TInterfaceList }
  2129.  
  2130. constructor TInterfaceList.Create;
  2131. begin
  2132.   inherited Create;
  2133.   FList := TThreadList.Create;
  2134. end;
  2135.  
  2136. destructor TInterfaceList.Destroy;
  2137. begin
  2138.   Clear;
  2139.   FList.Free;
  2140.   inherited Destroy;
  2141. end;
  2142.  
  2143. procedure TInterfaceList.Clear;
  2144. var
  2145.   I: Integer;
  2146. begin
  2147.   if FList <> nil then
  2148.   begin
  2149.     with FList.LockList do
  2150.     try
  2151.       for I := 0 to Count - 1 do
  2152.         IUnknown(List[I]) := nil;
  2153.       Clear;
  2154.     finally
  2155.       Self.FList.UnlockList;
  2156.     end;
  2157.   end;
  2158. end;
  2159.  
  2160. procedure TInterfaceList.Delete(Index: Integer);
  2161. begin
  2162.   with FList.LockList do
  2163.   try
  2164.     Self.Put(Index, nil);
  2165.     Delete(Index);
  2166.   finally
  2167.     Self.FList.UnlockList;
  2168.   end;
  2169. end;
  2170.  
  2171. function TInterfaceList.Expand: TInterfaceList;
  2172. begin
  2173.   with FList.LockList do
  2174.   try
  2175.     Expand;
  2176.     Result := Self;
  2177.   finally
  2178.     Self.FList.Unlocklist;
  2179.   end;
  2180. end;
  2181.  
  2182. function TInterfaceList.First: IUnknown;
  2183. begin
  2184.   Result := Get(0);
  2185. end;
  2186.  
  2187. function TInterfaceList.Get(Index: Integer): IUnknown;
  2188. begin
  2189.   with FList.LockList do
  2190.   try
  2191.     if (Index < 0) or (Index >= Count) then Error(@SListIndexError, Index);
  2192.     Result := IUnknown(List[Index]);
  2193.   finally
  2194.     Self.FList.UnlockList;
  2195.   end;
  2196. end;
  2197.  
  2198. function TInterfaceList.GetCapacity: Integer;
  2199. begin
  2200.   with FList.LockList do
  2201.   try
  2202.     Result := Capacity;
  2203.   finally
  2204.     Self.FList.UnlockList;
  2205.   end;
  2206. end;
  2207.  
  2208. function TInterfaceList.GetCount: Integer;
  2209. begin
  2210.   with FList.LockList do
  2211.   try
  2212.     Result := Count;
  2213.   finally
  2214.     Self.FList.UnlockList;
  2215.   end;
  2216. end;
  2217.  
  2218. function TInterfaceList.IndexOf(Item: IUnknown): Integer;
  2219. begin
  2220.   with FList.LockList do
  2221.   try
  2222.     Result := IndexOf(Pointer(Item));
  2223.   finally
  2224.     Self.FList.UnlockList;
  2225.   end;
  2226. end;
  2227.  
  2228. function TInterfaceList.Add(Item: IUnknown): Integer;
  2229. begin
  2230.   with FList.LockList do
  2231.   try
  2232.     Result := Add(nil);
  2233.     IUnknown(List[Result]) := Item;
  2234.   finally
  2235.     Self.FList.UnlockList;
  2236.   end;
  2237. end;
  2238.  
  2239. procedure TInterfaceList.Insert(Index: Integer; Item: IUnknown);
  2240. begin
  2241.   with FList.LockList do
  2242.   try
  2243.     Insert(Index, nil);
  2244.     IUnknown(List[Index]) := Item;
  2245.   finally
  2246.     Self.FList.UnlockList;
  2247.   end;
  2248. end;
  2249.  
  2250. function TInterfaceList.Last: IUnknown;
  2251. begin
  2252.   with FList.LockList do
  2253.   try
  2254.     Result := Self.Get(Count - 1);
  2255.   finally
  2256.     Self.FList.UnlockList;
  2257.   end;
  2258. end;
  2259.  
  2260. procedure TInterfaceList.Put(Index: Integer; Item: IUnknown);
  2261. begin
  2262.   with FList.LockList do
  2263.   try
  2264.     if (Index < 0) or (Index >= Count) then Error(@SListIndexError, Index);
  2265.     IUnknown(List[Index]) := Item;
  2266.   finally
  2267.     Self.FList.UnlockList;
  2268.   end;
  2269. end;
  2270.  
  2271. function TInterfaceList.Remove(Item: IUnknown): Integer;
  2272. begin
  2273.   with FList.LockList do
  2274.   try
  2275.     Result := IndexOf(Pointer(Item));
  2276.     if Result > -1 then
  2277.     begin
  2278.       IUnknown(List[Result]) := nil;
  2279.       Delete(Result);
  2280.     end;
  2281.   finally
  2282.     Self.FList.UnlockList;
  2283.   end;
  2284. end;
  2285.  
  2286. procedure TInterfaceList.SetCapacity(NewCapacity: Integer);
  2287. begin
  2288.   with FList.LockList do
  2289.   try
  2290.     Capacity := NewCapacity;
  2291.   finally
  2292.     Self.FList.UnlockList;
  2293.   end;
  2294. end;
  2295.  
  2296. procedure TInterfaceList.SetCount(NewCount: Integer);
  2297. begin
  2298.   with FList.LockList do
  2299.   try
  2300.     Count := NewCount;
  2301.   finally
  2302.     Self.FList.UnlockList;
  2303.   end;
  2304. end;
  2305.  
  2306. procedure TInterfaceList.Exchange(Index1, Index2: Integer);
  2307. begin
  2308.   with FList.LockList do
  2309.   try
  2310.     Exchange(Index1, Index2);
  2311.   finally
  2312.     Self.FList.UnlockList;
  2313.   end;
  2314. end;
  2315.  
  2316. procedure TInterfaceList.Lock;
  2317. begin
  2318.   FList.LockList;
  2319. end;
  2320.  
  2321. procedure TInterfaceList.Unlock;
  2322. begin
  2323.   FList.UnlockList;
  2324. end;
  2325.  
  2326. { TBits }
  2327.  
  2328. const
  2329.   BitsPerInt = SizeOf(Integer) * 8;
  2330.  
  2331. type
  2332.   TBitEnum = 0..BitsPerInt - 1;
  2333.   TBitSet = set of TBitEnum;
  2334.   PBitArray = ^TBitArray;
  2335.   TBitArray = array[0..4096] of TBitSet;
  2336.  
  2337. destructor TBits.Destroy;
  2338. begin
  2339.   SetSize(0);
  2340.   inherited Destroy;
  2341. end;
  2342.  
  2343. procedure TBits.Error;
  2344. begin
  2345.   raise EBitsError.CreateRes(@SBitsIndexError);
  2346. end;
  2347.  
  2348. procedure TBits.SetSize(Value: Integer);
  2349. var
  2350.   NewMem: Pointer;
  2351.   NewMemSize: Integer;
  2352.   OldMemSize: Integer;
  2353.  
  2354.   function Min(X, Y: Integer): Integer;
  2355.   begin
  2356.     Result := X;
  2357.     if X > Y then Result := Y;
  2358.   end;
  2359.  
  2360. begin
  2361.   if Value <> Size then
  2362.   begin
  2363.     if Value < 0 then Error;
  2364.     NewMemSize := ((Value + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  2365.     OldMemSize := ((Size + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer);
  2366.     if NewMemSize <> OldMemSize then
  2367.     begin
  2368.       NewMem := nil;
  2369.       if NewMemSize <> 0 then
  2370.       begin
  2371.         GetMem(NewMem, NewMemSize);
  2372.         FillChar(NewMem^, NewMemSize, 0);
  2373.       end;
  2374.       if OldMemSize <> 0 then
  2375.       begin
  2376.         if NewMem <> nil then
  2377.           Move(FBits^, NewMem^, Min(OldMemSize, NewMemSize));
  2378.         FreeMem(FBits, OldMemSize);
  2379.       end;
  2380.       FBits := NewMem;
  2381.     end;
  2382.     FSize := Value;
  2383.   end;
  2384. end;
  2385.  
  2386. procedure TBits.SetBit(Index: Integer; Value: Boolean); assembler;
  2387. asm
  2388.         CMP     Index,[EAX].FSize
  2389.         JAE     @@Size
  2390.  
  2391. @@1:    MOV     EAX,[EAX].FBits
  2392.         OR      Value,Value
  2393.         JZ      @@2
  2394.         BTS     [EAX],Index
  2395.         RET
  2396.  
  2397. @@2:    BTR     [EAX],Index
  2398.         RET
  2399.  
  2400. @@Size: CMP     Index,0
  2401.         JL      TBits.Error
  2402.         PUSH    Self
  2403.         PUSH    Index
  2404.         PUSH    ECX {Value}
  2405.         INC     Index
  2406.         CALL    TBits.SetSize
  2407.         POP     ECX {Value}
  2408.         POP     Index
  2409.         POP     Self
  2410.         JMP     @@1
  2411. end;
  2412.  
  2413. function TBits.GetBit(Index: Integer): Boolean; assembler;
  2414. asm
  2415.         CMP     Index,[EAX].FSize
  2416.         JAE     TBits.Error
  2417.         MOV     EAX,[EAX].FBits
  2418.         BT      [EAX],Index
  2419.         SBB     EAX,EAX
  2420.         AND     EAX,1
  2421. end;
  2422.  
  2423. function TBits.OpenBit: Integer;
  2424. var
  2425.   I: Integer;
  2426.   B: TBitSet;
  2427.   J: TBitEnum;
  2428.   E: Integer;
  2429. begin
  2430.   E := (Size + BitsPerInt - 1) div BitsPerInt - 1;
  2431.   for I := 0 to E do
  2432.     if PBitArray(FBits)^[I] <> [0..BitsPerInt - 1] then
  2433.     begin
  2434.       B := PBitArray(FBits)^[I];
  2435.       for J := Low(J) to High(J) do
  2436.       begin
  2437.         if not (J in B) then
  2438.         begin
  2439.           Result := I * BitsPerInt + J;
  2440.           if Result >= Size then Result := Size;
  2441.           Exit;
  2442.         end;
  2443.       end;
  2444.     end;
  2445.   Result := Size;
  2446. end;
  2447.  
  2448. { TPersistent }
  2449.  
  2450. destructor TPersistent.Destroy;
  2451. begin
  2452.   RemoveFixups(Self);
  2453.   inherited Destroy;
  2454. end;
  2455.  
  2456. procedure TPersistent.Assign(Source: TPersistent);
  2457. begin
  2458.   if Source <> nil then Source.AssignTo(Self) else AssignError(nil);
  2459. end;
  2460.  
  2461. procedure TPersistent.AssignError(Source: TPersistent);
  2462. var
  2463.   SourceName: string;
  2464. begin
  2465.   if Source <> nil then
  2466.     SourceName := Source.ClassName else
  2467.     SourceName := 'nil';
  2468.   raise EConvertError.CreateResFmt(@SAssignError, [SourceName, ClassName]);
  2469. end;
  2470.  
  2471. procedure TPersistent.AssignTo(Dest: TPersistent);
  2472. begin
  2473.   Dest.AssignError(Self);
  2474. end;
  2475.  
  2476. procedure TPersistent.DefineProperties(Filer: TFiler);
  2477. begin
  2478. end;
  2479.  
  2480. function TPersistent.GetNamePath: string;
  2481. var
  2482.   S: string;
  2483. begin
  2484.   Result := ClassName;
  2485.   if (GetOwner <> nil) then
  2486.   begin
  2487.     S := GetOwner.GetNamePath;
  2488.     if S <> '' then
  2489.       Result := S + '.' + Result;
  2490.   end;
  2491. end;
  2492.  
  2493. function TPersistent.GetOwner: TPersistent;
  2494. begin
  2495.   Result := nil;
  2496. end;
  2497.  
  2498. { TCollectionItem }
  2499.  
  2500. constructor TCollectionItem.Create(Collection: TCollection);
  2501. begin
  2502.   SetCollection(Collection);
  2503. end;
  2504.  
  2505. destructor TCollectionItem.Destroy;
  2506. begin
  2507.   SetCollection(nil);
  2508.   inherited Destroy;
  2509. end;
  2510.  
  2511. procedure TCollectionItem.Changed(AllItems: Boolean);
  2512. var
  2513.   Item: TCollectionItem;
  2514. begin
  2515.   if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then
  2516.   begin
  2517.     if AllItems then Item := nil else Item := Self;
  2518.     FCollection.Update(Item);
  2519.   end;
  2520. end;
  2521.  
  2522. function TCollectionItem.GetIndex: Integer;
  2523. begin
  2524.   if FCollection <> nil then
  2525.     Result := FCollection.FItems.IndexOf(Self) else
  2526.     Result := -1;
  2527. end;
  2528.  
  2529. function TCollectionItem.GetDisplayName: string;
  2530. begin
  2531.   Result := ClassName;
  2532. end;
  2533.  
  2534. function TCollectionItem.GetNamePath: string;
  2535. begin
  2536.   if FCollection <> nil then
  2537.     Result := Format('%s[%d]',[FCollection.GetNamePath, Index])
  2538.   else
  2539.     Result := ClassName;
  2540. end;
  2541.  
  2542. function TCollectionItem.GetOwner: TPersistent;
  2543. begin
  2544.   Result := FCollection;
  2545. end;
  2546.  
  2547. procedure TCollectionItem.SetCollection(Value: TCollection);
  2548. begin
  2549.   if FCollection <> Value then
  2550.   begin
  2551.     if FCollection <> nil then FCollection.RemoveItem(Self);
  2552.     if Value <> nil then Value.InsertItem(Self);
  2553.   end;
  2554. end;
  2555.  
  2556. procedure TCollectionItem.SetDisplayName(const Value: string);
  2557. begin
  2558.   Changed(False);
  2559. end;
  2560.  
  2561. procedure TCollectionItem.SetIndex(Value: Integer);
  2562. var
  2563.   CurIndex: Integer;
  2564. begin
  2565.   CurIndex := GetIndex;
  2566.   if (CurIndex >= 0) and (CurIndex <> Value) then
  2567.   begin
  2568.     FCollection.FItems.Move(CurIndex, Value);
  2569.     Changed(True);
  2570.   end;
  2571. end;
  2572.  
  2573. { TCollection }
  2574.  
  2575. constructor TCollection.Create(ItemClass: TCollectionItemClass);
  2576. begin
  2577.   FItemClass := ItemClass;
  2578.   FItems := TList.Create;
  2579. end;
  2580.  
  2581. destructor TCollection.Destroy;
  2582. begin
  2583.   FUpdateCount := 1;
  2584.   if FItems <> nil then Clear;
  2585.   FItems.Free;
  2586.   inherited Destroy;
  2587. end;
  2588.  
  2589. function TCollection.Add: TCollectionItem;
  2590. begin
  2591.   Result := FItemClass.Create(Self);
  2592. end;
  2593.  
  2594. procedure TCollection.Assign(Source: TPersistent);
  2595. var
  2596.   I: Integer;
  2597. begin
  2598.   if Source is TCollection then
  2599.   begin
  2600.     BeginUpdate;
  2601.     try
  2602.       Clear;
  2603.       for I := 0 to TCollection(Source).Count - 1 do
  2604.         Add.Assign(TCollection(Source).Items[I]);
  2605.     finally
  2606.       EndUpdate;
  2607.     end;
  2608.     Exit;
  2609.   end;
  2610.   inherited Assign(Source);
  2611. end;
  2612.  
  2613. procedure TCollection.BeginUpdate;
  2614. begin
  2615.   Inc(FUpdateCount);
  2616. end;
  2617.  
  2618. procedure TCollection.Changed;
  2619. begin
  2620.   if FUpdateCount = 0 then Update(nil);
  2621. end;
  2622.  
  2623. procedure TCollection.Clear;
  2624. begin
  2625.   if FItems.Count > 0 then
  2626.   begin
  2627.     BeginUpdate;
  2628.     try
  2629.       while FItems.Count > 0 do TCollectionItem(FItems.Last).Free;
  2630.     finally
  2631.       EndUpdate;
  2632.     end;
  2633.   end;
  2634. end;
  2635.  
  2636. procedure TCollection.EndUpdate;
  2637. begin
  2638.   Dec(FUpdateCount);
  2639.   Changed;
  2640. end;
  2641.  
  2642. function TCollection.FindItemID(ID: Integer): TCollectionItem;
  2643. var
  2644.   I: Integer;
  2645. begin
  2646.   for I := 0 to FItems.Count-1 do
  2647.   begin
  2648.     Result := TCollectionItem(FItems[I]);
  2649.     if Result.ID = ID then Exit;
  2650.   end;
  2651.   Result := nil;
  2652. end;
  2653.  
  2654. function TCollection.GetAttrCount: Integer;
  2655. begin
  2656.   Result := 0;
  2657. end;
  2658.  
  2659. function TCollection.GetAttr(Index: Integer): string;
  2660. begin
  2661.   Result := '';
  2662. end;
  2663.  
  2664. function TCollection.GetItemAttr(Index, ItemIndex: Integer): string;
  2665. begin
  2666.   Result := Items[ItemIndex].DisplayName;
  2667. end;
  2668.  
  2669. function TCollection.GetCount: Integer;
  2670. begin
  2671.   Result := FItems.Count;
  2672. end;
  2673.  
  2674. function TCollection.GetItem(Index: Integer): TCollectionItem;
  2675. begin
  2676.   Result := FItems[Index];
  2677. end;
  2678.  
  2679. function TCollection.GetNamePath: string;
  2680. var
  2681.   S, P: string;
  2682. begin
  2683.   Result := ClassName;
  2684.   if GetOwner = nil then Exit;
  2685.   S := GetOwner.GetNamePath;
  2686.   if S = '' then Exit;
  2687.   P := PropName;
  2688.   if P = '' then Exit;
  2689.   Result := S + '.' + P;
  2690. end;
  2691.  
  2692. function TCollection.GetPropName: string;
  2693. var
  2694.   I: Integer;
  2695.   Props: PPropList;
  2696.   TypeData: PTypeData;
  2697.   Owner: TPersistent;
  2698. begin
  2699.   Result := FPropName;
  2700.   Owner := GetOwner;
  2701.   if (Result <> '') or (Owner = nil) or (Owner.ClassInfo = nil) then Exit;
  2702.   TypeData := GetTypeData(Owner.ClassInfo);
  2703.   if (TypeData = nil) or (TypeData^.PropCount = 0) then Exit;
  2704.   GetMem(Props, TypeData^.PropCount * sizeof(Pointer));
  2705.   try
  2706.     GetPropInfos(Owner.ClassInfo, Props);
  2707.     for I := 0 to TypeData^.PropCount-1 do
  2708.     begin
  2709.       with Props^[I]^ do
  2710.         if (PropType^^.Kind = tkClass) and
  2711.           (GetOrdProp(Owner, Props^[I]) = Integer(Self)) then
  2712.           FPropName := Name;
  2713.     end;
  2714.   finally
  2715.     Freemem(Props);
  2716.   end;
  2717.   Result := FPropName;
  2718. end;
  2719.  
  2720. function TCollection.Insert(Index: Integer): TCollectionItem;
  2721. begin
  2722.   Result := Add;
  2723.   Result.Index := Index;
  2724. end;
  2725.  
  2726. // Out param is more code efficient for interfaces than function result
  2727. procedure GetDesigner(Obj: TPersistent; out Result: IDesignerNotify);
  2728. var
  2729.   Temp: TPersistent;
  2730. begin
  2731.   Result := nil;
  2732.   if Obj = nil then Exit;
  2733.   Temp := Obj.GetOwner;
  2734.   if Temp = nil then
  2735.   begin
  2736.     if (Obj is TComponent) and (csDesigning in TComponent(Obj).ComponentState) then
  2737.       TComponent(Obj).QueryInterface(IDesignerNotify, Result);
  2738.   end
  2739.   else
  2740.   begin
  2741.     if (Obj is TComponent) and
  2742.       not (csDesigning in TComponent(Obj).ComponentState) then Exit;
  2743.     GetDesigner(Temp, Result);
  2744.   end;
  2745. end;
  2746.  
  2747. function FindRootDesigner(Obj: TPersistent): IDesignerNotify;
  2748. begin
  2749.   GetDesigner(Obj, Result);
  2750. end;
  2751.  
  2752. procedure NotifyDesigner(Self, Item: TPersistent; Operation: TOperation);
  2753. var
  2754.   Designer: IDesignerNotify;
  2755. begin
  2756.   GetDesigner(Self, Designer);
  2757.   if Designer <> nil then
  2758.     Designer.Notification(Item, Operation);
  2759. end;
  2760.  
  2761. procedure TCollection.InsertItem(Item: TCollectionItem);
  2762. begin
  2763.   if not (Item is FItemClass) then TList.Error(@SInvalidProperty, 0);
  2764.   FItems.Add(Item);
  2765.   Item.FCollection := Self;
  2766.   Item.FID := FNextID;
  2767.   Inc(FNextID);
  2768.   SetItemName(Item);
  2769.   Changed;
  2770.   NotifyDesigner(Self, Item, opInsert);
  2771. end;
  2772.  
  2773. procedure TCollection.RemoveItem(Item: TCollectionItem);
  2774. begin
  2775.   NotifyDesigner(Self, Item, opRemove);
  2776.   FItems.Remove(Item);
  2777.   Item.FCollection := nil;
  2778.   Changed;
  2779. end;
  2780.  
  2781. procedure TCollection.SetItem(Index: Integer; Value: TCollectionItem);
  2782. begin
  2783.   TCollectionItem(FItems[Index]).Assign(Value);
  2784. end;
  2785.  
  2786. procedure TCollection.SetItemName(Item: TCollectionItem);
  2787. begin
  2788. end;
  2789.  
  2790. procedure TCollection.Update(Item: TCollectionItem);
  2791. begin
  2792. end;
  2793.  
  2794. procedure TCollection.Delete(Index: Integer);
  2795. begin
  2796.   TCollectionItem(FItems[Index]).Free;
  2797. end;
  2798.  
  2799. { TOwnedCollection }
  2800.  
  2801. constructor TOwnedCollection.Create(AOwner: TPersistent;
  2802.   ItemClass: TCollectionItemClass);
  2803. begin
  2804.   FOwner := AOwner;
  2805.   inherited Create(ItemClass);
  2806. end;
  2807.  
  2808. function TOwnedCollection.GetOwner: TPersistent;
  2809. begin
  2810.   Result := FOwner;
  2811. end;
  2812.  
  2813. { TStrings }
  2814.  
  2815. destructor TStrings.Destroy;
  2816. begin
  2817.   StringsAdapter := nil;
  2818.   inherited Destroy;
  2819. end;
  2820.  
  2821. function TStrings.Add(const S: string): Integer;
  2822. begin
  2823.   Result := GetCount;
  2824.   Insert(Result, S);
  2825. end;
  2826.  
  2827. function TStrings.AddObject(const S: string; AObject: TObject): Integer;
  2828. begin
  2829.   Result := Add(S);
  2830.   PutObject(Result, AObject);
  2831. end;
  2832.  
  2833. procedure TStrings.Append(const S: string);
  2834. begin
  2835.   Add(S);
  2836. end;
  2837.  
  2838. procedure TStrings.AddStrings(Strings: TStrings);
  2839. var
  2840.   I: Integer;
  2841. begin
  2842.   BeginUpdate;
  2843.   try
  2844.     for I := 0 to Strings.Count - 1 do
  2845.       AddObject(Strings[I], Strings.Objects[I]);
  2846.   finally
  2847.     EndUpdate;
  2848.   end;
  2849. end;
  2850.  
  2851. procedure TStrings.Assign(Source: TPersistent);
  2852. begin
  2853.   if Source is TStrings then
  2854.   begin
  2855.     BeginUpdate;
  2856.     try
  2857.       Clear;
  2858.       AddStrings(TStrings(Source));
  2859.     finally
  2860.       EndUpdate;
  2861.     end;
  2862.     Exit;
  2863.   end;
  2864.   inherited Assign(Source);
  2865. end;
  2866.  
  2867. procedure TStrings.BeginUpdate;
  2868. begin
  2869.   if FUpdateCount = 0 then SetUpdateState(True);
  2870.   Inc(FUpdateCount);
  2871. end;
  2872.  
  2873. procedure TStrings.DefineProperties(Filer: TFiler);
  2874.  
  2875.   function DoWrite: Boolean;
  2876.   begin
  2877.     if Filer.Ancestor <> nil then
  2878.     begin
  2879.       Result := True;
  2880.       if Filer.Ancestor is TStrings then
  2881.         Result := not Equals(TStrings(Filer.Ancestor))
  2882.     end
  2883.     else Result := Count > 0;
  2884.   end;
  2885.  
  2886. begin
  2887.   Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite);
  2888. end;
  2889.  
  2890. procedure TStrings.EndUpdate;
  2891. begin
  2892.   Dec(FUpdateCount);
  2893.   if FUpdateCount = 0 then SetUpdateState(False);
  2894. end;
  2895.  
  2896. function TStrings.Equals(Strings: TStrings): Boolean;
  2897. var
  2898.   I, Count: Integer;
  2899. begin
  2900.   Result := False;
  2901.   Count := GetCount;
  2902.   if Count <> Strings.GetCount then Exit;
  2903.   for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit;
  2904.   Result := True;
  2905. end;
  2906.  
  2907. procedure TStrings.Error(const Msg: string; Data: Integer);
  2908.  
  2909.   function ReturnAddr: Pointer;
  2910.   asm
  2911.           MOV     EAX,[EBP+4]
  2912.   end;
  2913.  
  2914. begin
  2915.   raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr;
  2916. end;
  2917.  
  2918. procedure TStrings.Error(Msg: PResStringRec; Data: Integer);
  2919. begin
  2920.   Error(LoadResString(Msg), Data);
  2921. end;
  2922.  
  2923. procedure TStrings.Exchange(Index1, Index2: Integer);
  2924. var
  2925.   TempObject: TObject;
  2926.   TempString: string;
  2927. begin
  2928.   BeginUpdate;
  2929.   try
  2930.     TempString := Strings[Index1];
  2931.     TempObject := Objects[Index1];
  2932.     Strings[Index1] := Strings[Index2];
  2933.     Objects[Index1] := Objects[Index2];
  2934.     Strings[Index2] := TempString;
  2935.     Objects[Index2] := TempObject;
  2936.   finally
  2937.     EndUpdate;
  2938.   end;
  2939. end;
  2940.  
  2941. function TStrings.GetCapacity: Integer;
  2942. begin  // descendants may optionally override/replace this default implementation
  2943.   Result := Count;
  2944. end;
  2945.  
  2946. function TStrings.GetCommaText: string;
  2947. var
  2948.   S: string;
  2949.   P: PChar;
  2950.   I, Count: Integer;
  2951. begin
  2952.   Count := GetCount;
  2953.   if (Count = 1) and (Get(0) = '') then
  2954.     Result := '""'
  2955.   else
  2956.   begin
  2957.     Result := '';
  2958.     for I := 0 to Count - 1 do
  2959.     begin
  2960.       S := Get(I);
  2961.       P := PChar(S);
  2962.       while not (P^ in [#0..' ','"',',']) do P := CharNext(P);
  2963.       if (P^ <> #0) then S := AnsiQuotedStr(S, '"');
  2964.       Result := Result + S + ',';
  2965.     end;
  2966.     System.Delete(Result, Length(Result), 1);
  2967.   end;
  2968. end;
  2969.  
  2970. function TStrings.GetName(Index: Integer): string;
  2971. var
  2972.   P: Integer;
  2973. begin
  2974.   Result := Get(Index);
  2975.   P := AnsiPos('=', Result);
  2976.   if P <> 0 then
  2977.     SetLength(Result, P-1) else
  2978.     SetLength(Result, 0);
  2979. end;
  2980.  
  2981. function TStrings.GetObject(Index: Integer): TObject;
  2982. begin
  2983.   Result := nil;
  2984. end;
  2985.  
  2986. function TStrings.GetText: PChar;
  2987. begin
  2988.   Result := StrNew(PChar(GetTextStr));
  2989. end;
  2990.  
  2991. function TStrings.GetTextStr: string;
  2992. var
  2993.   I, L, Size, Count: Integer;
  2994.   P: PChar;
  2995.   S: string;
  2996. begin
  2997.   Count := GetCount;
  2998.   Size := 0;
  2999.   for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + 2);
  3000.   SetString(Result, nil, Size);
  3001.   P := Pointer(Result);
  3002.   for I := 0 to Count - 1 do
  3003.   begin
  3004.     S := Get(I);
  3005.     L := Length(S);
  3006.     if L <> 0 then
  3007.     begin
  3008.       System.Move(Pointer(S)^, P^, L);
  3009.       Inc(P, L);
  3010.     end;
  3011.     P^ := #13;
  3012.     Inc(P);
  3013.     P^ := #10;
  3014.     Inc(P);
  3015.   end;
  3016. end;
  3017.  
  3018. function TStrings.GetValue(const Name: string): string;
  3019. var
  3020.   I: Integer;
  3021. begin
  3022.   I := IndexOfName(Name);
  3023.   if I >= 0 then
  3024.     Result := Copy(Get(I), Length(Name) + 2, MaxInt) else
  3025.     Result := '';
  3026. end;
  3027.  
  3028. function TStrings.IndexOf(const S: string): Integer;
  3029. begin
  3030.   for Result := 0 to GetCount - 1 do
  3031.     if AnsiCompareText(Get(Result), S) = 0 then Exit;
  3032.   Result := -1;
  3033. end;
  3034.  
  3035. function TStrings.IndexOfName(const Name: string): Integer;
  3036. var
  3037.   P: Integer;
  3038.   S: string;
  3039. begin
  3040.   for Result := 0 to GetCount - 1 do
  3041.   begin
  3042.     S := Get(Result);
  3043.     P := AnsiPos('=', S);
  3044.     if (P <> 0) and (AnsiCompareText(Copy(S, 1, P - 1), Name) = 0) then Exit;
  3045.   end;
  3046.   Result := -1;
  3047. end;
  3048.  
  3049. function TStrings.IndexOfObject(AObject: TObject): Integer;
  3050. begin
  3051.   for Result := 0 to GetCount - 1 do
  3052.     if GetObject(Result) = AObject then Exit;
  3053.   Result := -1;
  3054. end;
  3055.  
  3056. procedure TStrings.InsertObject(Index: Integer; const S: string;
  3057.   AObject: TObject);
  3058. begin
  3059.   Insert(Index, S);
  3060.   PutObject(Index, AObject);
  3061. end;
  3062.  
  3063. procedure TStrings.LoadFromFile(const FileName: string);
  3064. var
  3065.   Stream: TStream;
  3066. begin
  3067.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  3068.   try
  3069.     LoadFromStream(Stream);
  3070.   finally
  3071.     Stream.Free;
  3072.   end;
  3073. end;
  3074.  
  3075. procedure TStrings.LoadFromStream(Stream: TStream);
  3076. var
  3077.   Size: Integer;
  3078.   S: string;
  3079. begin
  3080.   BeginUpdate;
  3081.   try
  3082.     Size := Stream.Size - Stream.Position;
  3083.     SetString(S, nil, Size);
  3084.     Stream.Read(Pointer(S)^, Size);
  3085.     SetTextStr(S);
  3086.   finally
  3087.     EndUpdate;
  3088.   end;
  3089. end;
  3090.  
  3091. procedure TStrings.Move(CurIndex, NewIndex: Integer);
  3092. var
  3093.   TempObject: TObject;
  3094.   TempString: string;
  3095. begin
  3096.   if CurIndex <> NewIndex then
  3097.   begin
  3098.     BeginUpdate;
  3099.     try
  3100.       TempString := Get(CurIndex);
  3101.       TempObject := GetObject(CurIndex);
  3102.       Delete(CurIndex);
  3103.       InsertObject(NewIndex, TempString, TempObject);
  3104.     finally
  3105.       EndUpdate;
  3106.     end;
  3107.   end;
  3108. end;
  3109.  
  3110. procedure TStrings.Put(Index: Integer; const S: string);
  3111. var
  3112.   TempObject: TObject;
  3113. begin
  3114.   TempObject := GetObject(Index);
  3115.   Delete(Index);
  3116.   InsertObject(Index, S, TempObject);
  3117. end;
  3118.  
  3119. procedure TStrings.PutObject(Index: Integer; AObject: TObject);
  3120. begin
  3121. end;
  3122.  
  3123. procedure TStrings.ReadData(Reader: TReader);
  3124. begin
  3125.   Reader.ReadListBegin;
  3126.   BeginUpdate;
  3127.   try
  3128.     Clear;
  3129.     while not Reader.EndOfList do Add(Reader.ReadString);
  3130.   finally
  3131.     EndUpdate;
  3132.   end;
  3133.   Reader.ReadListEnd;
  3134. end;
  3135.  
  3136. procedure TStrings.SaveToFile(const FileName: string);
  3137. var
  3138.   Stream: TStream;
  3139. begin
  3140.   Stream := TFileStream.Create(FileName, fmCreate);
  3141.   try
  3142.     SaveToStream(Stream);
  3143.   finally
  3144.     Stream.Free;
  3145.   end;
  3146. end;
  3147.  
  3148. procedure TStrings.SaveToStream(Stream: TStream);
  3149. var
  3150.   S: string;
  3151. begin
  3152.   S := GetTextStr;
  3153.   Stream.WriteBuffer(Pointer(S)^, Length(S));
  3154. end;
  3155.  
  3156. procedure TStrings.SetCapacity(NewCapacity: Integer);
  3157. begin
  3158.   // do nothing - descendants may optionally implement this method
  3159. end;
  3160.  
  3161. procedure TStrings.SetCommaText(const Value: string);
  3162. var
  3163.   P, P1: PChar;
  3164.   S: string;
  3165. begin
  3166.   BeginUpdate;
  3167.   try
  3168.     Clear;
  3169.     P := PChar(Value);
  3170.     while P^ in [#1..' '] do P := CharNext(P);
  3171.     while P^ <> #0 do
  3172.     begin
  3173.       if P^ = '"' then
  3174.         S := AnsiExtractQuotedStr(P, '"')
  3175.       else
  3176.       begin
  3177.         P1 := P;
  3178.         while (P^ > ' ') and (P^ <> ',') do P := CharNext(P);
  3179.         SetString(S, P1, P - P1);
  3180.       end;
  3181.       Add(S);
  3182.       while P^ in [#1..' '] do P := CharNext(P);
  3183.       if P^ = ',' then
  3184.         repeat
  3185.           P := CharNext(P);
  3186.         until not (P^ in [#1..' ']);
  3187.     end;
  3188.   finally
  3189.     EndUpdate;
  3190.   end;
  3191. end;
  3192.  
  3193. procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter);
  3194. begin
  3195.   if FAdapter <> nil then FAdapter.ReleaseStrings;
  3196.   FAdapter := Value;
  3197.   if FAdapter <> nil then FAdapter.ReferenceStrings(Self);
  3198. end;
  3199.  
  3200. procedure TStrings.SetText(Text: PChar);
  3201. begin
  3202.   SetTextStr(Text);
  3203. end;
  3204.  
  3205. procedure TStrings.SetTextStr(const Value: string);
  3206. var
  3207.   P, Start: PChar;
  3208.   S: string;
  3209. begin
  3210.   BeginUpdate;
  3211.   try
  3212.     Clear;
  3213.     P := Pointer(Value);
  3214.     if P <> nil then
  3215.       while P^ <> #0 do
  3216.       begin
  3217.         Start := P;
  3218.         while not (P^ in [#0, #10, #13]) do Inc(P);
  3219.         SetString(S, Start, P - Start);
  3220.         Add(S);
  3221.         if P^ = #13 then Inc(P);
  3222.         if P^ = #10 then Inc(P);
  3223.       end;
  3224.   finally
  3225.     EndUpdate;
  3226.   end;
  3227. end;
  3228.  
  3229. procedure TStrings.SetUpdateState(Updating: Boolean);
  3230. begin
  3231. end;
  3232.  
  3233. procedure TStrings.SetValue(const Name, Value: string);
  3234. var
  3235.   I: Integer;
  3236. begin
  3237.   I := IndexOfName(Name);
  3238.   if Value <> '' then
  3239.   begin
  3240.     if I < 0 then I := Add('');
  3241.     Put(I, Name + '=' + Value);
  3242.   end else
  3243.   begin
  3244.     if I >= 0 then Delete(I);
  3245.   end;
  3246. end;
  3247.  
  3248. procedure TStrings.WriteData(Writer: TWriter);
  3249. var
  3250.   I: Integer;
  3251. begin
  3252.   Writer.WriteListBegin;
  3253.   for I := 0 to Count - 1 do Writer.WriteString(Get(I));
  3254.   Writer.WriteListEnd;
  3255. end;
  3256.  
  3257. { TStringList }
  3258.  
  3259. destructor TStringList.Destroy;
  3260. begin
  3261.   FOnChange := nil;
  3262.   FOnChanging := nil;
  3263.   inherited Destroy;
  3264.   if FCount <> 0 then Finalize(FList^[0], FCount);
  3265.   FCount := 0;
  3266.   SetCapacity(0);
  3267. end;
  3268.  
  3269. function TStringList.Add(const S: string): Integer;
  3270. begin
  3271.   if not Sorted then
  3272.     Result := FCount
  3273.   else
  3274.     if Find(S, Result) then
  3275.       case Duplicates of
  3276.         dupIgnore: Exit;
  3277.         dupError: Error(@SDuplicateString, 0);
  3278.       end;
  3279.   InsertItem(Result, S);
  3280. end;
  3281.  
  3282. procedure TStringList.Changed;
  3283. begin
  3284.   if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
  3285. end;
  3286.  
  3287. procedure TStringList.Changing;
  3288. begin
  3289.   if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
  3290. end;
  3291.  
  3292. procedure TStringList.Clear;
  3293. begin
  3294.   if FCount <> 0 then
  3295.   begin
  3296.     Changing;
  3297.     Finalize(FList^[0], FCount);
  3298.     FCount := 0;
  3299.     SetCapacity(0);
  3300.     Changed;
  3301.   end;
  3302. end;
  3303.  
  3304. procedure TStringList.Delete(Index: Integer);
  3305. begin
  3306.   if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
  3307.   Changing;
  3308.   Finalize(FList^[Index]);
  3309.   Dec(FCount);
  3310.   if Index < FCount then
  3311.     System.Move(FList^[Index + 1], FList^[Index],
  3312.       (FCount - Index) * SizeOf(TStringItem));
  3313.   Changed;
  3314. end;
  3315.  
  3316. procedure TStringList.Exchange(Index1, Index2: Integer);
  3317. begin
  3318.   if (Index1 < 0) or (Index1 >= FCount) then Error(@SListIndexError, Index1);
  3319.   if (Index2 < 0) or (Index2 >= FCount) then Error(@SListIndexError, Index2);
  3320.   Changing;
  3321.   ExchangeItems(Index1, Index2);
  3322.   Changed;
  3323. end;
  3324.  
  3325. procedure TStringList.ExchangeItems(Index1, Index2: Integer);
  3326. var
  3327.   Temp: Integer;
  3328.   Item1, Item2: PStringItem;
  3329. begin
  3330.   Item1 := @FList^[Index1];
  3331.   Item2 := @FList^[Index2];
  3332.   Temp := Integer(Item1^.FString);
  3333.   Integer(Item1^.FString) := Integer(Item2^.FString);
  3334.   Integer(Item2^.FString) := Temp;
  3335.   Temp := Integer(Item1^.FObject);
  3336.   Integer(Item1^.FObject) := Integer(Item2^.FObject);
  3337.   Integer(Item2^.FObject) := Temp;
  3338. end;
  3339.  
  3340. function TStringList.Find(const S: string; var Index: Integer): Boolean;
  3341. var
  3342.   L, H, I, C: Integer;
  3343. begin
  3344.   Result := False;
  3345.   L := 0;
  3346.   H := FCount - 1;
  3347.   while L <= H do
  3348.   begin
  3349.     I := (L + H) shr 1;
  3350.     C := AnsiCompareText(FList^[I].FString, S);
  3351.     if C < 0 then L := I + 1 else
  3352.     begin
  3353.       H := I - 1;
  3354.       if C = 0 then
  3355.       begin
  3356.         Result := True;
  3357.         if Duplicates <> dupAccept then L := I;
  3358.       end;
  3359.     end;
  3360.   end;
  3361.   Index := L;
  3362. end;
  3363.  
  3364. function TStringList.Get(Index: Integer): string;
  3365. begin
  3366.   if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
  3367.   Result := FList^[Index].FString;
  3368. end;
  3369.  
  3370. function TStringList.GetCapacity: Integer;
  3371. begin
  3372.   Result := FCapacity;
  3373. end;
  3374.  
  3375. function TStringList.GetCount: Integer;
  3376. begin
  3377.   Result := FCount;
  3378. end;
  3379.  
  3380. function TStringList.GetObject(Index: Integer): TObject;
  3381. begin
  3382.   if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
  3383.   Result := FList^[Index].FObject;
  3384. end;
  3385.  
  3386. procedure TStringList.Grow;
  3387. var
  3388.   Delta: Integer;
  3389. begin
  3390.   if FCapacity > 64 then Delta := FCapacity div 4 else
  3391.     if FCapacity > 8 then Delta := 16 else
  3392.       Delta := 4;
  3393.   SetCapacity(FCapacity + Delta);
  3394. end;
  3395.  
  3396. function TStringList.IndexOf(const S: string): Integer;
  3397. begin
  3398.   if not Sorted then Result := inherited IndexOf(S) else
  3399.     if not Find(S, Result) then Result := -1;
  3400. end;
  3401.  
  3402. procedure TStringList.Insert(Index: Integer; const S: string);
  3403. begin
  3404.   if Sorted then Error(@SSortedListError, 0);
  3405.   if (Index < 0) or (Index > FCount) then Error(@SListIndexError, Index);
  3406.   InsertItem(Index, S);
  3407. end;
  3408.  
  3409. procedure TStringList.InsertItem(Index: Integer; const S: string);
  3410. begin
  3411.   Changing;
  3412.   if FCount = FCapacity then Grow;
  3413.   if Index < FCount then
  3414.     System.Move(FList^[Index], FList^[Index + 1],
  3415.       (FCount - Index) * SizeOf(TStringItem));
  3416.   with FList^[Index] do
  3417.   begin
  3418.     Pointer(FString) := nil;
  3419.     FObject := nil;
  3420.     FString := S;
  3421.   end;
  3422.   Inc(FCount);
  3423.   Changed;
  3424. end;
  3425.  
  3426. procedure TStringList.Put(Index: Integer; const S: string);
  3427. begin
  3428.   if Sorted then Error(@SSortedListError, 0);
  3429.   if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
  3430.   Changing;
  3431.   FList^[Index].FString := S;
  3432.   Changed;
  3433. end;
  3434.  
  3435. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  3436. begin
  3437.   if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index);
  3438.   Changing;
  3439.   FList^[Index].FObject := AObject;
  3440.   Changed;
  3441. end;
  3442.  
  3443. procedure TStringList.QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
  3444. var
  3445.   I, J, P: Integer;
  3446. begin
  3447.   repeat
  3448.     I := L;
  3449.     J := R;
  3450.     P := (L + R) shr 1;
  3451.     repeat
  3452.       while SCompare(Self, I, P) < 0 do Inc(I);
  3453.       while SCompare(Self, J, P) > 0 do Dec(J);
  3454.       if I <= J then
  3455.       begin
  3456.         ExchangeItems(I, J);
  3457.         if P = I then
  3458.           P := J
  3459.         else if P = J then
  3460.           P := I;
  3461.         Inc(I);
  3462.         Dec(J);
  3463.       end;
  3464.     until I > J;
  3465.     if L < J then QuickSort(L, J, SCompare);
  3466.     L := I;
  3467.   until I >= R;
  3468. end;
  3469.  
  3470. procedure TStringList.SetCapacity(NewCapacity: Integer);
  3471. begin
  3472.   ReallocMem(FList, NewCapacity * SizeOf(TStringItem));
  3473.   FCapacity := NewCapacity;
  3474. end;
  3475.  
  3476. procedure TStringList.SetSorted(Value: Boolean);
  3477. begin
  3478.   if FSorted <> Value then
  3479.   begin
  3480.     if Value then Sort;
  3481.     FSorted := Value;
  3482.   end;
  3483. end;
  3484.  
  3485. procedure TStringList.SetUpdateState(Updating: Boolean);
  3486. begin
  3487.   if Updating then Changing else Changed;
  3488. end;
  3489.  
  3490. function StringListAnsiCompare(List: TStringList; Index1, Index2: Integer): Integer;
  3491. begin
  3492.   Result := AnsiCompareText(List.FList^[Index1].FString,
  3493.                             List.FList^[Index2].FString);
  3494. end;
  3495.  
  3496. procedure TStringList.Sort;
  3497. begin
  3498.   CustomSort(StringListAnsiCompare);
  3499. end;
  3500.  
  3501. procedure TStringList.CustomSort(Compare: TStringListSortCompare);
  3502. begin
  3503.   if not Sorted and (FCount > 1) then
  3504.   begin
  3505.     Changing;
  3506.     QuickSort(0, FCount - 1, Compare);
  3507.     Changed;
  3508.   end;
  3509. end;
  3510.  
  3511. { TStream }
  3512.  
  3513. function TStream.GetPosition: Longint;
  3514. begin
  3515.   Result := Seek(0, 1);
  3516. end;
  3517.  
  3518. procedure TStream.SetPosition(Pos: Longint);
  3519. begin
  3520.   Seek(Pos, 0);
  3521. end;
  3522.  
  3523. function TStream.GetSize: Longint;
  3524. var
  3525.   Pos: Longint;
  3526. begin
  3527.   Pos := Seek(0, 1);
  3528.   Result := Seek(0, 2);
  3529.   Seek(Pos, 0);
  3530. end;
  3531.  
  3532. procedure TStream.SetSize(NewSize: Longint);
  3533. begin
  3534.   // default = do nothing  (read-only streams, etc)
  3535. end;
  3536.  
  3537. procedure TStream.ReadBuffer(var Buffer; Count: Longint);
  3538. begin
  3539.   if (Count <> 0) and (Read(Buffer, Count) <> Count) then
  3540.     raise EReadError.CreateRes(@SReadError);
  3541. end;
  3542.  
  3543. procedure TStream.WriteBuffer(const Buffer; Count: Longint);
  3544. begin
  3545.   if (Count <> 0) and (Write(Buffer, Count) <> Count) then
  3546.     raise EWriteError.CreateRes(@SWriteError);
  3547. end;
  3548.  
  3549. function TStream.CopyFrom(Source: TStream; Count: Longint): Longint;
  3550. const
  3551.   MaxBufSize = $F000;
  3552. var
  3553.   BufSize, N: Integer;
  3554.   Buffer: PChar;
  3555. begin
  3556.   if Count = 0 then
  3557.   begin
  3558.     Source.Position := 0;
  3559.     Count := Source.Size;
  3560.   end;
  3561.   Result := Count;
  3562.   if Count > MaxBufSize then BufSize := MaxBufSize else BufSize := Count;
  3563.   GetMem(Buffer, BufSize);
  3564.   try
  3565.     while Count <> 0 do
  3566.     begin
  3567.       if Count > BufSize then N := BufSize else N := Count;
  3568.       Source.ReadBuffer(Buffer^, N);
  3569.       WriteBuffer(Buffer^, N);
  3570.       Dec(Count, N);
  3571.     end;
  3572.   finally
  3573.     FreeMem(Buffer, BufSize);
  3574.   end;
  3575. end;
  3576.  
  3577. function TStream.ReadComponent(Instance: TComponent): TComponent;
  3578. var
  3579.   Reader: TReader;
  3580. begin
  3581.   Reader := TReader.Create(Self, 4096);
  3582.   try
  3583.     Result := Reader.ReadRootComponent(Instance);
  3584.   finally
  3585.     Reader.Free;
  3586.   end;
  3587. end;
  3588.  
  3589. procedure TStream.WriteComponent(Instance: TComponent);
  3590. begin
  3591.   WriteDescendent(Instance, nil);
  3592. end;
  3593.  
  3594. procedure TStream.WriteDescendent(Instance, Ancestor: TComponent);
  3595. var
  3596.   Writer: TWriter;
  3597. begin
  3598.   Writer := TWriter.Create(Self, 4096);
  3599.   try
  3600.     Writer.WriteDescendent(Instance, Ancestor);
  3601.   finally
  3602.     Writer.Free;
  3603.   end;
  3604. end;
  3605.  
  3606. function TStream.ReadComponentRes(Instance: TComponent): TComponent;
  3607. begin
  3608.   ReadResHeader;
  3609.   Result := ReadComponent(Instance);
  3610. end;
  3611.  
  3612. procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent);
  3613. begin
  3614.   WriteDescendentRes(ResName, Instance, nil);
  3615. end;
  3616.  
  3617. procedure TStream.WriteResourceHeader(const ResName: string; out FixupInfo: Integer);
  3618. var
  3619.   HeaderSize: Integer;
  3620.   Header: array[0..79] of Char;
  3621. begin
  3622.   Byte((@Header[0])^) := $FF;
  3623.   Word((@Header[1])^) := 10;
  3624.   HeaderSize := StrLen(StrUpper(StrPLCopy(@Header[3], ResName, 63))) + 10;
  3625.   Word((@Header[HeaderSize - 6])^) := $1030;
  3626.   Longint((@Header[HeaderSize - 4])^) := 0;
  3627.   WriteBuffer(Header, HeaderSize);
  3628.   FixupInfo := Position;
  3629. end;
  3630.  
  3631. procedure TStream.FixupResourceHeader(FixupInfo: Integer);
  3632. var
  3633.   ImageSize: Integer;
  3634. begin
  3635.   ImageSize := Position - FixupInfo;
  3636.   Position := FixupInfo - 4;
  3637.   WriteBuffer(ImageSize, SizeOf(Longint));
  3638.   Position := FixupInfo + ImageSize;
  3639. end;
  3640.  
  3641. procedure TStream.WriteDescendentRes(const ResName: string; Instance,
  3642.   Ancestor: TComponent);
  3643. var
  3644.   FixupInfo: Integer;
  3645. begin
  3646.   WriteResourceHeader(ResName, FixupInfo);
  3647.   WriteDescendent(Instance, Ancestor);
  3648.   FixupResourceHeader(FixupInfo);
  3649. end;
  3650.  
  3651. procedure TStream.ReadResHeader;
  3652. var
  3653.   ReadCount: Cardinal;
  3654.   Header: array[0..79] of Char;
  3655. begin
  3656.   FillChar(Header, SizeOf(Header), 0);
  3657.   ReadCount := Read(Header, SizeOf(Header) - 1);
  3658.   if (Byte((@Header[0])^) = $FF) and (Word((@Header[1])^) = 10) then
  3659.     Seek(StrLen(Header + 3) + 10 - ReadCount, 1)
  3660.   else
  3661.     raise EInvalidImage.CreateRes(@SInvalidImage);
  3662. end;
  3663.  
  3664. { THandleStream }
  3665.  
  3666. constructor THandleStream.Create(AHandle: Integer);
  3667. begin
  3668.   FHandle := AHandle;
  3669. end;
  3670.  
  3671. function THandleStream.Read(var Buffer; Count: Longint): Longint;
  3672. begin
  3673.   Result := FileRead(FHandle, Buffer, Count);
  3674.   if Result = -1 then Result := 0;
  3675. end;
  3676.  
  3677. function THandleStream.Write(const Buffer; Count: Longint): Longint;
  3678. begin
  3679.   Result := FileWrite(FHandle, Buffer, Count);
  3680.   if Result = -1 then Result := 0;
  3681. end;
  3682.  
  3683. function THandleStream.Seek(Offset: Longint; Origin: Word): Longint;
  3684. begin
  3685.   Result := FileSeek(FHandle, Offset, Origin);
  3686. end;
  3687.  
  3688. procedure THandleStream.SetSize(NewSize: Longint);
  3689. begin
  3690.   Seek(NewSize, soFromBeginning);
  3691.   Win32Check(SetEndOfFile(FHandle));
  3692. end;
  3693.  
  3694. { TFileStream }
  3695.  
  3696. constructor TFileStream.Create(const FileName: string; Mode: Word);
  3697. begin
  3698.   if Mode = fmCreate then
  3699.   begin
  3700.     FHandle := FileCreate(FileName);
  3701.     if FHandle < 0 then
  3702.       raise EFCreateError.CreateResFmt(@SFCreateError, [FileName]);
  3703.   end else
  3704.   begin
  3705.     FHandle := FileOpen(FileName, Mode);
  3706.     if FHandle < 0 then
  3707.       raise EFOpenError.CreateResFmt(@SFOpenError, [FileName]);
  3708.   end;
  3709. end;
  3710.  
  3711. destructor TFileStream.Destroy;
  3712. begin
  3713.   if FHandle >= 0 then FileClose(FHandle);
  3714. end;
  3715.  
  3716.  
  3717. { TCustomMemoryStream }
  3718.  
  3719. procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; Size: Longint);
  3720. begin
  3721.   FMemory := Ptr;
  3722.   FSize := Size;
  3723. end;
  3724.  
  3725. function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
  3726. begin
  3727.   if (FPosition >= 0) and (Count >= 0) then
  3728.   begin
  3729.     Result := FSize - FPosition;
  3730.     if Result > 0 then
  3731.     begin
  3732.       if Result > Count then Result := Count;
  3733.       Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
  3734.       Inc(FPosition, Result);
  3735.       Exit;
  3736.     end;
  3737.   end;
  3738.   Result := 0;
  3739. end;
  3740.  
  3741. function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
  3742. begin
  3743.   case Origin of
  3744.     soFromBeginning: FPosition := Offset;
  3745.     soFromCurrent: Inc(FPosition, Offset);
  3746.     soFromEnd: FPosition := FSize + Offset;
  3747.   end;
  3748.   Result := FPosition;
  3749. end;
  3750.  
  3751. procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
  3752. begin
  3753.   if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
  3754. end;
  3755.  
  3756. procedure TCustomMemoryStream.SaveToFile(const FileName: string);
  3757. var
  3758.   Stream: TStream;
  3759. begin
  3760.   Stream := TFileStream.Create(FileName, fmCreate);
  3761.   try
  3762.     SaveToStream(Stream);
  3763.   finally
  3764.     Stream.Free;
  3765.   end;
  3766. end;
  3767.  
  3768. { TMemoryStream }
  3769.  
  3770. const
  3771.   MemoryDelta = $2000; { Must be a power of 2 }
  3772.  
  3773. destructor TMemoryStream.Destroy;
  3774. begin
  3775.   Clear;
  3776.   inherited Destroy;
  3777. end;
  3778.  
  3779. procedure TMemoryStream.Clear;
  3780. begin
  3781.   SetCapacity(0);
  3782.   FSize := 0;
  3783.   FPosition := 0;
  3784. end;
  3785.  
  3786. procedure TMemoryStream.LoadFromStream(Stream: TStream);
  3787. var
  3788.   Count: Longint;
  3789. begin
  3790.   Stream.Position := 0;
  3791.   Count := Stream.Size;
  3792.   SetSize(Count);
  3793.   if Count <> 0 then Stream.ReadBuffer(FMemory^, Count);
  3794. end;
  3795.  
  3796. procedure TMemoryStream.LoadFromFile(const FileName: string);
  3797. var
  3798.   Stream: TStream;
  3799. begin
  3800.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  3801.   try
  3802.     LoadFromStream(Stream);
  3803.   finally
  3804.     Stream.Free;
  3805.   end;
  3806. end;
  3807.  
  3808. procedure TMemoryStream.SetCapacity(NewCapacity: Longint);
  3809. begin
  3810.   SetPointer(Realloc(NewCapacity), FSize);
  3811.   FCapacity := NewCapacity;
  3812. end;
  3813.  
  3814. procedure TMemoryStream.SetSize(NewSize: Longint);
  3815. var
  3816.   OldPosition: Longint;
  3817. begin
  3818.   OldPosition := FPosition;
  3819.   SetCapacity(NewSize);
  3820.   FSize := NewSize;
  3821.   if OldPosition > NewSize then Seek(0, soFromEnd);
  3822. end;
  3823.  
  3824. function TMemoryStream.Realloc(var NewCapacity: Longint): Pointer;
  3825. begin
  3826.   if NewCapacity > 0 then
  3827.     NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  3828.   Result := Memory;
  3829.   if NewCapacity <> FCapacity then
  3830.   begin
  3831.     if NewCapacity = 0 then
  3832.     begin
  3833.       GlobalFreePtr(Memory);
  3834.       Result := nil;
  3835.     end else
  3836.     begin
  3837.       if Capacity = 0 then
  3838.         Result := GlobalAllocPtr(HeapAllocFlags, NewCapacity)
  3839.       else
  3840.         Result := GlobalReallocPtr(Memory, NewCapacity, HeapAllocFlags);
  3841.       if Result = nil then raise EStreamError.CreateRes(@SMemoryStreamError);
  3842.     end;
  3843.   end;
  3844. end;
  3845.  
  3846. function TMemoryStream.Write(const Buffer; Count: Longint): Longint;
  3847. var
  3848.   Pos: Longint;
  3849. begin
  3850.   if (FPosition >= 0) and (Count >= 0) then
  3851.   begin
  3852.     Pos := FPosition + Count;
  3853.     if Pos > 0 then
  3854.     begin
  3855.       if Pos > FSize then
  3856.       begin
  3857.         if Pos > FCapacity then
  3858.           SetCapacity(Pos);
  3859.         FSize := Pos;
  3860.       end;
  3861.       System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
  3862.       FPosition := Pos;
  3863.       Result := Count;
  3864.       Exit;
  3865.     end;
  3866.   end;
  3867.   Result := 0;
  3868. end;
  3869.  
  3870. { TStringStream }
  3871.  
  3872. constructor TStringStream.Create(const AString: string);
  3873. begin
  3874.   inherited Create;
  3875.   FDataString := AString;
  3876. end;
  3877.  
  3878. function TStringStream.Read(var Buffer; Count: Longint): Longint;
  3879. begin
  3880.   Result := Length(FDataString) - FPosition;
  3881.   if Result > Count then Result := Count;
  3882.   Move(PChar(@FDataString[FPosition + 1])^, Buffer, Result);
  3883.   Inc(FPosition, Result);
  3884. end;
  3885.  
  3886. function TStringStream.Write(const Buffer; Count: Longint): Longint;
  3887. begin
  3888.   Result := Count;
  3889.   SetLength(FDataString, (FPosition + Result));
  3890.   Move(Buffer, PChar(@FDataString[FPosition + 1])^, Result);
  3891.   Inc(FPosition, Result);
  3892. end;
  3893.  
  3894. function TStringStream.Seek(Offset: Longint; Origin: Word): Longint;
  3895. begin
  3896.   case Origin of
  3897.     soFromBeginning: FPosition := Offset;
  3898.     soFromCurrent: FPosition := FPosition + Offset;
  3899.     soFromEnd: FPosition := Length(FDataString) - Offset;
  3900.   end;
  3901.   if FPosition > Length(FDataString) then
  3902.     FPosition := Length(FDataString)
  3903.   else if FPosition < 0 then FPosition := 0;
  3904.   Result := FPosition;
  3905. end;
  3906.  
  3907. function TStringStream.ReadString(Count: Longint): string;
  3908. var
  3909.   Len: Integer;
  3910. begin
  3911.   Len := Length(FDataString) - FPosition;
  3912.   if Len > Count then Len := Count;
  3913.   SetString(Result, PChar(@FDataString[FPosition + 1]), Len);
  3914.   Inc(FPosition, Len);
  3915. end;
  3916.  
  3917. procedure TStringStream.WriteString(const AString: string);
  3918. begin
  3919.   Write(PChar(AString)^, Length(AString));
  3920. end;
  3921.  
  3922. procedure TStringStream.SetSize(NewSize: Longint);
  3923. begin
  3924.   SetLength(FDataString, NewSize);
  3925.   if FPosition > NewSize then FPosition := NewSize;
  3926. end;
  3927.  
  3928. { TResourceStream }
  3929.  
  3930. constructor TResourceStream.Create(Instance: THandle; const ResName: string;
  3931.   ResType: PChar);
  3932. begin
  3933.   inherited Create;
  3934.   Initialize(Instance, PChar(ResName), ResType);
  3935. end;
  3936.  
  3937. constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer;
  3938.   ResType: PChar);
  3939. begin
  3940.   inherited Create;
  3941.   Initialize(Instance, PChar(ResID), ResType);
  3942. end;
  3943.  
  3944. procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
  3945.  
  3946.   procedure Error;
  3947.   begin
  3948.     raise EResNotFound.CreateFmt(SResNotFound, [Name]);
  3949.   end;
  3950.  
  3951. begin
  3952.   HResInfo := FindResource(Instance, Name, ResType);
  3953.   if HResInfo = 0 then Error;
  3954.   HGlobal := LoadResource(Instance, HResInfo);
  3955.   if HGlobal = 0 then Error;
  3956.   SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo));
  3957. end;
  3958.  
  3959. destructor TResourceStream.Destroy;
  3960. begin
  3961.   UnlockResource(HGlobal);
  3962.   FreeResource(HGlobal);
  3963.   inherited Destroy;
  3964. end;
  3965.  
  3966. function TResourceStream.Write(const Buffer; Count: Longint): Longint;
  3967. begin
  3968.   raise EStreamError.CreateRes(@SCantWriteResourceStreamError);
  3969. end;
  3970.  
  3971. { TFiler }
  3972.  
  3973. constructor TFiler.Create(Stream: TStream; BufSize: Integer);
  3974. begin
  3975.   FStream := Stream;
  3976.   GetMem(FBuffer, BufSize);
  3977.   FBufSize := BufSize;
  3978. end;
  3979.  
  3980. destructor TFiler.Destroy;
  3981. begin
  3982.   if FBuffer <> nil then FreeMem(FBuffer, FBufSize);
  3983. end;
  3984.  
  3985. procedure TFiler.SetRoot(Value: TComponent);
  3986. begin
  3987.   FRoot := Value;
  3988. end;
  3989.  
  3990. { TPropFixup }
  3991.  
  3992. type
  3993.   TPropFixup = class
  3994.     FInstance: TPersistent;
  3995.     FInstanceRoot: TComponent;
  3996.     FPropInfo: PPropInfo;
  3997.     FRootName: string;
  3998.     FName: string;
  3999.     constructor Create(Instance: TPersistent; InstanceRoot: TComponent;
  4000.       PropInfo: PPropInfo; const RootName, Name: string);
  4001.     function MakeGlobalReference: Boolean;
  4002.   end;
  4003.  
  4004. var
  4005.   GlobalFixupList: TThreadList;
  4006.  
  4007. constructor TPropFixup.Create(Instance: TPersistent; InstanceRoot: TComponent;
  4008.   PropInfo: PPropInfo; const RootName, Name: string);
  4009. begin
  4010.   FInstance := Instance;
  4011.   FInstanceRoot := InstanceRoot;
  4012.   FPropInfo := PropInfo;
  4013.   FRootName := RootName;
  4014.   FName := Name;
  4015. end;
  4016.  
  4017. function TPropFixup.MakeGlobalReference: Boolean;
  4018. var
  4019.   S: PChar;
  4020.   P: PChar;
  4021. begin
  4022.   Result := False;
  4023.   S := PChar(Pointer(FName));
  4024.   P := S;
  4025.   while not (P^ in ['.', #0]) do Inc(P);
  4026.   if P^ = #0 then Exit;
  4027.   SetString(FRootName, S, P - S);
  4028.   Delete(FName, 1, P - S + 1);
  4029.   Result := True;
  4030. end;
  4031.  
  4032. function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent;
  4033. var
  4034.   Current, Found: TComponent;
  4035.   S, P: PChar;
  4036.   Name: string;
  4037. begin
  4038.   Result := nil;
  4039.   if NamePath = '' then Exit;
  4040.   Current := Root;
  4041.   P := PChar(Pointer(NamePath));
  4042.   while P^ <> #0 do
  4043.   begin
  4044.     S := P;
  4045.     while not (P^ in ['.', '-', #0]) do Inc(P);
  4046.     SetString(Name, S, P - S);
  4047.     Found := Current.FindComponent(Name);
  4048.     if (Found = nil) and SameText(Name, 'Owner') then                           { Do not translate }
  4049.       Found := Current;
  4050.     if Found = nil then Exit;
  4051.     if P^ = '.' then Inc(P);
  4052.     if P^ = '-' then Inc(P);
  4053.     if P^ = '>' then Inc(P);
  4054.     Current := Found;
  4055.   end;
  4056.   Result := Current;
  4057. end;
  4058.  
  4059. procedure GlobalFixupReferences;
  4060. var
  4061.   FinishedList: TList;
  4062.   NotFinishedList: TList;
  4063.   GlobalList: TList;
  4064.   I: Integer;
  4065.   Root: TComponent;
  4066.   Instance: TPersistent;
  4067.   Reference: Pointer;
  4068.  
  4069.   procedure AddFinished(Instance: TPersistent);
  4070.   begin
  4071.     if (FinishedList.IndexOf(Instance) < 0) and
  4072.       (NotFinishedList.IndexOf(Instance) >= 0) then
  4073.       FinishedList.Add(Instance);
  4074.   end;
  4075.  
  4076.   procedure AddNotFinished(Instance: TPersistent);
  4077.   var
  4078.     Index: Integer;
  4079.   begin
  4080.     Index := FinishedList.IndexOf(Instance);
  4081.     if Index <> -1 then FinishedList.Delete(Index);
  4082.     if NotFinishedList.IndexOf(Instance) < 0 then
  4083.       NotFinishedList.Add(Instance);
  4084.   end;
  4085.  
  4086. begin
  4087.   if Assigned(FindGlobalComponent) then
  4088.   begin
  4089.     // Fixup resolution requires a stable component / name space
  4090.     // Block construction and destruction of forms / datamodules during fixups
  4091.     GlobalNameSpace.BeginWrite;
  4092.     try
  4093.       GlobalList := GlobalFixupList.LockList;
  4094.       try
  4095.         if GlobalList.Count > 0 then
  4096.         begin
  4097.           FinishedList := TList.Create;
  4098.           try
  4099.             NotFinishedList := TList.Create;
  4100.             try
  4101.               I := 0;
  4102.               while I < GlobalList.Count do
  4103.                 with TPropFixup(GlobalList[I]) do
  4104.                 begin
  4105.                   Root := FindGlobalComponent(FRootName);
  4106.                   if (Root <> nil) or (GetOrdProp(FInstance, FPropInfo) <> 0) then
  4107.                   begin
  4108.                     if Root <> nil then
  4109.                     begin
  4110.                       Reference := FindNestedComponent(Root, FName);
  4111.                       SetOrdProp(FInstance, FPropInfo, Longint(Reference));
  4112.                     end;
  4113.                     AddFinished(FInstance);
  4114.                     GlobalList.Delete(I);
  4115.                     Free;
  4116.                   end else
  4117.                   begin
  4118.                     AddNotFinished(FInstance);
  4119.                     Inc(I);
  4120.                   end;
  4121.                 end;
  4122.             finally
  4123.               NotFinishedList.Free;
  4124.             end;
  4125.             for I := 0 to FinishedList.Count - 1 do
  4126.             begin
  4127.               Instance := FinishedList[I];
  4128.               if Instance is TComponent then
  4129.                 Exclude(TComponent(Instance).FComponentState, csFixups);
  4130.             end;
  4131.           finally
  4132.             FinishedList.Free;
  4133.           end;
  4134.         end;
  4135.       finally
  4136.         GlobalFixupList.UnlockList;
  4137.       end;
  4138.     finally
  4139.       GlobalNameSpace.EndWrite;
  4140.     end;
  4141.   end;
  4142. end;
  4143.  
  4144. function NameInStrings(Strings: TStrings; const Name: string): Boolean;
  4145. var
  4146.   I: Integer;
  4147. begin
  4148.   Result := True;
  4149.   for I := 0 to Strings.Count - 1 do
  4150.     if SameText(Name, Strings[I]) then Exit;
  4151.   Result := False;
  4152. end;
  4153.  
  4154. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  4155. var
  4156.   I: Integer;
  4157.   Fixup: TPropFixup;
  4158. begin
  4159.   with GlobalFixupList.LockList do
  4160.   try
  4161.     for I := 0 to Count - 1 do
  4162.     begin
  4163.       Fixup := Items[I];
  4164.       if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  4165.         not NameInStrings(Names, Fixup.FRootName) then
  4166.         Names.Add(Fixup.FRootName);
  4167.     end;
  4168.   finally
  4169.     GlobalFixupList.UnlockList;
  4170.   end;
  4171. end;
  4172.  
  4173. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  4174.   NewRootName: string);
  4175. var
  4176.   I: Integer;
  4177.   Fixup: TPropFixup;
  4178. begin
  4179.   with GlobalFixupList.LockList do
  4180.   try
  4181.     for I := 0 to Count - 1 do
  4182.     begin
  4183.       Fixup := Items[I];
  4184.       if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  4185.         SameText(OldRootName, Fixup.FRootName) then
  4186.         Fixup.FRootName := NewRootName;
  4187.     end;
  4188.     GlobalFixupReferences;
  4189.   finally
  4190.     GlobalFixupList.Unlocklist;
  4191.   end;
  4192. end;
  4193.  
  4194. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  4195. var
  4196.   I: Integer;
  4197.   Fixup: TPropFixup;
  4198. begin
  4199.   if GlobalFixupList = nil then Exit;
  4200.   with GlobalFixupList.LockList do
  4201.   try
  4202.     for I := Count - 1 downto 0 do
  4203.     begin
  4204.       Fixup := Items[I];
  4205.       if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  4206.         ((RootName = '') or SameText(RootName, Fixup.FRootName)) then
  4207.       begin
  4208.         Delete(I);
  4209.         Fixup.Free;
  4210.       end;
  4211.     end;
  4212.   finally
  4213.     GlobalFixupList.UnlockList;
  4214.   end;
  4215. end;
  4216.  
  4217. procedure RemoveFixups(Instance: TPersistent);
  4218. var
  4219.   I: Integer;
  4220.   Fixup: TPropFixup;
  4221. begin
  4222.   if GlobalFixupList = nil then Exit;
  4223.   with GlobalFixupList.LockList do
  4224.   try
  4225.     for I := Count - 1 downto 0 do
  4226.     begin
  4227.       Fixup := Items[I];
  4228.       if (Fixup.FInstance = Instance) then
  4229.       begin
  4230.         Delete(I);
  4231.         Fixup.Free;
  4232.       end;
  4233.     end;
  4234.   finally
  4235.     GlobalFixupList.UnlockList;
  4236.   end;
  4237. end;
  4238.  
  4239. procedure GetFixupInstanceNames(Root: TComponent;
  4240.   const ReferenceRootName: string; Names: TStrings);
  4241. var
  4242.   I: Integer;
  4243.   Fixup: TPropFixup;
  4244. begin
  4245.   with GlobalFixupList.LockList do
  4246.   try
  4247.     for I := 0 to Count - 1 do
  4248.     begin
  4249.       Fixup := Items[I];
  4250.       if (Fixup.FInstanceRoot = Root) and
  4251.         SameText(ReferenceRootName, Fixup.FRootName) and
  4252.         not NameInStrings(Names, Fixup.FName) then
  4253.         Names.Add(Fixup.FName);
  4254.     end;
  4255.   finally
  4256.     GlobalFixupList.UnlockList;
  4257.   end;
  4258. end;
  4259.  
  4260. { TReader }
  4261.  
  4262. procedure ReadError(Ident: PResStringRec);
  4263. begin
  4264.   raise EReadError.CreateRes(Ident);
  4265. end;
  4266.  
  4267. procedure PropValueError;
  4268. begin
  4269.   ReadError(@SInvalidPropertyValue);
  4270. end;
  4271.  
  4272. procedure PropertyNotFound;
  4273. begin
  4274.   ReadError(@SUnknownProperty);
  4275. end;
  4276.  
  4277. function EnumValue(EnumType: PTypeInfo; const EnumName: string): Integer;
  4278. begin
  4279.   Result := GetEnumValue(EnumType, EnumName);
  4280.   if Result = -1 then PropValueError;
  4281. end;
  4282.  
  4283. destructor TReader.Destroy;
  4284. begin
  4285.   FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), 1);
  4286.   inherited Destroy;
  4287. end;
  4288.  
  4289. procedure TReader.BeginReferences;
  4290. begin
  4291.   FLoaded := TList.Create;
  4292.   try
  4293.     FFixups := TList.Create;
  4294.   except
  4295.     FLoaded.Free;
  4296.     raise;
  4297.   end;
  4298. end;
  4299.  
  4300. procedure TReader.CheckValue(Value: TValueType);
  4301. begin
  4302.   if ReadValue <> Value then
  4303.   begin
  4304.     Dec(FBufPos);
  4305.     SkipValue;
  4306.     PropValueError;
  4307.   end;
  4308. end;
  4309.  
  4310. procedure TReader.DefineProperty(const Name: string;
  4311.   ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
  4312. begin
  4313.   if SameText(Name, FPropName) and Assigned(ReadData) then
  4314.   begin
  4315.     ReadData(Self);
  4316.     FPropName := '';
  4317.   end;
  4318. end;
  4319.  
  4320. procedure TReader.DefineBinaryProperty(const Name: string;
  4321.   ReadData, WriteData: TStreamProc; HasData: Boolean);
  4322. var
  4323.   Stream: TMemoryStream;
  4324.   Count: Longint;
  4325. begin
  4326.   if SameText(Name, FPropName) and Assigned(ReadData) then
  4327.   begin
  4328.     if ReadValue <> vaBinary then
  4329.     begin
  4330.       Dec(FBufPos);
  4331.       SkipValue;
  4332.       FCanHandleExcepts := True;
  4333.       PropValueError;
  4334.     end;
  4335.     Stream := TMemoryStream.Create;
  4336.     try
  4337.       Read(Count, SizeOf(Count));
  4338.       Stream.SetSize(Count);
  4339.       Read(Stream.Memory^, Count);
  4340.       FCanHandleExcepts := True;
  4341.       ReadData(Stream);
  4342.     finally
  4343.       Stream.Free;
  4344.     end;
  4345.     FPropName := '';
  4346.   end;
  4347. end;
  4348.  
  4349. function TReader.EndOfList: Boolean;
  4350. begin
  4351.   Result := ReadValue = vaNull;
  4352.   Dec(FBufPos);
  4353. end;
  4354.  
  4355. procedure TReader.EndReferences;
  4356. begin
  4357.   FreeFixups;
  4358.   FLoaded.Free;
  4359.   FLoaded := nil;
  4360. end;
  4361.  
  4362. function TReader.Error(const Message: string): Boolean;
  4363. begin
  4364.   Result := False;
  4365.   if Assigned(FOnError) then FOnError(Self, Message, Result);
  4366. end;
  4367.  
  4368. function TReader.FindMethod(Root: TComponent;
  4369.   const MethodName: string): Pointer;
  4370. var
  4371.   Error: Boolean;
  4372. begin
  4373.   Result := Root.MethodAddress(MethodName);
  4374.   Error := Result = nil;
  4375.   if Assigned(FOnFindMethod) then FOnFindMethod(Self, MethodName, Result, Error);
  4376.   if Error then PropValueError;
  4377. end;
  4378.  
  4379. procedure RemoveGlobalFixup(Fixup: TPropFixup);
  4380. var
  4381.   I: Integer;
  4382. begin
  4383.   with GlobalFixupList.LockList do
  4384.   try
  4385.     for I := Count-1 downto 0 do
  4386.       with TPropFixup(Items[I]) do
  4387.         if (FInstance = Fixup.FInstance) and (FPropInfo = Fixup.FPropInfo) then
  4388.         begin
  4389.           Free;
  4390.           Delete(I);
  4391.         end;
  4392.   finally
  4393.     GlobalFixupList.UnlockList;
  4394.   end;
  4395. end;
  4396.  
  4397. procedure TReader.DoFixupReferences;
  4398. var
  4399.   I: Integer;
  4400.   CompName: string;
  4401.   Reference: Pointer;
  4402. begin
  4403.   if FFixups <> nil then
  4404.     try
  4405.       for I := 0 to FFixups.Count - 1 do
  4406.         with TPropFixup(FFixups[I]) do
  4407.         begin
  4408.           CompName := FName;
  4409.           ReferenceName(CompName);
  4410.           Reference := FindNestedComponent(FInstanceRoot, CompName);
  4411.           { Free any preexisting global fixups for this instance/property.
  4412.             Last fixup added is the only one that counts.
  4413.             In particular, fixups created when streaming inherited forms/frames
  4414.             must be destroyed when overriding references are found later
  4415.             in the stream.  }
  4416.           RemoveGlobalFixup(FFixups[I]);
  4417.           if (Reference = nil) and MakeGlobalReference then
  4418.           begin
  4419.             GlobalFixupList.Add(FFixups[I]);
  4420.             FFixups[I] := nil;
  4421.           end
  4422.           else
  4423.             SetOrdProp(FInstance, FPropInfo, Longint(Reference));
  4424.         end;
  4425.     finally
  4426.       FreeFixups;
  4427.     end;
  4428. end;
  4429.  
  4430. procedure TReader.FixupReferences;
  4431. var
  4432.   I: Integer;
  4433. begin
  4434.   DoFixupReferences;
  4435.   GlobalFixupReferences;
  4436.   for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
  4437. end;
  4438.  
  4439. procedure TReader.FlushBuffer;
  4440. begin
  4441.   FStream.Position := Position;
  4442.   FBufPos := 0;
  4443.   FBufEnd := 0;
  4444. end;
  4445.  
  4446. procedure TReader.FreeFixups;
  4447. var
  4448.   I: Integer;
  4449. begin
  4450.   if FFixups <> nil then
  4451.   begin
  4452.     for I := 0 to FFixups.Count - 1 do TPropFixup(FFixups[I]).Free;
  4453.     FFixups.Free;
  4454.     FFixups := nil;
  4455.   end;
  4456. end;
  4457.  
  4458. function TReader.GetPosition: Longint;
  4459. begin
  4460.   Result := FStream.Position - (FBufEnd - FBufPos);
  4461. end;
  4462.  
  4463. function TReader.NextValue: TValueType;
  4464. begin
  4465.   Result := ReadValue;
  4466.   Dec(FBufPos);
  4467. end;
  4468.  
  4469. procedure TReader.PropertyError;
  4470. begin
  4471.   SkipValue;
  4472.   PropertyNotFound;
  4473. end;
  4474.  
  4475. procedure TReader.Read(var Buf; Count: Longint); assembler;
  4476. asm
  4477.         PUSH    ESI
  4478.         PUSH    EDI
  4479.         PUSH    EBX
  4480.         MOV     EDI,EDX
  4481.         MOV     EBX,ECX
  4482.         MOV     ESI,EAX
  4483.         JMP     @@6
  4484. @@1:    MOV     ECX,[ESI].TReader.FBufEnd
  4485.         SUB     ECX,[ESI].TReader.FBufPos
  4486.         JA      @@2
  4487.         MOV     EAX,ESI
  4488.         CALL    TReader.ReadBuffer
  4489.         MOV     ECX,[ESI].TReader.FBufEnd
  4490. @@2:    CMP     ECX,EBX
  4491.         JB      @@3
  4492.         MOV     ECX,EBX
  4493. @@3:    PUSH    ESI
  4494.         SUB     EBX,ECX
  4495.         MOV     EAX,[ESI].TReader.FBuffer
  4496.         ADD     EAX,[ESI].TReader.FBufPos
  4497.         ADD     [ESI].TReader.FBufPos,ECX
  4498.         MOV     ESI,EAX
  4499.         MOV     EDX,ECX
  4500.         SHR     ECX,2
  4501.         CLD
  4502.         REP     MOVSD
  4503.         MOV     ECX,EDX
  4504.         AND     ECX,3
  4505.         REP     MOVSB
  4506.         POP     ESI
  4507. @@6:    OR      EBX,EBX
  4508.         JNE     @@1
  4509.         POP     EBX
  4510.         POP     EDI
  4511.         POP     ESI
  4512. end;
  4513.  
  4514. procedure TReader.ReadBuffer;
  4515. begin
  4516.   FBufEnd := FStream.Read(FBuffer^, FBufSize);
  4517.   if FBufEnd = 0 then raise EReadError.CreateRes(@SReadError);
  4518.   FBufPos := 0;
  4519. end;
  4520.  
  4521. function TReader.ReadBoolean: Boolean;
  4522. begin
  4523.   Result := ReadValue = vaTrue;
  4524. end;
  4525.  
  4526. function TReader.ReadChar: Char;
  4527. begin
  4528.   CheckValue(vaString);
  4529.   Read(Result, 1);
  4530.   if Ord(Result) <> 1 then
  4531.   begin
  4532.     Dec(FBufPos);
  4533.     ReadStr;
  4534.     PropValueError;
  4535.   end;
  4536.   Read(Result, 1);
  4537. end;
  4538.  
  4539. procedure TReader.ReadCollection(Collection: TCollection);
  4540. var
  4541.   Item: TPersistent;
  4542. begin
  4543.   Collection.BeginUpdate;
  4544.   try
  4545.     if not EndOfList then Collection.Clear;
  4546.     while not EndOfList do
  4547.     begin
  4548.       if NextValue in [vaInt8, vaInt16, vaInt32] then ReadInteger;
  4549.       Item := Collection.Add;
  4550.       ReadListBegin;
  4551.       while not EndOfList do ReadProperty(Item);
  4552.       ReadListEnd;
  4553.     end;
  4554.     ReadListEnd;
  4555.   finally
  4556.     Collection.EndUpdate;
  4557.   end;
  4558. end;
  4559.  
  4560. function TReader.ReadComponent(Component: TComponent): TComponent;
  4561. var
  4562.   CompClass, CompName: string;
  4563.   Flags: TFilerFlags;
  4564.   Position: Integer;
  4565.   OldParent, OldLookupRoot: TComponent;
  4566.  
  4567.   function ComponentCreated: Boolean;
  4568.   begin
  4569.     Result := not (ffInherited in Flags) and (Component = nil);
  4570.   end;
  4571.  
  4572.   function Recover(var Component: TComponent): Boolean;
  4573.   begin
  4574.     Result := False;
  4575.     if not (ExceptObject is Exception) then Exit;
  4576.     if ComponentCreated then Component.Free;
  4577.     Component := nil;
  4578.     SkipComponent(False);
  4579.     Result := Error(Exception(ExceptObject).Message);
  4580.   end;
  4581.  
  4582.   procedure CreateComponent;
  4583.   var
  4584.     ComponentClass: TComponentClass;
  4585.   begin
  4586.     try
  4587.       ComponentClass := FindComponentClass(CompClass);
  4588.       Result := nil;
  4589.       if Assigned(FOnCreateComponent) then
  4590.         FOnCreateComponent(Self, ComponentClass, Result);
  4591.       if Result = nil then
  4592.       begin
  4593.         Result := TComponent(ComponentClass.NewInstance);
  4594.         if ffInline in Flags then
  4595.         begin
  4596.           Include(Result.FComponentState, csLoading);
  4597.           Include(Result.FComponentState, csInline);
  4598.         end;
  4599.         try
  4600.           Result.Create(Owner);
  4601.         except
  4602.           Result := nil;
  4603.           raise;
  4604.         end;
  4605.       end;
  4606.       Include(Result.FComponentState, csLoading);
  4607.     except
  4608.       if not Recover(Result) then raise;
  4609.     end;
  4610.   end;
  4611.  
  4612.   procedure SetCompName;
  4613.   begin
  4614.     try
  4615.       Result.SetParentComponent(Parent);
  4616.       SetName(Result, CompName);
  4617.       if Assigned(FindGlobalComponent) and
  4618.         (FindGlobalComponent(CompName) = Result) then
  4619.         Include(Result.FComponentState, csInline);
  4620.     except
  4621.       if not Recover(Result) then raise;
  4622.     end;
  4623.   end;
  4624.  
  4625.   procedure FindExistingComponent;
  4626.   begin
  4627.     try
  4628.       Result := FindAncestorComponent(CompName, FindComponentClass(CompClass));
  4629.       Parent := Result.GetParentComponent;
  4630.       if Parent = nil then Parent := Root;
  4631.     except
  4632.       if not Recover(Result) then raise;
  4633.     end;
  4634.   end;
  4635.  
  4636.  
  4637. begin
  4638.   ReadPrefix(Flags, Position);
  4639.   CompClass := ReadStr;
  4640.   CompName := ReadStr;
  4641.   OldParent := Parent;
  4642.   OldLookupRoot := FLookupRoot;
  4643.   try
  4644.     Result := Component;
  4645.     if Result = nil then
  4646.       if ffInherited in Flags then
  4647.         FindExistingComponent else
  4648.         CreateComponent;
  4649.     if Result <> nil then
  4650.       try
  4651.         Include(Result.FComponentState, csLoading);
  4652.         if not (ffInherited in Flags) then SetCompName;
  4653.         if Result = nil then Exit;
  4654.         if csInline in Result.ComponentState then
  4655.           FLookupRoot := Result;
  4656.         Include(Result.FComponentState, csReading);
  4657.         Result.ReadState(Self);
  4658.         Exclude(Result.FComponentState, csReading);
  4659.         if ffChildPos in Flags then Parent.SetChildOrder(Result, Position);
  4660.         if (ffInherited in Flags) or (csInline in Result.ComponentState) then
  4661.         begin
  4662.           if FLoaded.IndexOf(Result) < 0 then
  4663.             FLoaded.Add(Result)
  4664.         end
  4665.         else
  4666.           FLoaded.Add(Result);
  4667.       except
  4668.         if ComponentCreated then Result.Free;
  4669.         raise;
  4670.       end;
  4671.   finally
  4672.     Parent := OldParent;
  4673.     FLookupRoot := OldLookupRoot;
  4674.   end;
  4675. end;
  4676.  
  4677. procedure TReader.ReadData(Instance: TComponent);
  4678. begin
  4679.   if FFixups = nil then
  4680.   begin
  4681.     FFixups := TList.Create;
  4682.     try
  4683.       ReadDataInner(Instance);
  4684.       DoFixupReferences;
  4685.     finally
  4686.       FreeFixups;
  4687.     end;
  4688.   end else
  4689.     ReadDataInner(Instance);
  4690. end;
  4691.  
  4692. procedure TReader.ReadDataInner(Instance: TComponent);
  4693. var
  4694.   OldParent, OldOwner: TComponent;
  4695. begin
  4696.   while not EndOfList do ReadProperty(Instance);
  4697.   ReadListEnd;
  4698.   OldParent := Parent;
  4699.   OldOwner := Owner;
  4700.   Parent := Instance.GetChildParent;
  4701.   try
  4702.     Owner := Instance.GetChildOwner;
  4703.     if not Assigned(Owner) then Owner := Root;
  4704.     while not EndOfList do ReadComponent(nil);
  4705.     ReadListEnd;
  4706.   finally
  4707.     Parent := OldParent;
  4708.     Owner := OldOwner;
  4709.   end;
  4710. end;
  4711.  
  4712. function TReader.ReadFloat: Extended;
  4713. begin
  4714.   if ReadValue = vaExtended then Read(Result, SizeOf(Result)) else
  4715.   begin
  4716.     Dec(FBufPos);
  4717.     Result := ReadInteger;
  4718.   end;
  4719. end;
  4720.  
  4721. function TReader.ReadSingle: Single;
  4722. begin
  4723.   if ReadValue = vaSingle then Read(Result, SizeOf(Result)) else
  4724.   begin
  4725.     Dec(FBufPos);
  4726.     Result := ReadInteger;
  4727.   end;
  4728. end;
  4729.  
  4730. function TReader.ReadCurrency: Currency;
  4731. begin
  4732.   if ReadValue = vaCurrency then Read(Result, SizeOf(Result)) else
  4733.   begin
  4734.     Dec(FBufPos);
  4735.     Result := ReadInteger;
  4736.   end;
  4737. end;
  4738.  
  4739. function TReader.ReadDate: TDateTime;
  4740. begin
  4741.   if ReadValue = vaDate then Read(Result, SizeOf(Result)) else
  4742.   begin
  4743.     Dec(FBufPos);
  4744.     Result := ReadInteger;
  4745.   end;
  4746. end;
  4747.  
  4748. function TReader.ReadIdent: string;
  4749. var
  4750.   L: Byte;
  4751. begin
  4752.   case ReadValue of
  4753.     vaIdent:
  4754.       begin
  4755.         Read(L, SizeOf(Byte));
  4756.         SetString(Result, PChar(nil), L);
  4757.         Read(Result[1], L);
  4758.       end;
  4759.     vaFalse:
  4760.       Result := 'False';
  4761.     vaTrue:
  4762.       Result := 'True';
  4763.     vaNil:
  4764.       Result := 'nil';
  4765.     vaNull:
  4766.       Result := 'Null';
  4767.   else
  4768.     PropValueError;
  4769.   end;
  4770. end;
  4771.  
  4772. function TReader.ReadInteger: Longint;
  4773. var
  4774.   S: Shortint;
  4775.   I: Smallint;
  4776. begin
  4777.   case ReadValue of
  4778.     vaInt8:
  4779.       begin
  4780.         Read(S, SizeOf(Shortint));
  4781.         Result := S;
  4782.       end;
  4783.     vaInt16:
  4784.       begin
  4785.         Read(I, SizeOf(I));
  4786.         Result := I;
  4787.       end;
  4788.     vaInt32:
  4789.       Read(Result, SizeOf(Result));
  4790.   else
  4791.     PropValueError;
  4792.   end;
  4793. end;
  4794.  
  4795. function TReader.ReadInt64: Int64;
  4796. begin
  4797.   if NextValue = vaInt64 then
  4798.   begin
  4799.     ReadValue;
  4800.     Read(Result, Sizeof(Result));
  4801.   end
  4802.   else
  4803.     Result := ReadInteger;
  4804. end;
  4805.  
  4806. procedure TReader.ReadListBegin;
  4807. begin
  4808.   CheckValue(vaList);
  4809. end;
  4810.  
  4811. procedure TReader.ReadListEnd;
  4812. begin
  4813.   CheckValue(vaNull);
  4814. end;
  4815.  
  4816. procedure TReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
  4817. var
  4818.   Prefix: Byte;
  4819. begin
  4820.   Flags := [];
  4821.   if Byte(NextValue) and $F0 = $F0 then
  4822.   begin
  4823.     Prefix := Byte(ReadValue);
  4824.     Byte(Flags) := Prefix and $0F;
  4825.     if ffChildPos in Flags then AChildPos := ReadInteger;
  4826.   end;
  4827. end;
  4828.  
  4829. procedure TReader.ReadProperty(AInstance: TPersistent);
  4830. var
  4831.   I, J, L: Integer;
  4832.   Instance: TPersistent;
  4833.   PropInfo: PPropInfo;
  4834.   PropValue: TObject;
  4835.   PropPath: string;
  4836.  
  4837.   procedure HandleException(E: Exception);
  4838.   var
  4839.     Name: string;
  4840.   begin
  4841.     Name := '';
  4842.     if AInstance is TComponent then
  4843.       Name := TComponent(AInstance).Name;
  4844.     if Name = '' then Name := AInstance.ClassName;
  4845.     raise EReadError.CreateResFmt(@SPropertyException, [Name, DotSep, PropPath, E.Message]);
  4846.   end;
  4847.  
  4848.   procedure PropPathError;
  4849.   begin
  4850.     SkipValue;
  4851.     ReadError(@SInvalidPropertyPath);
  4852.   end;
  4853.  
  4854. begin
  4855.   try
  4856.     PropPath := ReadStr;
  4857.     try
  4858.       I := 1;
  4859.       L := Length(PropPath);
  4860.       Instance := AInstance;
  4861.       FCanHandleExcepts := True;
  4862.       while True do
  4863.       begin
  4864.         J := I;
  4865.         while (I <= L) and (PropPath[I] <> '.') do Inc(I);
  4866.         FPropName := Copy(PropPath, J, I - J);
  4867.         if I > L then Break;
  4868.         PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
  4869.         if PropInfo = nil then PropertyError;
  4870.         PropValue := nil;
  4871.         if PropInfo^.PropType^.Kind = tkClass then
  4872.           PropValue := TObject(GetOrdProp(Instance, PropInfo));
  4873.         if not (PropValue is TPersistent) then PropPathError;
  4874.         Instance := TPersistent(PropValue);
  4875.         Inc(I);
  4876.       end;
  4877.       PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
  4878.       if PropInfo <> nil then ReadPropValue(Instance, PropInfo) else
  4879.       begin
  4880.         { Cannot reliably recover from an error in a defined property }
  4881.         FCanHandleExcepts := False;
  4882.         Instance.DefineProperties(Self);
  4883.         FCanHandleExcepts := True;
  4884.         if FPropName <> '' then PropertyError;
  4885.       end;
  4886.     except
  4887.       on E: Exception do HandleException(E);
  4888.     end;
  4889.   except
  4890.     on E: Exception do
  4891.       if not FCanHandleExcepts or not Error(E.Message) then raise;
  4892.   end;
  4893. end;
  4894.  
  4895. procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  4896. const
  4897.   NilMethod: TMethod = (Code: nil; Data: nil);
  4898. var
  4899.   PropType: PTypeInfo;
  4900.   Method: TMethod;
  4901.  
  4902.   procedure SetIntIdent(Instance: TPersistent; PropInfo: Pointer;
  4903.     const Ident: string);
  4904.   var
  4905.     V: Longint;
  4906.     IdentToInt: TIdentToInt;
  4907.   begin
  4908.     IdentToInt := FindIdentToInt(PPropInfo(PropInfo)^.PropType^);
  4909.     if Assigned(IdentToInt) and IdentToInt(Ident, V) then
  4910.       SetOrdProp(Instance, PropInfo, V)
  4911.     else
  4912.       PropValueError;
  4913.   end;
  4914.  
  4915.   procedure SetObjectIdent(Instance: TPersistent; PropInfo: Pointer;
  4916.     const Ident: string);
  4917.   begin
  4918.     FFixups.Add(TPropFixup.Create(Instance, Root, PropInfo, '', Ident));
  4919.   end;
  4920.  
  4921.   procedure ReadVariantProp;
  4922.   const
  4923.     ValTtoVarT: array[TValueType] of Integer = (varNull, varError, varByte,
  4924.       varSmallInt, varInteger, varDouble, varString, varError, varBoolean,
  4925.       varBoolean, varError, varError, varString, varEmpty, varError, varSingle,
  4926.       varCurrency, varDate, varOleStr, varError);
  4927.   var
  4928.     Value: Variant;
  4929.     ValType: TValueType;
  4930.   begin
  4931.     ValType := NextValue;
  4932.     case ValType of
  4933.       vaNil, vaNull:
  4934.       begin
  4935.         if ReadValue = vaNil then
  4936.           VarClear(Value) else
  4937.           Value := NULL;
  4938.       end;
  4939.       vaInt8: TVarData(Value).VByte := Byte(ReadInteger);
  4940.       vaInt16: TVarData(Value).VSmallint := Smallint(ReadInteger);
  4941.       vaInt32: TVarData(Value).VInteger := ReadInteger;
  4942.       vaExtended: TVarData(Value).VDouble := ReadFloat;
  4943.       vaSingle: TVarData(Value).VSingle := ReadSingle;
  4944.       vaCurrency: TVarData(Value).VCurrency := ReadCurrency;
  4945.       vaDate: TVarData(Value).VDate := ReadDate;
  4946.       vaString, vaLString: Value := ReadString;
  4947.       vaWString: Value := ReadWideString;
  4948.       vaFalse, vaTrue: TVarData(Value).VBoolean := ReadValue = vaTrue;
  4949.     else
  4950.       raise EReadError.CreateRes(@SReadError);
  4951.     end;
  4952.     TVarData(Value).VType := ValTtoVarT[ValType];
  4953.     SetVariantProp(Instance, PropInfo, Value);
  4954.   end;
  4955.  
  4956. begin
  4957.   if PPropInfo(PropInfo)^.SetProc = nil then ReadError(@SReadOnlyProperty);
  4958.   PropType := PPropInfo(PropInfo)^.PropType^;
  4959.   case PropType^.Kind of
  4960.     tkInteger:
  4961.       if NextValue = vaIdent then
  4962.         SetIntIdent(Instance, PropInfo, ReadIdent) else
  4963.         SetOrdProp(Instance, PropInfo, ReadInteger);
  4964.     tkChar:
  4965.       SetOrdProp(Instance, PropInfo, Ord(ReadChar));
  4966.     tkEnumeration:
  4967.       SetOrdProp(Instance, PropInfo, EnumValue(PropType, ReadIdent));
  4968.     tkFloat:
  4969.       SetFloatProp(Instance, PropInfo, ReadFloat);
  4970.     tkString, tkLString, tkWString:
  4971.       SetStrProp(Instance, PropInfo, ReadString);
  4972.     tkSet:
  4973.       SetOrdProp(Instance, PropInfo, ReadSet(PropType));
  4974.     tkClass:
  4975.       case NextValue of
  4976.         vaNil:
  4977.           begin
  4978.             ReadValue;
  4979.             SetOrdProp(Instance, PropInfo, 0)
  4980.           end;
  4981.         vaCollection:
  4982.           begin
  4983.             ReadValue;
  4984.             ReadCollection(TCollection(GetOrdProp(Instance, PropInfo)));
  4985.           end
  4986.       else
  4987.         SetObjectIdent(Instance, PropInfo, ReadIdent);
  4988.       end;
  4989.     tkMethod:
  4990.       if NextValue = vaNil then
  4991.       begin
  4992.         ReadValue;
  4993.         SetMethodProp(Instance, PropInfo, NilMethod);
  4994.       end
  4995.       else
  4996.       begin
  4997.         Method.Code :=  FindMethod(Root, ReadIdent);
  4998.         Method.Data := Root;
  4999.         if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method);
  5000.       end;
  5001.     tkVariant:
  5002.       ReadVariantProp;
  5003.     tkInt64: SetInt64Prop(Instance, PropInfo, ReadInt64);
  5004.   end;
  5005. end;
  5006.  
  5007. function TReader.ReadRootComponent(Root: TComponent): TComponent;
  5008.  
  5009.   function FindUniqueName(const Name: string): string;
  5010.   var
  5011.     I: Integer;
  5012.   begin
  5013.     I := 0;
  5014.     Result := '';
  5015.     if Assigned(FindGlobalComponent) then
  5016.     begin
  5017.       Result := Name;
  5018.       while FindGlobalComponent(Result) <> nil do
  5019.       begin
  5020.         Inc(I);
  5021.         Result := Format('%s_%d', [Name, I]);
  5022.       end;
  5023.     end;
  5024.   end;
  5025.  
  5026. var
  5027.   I: Integer;
  5028.   Flags: TFilerFlags;
  5029. begin
  5030.   ReadSignature;
  5031.   Result := nil;
  5032.   GlobalNameSpace.BeginWrite;  // Loading from stream adds to name space
  5033.   try
  5034.     try
  5035.       ReadPrefix(Flags, I);
  5036.       if Root = nil then
  5037.       begin
  5038.         Result := TComponentClass(FindClass(ReadStr)).Create(nil);
  5039.         Result.Name := ReadStr;
  5040.       end else
  5041.       begin
  5042.         Result := Root;
  5043.         ReadStr; { Ignore class name }
  5044.         if csDesigning in Result.ComponentState then
  5045.           ReadStr else
  5046.         begin
  5047.           Include(Result.FComponentState, csLoading);
  5048.           Include(Result.FComponentState, csReading);
  5049.           Result.Name := FindUniqueName(ReadStr);
  5050.         end;
  5051.       end;
  5052.       FRoot := Result;
  5053.       FLookupRoot := Result;
  5054.       if GlobalLoaded <> nil then
  5055.         FLoaded := GlobalLoaded else
  5056.         FLoaded := TList.Create;
  5057.       try
  5058.         if FLoaded.IndexOf(FRoot) < 0 then
  5059.           FLoaded.Add(FRoot);
  5060.         FOwner := FRoot;
  5061.         Include(FRoot.FComponentState, csLoading);
  5062.         Include(FRoot.FComponentState, csReading);
  5063.         FRoot.ReadState(Self);
  5064.         Exclude(FRoot.FComponentState, csReading);
  5065.         if GlobalLoaded = nil then
  5066.           for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
  5067.       finally
  5068.         if GlobalLoaded = nil then FLoaded.Free;
  5069.         FLoaded := nil;
  5070.       end;
  5071.       GlobalFixupReferences;
  5072.     except
  5073.       RemoveFixupReferences(Root, '');
  5074.       if Root = nil then Result.Free;
  5075.       raise;
  5076.     end;
  5077.   finally
  5078.     GlobalNameSpace.EndWrite;
  5079.   end;
  5080. end;
  5081.  
  5082. procedure TReader.ReadComponents(AOwner, AParent: TComponent;
  5083.   Proc: TReadComponentsProc);
  5084. var
  5085.   Component: TComponent;
  5086. begin
  5087.   Root := AOwner;
  5088.   Owner := AOwner;
  5089.   Parent := AParent;
  5090.   BeginReferences;
  5091.   try
  5092.     while not EndOfList do
  5093.     begin
  5094.       ReadSignature;
  5095.       Component := ReadComponent(nil);
  5096.       if Assigned(Proc) then Proc(Component);
  5097.     end;
  5098.     ReadListEnd;
  5099.     FixupReferences;
  5100.   finally
  5101.     EndReferences;
  5102.   end;
  5103. end;
  5104.  
  5105. function TReader.ReadSet(SetType: Pointer): Integer;
  5106. var
  5107.   EnumType: PTypeInfo;
  5108.   EnumName: string;
  5109. begin
  5110.   try
  5111.     if ReadValue <> vaSet then PropValueError;
  5112.     EnumType := GetTypeData(SetType)^.CompType^;
  5113.     Result := 0;
  5114.     while True do
  5115.     begin
  5116.       EnumName := ReadStr;
  5117.       if EnumName = '' then Break;
  5118.       Include(TIntegerSet(Result), EnumValue(EnumType, EnumName));
  5119.     end;
  5120.   except
  5121.     SkipSetBody;
  5122.     raise;
  5123.   end;
  5124. end;
  5125.  
  5126. procedure TReader.ReadSignature;
  5127. var
  5128.   Signature: Longint;
  5129. begin
  5130.   Read(Signature, SizeOf(Signature));
  5131.   if Signature <> Longint(FilerSignature) then ReadError(@SInvalidImage);
  5132. end;
  5133.  
  5134. function TReader.ReadStr: string;
  5135. var
  5136.   L: Byte;
  5137. begin
  5138.   Read(L, SizeOf(Byte));
  5139.   SetString(Result, PChar(nil), L);
  5140.   Read(Result[1], L);
  5141. end;
  5142.  
  5143. function TReader.ReadString: string;
  5144. var
  5145.   L: Integer;
  5146. begin
  5147.   L := 0;
  5148.   case ReadValue of
  5149.     vaString:
  5150.       Read(L, SizeOf(Byte));
  5151.     vaLString:
  5152.       Read(L, SizeOf(Integer));
  5153.   else
  5154.     PropValueError;
  5155.   end;
  5156.   SetString(Result, PChar(nil), L);
  5157.   Read(Pointer(Result)^, L);
  5158. end;
  5159.  
  5160. function TReader.ReadWideString: WideString;
  5161. var
  5162.   L: Integer;
  5163. begin
  5164.   L := 0;
  5165.   if ReadValue <> vaWString then
  5166.     PropValueError;
  5167.   Read(L, SizeOf(Integer));
  5168.   SetLength(Result, L);
  5169.   Read(Pointer(Result)^, L * 2);
  5170. end;
  5171.  
  5172. function TReader.ReadValue: TValueType;
  5173. begin
  5174.   Read(Result, SizeOf(Result));
  5175. end;
  5176.  
  5177. procedure TReader.SetPosition(Value: Longint);
  5178. begin
  5179.   FStream.Position := Value;
  5180.   FBufPos := 0;
  5181.   FBufEnd := 0;
  5182. end;
  5183.  
  5184. procedure TReader.SkipSetBody;
  5185. begin
  5186.   while ReadStr <> '' do begin end;
  5187. end;
  5188.  
  5189. procedure TReader.SkipValue;
  5190.  
  5191.   procedure SkipList;
  5192.   begin
  5193.     while not EndOfList do SkipValue;
  5194.     ReadListEnd;
  5195.   end;
  5196.  
  5197.   procedure SkipBytes(Count: Longint);
  5198.   var
  5199.     Bytes: array[0..255] of Char;
  5200.   begin
  5201.     while Count > 0 do
  5202.       if Count > SizeOf(Bytes) then
  5203.       begin
  5204.         Read(Bytes, SizeOf(Bytes));
  5205.         Dec(Count, SizeOf(Bytes));
  5206.       end
  5207.       else
  5208.       begin
  5209.         Read(Bytes, Count);
  5210.         Count := 0;
  5211.       end;
  5212.   end;
  5213.  
  5214.   procedure SkipBinary;
  5215.   var
  5216.     Count: Longint;
  5217.   begin
  5218.     Read(Count, SizeOf(Count));
  5219.     SkipBytes(Count);
  5220.   end;
  5221.  
  5222.   procedure SkipCollection;
  5223.   begin
  5224.     while not EndOfList do
  5225.     begin
  5226.       if NextValue in [vaInt8, vaInt16, vaInt32] then SkipValue;
  5227.       SkipBytes(1);
  5228.       while not EndOfList do SkipProperty;
  5229.       ReadListEnd;
  5230.     end;
  5231.     ReadListEnd;
  5232.   end;
  5233.  
  5234. begin
  5235.   case ReadValue of
  5236.     vaNull: begin end;
  5237.     vaList: SkipList;
  5238.     vaInt8: SkipBytes(1);
  5239.     vaInt16: SkipBytes(2);
  5240.     vaInt32: SkipBytes(4);
  5241.     vaExtended: SkipBytes(SizeOf(Extended));
  5242.     vaString, vaIdent: ReadStr;
  5243.     vaFalse, vaTrue: begin end;
  5244.     vaBinary: SkipBinary;
  5245.     vaSet: SkipSetBody;
  5246.     vaLString: SkipBinary;
  5247.     vaCollection: SkipCollection;
  5248.     vaSingle: SkipBytes(Sizeof(Single));
  5249.     vaCurrency: SkipBytes(SizeOf(Currency));
  5250.     vaDate: SkipBytes(Sizeof(TDateTime));
  5251.     vaWString: SkipBinary;
  5252.     vaInt64: SkipBytes(Sizeof(Int64));
  5253.   end;
  5254. end;
  5255.  
  5256. procedure TReader.CopyValue(Writer: TWriter);
  5257.  
  5258.   procedure CopySetBody;
  5259.   var
  5260.     s: string;
  5261.   begin
  5262.     Writer.WriteValue(ReadValue);
  5263.     repeat
  5264.       s := ReadStr;
  5265.       Writer.WriteStr(s);
  5266.     until s = '';
  5267.   end;
  5268.  
  5269.   procedure CopyList;
  5270.   begin
  5271.     Writer.WriteValue(ReadValue);
  5272.     while not EndOfList do
  5273.       CopyValue(Writer);
  5274.     ReadListEnd;
  5275.     Writer.WriteListEnd;
  5276.   end;
  5277.  
  5278.   procedure CopyBytes(Count: Longint);
  5279.   var
  5280.     Bytes: array[0..8191] of Char;
  5281.   begin
  5282.     while Count > SizeOf(Bytes) do
  5283.     begin
  5284.       Read(Bytes, SizeOf(Bytes));
  5285.       Writer.Write(Bytes, SizeOf(Bytes));
  5286.       Dec(Count, SizeOf(Bytes));
  5287.     end;
  5288.     if Count > 0 then
  5289.     begin
  5290.       Read(Bytes, Count);
  5291.       Writer.Write(Bytes, Count);
  5292.     end;
  5293.   end;
  5294.  
  5295.   procedure CopyBinary;
  5296.   var
  5297.     Count: Longint;
  5298.   begin
  5299.     Writer.WriteValue(ReadValue);
  5300.     Read(Count, SizeOf(Count));
  5301.     Writer.Write(Count, SizeOf(Count));
  5302.     CopyBytes(Count);
  5303.   end;
  5304.  
  5305. begin
  5306.   case NextValue of
  5307.     vaNull, vaFalse, vaTrue, vaNil: Writer.WriteValue(ReadValue);
  5308.     vaList, vaCollection: CopyList;
  5309.     vaInt8, vaInt16, vaInt32: Writer.WriteInteger(ReadInteger);
  5310.     vaExtended: Writer.WriteFloat(ReadFloat);
  5311.     vaString: Writer.WriteStr(ReadStr);
  5312.     vaIdent: Writer.WriteIdent(ReadIdent);
  5313.     vaBinary, vaLString, vaWString: CopyBinary;
  5314.     vaSet: CopySetBody;
  5315.     vaSingle: Writer.WriteSingle(ReadSingle);
  5316.     vaCurrency: Writer.WriteCurrency(ReadCurrency);
  5317.     vaDate: Writer.WriteDate(ReadDate);
  5318.     vaInt64: Writer.WriteInteger(ReadInt64);
  5319.   end;
  5320. end;
  5321.  
  5322. procedure TReader.SkipProperty;
  5323. begin
  5324.   ReadStr; { Skips property name }
  5325.   SkipValue;
  5326. end;
  5327.  
  5328. procedure TReader.SkipComponent(SkipHeader: Boolean);
  5329. var
  5330.   Flags: TFilerFlags;
  5331.   Position: Integer;
  5332. begin
  5333.   if SkipHeader then
  5334.   begin
  5335.     ReadPrefix(Flags, Position);
  5336.     ReadStr;
  5337.     ReadStr;
  5338.   end;
  5339.   while not EndOfList do SkipProperty;
  5340.   ReadListEnd;
  5341.   while not EndOfList do SkipComponent(True);
  5342.   ReadListEnd;
  5343. end;
  5344.  
  5345. function TReader.FindAncestorComponent(const Name: string;
  5346.   ComponentClass: TPersistentClass): TComponent;
  5347. var
  5348.   CompName: string;
  5349. begin
  5350.   CompName := Name;
  5351.   Result := nil;
  5352.   if FLookupRoot <> nil then
  5353.     Result := FLookupRoot.FindComponent(CompName);
  5354.   if Result = nil then
  5355.   begin
  5356.     if Assigned(FOnAncestorNotFound) then
  5357.       FOnAncestorNotFound(Self, CompName, ComponentClass, Result);
  5358.     if Result = nil then
  5359.       raise EReadError.CreateResFmt(@SAncestorNotFound, [CompName]);
  5360.   end;
  5361. end;
  5362.  
  5363. procedure TReader.ReferenceName(var Name: string);
  5364. begin
  5365.   if Assigned(FOnReferenceName) then FOnReferenceName(Self, Name);
  5366. end;
  5367.  
  5368. procedure TReader.SetName(Component: TComponent; var Name: string);
  5369. begin
  5370.   if Assigned(FOnSetName) then FOnSetName(Self, Component, Name);
  5371.   Component.Name := Name;
  5372. end;
  5373.  
  5374. function TReader.FindComponentClass(const ClassName: string): TComponentClass;
  5375. begin
  5376.   TPersistentClass(Result) := GetFieldClass(Root, ClassName);
  5377.   if not Assigned(Result) and Assigned(FLookupRoot) and (FLookupRoot <> Root) then
  5378.     TPersistentClass(Result) := GetFieldClass(FLookupRoot, ClassName);
  5379.   if Assigned(FOnFindComponentClass) then
  5380.     FOnFindComponentClass(Self, ClassName, Result);
  5381.   if (Result = nil) or not Result.InheritsFrom(TComponent) then
  5382.     ClassNotFound(ClassName);
  5383. end;
  5384.  
  5385. { TWriter }
  5386.  
  5387. destructor TWriter.Destroy;
  5388. begin
  5389.   WriteBuffer;
  5390.   inherited Destroy;
  5391. end;
  5392.  
  5393. procedure TWriter.AddAncestor(Component: TComponent);
  5394. begin
  5395.   FAncestorList.Add(Component);
  5396. end;
  5397.  
  5398. procedure TWriter.DefineProperty(const Name: string;
  5399.   ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
  5400. begin
  5401.   if HasData and Assigned(WriteData) then
  5402.   begin
  5403.     WritePropName(Name);
  5404.     WriteData(Self);
  5405.   end;
  5406. end;
  5407.  
  5408. procedure TWriter.DefineBinaryProperty(const Name: string;
  5409.   ReadData, WriteData: TStreamProc; HasData: Boolean);
  5410. begin
  5411.   if HasData and Assigned(WriteData) then
  5412.   begin
  5413.     WritePropName(Name);
  5414.     WriteBinary(WriteData);
  5415.   end;
  5416. end;
  5417.  
  5418. function TWriter.GetPosition: Longint;
  5419. begin
  5420.   Result := FStream.Position + FBufPos;
  5421. end;
  5422.  
  5423. procedure TWriter.FlushBuffer;
  5424. begin
  5425.   WriteBuffer;
  5426. end;
  5427.  
  5428. procedure TWriter.SetPosition(Value: Longint);
  5429. var
  5430.   StreamPosition: Longint;
  5431. begin
  5432.   StreamPosition := FStream.Position;
  5433.   { Only flush the buffer if the repostion is outside the buffer range }
  5434.   if (Value < StreamPosition) or (Value > StreamPosition + FBufPos) then
  5435.   begin
  5436.     WriteBuffer;
  5437.     FStream.Position := Value;
  5438.   end
  5439.   else FBufPos := Value - StreamPosition;
  5440. end;
  5441.  
  5442. procedure TWriter.SetRoot(Value: TComponent);
  5443. begin
  5444.   inherited SetRoot(Value);
  5445.   FLookupRoot := Value;
  5446. end;
  5447.  
  5448. procedure TWriter.Write(const Buf; Count: Longint); assembler;
  5449. asm
  5450.         PUSH    ESI
  5451.         PUSH    EDI
  5452.         PUSH    EBX
  5453.         MOV     ESI,EDX
  5454.         MOV     EBX,ECX
  5455.         MOV     EDI,EAX
  5456.         JMP     @@6
  5457. @@1:    MOV     ECX,[EDI].TWriter.FBufSize
  5458.         SUB     ECX,[EDI].TWriter.FBufPos
  5459.         JA      @@2
  5460.         MOV     EAX,EDI
  5461.         CALL    TWriter.WriteBuffer
  5462.         MOV     ECX,[EDI].TWriter.FBufSize
  5463. @@2:    CMP     ECX,EBX
  5464.         JB      @@3
  5465.         MOV     ECX,EBX
  5466. @@3:    SUB     EBX,ECX
  5467.         PUSH    EDI
  5468.         MOV     EAX,[EDI].TWriter.FBuffer
  5469.         ADD     EAX,[EDI].TWriter.FBufPos
  5470.         ADD     [EDI].TWriter.FBufPos,ECX
  5471. @@5:    MOV     EDI,EAX
  5472.         MOV     EDX,ECX
  5473.         SHR     ECX,2
  5474.         CLD
  5475.         REP     MOVSD
  5476.         MOV     ECX,EDX
  5477.         AND     ECX,3
  5478.         REP     MOVSB
  5479.         POP     EDI
  5480. @@6:    OR      EBX,EBX
  5481.         JNE     @@1
  5482.         POP     EBX
  5483.         POP     EDI
  5484.         POP     ESI
  5485. end;
  5486.  
  5487. procedure TWriter.WriteBinary(WriteData: TStreamProc);
  5488. var
  5489.   Stream: TMemoryStream;
  5490.   Count: Longint;
  5491. begin
  5492.   Stream := TMemoryStream.Create;
  5493.   try
  5494.     WriteData(Stream);
  5495.     WriteValue(vaBinary);
  5496.     Count := Stream.Size;
  5497.     Write(Count, SizeOf(Count));
  5498.     Write(Stream.Memory^, Count);
  5499.   finally
  5500.     Stream.Free;
  5501.   end;
  5502. end;
  5503.  
  5504. procedure TWriter.WriteBuffer;
  5505. begin
  5506.   FStream.WriteBuffer(FBuffer^, FBufPos);
  5507.   FBufPos := 0;
  5508. end;
  5509.  
  5510. procedure TWriter.WriteBoolean(Value: Boolean);
  5511. begin
  5512.   if Value then
  5513.     WriteValue(vaTrue) else
  5514.     WriteValue(vaFalse);
  5515. end;
  5516.  
  5517. procedure TWriter.WriteChar(Value: Char);
  5518. begin
  5519.   WriteString(Value);
  5520. end;
  5521.  
  5522. procedure TWriter.WriteCollection(Value: TCollection);
  5523. var
  5524.   I: Integer;
  5525. begin
  5526.   WriteValue(vaCollection);
  5527.   if Value <> nil then
  5528.     for I := 0 to Value.Count - 1 do
  5529.     begin
  5530.       WriteListBegin;
  5531.       WriteProperties(Value.Items[I]);
  5532.       WriteListEnd;
  5533.     end;
  5534.   WriteListEnd;
  5535. end;
  5536.  
  5537. procedure TWriter.WriteComponent(Component: TComponent);
  5538.  
  5539.   function FindAncestor(const Name: string): TComponent;
  5540.   var
  5541.     I: Integer;
  5542.   begin
  5543.     for I := 0 to FAncestorList.Count - 1 do
  5544.     begin
  5545.       Result := FAncestorList[I];
  5546.       if SameText(Result.Name, Name) then Exit;
  5547.     end;
  5548.     Result := nil;
  5549.   end;
  5550.  
  5551. var
  5552.   OldAncestor: TPersistent;
  5553.   OldRootAncestor: TComponent;
  5554.   AncestorComponent: TComponent;
  5555. begin
  5556.   OldAncestor := Ancestor;
  5557.   OldRootAncestor := RootAncestor;
  5558.   try
  5559.     Include(Component.FComponentState, csWriting);
  5560.     if Assigned(FAncestorList) then
  5561.       Ancestor := FindAncestor(Component.Name);
  5562.     if Assigned(FOnFindAncestor) and ((Ancestor = nil) or (Ancestor is
  5563.       TComponent)) then
  5564.     begin
  5565.       AncestorComponent := TComponent(Ancestor);
  5566.       FOnFindAncestor(Self, Component, Component.Name, AncestorComponent,
  5567.         FRootAncestor);
  5568.       Ancestor := AncestorComponent;
  5569.     end;
  5570.     Component.WriteState(Self);
  5571.     Exclude(Component.FComponentState, csWriting);
  5572.   finally
  5573.     Ancestor := OldAncestor;
  5574.     FRootAncestor := OldRootAncestor;
  5575.   end;
  5576. end;
  5577.  
  5578. procedure TWriter.WriteData(Instance: TComponent);
  5579. var
  5580.   PreviousPosition, PropertiesPosition: Longint;
  5581.   OldAncestorList: TList;
  5582.   OldAncestorPos, OldChildPos: Integer;
  5583.   OldRoot, OldRootAncestor: TComponent;
  5584.   Flags: TFilerFlags;
  5585. begin
  5586.   if FBufSize - FBufPos < Length(Instance.ClassName) +
  5587.     Length(Instance.Name) + 1+5+3 then WriteBuffer;
  5588.      { Prefix + vaInt + integer + 2 end lists }
  5589.   PreviousPosition := Position;
  5590.   Flags := [];
  5591.   if csInline in Instance.ComponentState then
  5592.     if (Ancestor <> nil) and (csAncestor in Instance.ComponentState) and (FAncestorList <> nil) then
  5593.       // If the AncestorList is not nil, this really came from an ancestor form
  5594.       Include(Flags, ffInherited)
  5595.     else
  5596.       // otherwise the Ancestor is the original frame
  5597.       Include(Flags, ffInline)
  5598.   else if Ancestor <> nil then
  5599.     Include(Flags, ffInherited);
  5600.   if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) and
  5601.     ((Ancestor = nil) or (FAncestorList[FAncestorPos] <> Ancestor)) then
  5602.     Include(Flags, ffChildPos);
  5603.   WritePrefix(Flags, FChildPos);
  5604.   WriteStr(Instance.ClassName);
  5605.   WriteStr(Instance.Name);
  5606.   PropertiesPosition := Position;
  5607.   if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) then
  5608.   begin
  5609.     if Ancestor <> nil then Inc(FAncestorPos);
  5610.     Inc(FChildPos);
  5611.   end;
  5612.   WriteProperties(Instance);
  5613.   WriteListEnd;
  5614.   OldAncestorList := FAncestorList;
  5615.   OldAncestorPos := FAncestorPos;
  5616.   OldChildPos := FChildPos;
  5617.   OldRoot := FRoot;
  5618.   OldRootAncestor := FRootAncestor;
  5619.   try
  5620.     FAncestorList := nil;
  5621.     FAncestorPos := 0;
  5622.     FChildPos := 0;
  5623.     if not IgnoreChildren then
  5624.       try
  5625.         if (FAncestor <> nil) and (FAncestor is TComponent) then
  5626.         begin
  5627.           if (FAncestor is TComponent) and (csInline in TComponent(FAncestor).ComponentState) then
  5628.             FRootAncestor := TComponent(FAncestor);
  5629.           FAncestorList := TList.Create;
  5630.           TComponent(FAncestor).GetChildren(AddAncestor, FRootAncestor);
  5631.         end;
  5632.         if csInline in Instance.ComponentState then
  5633.           FRoot := Instance;
  5634.         Instance.GetChildren(WriteComponent, FRoot);
  5635.       finally
  5636.         FAncestorList.Free;
  5637.       end;
  5638.   finally
  5639.     FAncestorList := OldAncestorList;
  5640.     FAncestorPos := OldAncestorPos;
  5641.     FChildPos := OldChildPos;
  5642.     FRoot := OldRoot;
  5643.     FRootAncestor := OldRootAncestor;
  5644.   end;
  5645.   WriteListEnd;
  5646.   if (Instance <> Root) and (Flags = [ffInherited]) and
  5647.     (Position = PropertiesPosition + (1 + 1)) then { (1 + 1) is two end lists }
  5648.     Position := PreviousPosition;
  5649. end;
  5650.  
  5651. procedure TWriter.WriteDescendent(Root: TComponent; AAncestor: TComponent);
  5652. begin
  5653.   FRootAncestor := AAncestor;
  5654.   FAncestor := AAncestor;
  5655.   FRoot := Root;
  5656.   FLookupRoot := Root;
  5657.   WriteSignature;
  5658.   WriteComponent(Root);
  5659. end;
  5660.  
  5661. procedure TWriter.WriteFloat(const Value: Extended);
  5662. begin
  5663.   WriteValue(vaExtended);
  5664.   Write(Value, SizeOf(Extended));
  5665. end;
  5666.  
  5667. procedure TWriter.WriteSingle(const Value: Single);
  5668. begin
  5669.   WriteValue(vaSingle);
  5670.   Write(Value, SizeOf(Single));
  5671. end;
  5672.  
  5673. procedure TWriter.WriteCurrency(const Value: Currency);
  5674. begin
  5675.   WriteValue(vaCurrency);
  5676.   Write(Value, SizeOf(Currency));
  5677. end;
  5678.  
  5679. procedure TWriter.WriteDate(const Value: TDateTime);
  5680. begin
  5681.   WriteValue(vaDate);
  5682.   Write(Value, SizeOf(TDateTime));
  5683. end;
  5684.  
  5685. procedure TWriter.WriteIdent(const Ident: string);
  5686. begin
  5687.   if SameText(Ident, 'False') then WriteValue(vaFalse) else
  5688.   if SameText(Ident ,'True') then WriteValue(vaTrue) else
  5689.   if SameText(Ident ,'Null') then WriteValue(vaNull) else
  5690.   if SameText(Ident, 'nil') then WriteValue(vaNil) else
  5691.   begin
  5692.     WriteValue(vaIdent);
  5693.     WriteStr(Ident);
  5694.   end;
  5695. end;
  5696.  
  5697. procedure TWriter.WriteInteger(Value: Longint);
  5698. begin
  5699.   if (Value >= Low(ShortInt)) and (Value <= High(ShortInt)) then
  5700.   begin
  5701.     WriteValue(vaInt8);
  5702.     Write(Value, SizeOf(Shortint));
  5703.   end else
  5704.   if (Value >= Low(SmallInt)) and (Value <= High(SmallInt)) then
  5705.   begin
  5706.     WriteValue(vaInt16);
  5707.     Write(Value, SizeOf(Smallint));
  5708.   end
  5709.   else
  5710.   begin
  5711.     WriteValue(vaInt32);
  5712.     Write(Value, SizeOf(Integer));
  5713.   end;
  5714. end;
  5715.  
  5716. procedure TWriter.WriteInteger(Value: Int64);
  5717. begin
  5718.   if (Value >= Low(Integer)) and (Value <= High(Integer)) then
  5719.     WriteInteger(Longint(Value))
  5720.   else
  5721.   begin
  5722.     WriteValue(vaInt64);
  5723.     Write(Value, Sizeof(Int64));
  5724.   end;
  5725. end;
  5726.  
  5727. procedure TWriter.WriteListBegin;
  5728. begin
  5729.   WriteValue(vaList);
  5730. end;
  5731.  
  5732. procedure TWriter.WriteListEnd;
  5733. begin
  5734.   WriteValue(vaNull);
  5735. end;
  5736.  
  5737. procedure TWriter.WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  5738. var
  5739.   Prefix: Byte;
  5740. begin
  5741.   if Flags <> [] then
  5742.   begin
  5743.     Prefix := $F0 or Byte(Flags);
  5744.     Write(Prefix, SizeOf(Prefix));
  5745.     if ffChildPos in Flags then WriteInteger(AChildPos);
  5746.   end;
  5747. end;
  5748.  
  5749. procedure TWriter.WriteProperties(Instance: TPersistent);
  5750. var
  5751.   I, Count: Integer;
  5752.   PropInfo: PPropInfo;
  5753.   PropList: PPropList;
  5754. begin
  5755.   Count := GetTypeData(Instance.ClassInfo)^.PropCount;
  5756.   if Count > 0 then
  5757.   begin
  5758.     GetMem(PropList, Count * SizeOf(Pointer));
  5759.     try
  5760.       GetPropInfos(Instance.ClassInfo, PropList);
  5761.       for I := 0 to Count - 1 do
  5762.       begin
  5763.         PropInfo := PropList^[I];
  5764.         if PropInfo = nil then break;
  5765.         if IsStoredProp(Instance, PropInfo) then
  5766.           WriteProperty(Instance, PropInfo);
  5767.       end;
  5768.     finally
  5769.       FreeMem(PropList, Count * SizeOf(Pointer));
  5770.     end;
  5771.   end;
  5772.   Instance.DefineProperties(Self);
  5773. end;
  5774.  
  5775. procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  5776. var
  5777.   PropType: PTypeInfo;
  5778.  
  5779.   function AncestorValid: Boolean;
  5780.   begin
  5781.     Result := (Ancestor <> nil) and ((Instance.ClassType = Ancestor.ClassType) or
  5782.       (Instance = Root));
  5783.   end;
  5784.  
  5785.   procedure WritePropPath;
  5786.   begin
  5787.     WritePropName(PPropInfo(PropInfo)^.Name);
  5788.   end;
  5789.  
  5790.   procedure WriteSet(Value: Longint);
  5791.   var
  5792.     I: Integer;
  5793.     BaseType: PTypeInfo;
  5794.   begin
  5795.     BaseType := GetTypeData(PropType)^.CompType^;
  5796.     WriteValue(vaSet);
  5797.     for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do
  5798.       if I in TIntegerSet(Value) then WriteStr(GetEnumName(BaseType, I));
  5799.     WriteStr('');
  5800.   end;
  5801.  
  5802.   procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
  5803.   var
  5804.     Ident: string;
  5805.     IntToIdent: TIntToIdent;
  5806.   begin
  5807.     IntToIdent := FindIntToIdent(IntType);
  5808.     if Assigned(IntToIdent) and IntToIdent(Value, Ident) then
  5809.       WriteIdent(Ident)
  5810.     else
  5811.       WriteInteger(Value);
  5812.   end;
  5813.  
  5814.   procedure WriteCollectionProp(Collection: TCollection);
  5815.   var
  5816.     SavePropPath: string;
  5817.   begin
  5818.     WritePropPath;
  5819.     SavePropPath := FPropPath;
  5820.     try
  5821.       FPropPath := '';
  5822.       WriteCollection(Collection);
  5823.     finally
  5824.       FPropPath := SavePropPath;
  5825.     end;
  5826.   end;
  5827.  
  5828.   procedure WriteOrdProp;
  5829.   var
  5830.     Value: Longint;
  5831.  
  5832.     function IsDefaultValue: Boolean;
  5833.     begin
  5834.       if AncestorValid then
  5835.         Result := Value = GetOrdProp(Ancestor, PropInfo) else
  5836.         Result := Value = PPropInfo(PropInfo)^.Default;
  5837.     end;
  5838.  
  5839.   begin
  5840.     Value := GetOrdProp(Instance, PropInfo);
  5841.     if not IsDefaultValue then
  5842.     begin
  5843.       WritePropPath;
  5844.       case PropType^.Kind of
  5845.         tkInteger:
  5846.           WriteIntProp(PPropInfo(PropInfo)^.PropType^, Value);
  5847.         tkChar:
  5848.           WriteChar(Chr(Value));
  5849.         tkSet:
  5850.           WriteSet(Value);
  5851.         tkEnumeration:
  5852.           WriteIdent(GetEnumName(PropType, Value));
  5853.       end;
  5854.     end;
  5855.   end;
  5856.  
  5857.   procedure WriteFloatProp;
  5858.   var
  5859.     Value: Extended;
  5860.  
  5861.     function IsDefaultValue: Boolean;
  5862.     begin
  5863.       if AncestorValid then
  5864.         Result := Value = GetFloatProp(Ancestor, PropInfo) else
  5865.         Result := Value = 0;
  5866.     end;
  5867.  
  5868.   begin
  5869.     Value := GetFloatProp(Instance, PropInfo);
  5870.     if not IsDefaultValue then
  5871.     begin
  5872.       WritePropPath;
  5873.       WriteFloat(Value);
  5874.     end;
  5875.   end;
  5876.  
  5877.   procedure WriteInt64Prop;
  5878.   var
  5879.     Value: Int64;
  5880.  
  5881.     function IsDefaultValue: Boolean;
  5882.     begin
  5883.       if AncestorValid then
  5884.         Result := Value = GetInt64Prop(Ancestor, PropInfo) else
  5885.         Result := Value = 0;
  5886.     end;
  5887.  
  5888.   begin
  5889.     Value := GetInt64Prop(Instance, PropInfo);
  5890.     if not IsDefaultValue then
  5891.     begin
  5892.       WritePropPath;
  5893.       WriteInteger(Value);
  5894.     end;
  5895.   end;
  5896.  
  5897.   procedure WriteStrProp;
  5898.   var
  5899.     Value: string;
  5900.  
  5901.     function IsDefault: Boolean;
  5902.     begin
  5903.       if AncestorValid then
  5904.         Result := Value = GetStrProp(Ancestor, PropInfo) else
  5905.         Result := Value = '';
  5906.     end;
  5907.  
  5908.   begin
  5909.     Value := GetStrProp(Instance, PropInfo);
  5910.     if not IsDefault then
  5911.     begin
  5912.       WritePropPath;
  5913.       WriteString(Value);
  5914.     end;
  5915.   end;
  5916.  
  5917.   procedure WriteObjectProp;
  5918.   var
  5919.     Value: TObject;
  5920.     OldAncestor: TPersistent;
  5921.     SavePropPath, ComponentValue: string;
  5922.  
  5923.     function IsDefault: Boolean;
  5924.     var
  5925.       AncestorValue: TObject;
  5926.     begin
  5927.       AncestorValue := nil;
  5928.       if AncestorValid then
  5929.       begin
  5930.         AncestorValue := TObject(GetOrdProp(Ancestor, PropInfo));
  5931.         if (AncestorValue <> nil) and (TComponent(AncestorValue).Owner = FRootAncestor) and
  5932.           (Value <> nil) and (TComponent(Value).Owner = Root) and
  5933.           SameText(TComponent(AncestorValue).Name, TComponent(Value).Name) then
  5934.           AncestorValue := Value;
  5935.       end;
  5936.       Result := Value = AncestorValue;
  5937.     end;
  5938.  
  5939.     function GetComponentValue(Component: TComponent): string;
  5940.     begin
  5941.       if Component.Owner = LookupRoot then
  5942.         Result := Component.Name
  5943.       else if Component = LookupRoot then
  5944.         Result := 'Owner'                                                       { Do not translate }
  5945.       else if (Component.Owner <> nil) and (Component.Owner.Name <> '') and
  5946.         (Component.Name <> '') then
  5947.         Result := Component.Owner.Name + '.' + Component.Name
  5948.       else if Component.Name <> '' then
  5949.         Result := Component.Name + '.Owner'                                     { Do not translate }
  5950.       else Result := '';
  5951.     end;
  5952.  
  5953.   begin
  5954.     Value := TObject(GetOrdProp(Instance, PropInfo));
  5955.     if (Value = nil) and not IsDefault then
  5956.     begin
  5957.       WritePropPath;
  5958.       WriteValue(vaNil);
  5959.     end
  5960.     else if Value is TPersistent then
  5961.       if Value is TComponent then
  5962.       begin
  5963.         if not IsDefault then
  5964.         begin
  5965.           ComponentValue := GetComponentValue(TComponent(Value));
  5966.           if ComponentValue <> '' then
  5967.           begin
  5968.             WritePropPath;
  5969.             WriteIdent(ComponentValue);
  5970.           end
  5971.         end
  5972.       end else if Value is TCollection then
  5973.       begin
  5974.         if not AncestorValid or
  5975.           not CollectionsEqual(TCollection(Value),
  5976.             TCollection(GetOrdProp(Ancestor, PropInfo))) then
  5977.             WriteCollectionProp(TCollection(Value));
  5978.       end else
  5979.       begin
  5980.         OldAncestor := Ancestor;
  5981.         SavePropPath := FPropPath;
  5982.         try
  5983.           FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';
  5984.           if AncestorValid then
  5985.             Ancestor := TPersistent(GetOrdProp(Ancestor, PropInfo));
  5986.           WriteProperties(TPersistent(Value));
  5987.         finally
  5988.           Ancestor := OldAncestor;
  5989.           FPropPath := SavePropPath;
  5990.         end;
  5991.       end
  5992.   end;
  5993.  
  5994.   procedure WriteMethodProp;
  5995.   var
  5996.     Value: TMethod;
  5997.  
  5998.     function IsDefaultValue: Boolean;
  5999.     var
  6000.       DefaultCode: Pointer;
  6001.     begin
  6002.       DefaultCode := nil;
  6003.       if AncestorValid then DefaultCode := GetMethodProp(Ancestor, PropInfo).Code;
  6004.       Result := (Value.Code = DefaultCode) or
  6005.         ((Value.Code <> nil) and (FLookupRoot.MethodName(Value.Code) = ''));
  6006.     end;
  6007.  
  6008.   begin
  6009.     Value := GetMethodProp(Instance, PropInfo);
  6010.     if not IsDefaultValue then
  6011.     begin
  6012.       WritePropPath;
  6013.       if Value.Code = nil then
  6014.         WriteValue(vaNil) else
  6015.         WriteIdent(FLookupRoot.MethodName(Value.Code));
  6016.     end;
  6017.   end;
  6018.  
  6019.   procedure WriteVariantProp;
  6020.   var
  6021.     Value: Variant;
  6022.  
  6023.     function IsDefaultValue: Boolean;
  6024.     begin
  6025.       if AncestorValid then
  6026.         Result := Value = GetVariantProp(Ancestor, PropInfo) else
  6027.         Result := VarIsEmpty(Value);
  6028.     end;
  6029.  
  6030.   var
  6031.     VType: Integer;
  6032.   begin
  6033.     Value := GetVariantProp(Instance, PropInfo);
  6034.     if not IsDefaultValue then
  6035.     begin
  6036.       if VarIsArray(Value) then raise EWriteError.CreateRes(@SWriteError);
  6037.       WritePropPath;
  6038.       VType := VarType(Value);
  6039.       case VType and varTypeMask of
  6040.         varEmpty: WriteValue(vaNil);
  6041.         varNull: WriteValue(vaNull);
  6042.         varOleStr: WriteWideString(Value);
  6043.         varString: WriteString(Value);
  6044.         varByte, varSmallInt, varInteger: WriteInteger(Value);
  6045.         varSingle: WriteSingle(Value);
  6046.         varDouble: WriteFloat(Value);
  6047.         varCurrency: WriteCurrency(Value);
  6048.         varDate: WriteDate(Value);
  6049.         varBoolean:
  6050.           if Value then
  6051.             WriteValue(vaTrue) else
  6052.             WriteValue(vaFalse);
  6053.       else
  6054.         try
  6055.           WriteString(Value);
  6056.         except
  6057.           raise EWriteError.CreateRes(@SWriteError);
  6058.         end;
  6059.       end;
  6060.     end;
  6061.   end;
  6062.  
  6063. begin
  6064.   if (PPropInfo(PropInfo)^.SetProc <> nil) and
  6065.     (PPropInfo(PropInfo)^.GetProc <> nil) then
  6066.   begin
  6067.     PropType := PPropInfo(PropInfo)^.PropType^;
  6068.     case PropType^.Kind of
  6069.       tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp;
  6070.       tkFloat: WriteFloatProp;
  6071.       tkString, tkLString, tkWString: WriteStrProp;
  6072.       tkClass: WriteObjectProp;
  6073.       tkMethod: WriteMethodProp;
  6074.       tkVariant: WriteVariantProp;
  6075.       tkInt64: WriteInt64Prop;
  6076.     end;
  6077.   end;
  6078. end;
  6079.  
  6080. procedure TWriter.WritePropName(const PropName: string);
  6081. begin
  6082.   WriteStr(FPropPath + PropName);
  6083. end;
  6084.  
  6085. procedure TWriter.WriteRootComponent(Root: TComponent);
  6086. begin
  6087.   WriteDescendent(Root, nil);
  6088. end;
  6089.  
  6090. procedure TWriter.WriteSignature;
  6091. begin
  6092.   Write(FilerSignature, SizeOf(FilerSignature));
  6093. end;
  6094.  
  6095. procedure TWriter.WriteStr(const Value: string);
  6096. var
  6097.   L: Integer;
  6098. begin
  6099.   L := Length(Value);
  6100.   if L > 255 then L := 255;
  6101.   Write(L, SizeOf(Byte));
  6102.   Write(Value[1], L);
  6103. end;
  6104.  
  6105. procedure TWriter.WriteString(const Value: string);
  6106. var
  6107.   L: Integer;
  6108. begin
  6109.   L := Length(Value);
  6110.   if L <= 255 then
  6111.   begin
  6112.     WriteValue(vaString);
  6113.     Write(L, SizeOf(Byte));
  6114.   end else
  6115.   begin
  6116.     WriteValue(vaLString);
  6117.     Write(L, SizeOf(Integer));
  6118.   end;
  6119.   Write(Pointer(Value)^, L);
  6120. end;
  6121.  
  6122. procedure TWriter.WriteWideString(const Value: WideString);
  6123. var
  6124.   L: Integer;
  6125. begin
  6126.   WriteValue(vaWString);
  6127.   L := Length(Value);
  6128.   Write(L, SizeOf(Integer));
  6129.   Write(Pointer(Value)^, L * 2);
  6130. end;
  6131.  
  6132. procedure TWriter.WriteValue(Value: TValueType);
  6133. begin
  6134.   Write(Value, SizeOf(Value));
  6135. end;
  6136.  
  6137. { TParser }
  6138.  
  6139. const
  6140.   ParseBufSize = 4096;
  6141.  
  6142. procedure BinToHex(Buffer, Text: PChar; BufSize: Integer); assembler;
  6143. asm
  6144.         PUSH    ESI
  6145.         PUSH    EDI
  6146.         MOV     ESI,EAX
  6147.         MOV     EDI,EDX
  6148.         MOV     EDX,0
  6149.         JMP     @@1
  6150. @@0:    DB      '0123456789ABCDEF'
  6151. @@1:    LODSB
  6152.         MOV     DL,AL
  6153.         AND     DL,0FH
  6154.         MOV     AH,@@0.Byte[EDX]
  6155.         MOV     DL,AL
  6156.         SHR     DL,4
  6157.         MOV     AL,@@0.Byte[EDX]
  6158.         STOSW
  6159.         DEC     ECX
  6160.         JNE     @@1
  6161.         POP     EDI
  6162.         POP     ESI
  6163. end;
  6164.  
  6165. function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer; assembler;
  6166. asm
  6167.         PUSH    ESI
  6168.         PUSH    EDI
  6169.         PUSH    EBX
  6170.         MOV     ESI,EAX
  6171.         MOV     EDI,EDX
  6172.         MOV     EBX,EDX
  6173.         MOV     EDX,0
  6174.         JMP     @@1
  6175. @@0:    DB       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1
  6176.         DB      -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1
  6177.         DB      -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1
  6178.         DB      -1,10,11,12,13,14,15
  6179. @@1:    LODSW
  6180.         CMP     AL,'0'
  6181.         JB      @@2
  6182.         CMP     AL,'f'
  6183.         JA      @@2
  6184.         MOV     DL,AL
  6185.         MOV     AL,@@0.Byte[EDX-'0']
  6186.         CMP     AL,-1
  6187.         JE      @@2
  6188.         SHL     AL,4
  6189.         CMP     AH,'0'
  6190.         JB      @@2
  6191.         CMP     AH,'f'
  6192.         JA      @@2
  6193.         MOV     DL,AH
  6194.         MOV     AH,@@0.Byte[EDX-'0']
  6195.         CMP     AH,-1
  6196.         JE      @@2
  6197.         OR      AL,AH
  6198.         STOSB
  6199.         DEC     ECX
  6200.         JNE     @@1
  6201. @@2:    MOV     EAX,EDI
  6202.         SUB     EAX,EBX
  6203.         POP     EBX
  6204.         POP     EDI
  6205.         POP     ESI
  6206. end;
  6207.  
  6208. constructor TParser.Create(Stream: TStream);
  6209. begin
  6210.   FStream := Stream;
  6211.   GetMem(FBuffer, ParseBufSize);
  6212.   FBuffer[0] := #0;
  6213.   FBufPtr := FBuffer;
  6214.   FBufEnd := FBuffer + ParseBufSize;
  6215.   FSourcePtr := FBuffer;
  6216.   FSourceEnd := FBuffer;
  6217.   FTokenPtr := FBuffer;
  6218.   FSourceLine := 1;
  6219.   NextToken;
  6220. end;
  6221.  
  6222. destructor TParser.Destroy;
  6223. begin
  6224.   if FBuffer <> nil then
  6225.   begin
  6226.     FStream.Seek(Longint(FTokenPtr) - Longint(FBufPtr), 1);
  6227.     FreeMem(FBuffer, ParseBufSize);
  6228.   end;
  6229. end;
  6230.  
  6231. procedure TParser.CheckToken(T: Char);
  6232. begin
  6233.   if Token <> T then
  6234.     case T of
  6235.       toSymbol:
  6236.         Error(SIdentifierExpected);
  6237.       toString, toWString:
  6238.         Error(SStringExpected);
  6239.       toInteger, toFloat:
  6240.         Error(SNumberExpected);
  6241.     else
  6242.       ErrorFmt(SCharExpected, [T]);
  6243.     end;
  6244. end;
  6245.  
  6246. procedure TParser.CheckTokenSymbol(const S: string);
  6247. begin
  6248.   if not TokenSymbolIs(S) then ErrorFmt(SSymbolExpected, [S]);
  6249. end;
  6250.  
  6251. procedure TParser.Error(const Ident: string);
  6252. begin
  6253.   ErrorStr(Ident);
  6254. end;
  6255.  
  6256. procedure TParser.ErrorFmt(const Ident: string; const Args: array of const);
  6257. begin
  6258.   ErrorStr(Format(Ident, Args));
  6259. end;
  6260.  
  6261. procedure TParser.ErrorStr(const Message: string);
  6262. begin
  6263.   raise EParserError.CreateResFmt(@SParseError, [Message, FSourceLine]);
  6264. end;
  6265.  
  6266. procedure TParser.HexToBinary(Stream: TStream);
  6267. var
  6268.   Count: Integer;
  6269.   Buffer: array[0..255] of Char;
  6270. begin
  6271.   SkipBlanks;
  6272.   while FSourcePtr^ <> '}' do
  6273.   begin
  6274.     Count := HexToBin(FSourcePtr, Buffer, SizeOf(Buffer));
  6275.     if Count = 0 then Error(SInvalidBinary);
  6276.     Stream.Write(Buffer, Count);
  6277.     Inc(FSourcePtr, Count * 2);
  6278.     SkipBlanks;
  6279.   end;
  6280.   NextToken;
  6281. end;
  6282.  
  6283. function TParser.NextToken: Char;
  6284. var
  6285.   I, J: Integer;
  6286.   IsWideStr: Boolean;
  6287.   P, S: PChar;
  6288. begin
  6289.   SkipBlanks;
  6290.   P := FSourcePtr;
  6291.   FTokenPtr := P;
  6292.   case P^ of
  6293.     'A'..'Z', 'a'..'z', '_':
  6294.       begin
  6295.         Inc(P);
  6296.         while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
  6297.         Result := toSymbol;
  6298.       end;
  6299.     '#', '''':
  6300.       begin
  6301.         IsWideStr := False;
  6302.         J := 0;
  6303.         S := P;
  6304.         while True do
  6305.           case P^ of
  6306.             '#':
  6307.               begin
  6308.                 Inc(P);
  6309.                 I := 0;
  6310.                 while P^ in ['0'..'9'] do
  6311.                 begin
  6312.                   I := I * 10 + (Ord(P^) - Ord('0'));
  6313.                   Inc(P);
  6314.                 end;
  6315.                 if (i > 255) then IsWideStr := True;
  6316.                 Inc(J);
  6317.               end;
  6318.             '''':
  6319.               begin
  6320.                 Inc(P);
  6321.                 while True do
  6322.                 begin
  6323.                   case P^ of
  6324.                     #0, #10, #13:
  6325.                       Error(SInvalidString);
  6326.                     '''':
  6327.                       begin
  6328.                         Inc(P);
  6329.                         if P^ <> '''' then Break;
  6330.                       end;
  6331.                   end;
  6332.                   Inc(J);
  6333.                   Inc(P);
  6334.                 end;
  6335.               end;
  6336.           else
  6337.             Break;
  6338.           end;
  6339.         P := S;
  6340.         if IsWideStr then SetLength(FWideStr, J);
  6341.         J := 1;
  6342.         while True do
  6343.           case P^ of
  6344.             '#':
  6345.               begin
  6346.                 Inc(P);
  6347.                 I := 0;
  6348.                 while P^ in ['0'..'9'] do
  6349.                 begin
  6350.                   I := I * 10 + (Ord(P^) - Ord('0'));
  6351.                   Inc(P);
  6352.                 end;
  6353.                 if IsWideStr then
  6354.                 begin
  6355.                   FWideStr[J] := WideChar(SmallInt(I));
  6356.                   Inc(J);
  6357.                 end else
  6358.                 begin
  6359.                   S^ := Chr(I);
  6360.                   Inc(S);
  6361.                 end;
  6362.               end;
  6363.             '''':
  6364.               begin
  6365.                 Inc(P);
  6366.                 while True do
  6367.                 begin
  6368.                   case P^ of
  6369.                     #0, #10, #13:
  6370.                       Error(SInvalidString);
  6371.                     '''':
  6372.                       begin
  6373.                         Inc(P);
  6374.                         if P^ <> '''' then Break;
  6375.                       end;
  6376.                   end;
  6377.                   if IsWideStr then
  6378.                   begin
  6379.                     FWideStr[J] := WideChar(P^);
  6380.                     Inc(J);
  6381.                   end else
  6382.                   begin
  6383.                     S^ := P^;
  6384.                     Inc(S);
  6385.                   end;
  6386.                   Inc(P);
  6387.                 end;
  6388.               end;
  6389.           else
  6390.             Break;
  6391.           end;
  6392.         FStringPtr := S;
  6393.         if IsWideStr then
  6394.           Result := toWString else
  6395.           Result := toString;
  6396.       end;
  6397.     '$':
  6398.       begin
  6399.         Inc(P);
  6400.         while P^ in ['0'..'9', 'A'..'F', 'a'..'f'] do Inc(P);
  6401.         Result := toInteger;
  6402.       end;
  6403.     '-', '0'..'9':
  6404.       begin
  6405.         Inc(P);
  6406.         while P^ in ['0'..'9'] do Inc(P);
  6407.         Result := toInteger;
  6408.         while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do
  6409.         begin
  6410.           Inc(P);
  6411.           Result := toFloat;
  6412.         end;
  6413.         if (P^ in ['c', 'C', 'd', 'D', 's', 'S']) then
  6414.         begin
  6415.           Result := toFloat;
  6416.           FFloatType := P^;
  6417.           Inc(P);
  6418.         end else
  6419.           FFloatType := #0;
  6420.       end;
  6421.   else
  6422.     Result := P^;
  6423.     if Result <> toEOF then Inc(P);
  6424.   end;
  6425.   FSourcePtr := P;
  6426.   FToken := Result;
  6427. end;
  6428.  
  6429. procedure TParser.ReadBuffer;
  6430. var
  6431.   Count: Integer;
  6432. begin
  6433.   Inc(FOrigin, FSourcePtr - FBuffer);
  6434.   FSourceEnd[0] := FSaveChar;
  6435.   Count := FBufPtr - FSourcePtr;
  6436.   if Count <> 0 then Move(FSourcePtr[0], FBuffer[0], Count);
  6437.   FBufPtr := FBuffer + Count;
  6438.   Inc(FBufPtr, FStream.Read(FBufPtr[0], FBufEnd - FBufPtr));
  6439.   FSourcePtr := FBuffer;
  6440.   FSourceEnd := FBufPtr;
  6441.   if FSourceEnd = FBufEnd then
  6442.   begin
  6443.     FSourceEnd := LineStart(FBuffer, FSourceEnd - 1);
  6444.     if FSourceEnd = FBuffer then Error(SLineTooLong);
  6445.   end;
  6446.   FSaveChar := FSourceEnd[0];
  6447.   FSourceEnd[0] := #0;
  6448. end;
  6449.  
  6450. procedure TParser.SkipBlanks;
  6451. begin
  6452.   while True do
  6453.   begin
  6454.     case FSourcePtr^ of
  6455.       #0:
  6456.         begin
  6457.           ReadBuffer;
  6458.           if FSourcePtr^ = #0 then Exit;
  6459.           Continue;
  6460.         end;
  6461.       #10:
  6462.         Inc(FSourceLine);
  6463.       #33..#255:
  6464.         Exit;
  6465.     end;
  6466.     Inc(FSourcePtr);
  6467.   end;
  6468. end;
  6469.  
  6470. function TParser.SourcePos: Longint;
  6471. begin
  6472.   Result := FOrigin + (FTokenPtr - FBuffer);
  6473. end;
  6474.  
  6475. function TParser.TokenFloat: Extended;
  6476. begin
  6477.   if FFloatType <> #0 then Dec(FSourcePtr);
  6478.   Result := StrToFloat(TokenString);
  6479.   if FFloatType <> #0 then Inc(FSourcePtr);
  6480. end;
  6481.  
  6482. function TParser.TokenInt: Int64;
  6483. begin
  6484.   Result := StrToInt64(TokenString);
  6485. end;
  6486.  
  6487. function TParser.TokenString: string;
  6488. var
  6489.   L: Integer;
  6490. begin
  6491.   if FToken = toString then
  6492.     L := FStringPtr - FTokenPtr else
  6493.     L := FSourcePtr - FTokenPtr;
  6494.   SetString(Result, FTokenPtr, L);
  6495. end;
  6496.  
  6497. function TParser.TokenWideString: WideString;
  6498. begin
  6499.   Result := FWideStr;
  6500. end;
  6501.  
  6502. function TParser.TokenSymbolIs(const S: string): Boolean;
  6503. begin
  6504.   Result := (Token = toSymbol) and SameText(S, TokenString);
  6505. end;
  6506.  
  6507. function TParser.TokenComponentIdent: string;
  6508. var
  6509.   P: PChar;
  6510. begin
  6511.   CheckToken(toSymbol);
  6512.   P := FSourcePtr;
  6513.   while P^ = '.' do
  6514.   begin
  6515.     Inc(P);
  6516.     if not (P^ in ['A'..'Z', 'a'..'z', '_']) then
  6517.       Error(SIdentifierExpected);
  6518.     repeat
  6519.       Inc(P)
  6520.     until not (P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
  6521.   end;
  6522.   FSourcePtr := P;
  6523.   Result := TokenString;
  6524. end;
  6525.  
  6526. { Binary to text conversion }
  6527.  
  6528. procedure ObjectBinaryToText(Input, Output: TStream);
  6529. var
  6530.   NestingLevel: Integer;
  6531.   SaveSeparator: Char;
  6532.   Reader: TReader;
  6533.   Writer: TWriter;
  6534.  
  6535.   procedure WriteIndent;
  6536.   const
  6537.     Blanks: array[0..1] of Char = '  ';
  6538.   var
  6539.     I: Integer;
  6540.   begin
  6541.     for I := 1 to NestingLevel do Writer.Write(Blanks, SizeOf(Blanks));
  6542.   end;
  6543.  
  6544.   procedure WriteStr(const S: string);
  6545.   begin
  6546.     Writer.Write(S[1], Length(S));
  6547.   end;
  6548.  
  6549.   procedure NewLine;
  6550.   begin
  6551.     WriteStr(#13#10);
  6552.     WriteIndent;
  6553.   end;
  6554.  
  6555.   procedure ConvertValue; forward;
  6556.  
  6557.   procedure ConvertHeader;
  6558.   var
  6559.     ClassName, ObjectName: string;
  6560.     Flags: TFilerFlags;
  6561.     Position: Integer;
  6562.   begin
  6563.     Reader.ReadPrefix(Flags, Position);
  6564.     ClassName := Reader.ReadStr;
  6565.     ObjectName := Reader.ReadStr;
  6566.     WriteIndent;
  6567.     if ffInherited in Flags then
  6568.       WriteStr('inherited ')
  6569.     else if ffInline in Flags then
  6570.       WriteStr('inline ')
  6571.     else
  6572.       WriteStr('object ');
  6573.     if ObjectName <> '' then
  6574.     begin
  6575.       WriteStr(ObjectName);
  6576.       WriteStr(': ');
  6577.     end;
  6578.     WriteStr(ClassName);
  6579.     if ffChildPos in Flags then
  6580.     begin
  6581.       WriteStr(' [');
  6582.       WriteStr(IntToStr(Position));
  6583.       WriteStr(']');
  6584.     end;
  6585.     WriteStr(#13#10);
  6586.   end;
  6587.  
  6588.   procedure ConvertBinary;
  6589.   const
  6590.     BytesPerLine = 32;
  6591.   var
  6592.     MultiLine: Boolean;
  6593.     I: Integer;
  6594.     Count: Longint;
  6595.     Buffer: array[0..BytesPerLine - 1] of Char;
  6596.     Text: array[0..BytesPerLine * 2 - 1] of Char;
  6597.   begin
  6598.     Reader.ReadValue;
  6599.     WriteStr('{');
  6600.     Inc(NestingLevel);
  6601.     Reader.Read(Count, SizeOf(Count));
  6602.     MultiLine := Count >= BytesPerLine;
  6603.     while Count > 0 do
  6604.     begin
  6605.       if MultiLine then NewLine;
  6606.       if Count >= 32 then I := 32 else I := Count;
  6607.       Reader.Read(Buffer, I);
  6608.       BinToHex(Buffer, Text, I);
  6609.       Writer.Write(Text, I * 2);
  6610.       Dec(Count, I);
  6611.     end;
  6612.     Dec(NestingLevel);
  6613.     WriteStr('}');
  6614.   end;
  6615.  
  6616.   procedure ConvertProperty; forward;
  6617.  
  6618.   procedure ConvertValue;
  6619.   const
  6620.     LineLength = 64;
  6621.   var
  6622.     I, J, K, L: Integer;
  6623.     S: string;
  6624.     W: WideString;
  6625.     LineBreak: Boolean;
  6626.   begin
  6627.     case Reader.NextValue of
  6628.       vaList:
  6629.         begin
  6630.           Reader.ReadValue;
  6631.           WriteStr('(');
  6632.           Inc(NestingLevel);
  6633.           while not Reader.EndOfList do
  6634.           begin
  6635.             NewLine;
  6636.             ConvertValue;
  6637.           end;
  6638.           Reader.ReadListEnd;
  6639.           Dec(NestingLevel);
  6640.           WriteStr(')');
  6641.         end;
  6642.       vaInt8, vaInt16, vaInt32:
  6643.         WriteStr(IntToStr(Reader.ReadInteger));
  6644.       vaExtended:
  6645.         WriteStr(FloatToStr(Reader.ReadFloat));
  6646.       vaSingle:
  6647.         WriteStr(FloatToStr(Reader.ReadSingle) + 's');
  6648.       vaCurrency:
  6649.         WriteStr(FloatToStr(Reader.ReadCurrency * 10000) + 'c');
  6650.       vaDate:
  6651.         WriteStr(FloatToStr(Reader.ReadDate) + 'd');
  6652.       vaWString:
  6653.         begin
  6654.           W := Reader.ReadWideString;
  6655.           L := Length(W);
  6656.           if L = 0 then WriteStr('''''') else
  6657.           begin
  6658.             I := 1;
  6659.             Inc(NestingLevel);
  6660.             try
  6661.               if L > LineLength then NewLine;
  6662.               K := I;
  6663.               repeat
  6664.                 LineBreak := False;
  6665.                 if (W[I] >= ' ') and (W[I] <> '''') and (Ord(W[i]) <= 255) then
  6666.                 begin
  6667.                   J := I;
  6668.                   repeat
  6669.                     Inc(I)
  6670.                   until (I > L) or (W[I] < ' ') or (W[I] = '''') or
  6671.                     ((I - K) >= LineLength) or (Ord(W[i]) > 255);
  6672.                   if ((I - K) >= LineLength) then
  6673.                   begin
  6674.                     LineBreak := True;
  6675.                     if ByteType(W, I) = mbTrailByte then Dec(I);
  6676.                   end;
  6677.                   WriteStr('''');
  6678.                   while J < I do
  6679.                   begin
  6680.                     WriteStr(Char(W[J]));
  6681.                     Inc(J);
  6682.                   end;
  6683.                   WriteStr('''');
  6684.                 end else
  6685.                 begin
  6686.                   WriteStr('#');
  6687.                   WriteStr(IntToStr(Ord(W[I])));
  6688.                   Inc(I);
  6689.                   if ((I - K) >= LineLength) then LineBreak := True;
  6690.                 end;
  6691.                 if LineBreak and (I <= L) then
  6692.                 begin
  6693.                   WriteStr(' +');
  6694.                   NewLine;
  6695.                   K := I;
  6696.                 end;
  6697.               until I > L;
  6698.             finally
  6699.               Dec(NestingLevel);
  6700.             end;
  6701.           end;
  6702.         end;
  6703.       vaString, vaLString:
  6704.         begin
  6705.           S := Reader.ReadString;
  6706.           L := Length(S);
  6707.           if L = 0 then WriteStr('''''') else
  6708.           begin
  6709.             I := 1;
  6710.             Inc(NestingLevel);
  6711.             try
  6712.               if L > LineLength then NewLine;
  6713.               K := I;
  6714.               repeat
  6715.                 LineBreak := False;
  6716.                 if (S[I] >= ' ') and (S[I] <> '''') then
  6717.                 begin
  6718.                   J := I;
  6719.                   repeat
  6720.                     Inc(I)
  6721.                   until (I > L) or (S[I] < ' ') or (S[I] = '''') or
  6722.                     ((I - K) >= LineLength);
  6723.                   if ((I - K) >= LineLength) then
  6724.                   begin
  6725.                     LIneBreak := True;
  6726.                     if ByteType(S, I) = mbTrailByte then Dec(I);
  6727.                   end;
  6728.                   WriteStr('''');
  6729.                   Writer.Write(S[J], I - J);
  6730.                   WriteStr('''');
  6731.                 end else
  6732.                 begin
  6733.                   WriteStr('#');
  6734.                   WriteStr(IntToStr(Ord(S[I])));
  6735.                   Inc(I);
  6736.                   if ((I - K) >= LineLength) then LineBreak := True;
  6737.                 end;
  6738.                 if LineBreak and (I <= L) then
  6739.                 begin
  6740.                   WriteStr(' +');
  6741.                   NewLine;
  6742.                   K := I;
  6743.                 end;
  6744.               until I > L;
  6745.             finally
  6746.               Dec(NestingLevel);
  6747.             end;
  6748.           end;
  6749.         end;
  6750.       vaIdent, vaFalse, vaTrue, vaNil, vaNull:
  6751.         WriteStr(Reader.ReadIdent);
  6752.       vaBinary:
  6753.         ConvertBinary;
  6754.       vaSet:
  6755.         begin
  6756.           Reader.ReadValue;
  6757.           WriteStr('[');
  6758.           I := 0;
  6759.           while True do
  6760.           begin
  6761.             S := Reader.ReadStr;
  6762.             if S = '' then Break;
  6763.             if I > 0 then WriteStr(', ');
  6764.             WriteStr(S);
  6765.             Inc(I);
  6766.           end;
  6767.           WriteStr(']');
  6768.         end;
  6769.       vaCollection:
  6770.         begin
  6771.           Reader.ReadValue;
  6772.           WriteStr('<');
  6773.           Inc(NestingLevel);
  6774.           while not Reader.EndOfList do
  6775.           begin
  6776.             NewLine;
  6777.             WriteStr('item');
  6778.             if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
  6779.             begin
  6780.               WriteStr(' [');
  6781.               ConvertValue;
  6782.               WriteStr(']');
  6783.             end;
  6784.             WriteStr(#13#10);
  6785.             Reader.CheckValue(vaList);
  6786.             Inc(NestingLevel);
  6787.             while not Reader.EndOfList do ConvertProperty;
  6788.             Reader.ReadListEnd;
  6789.             Dec(NestingLevel);
  6790.             WriteIndent;
  6791.             WriteStr('end');
  6792.           end;
  6793.           Reader.ReadListEnd;
  6794.           Dec(NestingLevel);
  6795.           WriteStr('>');
  6796.         end;
  6797.       vaInt64:
  6798.         WriteStr(IntToStr(Reader.ReadInt64));
  6799.     end;
  6800.   end;
  6801.  
  6802.   procedure ConvertProperty;
  6803.   begin
  6804.     WriteIndent;
  6805.     WriteStr(Reader.ReadStr);
  6806.     WriteStr(' = ');
  6807.     ConvertValue;
  6808.     WriteStr(#13#10);
  6809.   end;
  6810.  
  6811.   procedure ConvertObject;
  6812.   begin
  6813.     ConvertHeader;
  6814.     Inc(NestingLevel);
  6815.     while not Reader.EndOfList do ConvertProperty;
  6816.     Reader.ReadListEnd;
  6817.     while not Reader.EndOfList do ConvertObject;
  6818.     Reader.ReadListEnd;
  6819.     Dec(NestingLevel);
  6820.     WriteIndent;
  6821.     WriteStr('end'#13#10);
  6822.   end;
  6823.  
  6824. begin
  6825.   NestingLevel := 0;
  6826.   Reader := TReader.Create(Input, 4096);
  6827.   SaveSeparator := DecimalSeparator;
  6828.   DecimalSeparator := '.';
  6829.   try
  6830.     Writer := TWriter.Create(Output, 4096);
  6831.     try
  6832.       Reader.ReadSignature;
  6833.       ConvertObject;
  6834.     finally
  6835.       Writer.Free;
  6836.     end;
  6837.   finally
  6838.     DecimalSeparator := SaveSeparator;
  6839.     Reader.Free;
  6840.   end;
  6841. end;
  6842.  
  6843. type
  6844.   TObjectTextConvertProc = procedure (Input, Output: TStream);
  6845.  
  6846. procedure InternalBinaryToText(Input, Output: TStream;
  6847.   var OriginalFormat: TStreamOriginalFormat;
  6848.   ConvertProc: TObjectTextConvertProc;
  6849.   BinarySignature: Integer; SignatureLength: Byte);
  6850. var
  6851.   Pos: Integer;
  6852.   Signature: Integer;
  6853. begin
  6854.   Pos := Input.Position;
  6855.   Signature := 0;
  6856.   if SignatureLength > sizeof(Signature) then SignatureLength := sizeof(Signature);
  6857.   Input.Read(Signature, SignatureLength);
  6858.   Input.Position := Pos;
  6859.   if Signature = BinarySignature then
  6860.   begin     // definitely binary format
  6861.     if OriginalFormat = sofBinary then
  6862.       Output.CopyFrom(Input, Input.Size - Input.Position)
  6863.     else
  6864.     begin
  6865.       if OriginalFormat = sofUnknown then
  6866.         Originalformat := sofBinary;
  6867.       ConvertProc(Input, Output);
  6868.     end;
  6869.   end
  6870.   else  // might be text format
  6871.   begin
  6872.     if OriginalFormat = sofBinary then
  6873.       ConvertProc(Input, Output)
  6874.     else
  6875.     begin
  6876.       if OriginalFormat = sofUnknown then
  6877.       begin   // text format may begin with "object", "inherited", or whitespace
  6878.         if Char(Signature) in ['o','O','i','I',' ',#13,#11,#9] then
  6879.           OriginalFormat := sofText
  6880.         else    // not binary, not text... let it raise the exception
  6881.         begin
  6882.           ConvertProc(Input, Output);
  6883.           Exit;
  6884.         end;
  6885.       end;
  6886.       if OriginalFormat = sofText then
  6887.         Output.CopyFrom(Input, Input.Size - Input.Position);
  6888.     end;
  6889.   end;
  6890. end;
  6891.  
  6892. procedure InternalTextToBinary(Input, Output: TStream;
  6893.   var OriginalFormat: TStreamOriginalFormat;
  6894.   ConvertProc: TObjectTextConvertProc;
  6895.   BinarySignature: Integer; SignatureLength: Byte);
  6896. var
  6897.   Pos: Integer;
  6898.   Signature: Integer;
  6899. begin
  6900.   Pos := Input.Position;
  6901.   Signature := 0;
  6902.   if SignatureLength > sizeof(Signature) then SignatureLength := sizeof(Signature);
  6903.   Input.Read(Signature, SignatureLength);
  6904.   Input.Position := Pos;
  6905.   if Signature = BinarySignature then
  6906.   begin     // definitely binary format
  6907.     if OriginalFormat = sofUnknown then
  6908.       Originalformat := sofBinary;
  6909.     if OriginalFormat = sofBinary then
  6910.       Output.CopyFrom(Input, Input.Size - Input.Position)
  6911.     else    // let it raise the exception
  6912.       ConvertProc(Input, Output);
  6913.   end
  6914.   else  // might be text format
  6915.   begin
  6916.     case OriginalFormat of
  6917.       sofUnknown:
  6918.         begin  // text format may begin with "object", "inherited", or whitespace
  6919.           if Char(Signature) in ['o','O','i','I',' ',#13,#11,#9] then
  6920.             OriginalFormat := sofText;
  6921.           // if its not binary, not text... let it raise the exception
  6922.           ConvertProc(Input, Output);
  6923.         end;
  6924.       sofBinary:  ConvertProc(Input, Output);
  6925.       sofText:    Output.CopyFrom(Input, Input.Size - Input.Position);
  6926.     end;
  6927.   end;
  6928. end;
  6929.  
  6930. procedure ObjectBinaryToText(Input, Output: TStream;
  6931.   var OriginalFormat: TStreamOriginalFormat);
  6932. begin
  6933.   InternalBinaryToText(Input, Output, OriginalFormat, ObjectBinaryToText,
  6934.     Integer(FilerSignature), sizeof(Integer));
  6935. end;
  6936.  
  6937. { Text to binary conversion }
  6938.  
  6939. procedure ObjectTextToBinary(Input, Output: TStream);
  6940. var
  6941.   SaveSeparator: Char;
  6942.   Parser: TParser;
  6943.   Writer: TWriter;
  6944.  
  6945.   function ConvertOrderModifier: Integer;
  6946.   begin
  6947.     Result := -1;
  6948.     if Parser.Token = '[' then
  6949.     begin
  6950.       Parser.NextToken;
  6951.       Parser.CheckToken(toInteger);
  6952.       Result := Parser.TokenInt;
  6953.       Parser.NextToken;
  6954.       Parser.CheckToken(']');
  6955.       Parser.NextToken;
  6956.     end;
  6957.   end;
  6958.  
  6959.   procedure ConvertHeader(IsInherited, IsInline: Boolean);
  6960.   var
  6961.     ClassName, ObjectName: string;
  6962.     Flags: TFilerFlags;
  6963.     Position: Integer;
  6964.   begin
  6965.     Parser.CheckToken(toSymbol);
  6966.     ClassName := Parser.TokenString;
  6967.     ObjectName := '';
  6968.     if Parser.NextToken = ':' then
  6969.     begin
  6970.       Parser.NextToken;
  6971.       Parser.CheckToken(toSymbol);
  6972.       ObjectName := ClassName;
  6973.       ClassName := Parser.TokenString;
  6974.       Parser.NextToken;
  6975.     end;
  6976.     Flags := [];
  6977.     Position := ConvertOrderModifier;
  6978.     if IsInherited then
  6979.       Include(Flags, ffInherited);
  6980.     if IsInline then
  6981.       Include(Flags, ffInline);
  6982.     if Position >= 0 then
  6983.       Include(Flags, ffChildPos);
  6984.     Writer.WritePrefix(Flags, Position);
  6985.     Writer.WriteStr(ClassName);
  6986.     Writer.WriteStr(ObjectName);
  6987.   end;
  6988.  
  6989.   procedure ConvertProperty; forward;
  6990.  
  6991.   procedure ConvertValue;
  6992.   var
  6993.     Order: Integer;
  6994.  
  6995.     function CombineString: string;
  6996.     begin
  6997.       Result := Parser.TokenString;
  6998.       while Parser.NextToken = '+' do
  6999.       begin
  7000.         Parser.NextToken;
  7001.         Parser.CheckToken(toString);
  7002.         Result := Result + Parser.TokenString;
  7003.       end;
  7004.     end;
  7005.  
  7006.     function CombineWideString: WideString;
  7007.     begin
  7008.       Result := Parser.TokenWideString;
  7009.       while Parser.NextToken = '+' do
  7010.       begin
  7011.         Parser.NextToken;
  7012.         Parser.CheckToken(toWString);
  7013.         Result := Result + Parser.TokenWideString;
  7014.       end;
  7015.     end;
  7016.  
  7017.   begin
  7018.     if Parser.Token = toString then
  7019.       Writer.WriteString(CombineString)
  7020.     else if Parser.Token = toWString then
  7021.       Writer.WriteWideString(CombineWideString)
  7022.     else
  7023.     begin
  7024.       case Parser.Token of
  7025.         toSymbol:
  7026.           Writer.WriteIdent(Parser.TokenComponentIdent);
  7027.         toInteger:
  7028.           Writer.WriteInteger(Parser.TokenInt);
  7029.         toFloat:
  7030.           begin
  7031.             case Parser.FloatType of
  7032.               's', 'S': Writer.WriteSingle(Parser.TokenFloat);
  7033.               'c', 'C': Writer.WriteCurrency(Parser.TokenFloat / 10000);
  7034.               'd', 'D': Writer.WriteDate(Parser.TokenFloat);
  7035.             else
  7036.               Writer.WriteFloat(Parser.TokenFloat);
  7037.             end;
  7038.           end;
  7039.         '[':
  7040.           begin
  7041.             Parser.NextToken;
  7042.             Writer.WriteValue(vaSet);
  7043.             if Parser.Token <> ']' then
  7044.               while True do
  7045.               begin
  7046.                 if Parser.Token <> toInteger then
  7047.                   Parser.CheckToken(toSymbol);
  7048.                 Writer.WriteStr(Parser.TokenString);
  7049.                 if Parser.NextToken = ']' then Break;
  7050.                 Parser.CheckToken(',');
  7051.                 Parser.NextToken;
  7052.               end;
  7053.             Writer.WriteStr('');
  7054.           end;
  7055.         '(':
  7056.           begin
  7057.             Parser.NextToken;
  7058.             Writer.WriteListBegin;
  7059.             while Parser.Token <> ')' do ConvertValue;
  7060.             Writer.WriteListEnd;
  7061.           end;
  7062.         '{':
  7063.           Writer.WriteBinary(Parser.HexToBinary);
  7064.         '<':
  7065.           begin
  7066.             Parser.NextToken;
  7067.             Writer.WriteValue(vaCollection);
  7068.             while Parser.Token <> '>' do
  7069.             begin
  7070.               Parser.CheckTokenSymbol('item');
  7071.               Parser.NextToken;
  7072.               Order := ConvertOrderModifier;
  7073.               if Order <> -1 then Writer.WriteInteger(Order);
  7074.               Writer.WriteListBegin;
  7075.               while not Parser.TokenSymbolIs('end') do ConvertProperty;
  7076.               Writer.WriteListEnd;
  7077.               Parser.NextToken;
  7078.             end;
  7079.             Writer.WriteListEnd;
  7080.           end;
  7081.       else
  7082.         Parser.Error(SInvalidProperty);
  7083.       end;
  7084.       Parser.NextToken;
  7085.     end;
  7086.   end;
  7087.  
  7088.   procedure ConvertProperty;
  7089.   var
  7090.     PropName: string;
  7091.   begin
  7092.     Parser.CheckToken(toSymbol);
  7093.     PropName := Parser.TokenString;
  7094.     Parser.NextToken;
  7095.     while Parser.Token = '.' do
  7096.     begin
  7097.       Parser.NextToken;
  7098.       Parser.CheckToken(toSymbol);
  7099.       PropName := PropName + '.' + Parser.TokenString;
  7100.       Parser.NextToken;
  7101.     end;
  7102.     Writer.WriteStr(PropName);
  7103.     Parser.CheckToken('=');
  7104.     Parser.NextToken;
  7105.     ConvertValue;
  7106.   end;
  7107.  
  7108.   procedure ConvertObject;
  7109.   var
  7110.     InheritedObject: Boolean;
  7111.     InlineObject: Boolean;
  7112.   begin
  7113.     InheritedObject := False;
  7114.     InlineObject := False;
  7115.     if Parser.TokenSymbolIs('INHERITED') then
  7116.       InheritedObject := True
  7117.     else if Parser.TokenSymbolIs('INLINE') then
  7118.       InlineObject := True
  7119.     else
  7120.       Parser.CheckTokenSymbol('OBJECT');
  7121.     Parser.NextToken;
  7122.     ConvertHeader(InheritedObject, InlineObject);
  7123.     while not Parser.TokenSymbolIs('END') and
  7124.       not Parser.TokenSymbolIs('OBJECT') and
  7125.       not Parser.TokenSymbolIs('INHERITED') and
  7126.       not Parser.TokenSymbolIs('INLINE') do
  7127.       ConvertProperty;
  7128.     Writer.WriteListEnd;
  7129.     while not Parser.TokenSymbolIs('END') do ConvertObject;
  7130.     Writer.WriteListEnd;
  7131.     Parser.NextToken;
  7132.   end;
  7133.  
  7134. begin
  7135.   Parser := TParser.Create(Input);
  7136.   SaveSeparator := DecimalSeparator;
  7137.   DecimalSeparator := '.';
  7138.   try
  7139.     Writer := TWriter.Create(Output, 4096);
  7140.     try
  7141.       Writer.WriteSignature;
  7142.       ConvertObject;
  7143.     finally
  7144.       Writer.Free;
  7145.     end;
  7146.   finally
  7147.     DecimalSeparator := SaveSeparator;
  7148.     Parser.Free;
  7149.   end;
  7150. end;
  7151.  
  7152. procedure ObjectTextToBinary(Input, Output: TStream;
  7153.   var OriginalFormat: TStreamOriginalFormat);
  7154. begin
  7155.   InternalTextToBinary(Input, Output, OriginalFormat, ObjectTextToBinary,
  7156.     Integer(FilerSignature), sizeof(Integer));
  7157. end;
  7158.  
  7159. { Resource to text conversion }
  7160.  
  7161. procedure ObjectResourceToText(Input, Output: TStream);
  7162. begin
  7163.   Input.ReadResHeader;
  7164.   ObjectBinaryToText(Input, Output);
  7165. end;
  7166.  
  7167. procedure ObjectResourceToText(Input, Output: TStream;
  7168.   var OriginalFormat: TStreamOriginalFormat);
  7169. begin
  7170.   InternalBinaryToText(Input, Output, OriginalFormat, ObjectResourceToText, $FF, 1);
  7171. end;
  7172.  
  7173. { Text to resource conversion }
  7174.  
  7175. procedure ObjectTextToResource(Input, Output: TStream);
  7176. var
  7177.   Len: Byte;
  7178.   Tmp: Longint;
  7179.   MemoryStream: TMemoryStream;
  7180.   MemorySize: Longint;
  7181.   Header: array[0..79] of Char;
  7182. begin
  7183.   MemoryStream := TMemoryStream.Create;
  7184.   try
  7185.     ObjectTextToBinary(Input, MemoryStream);
  7186.     MemorySize := MemoryStream.Size;
  7187.     FillChar(Header, SizeOf(Header), 0);
  7188.     MemoryStream.Position := SizeOf(Longint); { Skip header }
  7189.     MemoryStream.Read(Len, 1);
  7190.  
  7191.     { Skip over object prefix if it is present }
  7192.     if Len and $F0 = $F0 then
  7193.     begin
  7194.       if ffChildPos in TFilerFlags((Len and $F0)) then
  7195.       begin
  7196.         MemoryStream.Read(Len, 1);
  7197.         case TValueType(Len) of
  7198.           vaInt8: Len := 1;
  7199.           vaInt16: Len := 2;
  7200.           vaInt32: Len := 4;
  7201.         end;
  7202.         MemoryStream.Read(Tmp, Len);
  7203.       end;
  7204.       MemoryStream.Read(Len, 1);
  7205.     end;
  7206.  
  7207.     MemoryStream.Read(Header[3], Len);
  7208.     StrUpper(@Header[3]);
  7209.     Byte((@Header[0])^) := $FF;
  7210.     Word((@Header[1])^) := 10;
  7211.     Word((@Header[Len + 4])^) := $1030;
  7212.     Longint((@Header[Len + 6])^) := MemorySize;
  7213.     Output.Write(Header, Len + 10);
  7214.     Output.Write(MemoryStream.Memory^, MemorySize);
  7215.   finally
  7216.     MemoryStream.Free;
  7217.   end;
  7218. end;
  7219.  
  7220. procedure ObjectTextToResource(Input, Output: TStream;
  7221.   var OriginalFormat: TStreamOriginalFormat);
  7222. begin
  7223.   InternalTextToBinary(Input, Output, OriginalFormat, ObjectTextToResource, $FF, 1);
  7224. end;
  7225.  
  7226. function TestStreamFormat(Stream: TStream): TStreamOriginalFormat;
  7227. var
  7228.   Pos: Integer;
  7229.   Signature: Integer;
  7230. begin
  7231.   Pos := Stream.Position;
  7232.   Signature := 0;
  7233.   Stream.Read(Signature, sizeof(Signature));
  7234.   Stream.Position := Pos;
  7235.   if (Byte(Signature) = $FF) or (Signature = Integer(FilerSignature)) then
  7236.     Result := sofBinary
  7237.     // text format may begin with "object", "inherited", or whitespace
  7238.   else if Char(Signature) in ['o','O','i','I',' ',#13,#11,#9] then
  7239.     Result := sofText
  7240.   else
  7241.     Result := sofUnknown;
  7242. end;
  7243.  
  7244. { Thread management routines }
  7245.  
  7246. const
  7247.   CM_EXECPROC = $8FFF;
  7248.   CM_DESTROYWINDOW = $8FFE;
  7249.  
  7250. type
  7251.   PRaiseFrame = ^TRaiseFrame;
  7252.   TRaiseFrame = record
  7253.     NextRaise: PRaiseFrame;
  7254.     ExceptAddr: Pointer;
  7255.     ExceptObject: TObject;
  7256.     ExceptionRecord: PExceptionRecord;
  7257.   end;
  7258.  
  7259. var
  7260.   ThreadLock: TRTLCriticalSection;
  7261.   ThreadWindow: HWND;
  7262.   ThreadCount: Integer;
  7263.  
  7264. procedure FreeThreadWindow;
  7265. begin
  7266.   if ThreadWindow <> 0 then
  7267.   begin
  7268.     DestroyWindow(ThreadWindow);
  7269.     ThreadWindow := 0;
  7270.   end;
  7271. end;
  7272.  
  7273. function ThreadWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall;
  7274. begin
  7275.   case Message of
  7276.     CM_EXECPROC:
  7277.       with TThread(lParam) do
  7278.       begin
  7279.         Result := 0;
  7280.         try
  7281.           FSynchronizeException := nil;
  7282.           FMethod;
  7283.         except
  7284.           if RaiseList <> nil then
  7285.           begin
  7286.             FSynchronizeException := PRaiseFrame(RaiseList)^.ExceptObject;
  7287.             PRaiseFrame(RaiseList)^.ExceptObject := nil;
  7288.           end;
  7289.         end;
  7290.       end;
  7291.     CM_DESTROYWINDOW:
  7292.       begin
  7293.         EnterCriticalSection(ThreadLock);
  7294.         try
  7295.           Dec(ThreadCount);
  7296.           if ThreadCount = 0 then
  7297.             FreeThreadWindow;
  7298.         finally
  7299.           LeaveCriticalSection(ThreadLock);
  7300.         end;
  7301.         Result := 0;
  7302.       end;
  7303.   else
  7304.     Result := DefWindowProc(Window, Message, wParam, lParam);
  7305.   end;
  7306. end;
  7307.  
  7308. var
  7309.   ThreadWindowClass: TWndClass = (
  7310.     style: 0;
  7311.     lpfnWndProc: @ThreadWndProc;
  7312.     cbClsExtra: 0;
  7313.     cbWndExtra: 0;
  7314.     hInstance: 0;
  7315.     hIcon: 0;
  7316.     hCursor: 0;
  7317.     hbrBackground: 0;
  7318.     lpszMenuName: nil;
  7319.     lpszClassName: 'TThreadWindow');
  7320.  
  7321. procedure AddThread;
  7322.  
  7323.   function AllocateWindow: HWND;
  7324.   var
  7325.     TempClass: TWndClass;
  7326.     ClassRegistered: Boolean;
  7327.   begin
  7328.     ThreadWindowClass.hInstance := HInstance;
  7329.     ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName,
  7330.       TempClass);
  7331.     if not ClassRegistered or (TempClass.lpfnWndProc <> @ThreadWndProc) then
  7332.     begin
  7333.       if ClassRegistered then
  7334.         Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance);
  7335.       Windows.RegisterClass(ThreadWindowClass);
  7336.     end;
  7337.     Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0,
  7338.       0, 0, 0, 0, 0, 0, HInstance, nil);
  7339.   end;
  7340.  
  7341. begin
  7342.   EnterCriticalSection(ThreadLock);
  7343.   try
  7344.     if ThreadCount = 0 then
  7345.       ThreadWindow := AllocateWindow;
  7346.     Inc(ThreadCount);
  7347.   finally
  7348.     LeaveCriticalSection(ThreadLock);
  7349.   end;
  7350. end;
  7351.  
  7352. procedure RemoveThread;
  7353. begin
  7354.   EnterCriticalSection(ThreadLock);
  7355.   try
  7356.     if ThreadCount = 1 then
  7357.       PostMessage(ThreadWindow, CM_DESTROYWINDOW, 0, 0);
  7358.   finally
  7359.     LeaveCriticalSection(ThreadLock);
  7360.   end;
  7361. end;
  7362.  
  7363. { TThread }
  7364.  
  7365. function ThreadProc(Thread: TThread): Integer;
  7366. var
  7367.   FreeThread: Boolean;
  7368. begin
  7369.   try
  7370.     Thread.Execute;
  7371.   finally
  7372.     FreeThread := Thread.FFreeOnTerminate;
  7373.     Result := Thread.FReturnValue;
  7374.     Thread.FFinished := True;
  7375.     Thread.DoTerminate;
  7376.     if FreeThread then Thread.Free;
  7377.     EndThread(Result);
  7378.   end;
  7379. end;
  7380.  
  7381. constructor TThread.Create(CreateSuspended: Boolean);
  7382. var
  7383.   Flags: DWORD;
  7384. begin
  7385.   inherited Create;
  7386.   AddThread;
  7387.   FSuspended := CreateSuspended;
  7388.   Flags := 0;
  7389.   if CreateSuspended then Flags := CREATE_SUSPENDED;
  7390.   FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
  7391. end;
  7392.  
  7393. destructor TThread.Destroy;
  7394. begin
  7395.   if not FFinished and not Suspended then
  7396.   begin
  7397.     Terminate;
  7398.     WaitFor;
  7399.   end;
  7400.   if FHandle <> 0 then CloseHandle(FHandle);
  7401.   inherited Destroy;
  7402.   RemoveThread;
  7403. end;
  7404.  
  7405. procedure TThread.CallOnTerminate;
  7406. begin
  7407.   if Assigned(FOnTerminate) then FOnTerminate(Self);
  7408. end;
  7409.  
  7410. procedure TThread.DoTerminate;
  7411. begin
  7412.   if Assigned(FOnTerminate) then Synchronize(CallOnTerminate);
  7413. end;
  7414.  
  7415. const
  7416.   Priorities: array [TThreadPriority] of Integer =
  7417.    (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
  7418.     THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
  7419.     THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
  7420.  
  7421. function TThread.GetPriority: TThreadPriority;
  7422. var
  7423.   P: Integer;
  7424.   I: TThreadPriority;
  7425. begin
  7426.   P := GetThreadPriority(FHandle);
  7427.   Result := tpNormal;
  7428.   for I := Low(TThreadPriority) to High(TThreadPriority) do
  7429.     if Priorities[I] = P then Result := I;
  7430. end;
  7431.  
  7432. procedure TThread.SetPriority(Value: TThreadPriority);
  7433. begin
  7434.   SetThreadPriority(FHandle, Priorities[Value]);
  7435. end;
  7436.  
  7437. procedure TThread.Synchronize(Method: TThreadMethod);
  7438. begin
  7439.   FSynchronizeException := nil;
  7440.   FMethod := Method;
  7441.   SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
  7442.   if Assigned(FSynchronizeException) then raise FSynchronizeException;
  7443. end;
  7444.  
  7445. procedure TThread.SetSuspended(Value: Boolean);
  7446. begin
  7447.   if Value <> FSuspended then
  7448.     if Value then
  7449.       Suspend else
  7450.       Resume;
  7451. end;
  7452.  
  7453. procedure TThread.Suspend;
  7454. begin
  7455.   FSuspended := True;
  7456.   SuspendThread(FHandle);
  7457. end;
  7458.  
  7459. procedure TThread.Resume;
  7460. begin
  7461.   if ResumeThread(FHandle) = 1 then FSuspended := False;
  7462. end;
  7463.  
  7464. procedure TThread.Terminate;
  7465. begin
  7466.   FTerminated := True;
  7467. end;
  7468.  
  7469. function TThread.WaitFor: LongWord;
  7470. var
  7471.   Msg: TMsg;
  7472.   H: THandle;
  7473. begin
  7474.   H := FHandle;
  7475.   if GetCurrentThreadID = MainThreadID then
  7476.     while MsgWaitForMultipleObjects(1, H, False, INFINITE,
  7477.       QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
  7478.   else WaitForSingleObject(H, INFINITE);
  7479.   GetExitCodeThread(H, Result);
  7480. end;
  7481.  
  7482. { TComponent }
  7483.  
  7484. constructor TComponent.Create(AOwner: TComponent);
  7485. begin
  7486.   FComponentStyle := [csInheritable];
  7487.   if AOwner <> nil then AOwner.InsertComponent(Self);
  7488. end;
  7489.  
  7490. destructor TComponent.Destroy;
  7491. var
  7492.   I: Integer;
  7493. begin
  7494.   Destroying;
  7495.   if FFreeNotifies <> nil then
  7496.   begin
  7497.     for I := FFreeNotifies.Count - 1 downto 0 do
  7498.     begin
  7499.       TComponent(FFreeNotifies[I]).Notification(Self, opRemove);
  7500.       if FFreeNotifies = nil then Break;
  7501.     end;
  7502.     FFreeNotifies.Free;
  7503.     FFreeNotifies := nil;
  7504.   end;
  7505.   DestroyComponents;
  7506.   if FOwner <> nil then FOwner.RemoveComponent(Self);
  7507.   inherited Destroy;
  7508. end;
  7509.  
  7510. procedure TComponent.BeforeDestruction;
  7511. begin
  7512.   if not (csDestroying in ComponentState) then
  7513.     Destroying;
  7514. end;
  7515.  
  7516. procedure TComponent.FreeNotification(AComponent: TComponent);
  7517. begin
  7518.   if (Owner = nil) or (AComponent.Owner <> Owner) then
  7519.   begin
  7520.     if not Assigned(FFreeNotifies) then FFreeNotifies := TList.Create;
  7521.     if FFreeNotifies.IndexOf(AComponent) < 0 then
  7522.     begin
  7523.       FFreeNotifies.Add(AComponent);
  7524.       AComponent.FreeNotification(Self);
  7525.     end;
  7526.   end;
  7527.   Include(FComponentState, csFreeNotification);
  7528. end;
  7529.  
  7530. procedure TComponent.ReadLeft(Reader: TReader);
  7531. begin
  7532.   LongRec(FDesignInfo).Lo := Reader.ReadInteger;
  7533. end;
  7534.  
  7535. procedure TComponent.ReadTop(Reader: TReader);
  7536. begin
  7537.   LongRec(FDesignInfo).Hi := Reader.ReadInteger;
  7538. end;
  7539.  
  7540. procedure TComponent.WriteLeft(Writer: TWriter);
  7541. begin
  7542.   Writer.WriteInteger(LongRec(FDesignInfo).Lo);
  7543. end;
  7544.  
  7545. procedure TComponent.WriteTop(Writer: TWriter);
  7546. begin
  7547.   Writer.WriteInteger(LongRec(FDesignInfo).Hi);
  7548. end;
  7549.  
  7550. procedure TComponent.Insert(AComponent: TComponent);
  7551. begin
  7552.   if FComponents = nil then FComponents := TList.Create;
  7553.   FComponents.Add(AComponent);
  7554.   AComponent.FOwner := Self;
  7555. end;
  7556.  
  7557. procedure TComponent.Remove(AComponent: TComponent);
  7558. begin
  7559.   AComponent.FOwner := nil;
  7560.   FComponents.Remove(AComponent);
  7561.   if FComponents.Count = 0 then
  7562.   begin
  7563.     FComponents.Free;
  7564.     FComponents := nil;
  7565.   end;
  7566. end;
  7567.  
  7568. procedure TComponent.InsertComponent(AComponent: TComponent);
  7569. begin
  7570.   AComponent.ValidateContainer(Self);
  7571.   ValidateRename(AComponent, '', AComponent.FName);
  7572.   Insert(AComponent);
  7573.   AComponent.SetReference(True);
  7574.   if csDesigning in ComponentState then
  7575.     AComponent.SetDesigning(True);
  7576.   Notification(AComponent, opInsert);
  7577. end;
  7578.  
  7579. procedure TComponent.RemoveComponent(AComponent: TComponent);
  7580. begin
  7581.   ValidateRename(AComponent, AComponent.FName, '');
  7582.   Notification(AComponent, opRemove);
  7583.   AComponent.SetReference(False);
  7584.   Remove(AComponent);
  7585. end;
  7586.  
  7587. procedure TComponent.DestroyComponents;
  7588. var
  7589.   Instance: TComponent;
  7590. begin
  7591.   while FComponents <> nil do
  7592.   begin
  7593.     Instance := FComponents.Last;
  7594.     if (csFreeNotification in Instance.FComponentState)
  7595.       or (FComponentState * [csDesigning, csInline] = [csDesigning, csInline]) then
  7596.       RemoveComponent(Instance)
  7597.     else
  7598.       Remove(Instance);
  7599.     Instance.Destroy;
  7600.   end;
  7601. end;
  7602.  
  7603. procedure TComponent.Destroying;
  7604. var
  7605.   I: Integer;
  7606. begin
  7607.   if not (csDestroying in FComponentState) then
  7608.   begin
  7609.     Include(FComponentState, csDestroying);
  7610.     if FComponents <> nil then
  7611.       for I := 0 to FComponents.Count - 1 do
  7612.         TComponent(FComponents[I]).Destroying;
  7613.   end;
  7614. end;
  7615.  
  7616. procedure TComponent.RemoveNotification(AComponent: TComponent);
  7617. begin
  7618.   if FFreeNotifies <> nil then
  7619.   begin
  7620.     FFreeNotifies.Remove(AComponent);
  7621.     if FFreeNotifies.Count = 0 then
  7622.     begin
  7623.       FFreeNotifies.Free;
  7624.       FFreeNotifies := nil;
  7625.     end;
  7626.   end;
  7627. end;
  7628.  
  7629. procedure TComponent.RemoveFreeNotification(AComponent: TComponent);
  7630. begin
  7631.   RemoveNotification(AComponent);
  7632.   AComponent.RemoveNotification(Self);
  7633. end;
  7634.  
  7635. procedure TComponent.Notification(AComponent: TComponent;
  7636.   Operation: TOperation);
  7637. var
  7638.   I: Integer;
  7639. begin
  7640.   if (Operation = opRemove) and (AComponent <> nil) then
  7641.     RemoveFreeNotification(AComponent);
  7642.   if FComponents <> nil then
  7643.     for I := 0 to FComponents.Count - 1 do
  7644.       TComponent(FComponents[I]).Notification(AComponent, Operation);
  7645. end;
  7646.  
  7647. procedure TComponent.DefineProperties(Filer: TFiler);
  7648. var
  7649.   Ancestor: TComponent;
  7650.   Info: Longint;
  7651. begin
  7652.   Info := 0;
  7653.   Ancestor := TComponent(Filer.Ancestor);
  7654.   if Ancestor <> nil then Info := Ancestor.FDesignInfo;
  7655.   Filer.DefineProperty('Left', ReadLeft, WriteLeft,
  7656.     LongRec(FDesignInfo).Lo <> LongRec(Info).Lo);
  7657.   Filer.DefineProperty('Top', ReadTop, WriteTop,
  7658.     LongRec(FDesignInfo).Hi <> LongRec(Info).Hi);
  7659. end;
  7660.  
  7661. function TComponent.HasParent: Boolean;
  7662. begin
  7663.   Result := False;
  7664. end;
  7665.  
  7666. procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent);
  7667. begin
  7668. end;
  7669.  
  7670. function TComponent.GetChildOwner: TComponent;
  7671. begin
  7672.   Result := nil;
  7673. end;
  7674.  
  7675. function TComponent.GetChildParent: TComponent;
  7676. begin
  7677.   Result := Self;
  7678. end;
  7679.  
  7680. function TComponent.GetNamePath: string;
  7681. begin
  7682.   Result := FName;
  7683. end;
  7684.  
  7685. function TComponent.GetOwner: TPersistent;
  7686. begin
  7687.   Result := FOwner;
  7688. end;
  7689.  
  7690. procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer);
  7691. begin
  7692. end;
  7693.  
  7694. function TComponent.GetParentComponent: TComponent;
  7695. begin
  7696.   Result := nil;
  7697. end;
  7698.  
  7699. procedure TComponent.SetParentComponent(Value: TComponent);
  7700. begin
  7701. end;
  7702.  
  7703. procedure TComponent.Updating;
  7704. begin
  7705.   Include(FComponentState, csUpdating);
  7706. end;
  7707.  
  7708. procedure TComponent.Updated;
  7709. begin
  7710.   Exclude(FComponentState, csUpdating);
  7711. end;
  7712.  
  7713. procedure TComponent.Loaded;
  7714. begin
  7715.   Exclude(FComponentState, csLoading);
  7716. end;
  7717.  
  7718. procedure TComponent.ReadState(Reader: TReader);
  7719. begin
  7720.   Reader.ReadData(Self);
  7721. end;
  7722.  
  7723. procedure TComponent.WriteState(Writer: TWriter);
  7724. begin
  7725.   Writer.WriteData(Self);
  7726. end;
  7727.  
  7728. procedure TComponent.ValidateRename(AComponent: TComponent;
  7729.   const CurName, NewName: string);
  7730. begin
  7731.   if (AComponent <> nil) and not SameText(CurName, NewName) and
  7732.     (AComponent.Owner = Self) and (FindComponent(NewName) <> nil) then
  7733.     raise EComponentError.CreateResFmt(@SDuplicateName, [NewName]);
  7734.   if (csDesigning in ComponentState) and (Owner <> nil) then
  7735.     Owner.ValidateRename(AComponent, CurName, NewName);
  7736. end;
  7737.  
  7738. procedure TComponent.ValidateContainer(AComponent: TComponent);
  7739. begin
  7740.   AComponent.ValidateInsert(Self);
  7741. end;
  7742.  
  7743. procedure TComponent.ValidateInsert(AComponent: TComponent);
  7744. begin
  7745. end;
  7746.  
  7747. function TComponent.FindComponent(const AName: string): TComponent;
  7748. var
  7749.   I: Integer;
  7750. begin
  7751.   if (AName <> '') and (FComponents <> nil) then
  7752.     for I := 0 to FComponents.Count - 1 do
  7753.     begin
  7754.       Result := FComponents[I];
  7755.       if SameText(Result.FName, AName) then Exit;
  7756.     end;
  7757.   Result := nil;
  7758. end;
  7759.  
  7760. procedure TComponent.SetName(const NewName: TComponentName);
  7761. begin
  7762.   if FName <> NewName then
  7763.   begin
  7764.     if (NewName <> '') and not IsValidIdent(NewName) then
  7765.       raise EComponentError.CreateResFmt(@SInvalidName, [NewName]);
  7766.     if FOwner <> nil then
  7767.       FOwner.ValidateRename(Self, FName, NewName) else
  7768.       ValidateRename(nil, FName, NewName);
  7769.     SetReference(False);
  7770.     ChangeName(NewName);
  7771.     SetReference(True);
  7772.   end;
  7773. end;
  7774.  
  7775. procedure TComponent.ChangeName(const NewName: TComponentName);
  7776. begin
  7777.   FName := NewName;
  7778. end;
  7779.  
  7780. function TComponent.GetComponentIndex: Integer;
  7781. begin
  7782.   if (FOwner <> nil) and (FOwner.FComponents <> nil) then
  7783.     Result := FOwner.FComponents.IndexOf(Self) else
  7784.     Result := -1;
  7785. end;
  7786.  
  7787. function TComponent.GetComponent(AIndex: Integer): TComponent;
  7788. begin
  7789.   if FComponents = nil then TList.Error(@SListIndexError, AIndex);
  7790.   Result := FComponents[AIndex];
  7791. end;
  7792.  
  7793. function TComponent.GetComponentCount: Integer;
  7794. begin
  7795.   if FComponents <> nil then
  7796.     Result := FComponents.Count else
  7797.     Result := 0;
  7798. end;
  7799.  
  7800. procedure TComponent.SetComponentIndex(Value: Integer);
  7801. var
  7802.   I, Count: Integer;
  7803. begin
  7804.   if FOwner <> nil then
  7805.   begin
  7806.     I := FOwner.FComponents.IndexOf(Self);
  7807.     if I >= 0 then
  7808.     begin
  7809.       Count := FOwner.FComponents.Count;
  7810.       if Value < 0 then Value := 0;
  7811.       if Value >= Count then Value := Count - 1;
  7812.       if Value <> I then
  7813.       begin
  7814.         FOwner.FComponents.Delete(I);
  7815.         FOwner.FComponents.Insert(Value, Self);
  7816.       end;
  7817.     end;
  7818.   end;
  7819. end;
  7820.  
  7821. procedure TComponent.SetAncestor(Value: Boolean);
  7822. var
  7823.   I: Integer;
  7824. begin
  7825.   if Value then
  7826.     Include(FComponentState, csAncestor) else
  7827.     Exclude(FComponentState, csAncestor);
  7828.   for I := 0 to ComponentCount - 1 do
  7829.     Components[I].SetAncestor(Value);
  7830. end;
  7831.  
  7832. procedure TComponent.SetDesigning(Value, SetChildren: Boolean);
  7833. var
  7834.   I: Integer;
  7835. begin
  7836.   if Value then
  7837.     Include(FComponentState, csDesigning) else
  7838.     Exclude(FComponentState, csDesigning);
  7839.   if SetChildren then
  7840.     for I := 0 to ComponentCount - 1 do Components[I].SetDesigning(Value);
  7841. end;
  7842.  
  7843. procedure TComponent.SetInline(Value: Boolean);
  7844. begin
  7845.   if Value then
  7846.     Include(FComponentState, csInline) else
  7847.     Exclude(FComponentState, csInline);
  7848. end;
  7849.  
  7850. procedure TComponent.SetDesignInstance(Value: Boolean);
  7851. begin
  7852.   if Value then
  7853.     Include(FComponentState, csDesignInstance) else
  7854.     Exclude(FComponentState, csDesignInstance);
  7855. end;
  7856.  
  7857. procedure TComponent.SetReference(Enable: Boolean);
  7858. var
  7859.   Field: ^TComponent;
  7860. begin
  7861.   if FOwner <> nil then
  7862.   begin
  7863.     Field := FOwner.FieldAddress(FName);
  7864.     if Field <> nil then
  7865.       if Enable then Field^ := Self else Field^ := nil;
  7866.   end;
  7867. end;
  7868.  
  7869. function TComponent.ExecuteAction(Action: TBasicAction): Boolean;//!
  7870. begin
  7871.   if Action.HandlesTarget(Self) then
  7872.   begin
  7873.     Action.ExecuteTarget(Self);
  7874.     Result := True;
  7875.   end
  7876.   else Result := False;
  7877. end;
  7878.  
  7879. function TComponent.UpdateAction(Action: TBasicAction): Boolean;//!
  7880. begin
  7881.   if Action.HandlesTarget(Self) then
  7882.   begin
  7883.     Action.UpdateTarget(Self);
  7884.     Result := True;
  7885.   end
  7886.   else Result := False;
  7887. end;
  7888.  
  7889. function TComponent.GetComObject: IUnknown;
  7890. begin
  7891.   if FVCLComObject = nil then
  7892.   begin
  7893.     if Assigned(CreateVCLComObjectProc) then CreateVCLComObjectProc(Self);
  7894.     if FVCLComObject = nil then
  7895.       raise EComponentError.CreateResFmt(@SNoComSupport, [ClassName]);
  7896.   end;
  7897.   IVCLComObject(FVCLComObject).QueryInterface(IUnknown, Result);
  7898. end;
  7899.  
  7900. function TComponent.SafeCallException(ExceptObject: TObject;
  7901.   ExceptAddr: Pointer): HResult;
  7902. begin
  7903.   if FVCLComObject <> nil then
  7904.     Result := IVCLComObject(FVCLComObject).SafeCallException(
  7905.       ExceptObject, ExceptAddr)
  7906.   else
  7907.     Result := inherited SafeCallException(ExceptObject, ExceptAddr);
  7908. end;
  7909.  
  7910. procedure TComponent.FreeOnRelease;
  7911. begin
  7912.   if FVCLComObject <> nil then IVCLComObject(FVCLComObject).FreeOnRelease;
  7913. end;
  7914.  
  7915. class procedure TComponent.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
  7916. begin
  7917. end;
  7918.  
  7919. { TComponent.IUnknown }
  7920.  
  7921. function TComponent.QueryInterface(const IID: TGUID; out Obj): HResult;
  7922. begin
  7923.   if FVCLComObject = nil then
  7924.   begin
  7925.     if GetInterface(IID, Obj) then Result := S_OK
  7926.     else Result := E_NOINTERFACE
  7927.   end
  7928.   else
  7929.     Result := IVCLComObject(FVCLComObject).QueryInterface(IID, Obj);
  7930. end;
  7931.  
  7932. function TComponent._AddRef: Integer;
  7933. begin
  7934.   if FVCLComObject = nil then
  7935.     Result := -1   // -1 indicates no reference counting is taking place
  7936.   else
  7937.     Result := IVCLComObject(FVCLComObject)._AddRef;
  7938. end;
  7939.  
  7940. function TComponent._Release: Integer;
  7941. begin
  7942.   if FVCLComObject = nil then
  7943.     Result := -1   // -1 indicates no reference counting is taking place
  7944.   else
  7945.     Result := IVCLComObject(FVCLComObject)._Release;
  7946. end;
  7947.  
  7948. { TComponent.IDispatch }
  7949.  
  7950. function TComponent.GetTypeInfoCount(out Count: Integer): HResult;
  7951. begin
  7952.   if FVCLComObject = nil then
  7953.     Result := E_NOTIMPL
  7954.   else
  7955.     Result := IVCLComObject(FVCLComObject).GetTypeInfoCount(Count);
  7956. end;
  7957.  
  7958. function TComponent.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
  7959. begin
  7960.   if FVCLComObject = nil then
  7961.     Result := E_NOTIMPL
  7962.   else
  7963.     Result := IVCLComObject(FVCLComObject).GetTypeInfo(
  7964.       Index, LocaleID, TypeInfo);
  7965. end;
  7966.  
  7967. function TComponent.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  7968.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  7969. begin
  7970.   if FVCLComObject = nil then
  7971.     Result := E_NOTIMPL
  7972.   else
  7973.     Result := IVCLComObject(FVCLComObject).GetIDsOfNames(IID, Names,
  7974.       NameCount, LocaleID, DispIDs);
  7975. end;
  7976.  
  7977. function TComponent.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  7978.   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  7979. begin
  7980.   if FVCLComObject = nil then
  7981.     Result := E_NOTIMPL
  7982.   else
  7983.     Result := IVCLComObject(FVCLComObject).Invoke(DispID, IID, LocaleID,
  7984.       Flags, Params, VarResult, ExcepInfo, ArgErr);
  7985. end;
  7986.  
  7987. { TBasicActionLink }
  7988.  
  7989. constructor TBasicActionLink.Create(AClient: TObject);
  7990. begin
  7991.   inherited Create;
  7992.   AssignClient(AClient);
  7993. end;
  7994.  
  7995. procedure TBasicActionLink.AssignClient(AClient: TObject);
  7996. begin
  7997. end;
  7998.  
  7999. destructor TBasicActionLink.Destroy;
  8000. begin
  8001.   if FAction <> nil then FAction.UnRegisterChanges(Self);
  8002.   inherited Destroy;
  8003. end;
  8004.  
  8005. procedure TBasicActionLink.Change;
  8006. begin
  8007.   if Assigned(OnChange) then OnChange(FAction);
  8008. end;
  8009.  
  8010. function TBasicActionLink.Execute: Boolean;
  8011. begin
  8012.   Result := FAction.Execute;
  8013. end;
  8014.  
  8015. procedure TBasicActionLink.SetAction(Value: TBasicAction);
  8016. begin
  8017.   if Value <> FAction then
  8018.   begin
  8019.     if FAction <> nil then FAction.UnRegisterChanges(Self);
  8020.     FAction := Value;
  8021.     if Value <> nil then Value.RegisterChanges(Self);
  8022.   end;
  8023. end;
  8024.  
  8025. function TBasicActionLink.IsOnExecuteLinked: Boolean;
  8026. begin
  8027.   Result := True;
  8028. end;
  8029.  
  8030. procedure TBasicActionLink.SetOnExecute(Value: TNotifyEvent);
  8031. begin
  8032. end;
  8033.  
  8034. function TBasicActionLink.Update: Boolean;
  8035. begin
  8036.   Result := FAction.Update;
  8037. end;
  8038.  
  8039. { TBasicAction }
  8040.  
  8041. constructor TBasicAction.Create(AOwner: TComponent);
  8042. begin
  8043.   inherited Create(AOwner);
  8044.   FClients := TList.Create;
  8045. end;
  8046.  
  8047. destructor TBasicAction.Destroy;
  8048. begin
  8049.   inherited Destroy;
  8050.   while FClients.Count > 0 do
  8051.     UnRegisterChanges(TBasicActionLink(FClients.Last));
  8052.   FClients.Free;
  8053. end;
  8054.  
  8055. {!function TBasicAction.GetActionLinkClass: TBasicActionLinkClass;
  8056. begin
  8057.   Result := TBasicActionLink;
  8058. end;!}
  8059.  
  8060. function TBasicAction.HandlesTarget(Target: TObject): Boolean;
  8061. begin
  8062.   Result := False;
  8063. end;
  8064.  
  8065. procedure TBasicAction.ExecuteTarget(Target: TObject);
  8066. begin
  8067. end;
  8068.  
  8069. procedure TBasicAction.UpdateTarget(Target: TObject);
  8070. begin
  8071. end;
  8072.  
  8073. function TBasicAction.Execute: Boolean;
  8074. begin
  8075.   if Assigned(FOnExecute) then
  8076.   begin
  8077.     FOnExecute(Self);
  8078.     Result := True;
  8079.   end
  8080.   else Result := False;
  8081. end;
  8082.  
  8083. function TBasicAction.Update: Boolean;
  8084. begin
  8085.   if Assigned(FOnUpdate) then
  8086.   begin
  8087.     FOnUpdate(Self);
  8088.     Result := True;
  8089.   end
  8090.   else Result := False;
  8091. end;
  8092.  
  8093. procedure TBasicAction.SetOnExecute(Value: TNotifyEvent);
  8094. var
  8095.   I: Integer;
  8096. begin
  8097.   if @Value <> @OnExecute then
  8098.   begin
  8099.     for I := 0 to FClients.Count - 1 do
  8100.       TBasicActionLink(FClients[I]).SetOnExecute(Value);
  8101.     FOnExecute := Value;
  8102.     Change;
  8103.   end;
  8104. end;
  8105.  
  8106. procedure TBasicAction.Change;
  8107. {var
  8108.   I: Integer;}
  8109. begin
  8110.   if Assigned(FOnChange) then FOnChange(Self);
  8111. {!  for I := 0 to FClients.Count - 1 do
  8112.     TBasicActionLink(FClients[I]).Change;!}
  8113. end;
  8114.  
  8115. procedure TBasicAction.RegisterChanges(Value: TBasicActionLink);
  8116. begin
  8117.   Value.FAction := Self;
  8118.   FClients.Add(Value);
  8119. end;
  8120.  
  8121. procedure TBasicAction.UnRegisterChanges(Value: TBasicActionLink);
  8122. var
  8123.   I: Integer;
  8124. begin
  8125.   for I := 0 to FClients.Count - 1 do
  8126.     if FClients[I] = Value then
  8127.     begin
  8128.       Value.{!}FAction := nil;
  8129.       FClients.Delete(I);
  8130.       Break;
  8131.     end;
  8132. end;
  8133.  
  8134. { TStreamAdapter }
  8135.  
  8136. constructor TStreamAdapter.Create(Stream: TStream;
  8137.   Ownership: TStreamOwnership);
  8138. begin
  8139.   inherited Create;
  8140.   FStream := Stream;
  8141.   FOwnership := Ownership;
  8142. end;
  8143.  
  8144. destructor TStreamAdapter.Destroy;
  8145. begin
  8146.   if FOwnership = soOwned then
  8147.   begin
  8148.     FStream.Free;
  8149.     FStream := nil;
  8150.   end;
  8151.   inherited Destroy;
  8152. end;
  8153.  
  8154. function TStreamAdapter.Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult;
  8155. var
  8156.   NumRead: Longint;
  8157. begin
  8158.   try
  8159.     if pv = Nil then
  8160.     begin
  8161.       Result := STG_E_INVALIDPOINTER;
  8162.       Exit;
  8163.     end;
  8164.     NumRead := FStream.Read(pv^, cb);
  8165.     if pcbRead <> Nil then pcbRead^ := NumRead;
  8166.     Result := S_OK;
  8167.   except
  8168.     Result := S_FALSE;
  8169.   end;
  8170. end;
  8171.  
  8172. function TStreamAdapter.Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult;
  8173. var
  8174.   NumWritten: Longint;
  8175. begin
  8176.   try
  8177.     if pv = Nil then
  8178.     begin
  8179.       Result := STG_E_INVALIDPOINTER;
  8180.       Exit;
  8181.     end;
  8182.     NumWritten := FStream.Write(pv^, cb);
  8183.     if pcbWritten <> Nil then pcbWritten^ := NumWritten;
  8184.     Result := S_OK;
  8185.   except
  8186.     Result := STG_E_CANTSAVE;
  8187.   end;
  8188. end;
  8189.  
  8190. function TStreamAdapter.Seek(dlibMove: Largeint; dwOrigin: Longint;
  8191.   out libNewPosition: Largeint): HResult;
  8192. var
  8193.   NewPos: Integer;
  8194. begin
  8195.   try
  8196.     if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then
  8197.     begin
  8198.       Result := STG_E_INVALIDFUNCTION;
  8199.       Exit;
  8200.     end;
  8201.     NewPos := FStream.Seek(LongInt(dlibMove), dwOrigin);
  8202.     if @libNewPosition <> nil then libNewPosition := NewPos;
  8203.     Result := S_OK;
  8204.   except
  8205.     Result := STG_E_INVALIDPOINTER;
  8206.   end;
  8207. end;
  8208.  
  8209. function TStreamAdapter.SetSize(libNewSize: Largeint): HResult;
  8210. begin
  8211.   try
  8212.     FStream.Size := LongInt(libNewSize);
  8213.     if libNewSize <> FStream.Size then
  8214.       Result := E_FAIL
  8215.     else
  8216.       Result := S_OK;
  8217.   except
  8218.     Result := E_UNEXPECTED;
  8219.   end;
  8220. end;
  8221.  
  8222. function TStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  8223.   out cbWritten: Largeint): HResult;
  8224. const
  8225.   MaxBufSize = 1024 * 1024;  // 1mb
  8226. var
  8227.   Buffer: Pointer;
  8228.   BufSize, N, I: Integer;
  8229.   BytesRead, BytesWritten, W: LargeInt;
  8230. begin
  8231.   Result := S_OK;
  8232.   BytesRead := 0;
  8233.   BytesWritten := 0;
  8234.   try
  8235.     if cb > MaxBufSize then
  8236.       BufSize := MaxBufSize
  8237.     else
  8238.       BufSize := Integer(cb);
  8239.     GetMem(Buffer, BufSize);
  8240.     try
  8241.       while cb > 0 do
  8242.       begin
  8243.         if cb > MaxInt then
  8244.           I := MaxInt
  8245.         else
  8246.           I := cb;
  8247.         while I > 0 do
  8248.         begin
  8249.           if I > BufSize then N := BufSize else N := I;
  8250.           Inc(BytesRead, FStream.Read(Buffer^, N));
  8251.           W := 0;
  8252.           Result := stm.Write(Buffer, N, @W);
  8253.           Inc(BytesWritten, W);
  8254.           if (Result = S_OK) and (Integer(W) <> N) then Result := E_FAIL;
  8255.           if Result <> S_OK then Exit;
  8256.           Dec(I, N);
  8257.         end;
  8258.         Dec(cb, I);
  8259.       end;
  8260.     finally
  8261.       FreeMem(Buffer);
  8262.       if (@cbWritten <> nil) then cbWritten := BytesWritten;
  8263.       if (@cbRead <> nil) then cbRead := BytesRead;
  8264.     end;
  8265.   except
  8266.     Result := E_UNEXPECTED;
  8267.   end;
  8268. end;
  8269.  
  8270. function TStreamAdapter.Commit(grfCommitFlags: Longint): HResult;
  8271. begin
  8272.   Result := S_OK;
  8273. end;
  8274.  
  8275. function TStreamAdapter.Revert: HResult;
  8276. begin
  8277.   Result := STG_E_REVERTED;
  8278. end;
  8279.  
  8280. function TStreamAdapter.LockRegion(libOffset: Largeint; cb: Largeint;
  8281.   dwLockType: Longint): HResult;
  8282. begin
  8283.   Result := STG_E_INVALIDFUNCTION;
  8284. end;
  8285.  
  8286. function TStreamAdapter.UnlockRegion(libOffset: Largeint; cb: Largeint;
  8287.   dwLockType: Longint): HResult;
  8288. begin
  8289.   Result := STG_E_INVALIDFUNCTION;
  8290. end;
  8291.  
  8292. function TStreamAdapter.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult;
  8293. begin
  8294.   Result := S_OK;
  8295.   try
  8296.     if (@statstg <> nil) then
  8297.       with statstg do
  8298.       begin
  8299.         dwType := STGTY_STREAM;
  8300.         cbSize := FStream.Size;
  8301.         mTime.dwLowDateTime := 0;
  8302.         mTime.dwHighDateTime := 0;
  8303.         cTime.dwLowDateTime := 0;
  8304.         cTime.dwHighDateTime := 0;
  8305.         aTime.dwLowDateTime := 0;
  8306.         aTime.dwHighDateTime := 0;
  8307.         grfLocksSupported := LOCK_WRITE;
  8308.       end;
  8309.   except
  8310.     Result := E_UNEXPECTED;
  8311.   end;
  8312. end;
  8313.  
  8314. function TStreamAdapter.Clone(out stm: IStream): HResult;
  8315. begin
  8316.   Result := E_NOTIMPL;
  8317. end;
  8318.  
  8319.  
  8320. procedure FreeIntConstList;
  8321. var
  8322.   I: Integer;
  8323. begin
  8324.   with IntConstList.LockList do
  8325.   try
  8326.     for I := 0 to Count - 1 do
  8327.       TIntConst(Items[I]).Free;
  8328.   finally
  8329.     IntConstList.UnlockList;
  8330.   end;
  8331.   IntConstList.Free;
  8332. end;
  8333.  
  8334. procedure ModuleUnload(Instance: Longint);
  8335. begin
  8336.   UnregisterModuleClasses(HMODULE(Instance));
  8337. end;
  8338.  
  8339. initialization
  8340.   InitializeCriticalSection(ThreadLock);
  8341.   AddModuleUnloadProc(ModuleUnload);
  8342.   GlobalNameSpace := TMultiReadExclusiveWriteSynchronizer.Create;
  8343.   ClassList := TThreadList.Create;
  8344.   ClassAliasList := TStringList.Create;
  8345.   IntConstList := TThreadList.Create;
  8346.   GlobalFixupList := TThreadList.Create;
  8347.  
  8348. finalization
  8349.   UnRegisterModuleClasses(HInstance);
  8350.   GlobalNameSpace.BeginWrite;
  8351.   FreeIntConstList;
  8352.   ClassList.Free;
  8353.   ClassAliasList.Free;
  8354.   RemoveFixupReferences(nil, '');
  8355.   GlobalFixupList.Free;
  8356.   GlobalFixupList := nil;
  8357.   GlobalLists.Free;
  8358.   FreeThreadWindow;
  8359.   GlobalNameSpace.Free;
  8360.   GlobalNameSpace := nil;
  8361.   RemoveModuleUnloadProc(ModuleUnload);
  8362.   DeleteCriticalSection(ThreadLock);
  8363. end.
  8364.