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