system/Classes.pas

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