home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Install / DATA.Z / CLASSES.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-09  |  140.1 KB  |  5,714 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1995,96 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Classes;
  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-40].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.  
  1458. procedure TBits.SetBit(Index: Integer; Value: Boolean); assembler;
  1459. asm
  1460.         CMP     Index,[EAX].FSize
  1461.         JAE     @@Size
  1462.  
  1463. @@1:    MOV     EAX,[EAX].FBits
  1464.         OR      Value,Value
  1465.         JZ      @@2
  1466.         BTS     [EAX],Index
  1467.         RET
  1468.  
  1469. @@2:    BTR     [EAX],Index
  1470.         RET
  1471.  
  1472. @@Size: CMP     Index,0
  1473.         JL      TBits.Error
  1474.         PUSH    Self
  1475.         PUSH    Index
  1476.         PUSH    ECX {Value}
  1477.         INC     Index
  1478.         CALL    TBits.SetSize
  1479.         POP     ECX {Value}
  1480.         POP     Index
  1481.         POP     Self
  1482.         JMP     @@1
  1483. end;
  1484.  
  1485. function TBits.GetBit(Index: Integer): Boolean; assembler;
  1486. asm
  1487.         CMP     Index,[EAX].FSize
  1488.         JAE     TBits.Error
  1489.         MOV     EAX,[EAX].FBits
  1490.         BT      [EAX],Index
  1491.         SBB     EAX,EAX
  1492.         AND     EAX,1
  1493. end;
  1494.  
  1495.  
  1496. function TBits.OpenBit: Integer;
  1497. var
  1498.   I: Integer;
  1499.   B: TBitSet;
  1500.   J: TBitEnum;
  1501.   E: Integer;
  1502. begin
  1503.   E := (Size + BitsPerInt - 1) div BitsPerInt - 1;
  1504.   for I := 0 to E do
  1505.     if PBitArray(FBits)^[I] <> [0..BitsPerInt - 1] then
  1506.     begin
  1507.       B := PBitArray(FBits)^[I];
  1508.       for J := Low(J) to High(J) do
  1509.       begin
  1510.         if not (J in B) then
  1511.         begin
  1512.           Result := I * BitsPerInt + J;
  1513.           if Result >= Size then Result := Size;
  1514.           Exit;
  1515.         end;
  1516.       end;
  1517.     end;
  1518.   Result := Size;
  1519. end;
  1520.  
  1521. { TPersistent }
  1522.  
  1523. procedure TPersistent.Assign(Source: TPersistent);
  1524. begin
  1525.   if Source <> nil then Source.AssignTo(Self) else AssignError(nil);
  1526. end;
  1527.  
  1528. procedure TPersistent.AssignError(Source: TPersistent);
  1529. var
  1530.   SourceName: string;
  1531. begin
  1532.   if Source <> nil then
  1533.     SourceName := Source.ClassName else
  1534.     SourceName := 'nil';
  1535.   raise EConvertError.CreateResFmt(SAssignError, [SourceName, ClassName]);
  1536. end;
  1537.  
  1538. procedure TPersistent.AssignTo(Dest: TPersistent);
  1539. begin
  1540.   Dest.AssignError(Self);
  1541. end;
  1542.  
  1543. procedure TPersistent.DefineProperties(Filer: TFiler);
  1544. begin
  1545. end;
  1546.  
  1547. { TCollectionItem }
  1548.  
  1549. constructor TCollectionItem.Create(Collection: TCollection);
  1550. begin
  1551.   SetCollection(Collection);
  1552. end;
  1553.  
  1554. destructor TCollectionItem.Destroy;
  1555. begin
  1556.   SetCollection(nil);
  1557. end;
  1558.  
  1559. procedure TCollectionItem.Changed(AllItems: Boolean);
  1560. var
  1561.   Item: TCollectionItem;
  1562. begin
  1563.   if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then
  1564.   begin
  1565.     if AllItems then Item := nil else Item := Self;
  1566.     FCollection.Update(Item);
  1567.   end;
  1568. end;
  1569.  
  1570. function TCollectionItem.GetIndex: Integer;
  1571. begin
  1572.   if FCollection <> nil then
  1573.     Result := FCollection.FItems.IndexOf(Self) else
  1574.     Result := -1;
  1575. end;
  1576.  
  1577. procedure TCollectionItem.SetCollection(Value: TCollection);
  1578. begin
  1579.   if FCollection <> Value then
  1580.   begin
  1581.     if FCollection <> nil then FCollection.RemoveItem(Self);
  1582.     if Value <> nil then Value.InsertItem(Self);
  1583.   end;
  1584. end;
  1585.  
  1586. procedure TCollectionItem.SetIndex(Value: Integer);
  1587. var
  1588.   CurIndex: Integer;
  1589. begin
  1590.   CurIndex := GetIndex;
  1591.   if (CurIndex >= 0) and (CurIndex <> Value) then
  1592.   begin
  1593.     FCollection.FItems.Move(CurIndex, Value);
  1594.     Changed(True);
  1595.   end;
  1596. end;
  1597.  
  1598. { TCollection }
  1599.  
  1600. constructor TCollection.Create(ItemClass: TCollectionItemClass);
  1601. begin
  1602.   FItemClass := ItemClass;
  1603.   FItems := TList.Create;
  1604. end;
  1605.  
  1606. destructor TCollection.Destroy;
  1607. begin
  1608.   FUpdateCount := 1;
  1609.   if FItems <> nil then Clear;
  1610.   FItems.Free;
  1611. end;
  1612.  
  1613. function TCollection.Add: TCollectionItem;
  1614. begin
  1615.   Result := FItemClass.Create(Self);
  1616. end;
  1617.  
  1618. procedure TCollection.Assign(Source: TPersistent);
  1619. var
  1620.   I: Integer;
  1621. begin
  1622.   if Source is TCollection then
  1623.   begin
  1624.     BeginUpdate;
  1625.     try
  1626.       Clear;
  1627.       for I := 0 to TCollection(Source).Count - 1 do
  1628.         Add.Assign(TCollection(Source).Items[I]);
  1629.     finally
  1630.       EndUpdate;
  1631.     end;
  1632.     Exit;
  1633.   end;
  1634.   inherited Assign(Source);
  1635. end;
  1636.  
  1637. procedure TCollection.BeginUpdate;
  1638. begin
  1639.   Inc(FUpdateCount);
  1640. end;
  1641.  
  1642. procedure TCollection.Changed;
  1643. begin
  1644.   if FUpdateCount = 0 then Update(nil);
  1645. end;
  1646.  
  1647. procedure TCollection.Clear;
  1648. begin
  1649.   if FItems.Count > 0 then
  1650.   begin
  1651.     BeginUpdate;
  1652.     try
  1653.       while FItems.Count > 0 do TCollectionItem(FItems.Last).Free;
  1654.     finally
  1655.       EndUpdate;
  1656.     end;
  1657.   end;
  1658. end;
  1659.  
  1660. procedure TCollection.EndUpdate;
  1661. begin
  1662.   Dec(FUpdateCount);
  1663.   Changed;
  1664. end;
  1665.  
  1666. function TCollection.GetCount: Integer;
  1667. begin
  1668.   Result := FItems.Count;
  1669. end;
  1670.  
  1671. function TCollection.GetItem(Index: Integer): TCollectionItem;
  1672. begin
  1673.   Result := FItems[Index];
  1674. end;
  1675.  
  1676. procedure TCollection.InsertItem(Item: TCollectionItem);
  1677. begin
  1678.   if not (Item is FItemClass) then ListError(SInvalidProperty);
  1679.   FItems.Add(Item);
  1680.   Item.FCollection := Self;
  1681.   Changed;
  1682. end;
  1683.  
  1684. procedure TCollection.RemoveItem(Item: TCollectionItem);
  1685. begin
  1686.   FItems.Remove(Item);
  1687.   Item.FCollection := nil;
  1688.   Changed;
  1689. end;
  1690.  
  1691. procedure TCollection.SetItem(Index: Integer; Value: TCollectionItem);
  1692. begin
  1693.   TCollectionItem(FItems[Index]).Assign(Value);
  1694. end;
  1695.  
  1696. procedure TCollection.Update(Item: TCollectionItem);
  1697. begin
  1698. end;
  1699.  
  1700. { TStrings }
  1701.  
  1702. function TStrings.Add(const S: string): Integer;
  1703. begin
  1704.   Result := GetCount;
  1705.   Insert(Result, S);
  1706. end;
  1707.  
  1708. function TStrings.AddObject(const S: string; AObject: TObject): Integer;
  1709. begin
  1710.   Result := Add(S);
  1711.   PutObject(Result, AObject);
  1712. end;
  1713.  
  1714. procedure TStrings.Append(const S: string);
  1715. begin
  1716.   Add(S);
  1717. end;
  1718.  
  1719. procedure TStrings.AddStrings(Strings: TStrings);
  1720. var
  1721.   I: Integer;
  1722. begin
  1723.   BeginUpdate;
  1724.   try
  1725.     for I := 0 to Strings.Count - 1 do
  1726.       AddObject(Strings[I], Strings.Objects[I]);
  1727.   finally
  1728.     EndUpdate;
  1729.   end;
  1730. end;
  1731.  
  1732. procedure TStrings.Assign(Source: TPersistent);
  1733. begin
  1734.   if Source is TStrings then
  1735.   begin
  1736.     BeginUpdate;
  1737.     try
  1738.       Clear;
  1739.       AddStrings(TStrings(Source));
  1740.     finally
  1741.       EndUpdate;
  1742.     end;
  1743.     Exit;
  1744.   end;
  1745.   inherited Assign(Source);
  1746. end;
  1747.  
  1748. procedure TStrings.BeginUpdate;
  1749. begin
  1750.   if FUpdateCount = 0 then SetUpdateState(True);
  1751.   Inc(FUpdateCount);
  1752. end;
  1753.  
  1754. procedure TStrings.DefineProperties(Filer: TFiler);
  1755.  
  1756.   function DoWrite: Boolean;
  1757.   begin
  1758.     if Filer.Ancestor <> nil then
  1759.     begin
  1760.       Result := True;
  1761.       if Filer.Ancestor is TStrings then
  1762.         Result := not Equals(TStrings(Filer.Ancestor))
  1763.     end
  1764.     else Result := Count > 0;
  1765.   end;
  1766.  
  1767. begin
  1768.   Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite);
  1769. end;
  1770.  
  1771. procedure TStrings.EndUpdate;
  1772. begin
  1773.   Dec(FUpdateCount);
  1774.   if FUpdateCount = 0 then SetUpdateState(False);
  1775. end;
  1776.  
  1777. function TStrings.Equals(Strings: TStrings): Boolean;
  1778. var
  1779.   I, Count: Integer;
  1780. begin
  1781.   Result := False;
  1782.   Count := GetCount;
  1783.   if Count <> Strings.GetCount then Exit;
  1784.   for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit;
  1785.   Result := True;
  1786. end;
  1787.  
  1788. procedure TStrings.Exchange(Index1, Index2: Integer);
  1789. var
  1790.   TempObject: TObject;
  1791.   TempString: string;
  1792. begin
  1793.   TempString := Strings[Index1];
  1794.   TempObject := Objects[Index1];
  1795.   Strings[Index1] := Strings[Index2];
  1796.   Objects[Index1] := Objects[Index2];
  1797.   Strings[Index2] := TempString;
  1798.   Objects[Index2] := TempObject;
  1799. end;
  1800.  
  1801. function TStrings.GetCommaText: string;
  1802. var
  1803.   P, S, T: PChar;
  1804.   I, L, Count: Integer;
  1805.   Quotes: Boolean;
  1806.   Text: array[0..4095] of Char;
  1807. begin
  1808.   Count := GetCount;
  1809.   if (Count = 1) and (Get(0) = '') then Result := '""' else
  1810.   begin
  1811.     T := Text;
  1812.     for I := 0 to Count - 1 do
  1813.     begin
  1814.       if I <> 0 then
  1815.       begin
  1816.         T^ := ',';
  1817.         Inc(T);
  1818.       end;
  1819.       S := PChar(Get(I));
  1820.       L := 0;
  1821.       Quotes := False;
  1822.       P := S;
  1823.       while P^ <> #0 do
  1824.       begin
  1825.         if not Quotes and ((P^ <= ' ') or (P^ = '"') or (P^ = ',')) then
  1826.         begin
  1827.           Inc(L, 2);
  1828.           Quotes := True;
  1829.         end;
  1830.         if P^ = '"' then Inc(L);
  1831.         Inc(L);
  1832.         Inc(P);
  1833.       end;
  1834.       if T + L >= Text + SizeOf(Text) then Break;
  1835.       if Quotes then
  1836.       begin
  1837.         T^ := '"';
  1838.         Inc(T);
  1839.       end;
  1840.       P := S;
  1841.       while P^ <> #0 do
  1842.       begin
  1843.         if P^ = '"' then
  1844.         begin
  1845.           T^ := '"';
  1846.           Inc(T);
  1847.         end;
  1848.         T^ := P^;
  1849.         Inc(T);
  1850.         Inc(P);
  1851.       end;
  1852.       if Quotes then
  1853.       begin
  1854.         T^ := '"';
  1855.         Inc(T);
  1856.       end;
  1857.     end;
  1858.     SetString(Result, Text, T - Text);
  1859.   end;
  1860. end;
  1861.  
  1862. function TStrings.GetName(Index: Integer): string;
  1863. var
  1864.   P: Integer;
  1865. begin
  1866.   Result := Get(Index);
  1867.   P := Pos('=', Result);
  1868.   if P <> 0 then
  1869.     SetLength(Result, P-1) else
  1870.     SetLength(Result, 0);
  1871. end;
  1872.  
  1873. function TStrings.GetObject(Index: Integer): TObject;
  1874. begin
  1875.   Result := nil;
  1876. end;
  1877.  
  1878. function TStrings.GetText: PChar;
  1879. begin
  1880.   Result := StrNew(PChar(GetTextStr));
  1881. end;
  1882.  
  1883. function TStrings.GetTextStr: string;
  1884. var
  1885.   I, L, Size, Count: Integer;
  1886.   P: PChar;
  1887.   S: string;
  1888. begin
  1889.   Count := GetCount;
  1890.   Size := 0;
  1891.   for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + 2);
  1892.   SetString(Result, nil, Size);
  1893.   P := Pointer(Result);
  1894.   for I := 0 to Count - 1 do
  1895.   begin
  1896.     S := Get(I);
  1897.     L := Length(S);
  1898.     if L <> 0 then
  1899.     begin
  1900.       System.Move(Pointer(S)^, P^, L);
  1901.       Inc(P, L);
  1902.     end;
  1903.     P^ := #13;
  1904.     Inc(P);
  1905.     P^ := #10;
  1906.     Inc(P);
  1907.   end;
  1908. end;
  1909.  
  1910. function TStrings.GetValue(const Name: string): string;
  1911. var
  1912.   I: Integer;
  1913. begin
  1914.   I := IndexOfName(Name);
  1915.   if I >= 0 then
  1916.     Result := Copy(Get(I), Length(Name) + 2, MaxInt) else
  1917.     Result := '';
  1918. end;
  1919.  
  1920. function TStrings.IndexOf(const S: string): Integer;
  1921. begin
  1922.   for Result := 0 to GetCount - 1 do
  1923.     if AnsiCompareText(Get(Result), S) = 0 then Exit;
  1924.   Result := -1;
  1925. end;
  1926.  
  1927. function TStrings.IndexOfName(const Name: string): Integer;
  1928. var
  1929.   P: Integer;
  1930.   S: string;
  1931. begin
  1932.   for Result := 0 to GetCount - 1 do
  1933.   begin
  1934.     S := Get(Result);
  1935.     P := Pos('=', S);
  1936.     if (P <> 0) and (AnsiCompareText(Copy(S, 1, P - 1), Name) = 0) then Exit;
  1937.   end;
  1938.   Result := -1;
  1939. end;
  1940.  
  1941. function TStrings.IndexOfObject(AObject: TObject): Integer;
  1942. begin
  1943.   for Result := 0 to GetCount - 1 do
  1944.     if GetObject(Result) = AObject then Exit;
  1945.   Result := -1;
  1946. end;
  1947.  
  1948. procedure TStrings.InsertObject(Index: Integer; const S: string;
  1949.   AObject: TObject);
  1950. begin
  1951.   Insert(Index, S);
  1952.   PutObject(Index, AObject);
  1953. end;
  1954.  
  1955. procedure TStrings.LoadFromFile(const FileName: string);
  1956. var
  1957.   Stream: TStream;
  1958. begin
  1959.   Stream := TFileStream.Create(FileName, fmOpenRead);
  1960.   try
  1961.     LoadFromStream(Stream);
  1962.   finally
  1963.     Stream.Free;
  1964.   end;
  1965. end;
  1966.  
  1967. procedure TStrings.LoadFromStream(Stream: TStream);
  1968. var
  1969.   Size: Integer;
  1970.   S: string;
  1971. begin
  1972.   BeginUpdate;
  1973.   try
  1974.     Size := Stream.Size - Stream.Position;
  1975.     SetString(S, nil, Size);
  1976.     Stream.Read(Pointer(S)^, Size);
  1977.     SetTextStr(S);
  1978.   finally
  1979.     EndUpdate;
  1980.   end;
  1981. end;
  1982.  
  1983. procedure TStrings.Move(CurIndex, NewIndex: Integer);
  1984. var
  1985.   TempObject: TObject;
  1986.   TempString: string;
  1987. begin
  1988.   if CurIndex <> NewIndex then
  1989.   begin
  1990.     TempString := Get(CurIndex);
  1991.     TempObject := GetObject(CurIndex);
  1992.     Delete(CurIndex);
  1993.     InsertObject(NewIndex, TempString, TempObject);
  1994.   end;
  1995. end;
  1996.  
  1997. procedure TStrings.Put(Index: Integer; const S: string);
  1998. var
  1999.   TempObject: TObject;
  2000. begin
  2001.   TempObject := GetObject(Index);
  2002.   Delete(Index);
  2003.   InsertObject(Index, S, TempObject);
  2004. end;
  2005.  
  2006. procedure TStrings.PutObject(Index: Integer; AObject: TObject);
  2007. begin
  2008. end;
  2009.  
  2010. procedure TStrings.ReadData(Reader: TReader);
  2011. begin
  2012.   Reader.ReadListBegin;
  2013.   Clear;
  2014.   while not Reader.EndOfList do Add(Reader.ReadString);
  2015.   Reader.ReadListEnd;
  2016. end;
  2017.  
  2018. procedure TStrings.SaveToFile(const FileName: string);
  2019. var
  2020.   Stream: TStream;
  2021. begin
  2022.   Stream := TFileStream.Create(FileName, fmCreate);
  2023.   try
  2024.     SaveToStream(Stream);
  2025.   finally
  2026.     Stream.Free;
  2027.   end;
  2028. end;
  2029.  
  2030. procedure TStrings.SaveToStream(Stream: TStream);
  2031. var
  2032.   S: string;
  2033. begin
  2034.   S := GetText;
  2035.   Stream.WriteBuffer(Pointer(S)^, Length(S));
  2036. end;
  2037.  
  2038. procedure TStrings.SetCommaText(const Value: string);
  2039. var
  2040.   P, P1, P2: PChar;
  2041.   S: string;
  2042.   Text: array[0..4095] of Char;
  2043. begin
  2044.   BeginUpdate;
  2045.   try
  2046.     Clear;
  2047.     StrLCopy(Text, PChar(Value), SizeOf(Text) - 1);
  2048.     P := Text;
  2049.     while (P^ <> #0) and (P^ <= ' ') do Inc(P);
  2050.     if P^ <> #0 then
  2051.       while True do
  2052.       begin
  2053.         P1 := P;
  2054.         if P^ = '"' then
  2055.         begin
  2056.           P2 := P;
  2057.           Inc(P);
  2058.           while P^ <> #0 do
  2059.           begin
  2060.             if P^ = '"' then
  2061.             begin
  2062.               Inc(P);
  2063.               if P^ <> '"' then Break;
  2064.             end;
  2065.             P2^ := P^;
  2066.             Inc(P2);
  2067.             Inc(P);
  2068.           end;
  2069.         end else
  2070.         begin
  2071.           while (P^ > ' ') and (P^ <> ',') do Inc(P);
  2072.           P2 := P;
  2073.         end;
  2074.         SetString(S, P1, P2 - P1);
  2075.         Add(S);
  2076.         while (P^ <> #0) and (P^ <= ' ') do Inc(P);
  2077.         if P^ = #0 then Break;
  2078.         if P^ = ',' then
  2079.         begin
  2080.           Inc(P);
  2081.           while (P^ <> #0) and (P^ <= ' ') do Inc(P);
  2082.         end;
  2083.       end;
  2084.   finally
  2085.     EndUpdate;
  2086.   end;
  2087. end;
  2088.  
  2089. procedure TStrings.SetValue(const Name, Value: string);
  2090. var
  2091.   I: Integer;
  2092. begin
  2093.   I := IndexOfName(Name);
  2094.   if Value <> '' then
  2095.   begin
  2096.     if I < 0 then I := Add('');
  2097.     Put(I, Name + '=' + Value);
  2098.   end else
  2099.   begin
  2100.     if I >= 0 then Delete(I);
  2101.   end;
  2102. end;
  2103.  
  2104. procedure TStrings.SetText(Text: PChar);
  2105. begin
  2106.   SetTextStr(Text);
  2107. end;
  2108.  
  2109. procedure TStrings.SetTextStr(const Value: string);
  2110. var
  2111.   P, Start: PChar;
  2112.   S: string;
  2113. begin
  2114.   BeginUpdate;
  2115.   try
  2116.     Clear;
  2117.     P := Pointer(Value);
  2118.     if P <> nil then
  2119.       while P^ <> #0 do
  2120.       begin
  2121.         Start := P;
  2122.         while not (P^ in [#0, #10, #13]) do Inc(P);
  2123.         SetString(S, Start, P - Start);
  2124.         Add(S);
  2125.         if P^ = #13 then Inc(P);
  2126.         if P^ = #10 then Inc(P);
  2127.       end;
  2128.   finally
  2129.     EndUpdate;
  2130.   end;
  2131. end;
  2132.  
  2133. procedure TStrings.SetUpdateState(Updating: Boolean);
  2134. begin
  2135. end;
  2136.  
  2137. procedure TStrings.WriteData(Writer: TWriter);
  2138. var
  2139.   I: Integer;
  2140. begin
  2141.   Writer.WriteListBegin;
  2142.   for I := 0 to Count - 1 do Writer.WriteString(Get(I));
  2143.   Writer.WriteListEnd;
  2144. end;
  2145.  
  2146. { TStringList }
  2147.  
  2148. destructor TStringList.Destroy;
  2149. begin
  2150.   FOnChange := nil;
  2151.   FOnChanging := nil;
  2152.   if FCount <> 0 then Finalize(FList^[0], FCount);
  2153.   FCount := 0;
  2154.   SetCapacity(0);
  2155. end;
  2156.  
  2157. function TStringList.Add(const S: string): Integer;
  2158. begin
  2159.   if not Sorted then
  2160.     Result := FCount
  2161.   else
  2162.     if Find(S, Result) then
  2163.       case Duplicates of
  2164.         dupIgnore: Exit;
  2165.         dupError: ListError(SDuplicateString);
  2166.       end;
  2167.   InsertItem(Result, S);
  2168. end;
  2169.  
  2170. procedure TStringList.Changed;
  2171. begin
  2172.   if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
  2173. end;
  2174.  
  2175. procedure TStringList.Changing;
  2176. begin
  2177.   if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
  2178. end;
  2179.  
  2180. procedure TStringList.Clear;
  2181. begin
  2182.   if FCount <> 0 then
  2183.   begin
  2184.     Changing;
  2185.     Finalize(FList^[0], FCount);
  2186.     FCount := 0;
  2187.     SetCapacity(0);
  2188.     Changed;
  2189.   end;
  2190. end;
  2191.  
  2192. procedure TStringList.Delete(Index: Integer);
  2193. begin
  2194.   if (Index < 0) or (Index >= FCount) then ListIndexError;
  2195.   Changing;
  2196.   Finalize(FList^[Index]);
  2197.   Dec(FCount);
  2198.   if Index < FCount then
  2199.     System.Move(FList^[Index + 1], FList^[Index],
  2200.       (FCount - Index) * SizeOf(TStringItem));
  2201.   Changed;
  2202. end;
  2203.  
  2204. procedure TStringList.Exchange(Index1, Index2: Integer);
  2205. begin
  2206.   if (Index1 < 0) or (Index1 >= FCount) or
  2207.     (Index2 < 0) or (Index2 >= FCount) then ListIndexError;
  2208.   Changing;
  2209.   ExchangeItems(Index1, Index2);
  2210.   Changed;
  2211. end;
  2212.  
  2213. procedure TStringList.ExchangeItems(Index1, Index2: Integer);
  2214. var
  2215.   Temp: Integer;
  2216.   Item1, Item2: PStringItem;
  2217. begin
  2218.   Item1 := @FList^[Index1];
  2219.   Item2 := @FList^[Index2];
  2220.   Temp := Integer(Item1^.FString);
  2221.   Integer(Item1^.FString) := Integer(Item2^.FString);
  2222.   Integer(Item2^.FString) := Temp;
  2223.   Temp := Integer(Item1^.FObject);
  2224.   Integer(Item1^.FObject) := Integer(Item2^.FObject);
  2225.   Integer(Item2^.FObject) := Temp;
  2226. end;
  2227.  
  2228. function TStringList.Find(const S: string; var Index: Integer): Boolean;
  2229. var
  2230.   L, H, I, C: Integer;
  2231. begin
  2232.   Result := False;
  2233.   L := 0;
  2234.   H := FCount - 1;
  2235.   while L <= H do
  2236.   begin
  2237.     I := (L + H) shr 1;
  2238.     C := AnsiCompareText(FList^[I].FString, S);
  2239.     if C < 0 then L := I + 1 else
  2240.     begin
  2241.       H := I - 1;
  2242.       if C = 0 then
  2243.       begin
  2244.         Result := True;
  2245.         if Duplicates <> dupAccept then L := I;
  2246.       end;
  2247.     end;
  2248.   end;
  2249.   Index := L;
  2250. end;
  2251.  
  2252. function TStringList.Get(Index: Integer): string;
  2253. begin
  2254.   if (Index < 0) or (Index >= FCount) then ListIndexError;
  2255.   Result := FList^[Index].FString;
  2256. end;
  2257.  
  2258. function TStringList.GetCount: Integer;
  2259. begin
  2260.   Result := FCount;
  2261. end;
  2262.  
  2263. function TStringList.GetObject(Index: Integer): TObject;
  2264. begin
  2265.   if (Index < 0) or (Index >= FCount) then ListIndexError;
  2266.   Result := FList^[Index].FObject;
  2267. end;
  2268.  
  2269. procedure TStringList.Grow;
  2270. var
  2271.   Delta: Integer;
  2272. begin
  2273.   if FCapacity > 8 then Delta := 16 else
  2274.     if FCapacity > 4 then Delta := 8 else
  2275.       Delta := 4;
  2276.   SetCapacity(FCapacity + Delta);
  2277. end;
  2278.  
  2279. function TStringList.IndexOf(const S: string): Integer;
  2280. begin
  2281.   if not Sorted then Result := inherited IndexOf(S) else
  2282.     if not Find(S, Result) then Result := -1;
  2283. end;
  2284.  
  2285. procedure TStringList.Insert(Index: Integer; const S: string);
  2286. begin
  2287.   if Sorted then ListError(SSortedListError);
  2288.   if (Index < 0) or (Index > FCount) then ListIndexError;
  2289.   InsertItem(Index, S);
  2290. end;
  2291.  
  2292. procedure TStringList.InsertItem(Index: Integer; const S: string);
  2293. begin
  2294.   Changing;
  2295.   if FCount = FCapacity then Grow;
  2296.   if Index < FCount then
  2297.     System.Move(FList^[Index], FList^[Index + 1],
  2298.       (FCount - Index) * SizeOf(TStringItem));
  2299.   with FList^[Index] do
  2300.   begin
  2301.     Pointer(FString) := nil;
  2302.     FObject := nil;
  2303.     FString := S;
  2304.   end;
  2305.   Inc(FCount);
  2306.   Changed;
  2307. end;
  2308.  
  2309. procedure TStringList.Put(Index: Integer; const S: string);
  2310. begin
  2311.   if Sorted then ListError(SSortedListError);
  2312.   if (Index < 0) or (Index >= FCount) then ListIndexError;
  2313.   Changing;
  2314.   FList^[Index].FString := S;
  2315.   Changed;
  2316. end;
  2317.  
  2318. procedure TStringList.PutObject(Index: Integer; AObject: TObject);
  2319. begin
  2320.   if (Index < 0) or (Index >= FCount) then ListIndexError;
  2321.   Changing;
  2322.   FList^[Index].FObject := AObject;
  2323.   Changed;
  2324. end;
  2325.  
  2326. procedure TStringList.QuickSort(L, R: Integer);
  2327. var
  2328.   I, J: Integer;
  2329.   P: string;
  2330. begin
  2331.   repeat
  2332.     I := L;
  2333.     J := R;
  2334.     P := FList^[(L + R) shr 1].FString;
  2335.     repeat
  2336.       while AnsiCompareText(FList^[I].FString, P) < 0 do Inc(I);
  2337.       while AnsiCompareText(FList^[J].FString, P) > 0 do Dec(J);
  2338.       if I <= J then
  2339.       begin
  2340.         ExchangeItems(I, J);
  2341.         Inc(I);
  2342.         Dec(J);
  2343.       end;
  2344.     until I > J;
  2345.     if L < J then QuickSort(L, J);
  2346.     L := I;
  2347.   until I >= R;
  2348. end;
  2349.  
  2350. procedure TStringList.SetCapacity(NewCapacity: Integer);
  2351. begin
  2352.   ReallocMem(FList, NewCapacity * SizeOf(TStringItem));
  2353.   FCapacity := NewCapacity;
  2354. end;
  2355.  
  2356. procedure TStringList.SetSorted(Value: Boolean);
  2357. begin
  2358.   if FSorted <> Value then
  2359.   begin
  2360.     if Value then Sort;
  2361.     FSorted := Value;
  2362.   end;
  2363. end;
  2364.  
  2365. procedure TStringList.SetUpdateState(Updating: Boolean);
  2366. begin
  2367.   if Updating then Changing else Changed;
  2368. end;
  2369.  
  2370. procedure TStringList.Sort;
  2371. begin
  2372.   if not Sorted and (FCount > 1) then
  2373.   begin
  2374.     Changing;
  2375.     QuickSort(0, FCount - 1);
  2376.     Changed;
  2377.   end;
  2378. end;
  2379.  
  2380. { TStream }
  2381.  
  2382. function TStream.GetPosition: Longint;
  2383. begin
  2384.   Result := Seek(0, 1);
  2385. end;
  2386.  
  2387. procedure TStream.SetPosition(Pos: Longint);
  2388. begin
  2389.   Seek(Pos, 0);
  2390. end;
  2391.  
  2392. function TStream.GetSize: Longint;
  2393. var
  2394.   Pos: Longint;
  2395. begin
  2396.   Pos := Seek(0, 1);
  2397.   Result := Seek(0, 2);
  2398.   Seek(Pos, 0);
  2399. end;
  2400.  
  2401. procedure TStream.ReadBuffer(var Buffer; Count: Longint);
  2402. begin
  2403.   if (Count <> 0) and (Read(Buffer, Count) <> Count) then
  2404.     raise EReadError.CreateRes(SReadError);
  2405. end;
  2406.  
  2407. procedure TStream.WriteBuffer(const Buffer; Count: Longint);
  2408. begin
  2409.   if (Count <> 0) and (Write(Buffer, Count) <> Count) then
  2410.     raise EWriteError.CreateRes(SWriteError);
  2411. end;
  2412.  
  2413. function TStream.CopyFrom(Source: TStream; Count: Longint): Longint;
  2414. const
  2415.   MaxBufSize = $F000;
  2416. var
  2417.   BufSize, N: Integer;
  2418.   Buffer: PChar;
  2419. begin
  2420.   if Count = 0 then
  2421.   begin
  2422.     Source.Position := 0;
  2423.     Count := Source.Size;
  2424.   end;
  2425.   Result := Count;
  2426.   if Count > MaxBufSize then BufSize := MaxBufSize else BufSize := Count;
  2427.   GetMem(Buffer, BufSize);
  2428.   try
  2429.     while Count <> 0 do
  2430.     begin
  2431.       if Count > BufSize then N := BufSize else N := Count;
  2432.       Source.ReadBuffer(Buffer^, N);
  2433.       WriteBuffer(Buffer^, N);
  2434.       Dec(Count, N);
  2435.     end;
  2436.   finally
  2437.     FreeMem(Buffer, BufSize);
  2438.   end;
  2439. end;
  2440.  
  2441. function TStream.ReadComponent(Instance: TComponent): TComponent;
  2442. var
  2443.   Reader: TReader;
  2444. begin
  2445.   Reader := TReader.Create(Self, 4096);
  2446.   try
  2447.     Result := Reader.ReadRootComponent(Instance);
  2448.   finally
  2449.     Reader.Free;
  2450.   end;
  2451. end;
  2452.  
  2453. procedure TStream.WriteComponent(Instance: TComponent);
  2454. begin
  2455.   WriteDescendent(Instance, nil);
  2456. end;
  2457.  
  2458. procedure TStream.WriteDescendent(Instance, Ancestor: TComponent);
  2459. var
  2460.   Writer: TWriter;
  2461. begin
  2462.   Writer := TWriter.Create(Self, 4096);
  2463.   try
  2464.     Writer.WriteDescendent(Instance, Ancestor);
  2465.   finally
  2466.     Writer.Free;
  2467.   end;
  2468. end;
  2469.  
  2470. function TStream.ReadComponentRes(Instance: TComponent): TComponent;
  2471. begin
  2472.   ReadResHeader;
  2473.   Result := ReadComponent(Instance);
  2474. end;
  2475.  
  2476. procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent);
  2477. begin
  2478.   WriteDescendentRes(ResName, Instance, nil);
  2479. end;
  2480.  
  2481. procedure TStream.WriteDescendentRes(const ResName: string; Instance,
  2482.   Ancestor: TComponent);
  2483. var
  2484.   HeaderSize: Integer;
  2485.   Origin, ImageSize: Longint;
  2486.   Header: array[0..79] of Char;
  2487. begin
  2488.   Byte((@Header[0])^) := $FF;
  2489.   Word((@Header[1])^) := 10;
  2490.   HeaderSize := StrLen(StrUpper(StrPLCopy(@Header[3], ResName, 63))) + 10;
  2491.   Word((@Header[HeaderSize - 6])^) := $1030;
  2492.   Longint((@Header[HeaderSize - 4])^) := 0;
  2493.   WriteBuffer(Header, HeaderSize);
  2494.   Origin := Position;
  2495.   WriteDescendent(Instance, Ancestor);
  2496.   ImageSize := Position - Origin;
  2497.   Position := Origin - 4;
  2498.   WriteBuffer(ImageSize, SizeOf(Longint));
  2499.   Position := Origin + ImageSize;
  2500. end;
  2501.  
  2502. procedure TStream.ReadResHeader;
  2503. var
  2504.   ReadCount: Longint;
  2505.   Header: array[0..79] of Char;
  2506. begin
  2507.   FillChar(Header, SizeOf(Header), 0);
  2508.   ReadCount := Read(Header, SizeOf(Header) - 1);
  2509.   if (Byte((@Header[0])^) = $FF) and (Word((@Header[1])^) = 10) then
  2510.     Seek(StrLen(Header + 3) + 10 - ReadCount, 1)
  2511.   else
  2512.     raise EInvalidImage.CreateRes(SInvalidImage);
  2513. end;
  2514.  
  2515. { THandleStream }
  2516.  
  2517. constructor THandleStream.Create(AHandle: Integer);
  2518. begin
  2519.   FHandle := AHandle;
  2520. end;
  2521.  
  2522. function THandleStream.Read(var Buffer; Count: Longint): Longint;
  2523. begin
  2524.   Result := FileRead(FHandle, Buffer, Count);
  2525.   if Result = -1 then Result := 0;
  2526. end;
  2527.  
  2528. function THandleStream.Write(const Buffer; Count: Longint): Longint;
  2529. begin
  2530.   Result := FileWrite(FHandle, Buffer, Count);
  2531.   if Result = -1 then Result := 0;
  2532. end;
  2533.  
  2534. function THandleStream.Seek(Offset: Longint; Origin: Word): Longint;
  2535. begin
  2536.   Result := FileSeek(FHandle, Offset, Origin);
  2537. end;
  2538.  
  2539. { TFileStream }
  2540.  
  2541. constructor TFileStream.Create(const FileName: string; Mode: Word);
  2542. begin
  2543.   if Mode = fmCreate then
  2544.   begin
  2545.     FHandle := FileCreate(FileName);
  2546.     if FHandle < 0 then
  2547.       raise EFCreateError.CreateResFmt(SFCreateError, [FileName]);
  2548.   end else
  2549.   begin
  2550.     FHandle := FileOpen(FileName, Mode);
  2551.     if FHandle < 0 then
  2552.       raise EFOpenError.CreateResFmt(SFOpenError, [FileName]);
  2553.   end;
  2554. end;
  2555.  
  2556. destructor TFileStream.Destroy;
  2557. begin
  2558.   if FHandle >= 0 then FileClose(FHandle);
  2559. end;
  2560.  
  2561.  
  2562. { TCustomMemoryStream }
  2563.  
  2564. procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; Size: Longint);
  2565. begin
  2566.   FMemory := Ptr;
  2567.   FSize := Size;
  2568. end;
  2569.  
  2570. function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
  2571. begin
  2572.   if (FPosition >= 0) and (Count >= 0) then
  2573.   begin
  2574.     Result := FSize - FPosition;
  2575.     if Result > 0 then
  2576.     begin
  2577.       if Result > Count then Result := Count;
  2578.       Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result);
  2579.       Inc(FPosition, Result);
  2580.       Exit;
  2581.     end;
  2582.   end;
  2583.   Result := 0;
  2584. end;
  2585.  
  2586. function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
  2587. begin
  2588.   case Origin of
  2589.     0: FPosition := Offset;
  2590.     1: Inc(FPosition, Offset);
  2591.     2: FPosition := FSize + Offset;
  2592.   end;
  2593.   Result := FPosition;
  2594. end;
  2595.  
  2596. procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
  2597. begin
  2598.   if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize);
  2599. end;
  2600.  
  2601. procedure TCustomMemoryStream.SaveToFile(const FileName: string);
  2602. var
  2603.   Stream: TStream;
  2604. begin
  2605.   Stream := TFileStream.Create(FileName, fmCreate);
  2606.   try
  2607.     SaveToStream(Stream);
  2608.   finally
  2609.     Stream.Free;
  2610.   end;
  2611. end;
  2612.  
  2613. { TMemoryStream }
  2614.  
  2615. const
  2616.   MemoryDelta = $2000; { Must be a power of 2 }
  2617.  
  2618. destructor TMemoryStream.Destroy;
  2619. begin
  2620.   Clear;
  2621.   inherited Destroy;
  2622. end;
  2623.  
  2624. procedure TMemoryStream.Clear;
  2625. begin
  2626.   SetCapacity(0);
  2627.   FSize := 0;
  2628.   FPosition := 0;
  2629. end;
  2630.  
  2631. procedure TMemoryStream.LoadFromStream(Stream: TStream);
  2632. var
  2633.   Count: Longint;
  2634. begin
  2635.   Stream.Position := 0;
  2636.   Count := Stream.Size;
  2637.   SetSize(Count);
  2638.   if Count <> 0 then Stream.ReadBuffer(FMemory^, Count);
  2639. end;
  2640.  
  2641. procedure TMemoryStream.LoadFromFile(const FileName: string);
  2642. var
  2643.   Stream: TStream;
  2644. begin
  2645.   Stream := TFileStream.Create(FileName, fmOpenRead);
  2646.   try
  2647.     LoadFromStream(Stream);
  2648.   finally
  2649.     Stream.Free;
  2650.   end;
  2651. end;
  2652.  
  2653. procedure TMemoryStream.SetCapacity(NewCapacity: Longint);
  2654. begin
  2655.   SetPointer(Realloc(NewCapacity), FSize);
  2656.   FCapacity := NewCapacity;
  2657. end;
  2658.  
  2659. procedure TMemoryStream.SetSize(NewSize: Longint);
  2660. begin
  2661.   Clear;
  2662.   SetCapacity(NewSize);
  2663.   FSize := NewSize;
  2664. end;
  2665.  
  2666. function TMemoryStream.Realloc(var NewCapacity: Longint): Pointer;
  2667. begin
  2668.   if NewCapacity > 0 then
  2669.     NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1);
  2670.   Result := Memory;
  2671.   if NewCapacity <> FCapacity then
  2672.   begin
  2673.     if NewCapacity = 0 then
  2674.     begin
  2675.       GlobalFreePtr(Memory);
  2676.       Result := nil;
  2677.     end else
  2678.     begin
  2679.       if Capacity = 0 then
  2680.         Result := GlobalAllocPtr(HeapAllocFlags, NewCapacity)
  2681.       else
  2682.         Result := GlobalReallocPtr(Memory, NewCapacity, HeapAllocFlags);
  2683.       if Result = nil then raise EStreamError.CreateRes(SMemoryStreamError);
  2684.     end;
  2685.   end;
  2686. end;
  2687.  
  2688. function TMemoryStream.Write(const Buffer; Count: Longint): Longint;
  2689. var
  2690.   Pos: Longint;
  2691. begin
  2692.   if (FPosition >= 0) and (Count >= 0) then
  2693.   begin
  2694.     Pos := FPosition + Count;
  2695.     if Pos > 0 then
  2696.     begin
  2697.       if Pos > FSize then
  2698.       begin
  2699.         if Pos > FCapacity then
  2700.           SetCapacity(Pos);
  2701.         FSize := Pos;
  2702.       end;
  2703.       System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count);
  2704.       FPosition := Pos;
  2705.       Result := Count;
  2706.       Exit;
  2707.     end;
  2708.   end;
  2709.   Result := 0;
  2710. end;
  2711.  
  2712. { TResourceStream }
  2713.  
  2714. constructor TResourceStream.Create(Instance: THandle; const ResName: string;
  2715.   ResType: PChar);
  2716. begin
  2717.   inherited Create;
  2718.   Initialize(Instance, PChar(ResName), ResType);
  2719. end;
  2720.  
  2721. constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer;
  2722.   ResType: PChar);
  2723. begin
  2724.   inherited Create;
  2725.   Initialize(Instance, PChar(ResID), ResType);
  2726. end;
  2727.  
  2728. procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
  2729.  
  2730.   procedure Error;
  2731.   begin
  2732.     raise EResNotFound.Create(FmtLoadStr(SResNotFound, [Name]));
  2733.   end;
  2734.  
  2735. begin
  2736.   HResInfo := FindResource(Instance, Name, ResType);
  2737.   if HResInfo = 0 then Error;
  2738.   HGlobal := LoadResource(Instance, HResInfo);
  2739.   if HGlobal = 0 then Error;
  2740.   SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo));
  2741. end;
  2742.  
  2743. destructor TResourceStream.Destroy;
  2744. begin
  2745.   UnlockResource(HGlobal);
  2746.   FreeResource(HResInfo);
  2747.   inherited Destroy;
  2748. end;
  2749.  
  2750. function TResourceStream.Write(const Buffer; Count: Longint): Longint;
  2751. begin
  2752.   raise EStreamError.CreateRes(SCantWriteResourceStreamError);
  2753. end;
  2754.  
  2755. { TFiler }
  2756.  
  2757. constructor TFiler.Create(Stream: TStream; BufSize: Integer);
  2758. begin
  2759.   FStream := Stream;
  2760.   GetMem(FBuffer, BufSize);
  2761.   FBufSize := BufSize;
  2762. end;
  2763.  
  2764. destructor TFiler.Destroy;
  2765. begin
  2766.   if FBuffer <> nil then FreeMem(FBuffer, FBufSize);
  2767. end;
  2768.  
  2769. { TPropFixup }
  2770.  
  2771. type
  2772.   TPropFixup = class
  2773.     FInstance: TPersistent;
  2774.     FInstanceRoot: TComponent;
  2775.     FPropInfo: PPropInfo;
  2776.     FRootName: string;
  2777.     FName: string;
  2778.     constructor Create(Instance: TPersistent; InstanceRoot: TComponent;
  2779.       PropInfo: PPropInfo; const RootName, Name: string);
  2780.   end;
  2781.  
  2782. var
  2783.   GlobalFixupList: TList;
  2784.  
  2785. constructor TPropFixup.Create(Instance: TPersistent; InstanceRoot: TComponent;
  2786.   PropInfo: PPropInfo; const RootName, Name: string);
  2787. begin
  2788.   FInstance := Instance;
  2789.   FInstanceRoot := InstanceRoot;
  2790.   FPropInfo := PropInfo;
  2791.   FRootName := RootName;
  2792.   FName := Name;
  2793. end;
  2794.  
  2795. procedure GlobalFixupReferences;
  2796. var
  2797.   FinishedList: TList;
  2798.   NotFinishedList: TList;
  2799.   I: Integer;
  2800.   Root: TComponent;
  2801.   Instance: TPersistent;
  2802.  
  2803.   procedure AddFinished(Instance: TPersistent);
  2804.   begin
  2805.     if (FinishedList.IndexOf(Instance) < 0) and
  2806.       (NotFinishedList.IndexOf(Instance) >= 0) then
  2807.       FinishedList.Add(Instance);
  2808.   end;
  2809.  
  2810.   procedure AddNotFinished(Instance: TPersistent);
  2811.   var
  2812.     Index: Integer;
  2813.   begin
  2814.     Index := FinishedList.IndexOf(Instance);
  2815.     if Index <> -1 then FinishedList.Delete(Index);
  2816.     if NotFinishedList.IndexOf(Instance) < 0 then
  2817.       NotFinishedList.Add(Instance);
  2818.   end;
  2819.  
  2820. begin
  2821.   if Assigned(FindGlobalComponent) and (GlobalFixupList.Count > 0) then
  2822.   begin
  2823.     FinishedList := TList.Create;
  2824.     try
  2825.       NotFinishedList := TList.Create;
  2826.       try
  2827.         I := 0;
  2828.         while I < GlobalFixupList.Count do
  2829.           with TPropFixup(GlobalFixupList[I]) do
  2830.           begin
  2831.             Root := FindGlobalComponent(FRootName);
  2832.             if (Root <> nil) or (GetOrdProp(FInstance, FPropInfo) <> 0) then
  2833.             begin
  2834.               if Root <> nil then
  2835.                 SetOrdProp(FInstance, FPropInfo,
  2836.                   Longint(Root.FindComponent(FName)));
  2837.               AddFinished(FInstance);
  2838.               GlobalFixupList.Delete(I);
  2839.               Free;
  2840.             end else
  2841.             begin
  2842.               AddNotFinished(FInstance);
  2843.               Inc(I);
  2844.             end;
  2845.           end;
  2846.       finally
  2847.         NotFinishedList.Free;
  2848.       end;
  2849.       for I := 0 to FinishedList.Count - 1 do
  2850.       begin
  2851.         Instance := FinishedList[I];
  2852.         if Instance is TComponent then
  2853.           Exclude(TComponent(Instance).FComponentState, csFixups);
  2854.       end;
  2855.     finally
  2856.       FinishedList.Free;
  2857.     end;
  2858.   end;
  2859. end;
  2860.  
  2861. function NameInStrings(Strings: TStrings; const Name: string): Boolean;
  2862. var
  2863.   I: Integer;
  2864. begin
  2865.   Result := True;
  2866.   for I := 0 to Strings.Count - 1 do
  2867.     if CompareText(Name, Strings[I]) = 0 then Exit;
  2868.   Result := False;
  2869. end;
  2870.  
  2871. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  2872. var
  2873.   I: Integer;
  2874.   Fixup: TPropFixup;
  2875. begin
  2876.   for I := 0 to GlobalFixupList.Count - 1 do
  2877.   begin
  2878.     Fixup := GlobalFixupList[I];
  2879.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  2880.       not NameInStrings(Names, Fixup.FRootName) then
  2881.       Names.Add(Fixup.FRootName);
  2882.   end;
  2883. end;
  2884.  
  2885. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  2886.   NewRootName: string);
  2887. var
  2888.   I: Integer;
  2889.   Fixup: TPropFixup;
  2890. begin
  2891.   for I := 0 to GlobalFixupList.Count - 1 do
  2892.   begin
  2893.     Fixup := GlobalFixupList[I];
  2894.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  2895.       (CompareText(OldRootName, Fixup.FRootName) = 0) then
  2896.       Fixup.FRootName := NewRootName;
  2897.   end;
  2898.   GlobalFixupReferences;
  2899. end;
  2900.  
  2901. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  2902. var
  2903.   I: Integer;
  2904.   Fixup: TPropFixup;
  2905. begin
  2906.   for I := GlobalFixupList.Count - 1 downto 0 do
  2907.   begin
  2908.     Fixup := GlobalFixupList[I];
  2909.     if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and
  2910.       ((RootName = '') or (CompareText(RootName, Fixup.FRootName) = 0)) then
  2911.     begin
  2912.       GlobalFixupList.Delete(I);
  2913.       Fixup.Free;
  2914.     end;
  2915.   end;
  2916. end;
  2917.  
  2918. procedure GetFixupInstanceNames(Root: TComponent;
  2919.   const ReferenceRootName: string; Names: TStrings);
  2920. var
  2921.   I: Integer;
  2922.   Fixup: TPropFixup;
  2923. begin
  2924.   for I := 0 to GlobalFixupList.Count - 1 do
  2925.   begin
  2926.     Fixup := GlobalFixupList[I];
  2927.     if (Fixup.FInstanceRoot = Root) and
  2928.       (CompareText(ReferenceRootName, Fixup.FRootName) = 0) and
  2929.       not NameInStrings(Names, Fixup.FName) then
  2930.       Names.Add(Fixup.FName);
  2931.   end;
  2932. end;
  2933.  
  2934. { TReader }
  2935.  
  2936. procedure ReadError(Ident: Integer);
  2937. begin
  2938.   raise EReadError.CreateRes(Ident);
  2939. end;
  2940.  
  2941. procedure PropValueError;
  2942. begin
  2943.   ReadError(SInvalidPropertyValue);
  2944. end;
  2945.  
  2946. procedure PropertyNotFound;
  2947. begin
  2948.   ReadError(SUnknownProperty);
  2949. end;
  2950.  
  2951. function EnumValue(EnumType: PTypeInfo; const EnumName: string): Integer;
  2952. begin
  2953.   Result := GetEnumValue(EnumType, EnumName);
  2954.   if Result = -1 then PropValueError;
  2955. end;
  2956.  
  2957. destructor TReader.Destroy;
  2958. begin
  2959.   FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), 1);
  2960.   inherited Destroy;
  2961. end;
  2962.  
  2963. procedure TReader.BeginReferences;
  2964. begin
  2965.   FLoaded := TList.Create;
  2966.   try
  2967.     FFixups := TList.Create;
  2968.   except
  2969.     FLoaded.Free;
  2970.     raise;
  2971.   end;
  2972. end;
  2973.  
  2974. procedure TReader.CheckValue(Value: TValueType);
  2975. begin
  2976.   if ReadValue <> Value then
  2977.   begin
  2978.     Dec(FBufPos);
  2979.     SkipValue;
  2980.     PropValueError;
  2981.   end;
  2982. end;
  2983.  
  2984. procedure TReader.DefineProperty(const Name: string;
  2985.   ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
  2986. begin
  2987.   if CompareText(Name, FPropName) = 0 then
  2988.   begin
  2989.     ReadData(Self);
  2990.     FPropName := '';
  2991.   end;
  2992. end;
  2993.  
  2994. procedure TReader.DefineBinaryProperty(const Name: string;
  2995.   ReadData, WriteData: TStreamProc; HasData: Boolean);
  2996. var
  2997.   Stream: TMemoryStream;
  2998.   Count: Longint;
  2999. begin
  3000.   if CompareText(Name, FPropName) = 0 then
  3001.   begin
  3002.     if ReadValue <> vaBinary then
  3003.     begin
  3004.       Dec(FBufPos);
  3005.       SkipValue;
  3006.       FCanHandleExcepts := True;
  3007.       PropValueError;
  3008.     end;
  3009.     Stream := TMemoryStream.Create;
  3010.     try
  3011.       Read(Count, SizeOf(Count));
  3012.       Stream.SetSize(Count);
  3013.       Read(Stream.Memory^, Count);
  3014.       FCanHandleExcepts := True;
  3015.       ReadData(Stream);
  3016.     finally
  3017.       Stream.Free;
  3018.     end;
  3019.     FPropName := '';
  3020.   end;
  3021. end;
  3022.  
  3023. function TReader.EndOfList: Boolean;
  3024. begin
  3025.   Result := ReadValue = vaNull;
  3026.   Dec(FBufPos);
  3027. end;
  3028.  
  3029. procedure TReader.EndReferences;
  3030. begin
  3031.   FreeFixups;
  3032.   FLoaded.Free;
  3033.   FLoaded := nil;
  3034. end;
  3035.  
  3036. function TReader.Error(const Message: string): Boolean;
  3037. begin
  3038.   Result := False;
  3039.   if Assigned(FOnError) then FOnError(Self, Message, Result);
  3040. end;
  3041.  
  3042. function TReader.FindMethod(Root: TComponent;
  3043.   const MethodName: string): Pointer;
  3044. var
  3045.   Error: Boolean;
  3046. begin
  3047.   Result := Root.MethodAddress(MethodName);
  3048.   Error := Result = nil;
  3049.   if Assigned(FOnFindMethod) then FOnFindMethod(Self, MethodName, Result, Error);
  3050.   if Error then PropValueError;
  3051. end;
  3052.  
  3053. procedure TReader.DoFixupReferences;
  3054. var
  3055.   I: Integer;
  3056. begin
  3057.   if FFixups <> nil then
  3058.     try
  3059.       for I := 0 to FFixups.Count - 1 do
  3060.         with TPropFixup(FFixups[I]) do
  3061.           SetOrdProp(FInstance, FPropInfo,
  3062.             Longint(FRoot.FindComponent(FName)));
  3063.     finally
  3064.       FreeFixups;
  3065.     end;
  3066. end;
  3067.  
  3068. procedure TReader.FixupReferences;
  3069. var
  3070.   I: Integer;
  3071. begin
  3072.   DoFixupReferences;
  3073.   GlobalFixupReferences;
  3074.   for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
  3075. end;
  3076.  
  3077. procedure TReader.FlushBuffer;
  3078. begin
  3079.   FStream.Position := FStream.Position - (FBufEnd - FBufPos);
  3080.   FBufPos := 0;
  3081.   FBufEnd := 0;
  3082. end;
  3083.  
  3084. procedure TReader.FreeFixups;
  3085. var
  3086.   I: Integer;
  3087. begin
  3088.   if FFixups <> nil then
  3089.   begin
  3090.     for I := 0 to FFixups.Count - 1 do TPropFixup(FFixups[I]).Free;
  3091.     FFixups.Free;
  3092.     FFixups := nil;
  3093.   end;
  3094. end;
  3095.  
  3096. function TReader.GetPosition: Longint;
  3097. begin
  3098.   Result := FStream.Position + FBufPos;
  3099. end;
  3100.  
  3101. function TReader.NextValue: TValueType;
  3102. begin
  3103.   Result := ReadValue;
  3104.   Dec(FBufPos);
  3105. end;
  3106.  
  3107. procedure TReader.PropertyError;
  3108. begin
  3109.   SkipValue;
  3110.   PropertyNotFound;
  3111. end;
  3112.  
  3113. procedure TReader.Read(var Buf; Count: Longint); assembler;
  3114. asm
  3115.         PUSH    ESI
  3116.         PUSH    EDI
  3117.         PUSH    EBX
  3118.         MOV     EDI,EDX
  3119.         MOV     EBX,ECX
  3120.         MOV     ESI,EAX
  3121.         JMP     @@6
  3122. @@1:    MOV     ECX,[ESI].TReader.FBufEnd
  3123.         SUB     ECX,[ESI].TReader.FBufPos
  3124.         JA      @@2
  3125.         MOV     EAX,ESI
  3126.         CALL    TReader.ReadBuffer
  3127.         MOV     ECX,[ESI].TReader.FBufEnd
  3128. @@2:    CMP     ECX,EBX
  3129.         JB      @@3
  3130.         MOV     ECX,EBX
  3131. @@3:    PUSH    ESI
  3132.         SUB     EBX,ECX
  3133.         MOV     EAX,[ESI].TReader.FBuffer
  3134.         ADD     EAX,[ESI].TReader.FBufPos
  3135.         ADD     [ESI].TReader.FBufPos,ECX
  3136.         MOV     ESI,EAX
  3137.         MOV     EDX,ECX
  3138.         SHR     ECX,2
  3139.         CLD
  3140.         REP     MOVSD
  3141.         MOV     ECX,EDX
  3142.         AND     ECX,3
  3143.         REP     MOVSB
  3144.         POP     ESI
  3145. @@6:    OR      EBX,EBX
  3146.         JNE     @@1
  3147.         POP     EBX
  3148.         POP     EDI
  3149.         POP     ESI
  3150. end;
  3151.  
  3152. procedure TReader.ReadBuffer;
  3153. begin
  3154.   FBufEnd := FStream.Read(FBuffer^, FBufSize);
  3155.   if FBufEnd = 0 then raise EReadError.CreateRes(SReadError);
  3156.   FBufPos := 0;
  3157. end;
  3158.  
  3159. function TReader.ReadBoolean: Boolean;
  3160. begin
  3161.   Result := ReadValue = vaTrue;
  3162. end;
  3163.  
  3164. function TReader.ReadChar: Char;
  3165. begin
  3166.   CheckValue(vaString);
  3167.   Read(Result, 1);
  3168.   if Ord(Result) <> 1 then
  3169.   begin
  3170.     Dec(FBufPos);
  3171.     ReadStr;
  3172.     PropValueError;
  3173.   end;
  3174.   Read(Result, 1);
  3175. end;
  3176.  
  3177. procedure TReader.ReadCollection(Collection: TCollection);
  3178. var
  3179.   Item: TPersistent;
  3180.   Index: Integer;
  3181. begin
  3182.   Index := 0;
  3183.   Collection.BeginUpdate;
  3184.   try
  3185.     while not EndOfList do
  3186.     begin
  3187.       if NextValue in [vaInt8, vaInt16, vaInt32] then Index := ReadInteger;
  3188.       while Collection.Count <= Index do Collection.Add;
  3189.       Item := Collection.Items[Index];
  3190.       ReadListBegin;
  3191.       while not EndOfList do ReadProperty(Item);
  3192.       ReadListEnd;
  3193.       Inc(Index);
  3194.     end;
  3195.     ReadListEnd;
  3196.   finally
  3197.     Collection.EndUpdate;
  3198.   end;
  3199. end;
  3200.  
  3201. function TReader.ReadComponent(Component: TComponent): TComponent;
  3202. var
  3203.   CompClass, CompName: string;
  3204.   Flags: TFilerFlags;
  3205.   Position: Integer;
  3206.  
  3207.   function ComponentCreated: Boolean;
  3208.   begin
  3209.     Result := not (ffInherited in Flags) and (Component = nil);
  3210.   end;
  3211.  
  3212.   function Recover(var Component: TComponent): Boolean;
  3213.   begin
  3214.     Result := False;
  3215.     if not (ExceptObject is Exception) then Exit;
  3216.     if ComponentCreated then Component.Free;
  3217.     Component := nil;
  3218.     SkipComponent(False);
  3219.     Result := Error(Exception(ExceptObject).Message);
  3220.   end;
  3221.  
  3222.   procedure CreateComponent;
  3223.   begin
  3224.     try
  3225.       Result := TComponentClass(FindFieldClass(Root, CompClass)).Create(Owner);
  3226.       Include(Result.FComponentState, csLoading);
  3227.     except
  3228.       if not Recover(Result) then raise;
  3229.     end;
  3230.   end;
  3231.  
  3232.   procedure SetCompName;
  3233.   begin
  3234.     try
  3235.       Result.SetParentComponent(Parent);
  3236.       SetName(Result, CompName);
  3237.     except
  3238.       if not Recover(Result) then raise;
  3239.     end;
  3240.   end;
  3241.  
  3242.   procedure FindExistingComponent;
  3243.   begin
  3244.     try
  3245.       Result := Root.FindComponent(CompName);
  3246.       if Result = nil then
  3247.         raise EReadError.CreateResFmt(SAncestorNotFound, [CompName]);
  3248.     except
  3249.       if not Recover(Result) then raise;
  3250.     end;
  3251.   end;
  3252.  
  3253. begin
  3254.   ReadPrefix(Flags, Position);
  3255.   CompClass := ReadStr;
  3256.   CompName := ReadStr;
  3257.   Result := Component;
  3258.   if Result = nil then
  3259.     if ffInherited in Flags then
  3260.       FindExistingComponent else
  3261.       CreateComponent;
  3262.   if Result <> nil then
  3263.     try
  3264.       Include(Result.FComponentState, csLoading);
  3265.       if not (ffInherited in Flags) then SetCompName;
  3266.       if Result = nil then Exit;
  3267.       Include(Result.FComponentState, csReading);
  3268.       Result.ReadState(Self);
  3269.       Exclude(Result.FComponentState, csReading);
  3270.       if ffChildPos in Flags then Parent.SetChildOrder(Result, Position);
  3271.       FLoaded.Add(Result);
  3272.     except
  3273.       if ComponentCreated then Result.Free;
  3274.       raise;
  3275.     end;
  3276. end;
  3277.  
  3278. procedure TReader.ReadData(Instance: TComponent);
  3279. begin
  3280.   if FFixups = nil then
  3281.   begin
  3282.     FFixups := TList.Create;
  3283.     try
  3284.       ReadDataInner(Instance);
  3285.       DoFixupReferences;
  3286.     finally
  3287.       FreeFixups;
  3288.     end;
  3289.   end else
  3290.     ReadDataInner(Instance);
  3291. end;
  3292.  
  3293. procedure TReader.ReadDataInner(Instance: TComponent);
  3294. var
  3295.   OldParent, OldOwner: TComponent;
  3296. begin
  3297.   while not EndOfList do ReadProperty(Instance);
  3298.   ReadListEnd;
  3299.   OldParent := Parent;
  3300.   OldOwner := Owner;
  3301.   Parent := Instance.GetChildParent;
  3302.   try
  3303.     Owner := Instance.GetChildOwner;
  3304.     if not Assigned(Owner) then Owner := Root;
  3305.     while not EndOfList do ReadComponent(nil);
  3306.     ReadListEnd;
  3307.   finally
  3308.     Parent := OldParent;
  3309.     Owner := OldOwner;
  3310.   end;
  3311. end;
  3312.  
  3313. function TReader.ReadFloat: Extended;
  3314. begin
  3315.   if ReadValue = vaExtended then Read(Result, SizeOf(Result)) else
  3316.   begin
  3317.     Dec(FBufPos);
  3318.     Result := ReadInteger;
  3319.   end;
  3320. end;
  3321.  
  3322. function TReader.ReadIdent: string;
  3323. var
  3324.   L: Byte;
  3325. begin
  3326.   case ReadValue of
  3327.     vaIdent:
  3328.       begin
  3329.         Read(L, SizeOf(Byte));
  3330.         SetString(Result, PChar(nil), L);
  3331.         Read(Result[1], L);
  3332.       end;
  3333.     vaFalse:
  3334.       Result := 'False';
  3335.     vaTrue:
  3336.       Result := 'True';
  3337.     vaNil:
  3338.       Result := 'nil';
  3339.   else
  3340.     PropValueError;
  3341.   end;
  3342. end;
  3343.  
  3344. function TReader.ReadInteger: Longint;
  3345. var
  3346.   S: Shortint;
  3347.   I: Smallint;
  3348. begin
  3349.   case ReadValue of
  3350.     vaInt8:
  3351.       begin
  3352.         Read(S, SizeOf(Shortint));
  3353.         Result := S;
  3354.       end;
  3355.     vaInt16:
  3356.       begin
  3357.         Read(I, SizeOf(I));
  3358.         Result := I;
  3359.       end;
  3360.     vaInt32:
  3361.       Read(Result, SizeOf(Result));
  3362.   else
  3363.     PropValueError;
  3364.   end;
  3365. end;
  3366.  
  3367. procedure TReader.ReadListBegin;
  3368. begin
  3369.   CheckValue(vaList);
  3370. end;
  3371.  
  3372. procedure TReader.ReadListEnd;
  3373. begin
  3374.   CheckValue(vaNull);
  3375. end;
  3376.  
  3377. procedure TReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
  3378. var
  3379.   Prefix: Byte;
  3380. begin
  3381.   Flags := [];
  3382.   if Byte(NextValue) and $F0 = $F0 then
  3383.   begin
  3384.     Prefix := Byte(ReadValue);
  3385.     Byte(Flags) := Prefix and $0F;
  3386.     if ffChildPos in Flags then AChildPos := ReadInteger;
  3387.   end;
  3388. end;
  3389.  
  3390. procedure TReader.ReadProperty(AInstance: TPersistent);
  3391. var
  3392.   I, J, L: Integer;
  3393.   Instance: TPersistent;
  3394.   PropInfo: PPropInfo;
  3395.   PropValue: TObject;
  3396.   PropPath: string;
  3397.  
  3398.   procedure HandleException(E: Exception);
  3399.   var
  3400.     Name: string;
  3401.   begin
  3402.     Name := '';
  3403.     if AInstance is TComponent then
  3404.       Name := TComponent(AInstance).Name;
  3405.     if Name = '' then Name := AInstance.ClassName;
  3406.     raise EReadError.CreateResFmt(SPropertyException,
  3407.       [Name, PropPath, E.Message]);
  3408.   end;
  3409.  
  3410.   procedure PropPathError;
  3411.   begin
  3412.     SkipValue;
  3413.     ReadError(SInvalidPropertyPath);
  3414.   end;
  3415.  
  3416. begin
  3417.   try
  3418.     PropPath := ReadStr;
  3419.     try
  3420.       I := 1;
  3421.       L := Length(PropPath);
  3422.       Instance := AInstance;
  3423.       FCanHandleExcepts := True;
  3424.       while True do
  3425.       begin
  3426.         J := I;
  3427.         while (I <= L) and (PropPath[I] <> '.') do Inc(I);
  3428.         FPropName := Copy(PropPath, J, I - J);
  3429.         if I > L then Break;
  3430.         PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
  3431.         if PropInfo = nil then PropertyError;
  3432.         PropValue := nil;
  3433.         if PropInfo^.PropType^.Kind = tkClass then
  3434.           PropValue := TObject(GetOrdProp(Instance, PropInfo));
  3435.         if not (PropValue is TPersistent) then PropPathError;
  3436.         Instance := TPersistent(PropValue);
  3437.         Inc(I);
  3438.       end;
  3439.       PropInfo := GetPropInfo(Instance.ClassInfo, FPropName);
  3440.       if PropInfo <> nil then ReadPropValue(Instance, PropInfo) else
  3441.       begin
  3442.         { Cannot reliably recover from an error in a defined property }
  3443.         FCanHandleExcepts := False;
  3444.         Instance.DefineProperties(Self);
  3445.         FCanHandleExcepts := True;
  3446.         if FPropName <> '' then PropertyError;
  3447.       end;
  3448.     except
  3449.       on E: Exception do HandleException(E);
  3450.     end;
  3451.   except
  3452.     on E: Exception do
  3453.       if not FCanHandleExcepts or not Error(E.Message) then raise;
  3454.   end;
  3455. end;
  3456.  
  3457. procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  3458. const
  3459.   NilMethod: TMethod = (Code: nil; Data: nil);
  3460. var
  3461.   PropType: PTypeInfo;
  3462.   Method: TMethod;
  3463.  
  3464.   procedure SetIntIdent(Instance: TPersistent; PropInfo: Pointer;
  3465.     const Ident: string);
  3466.   var
  3467.     I: Integer;
  3468.     V: Longint;
  3469.   begin
  3470.     for I := 0 to IntConstList.Count - 1 do
  3471.       with TIntConst(IntConstList[I]) do
  3472.         if PPropInfo(PropInfo)^.PropType = IntegerType then
  3473.           if IdentToInt(Ident, V) then
  3474.           begin
  3475.             SetOrdProp(Instance, PropInfo, V);
  3476.             Exit;
  3477.           end;
  3478.     PropValueError;
  3479.   end;
  3480.  
  3481.   procedure SetObjectIdent(Instance: TPersistent; PropInfo: Pointer;
  3482.     const Ident: string);
  3483.   var
  3484.     RootName, Name: string;
  3485.     P: Integer;
  3486.     Fixup: TPropFixup;
  3487.   begin
  3488.     RootName := '';
  3489.     Name := Ident;
  3490.     P := Pos('.', Ident);
  3491.     if P <> 0 then
  3492.     begin
  3493.       RootName := Copy(Ident, 1, P - 1);
  3494.       Name := Copy(Ident, P + 1, MaxInt);
  3495.     end;
  3496.     Fixup := TPropFixup.Create(Instance, Root, PropInfo, RootName, Name);
  3497.     if RootName = '' then
  3498.       FFixups.Add(Fixup) else
  3499.       GlobalFixupList.Add(Fixup);
  3500.   end;
  3501.  
  3502. begin
  3503.   if PPropInfo(PropInfo)^.SetProc = nil then ReadError(SReadOnlyProperty);
  3504.   PropType := PPropInfo(PropInfo)^.PropType;
  3505.   case PropType^.Kind of
  3506.     tkInteger:
  3507.       if NextValue = vaIdent then
  3508.         SetIntIdent(Instance, PropInfo, ReadIdent) else
  3509.         SetOrdProp(Instance, PropInfo, ReadInteger);
  3510.     tkChar:
  3511.       SetOrdProp(Instance, PropInfo, Ord(ReadChar));
  3512.     tkEnumeration:
  3513.       SetOrdProp(Instance, PropInfo, EnumValue(PropType, ReadIdent));
  3514.     tkFloat:
  3515.       SetFloatProp(Instance, PropInfo, ReadFloat);
  3516.     tkString, tkLString:
  3517.       SetStrProp(Instance, PropInfo, ReadString);
  3518.     tkSet:
  3519.       SetOrdProp(Instance, PropInfo, ReadSet(PropType));
  3520.     tkClass:
  3521.       case NextValue of
  3522.         vaNil:
  3523.           begin
  3524.             ReadValue;
  3525.             SetOrdProp(Instance, PropInfo, 0)
  3526.           end;
  3527.         vaCollection:
  3528.           begin
  3529.             ReadValue;
  3530.             ReadCollection(TCollection(GetOrdProp(Instance, PropInfo)));
  3531.           end
  3532.       else
  3533.         SetObjectIdent(Instance, PropInfo, ReadIdent);
  3534.       end;
  3535.     tkMethod:
  3536.       if NextValue = vaNil then
  3537.       begin
  3538.         ReadValue;
  3539.         SetMethodProp(Instance, PropInfo, NilMethod);
  3540.       end
  3541.       else
  3542.       begin
  3543.         Method.Code :=  FindMethod(Root, ReadIdent);
  3544.         Method.Data := Root;
  3545.         if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method);
  3546.       end;
  3547.   end;
  3548. end;
  3549.  
  3550. function TReader.ReadRootComponent(Root: TComponent): TComponent;
  3551.  
  3552.   function FindUniqueName(const Name: string): string;
  3553.   var
  3554.     I: Integer;
  3555.   begin
  3556.     I := 0;
  3557.     Result := '';
  3558.     if Assigned(FindGlobalComponent) then
  3559.     begin
  3560.       Result := Name;
  3561.       while FindGlobalComponent(Result) <> nil do
  3562.       begin
  3563.         Inc(I);
  3564.         Result := Format('%s_%d', [Name, I]);
  3565.       end;
  3566.     end;
  3567.   end;
  3568.  
  3569. var
  3570.   I: Integer;
  3571.   Flags: TFilerFlags;
  3572. begin
  3573.   ReadSignature;
  3574.   Result := nil;
  3575.   try
  3576.     ReadPrefix(Flags, I);
  3577.     if Root = nil then
  3578.     begin
  3579.       Result := TComponentClass(FindClass(ReadStr)).Create(nil);
  3580.       Result.Name := ReadStr;
  3581.     end else
  3582.     begin
  3583.       Result := Root;
  3584.       ReadStr; { Ignore class name }
  3585.       if csDesigning in Result.ComponentState then
  3586.         ReadStr else
  3587.         Result.Name := FindUniqueName(ReadStr);
  3588.     end;
  3589.     FRoot := Result;
  3590.     if GlobalLoaded <> nil then
  3591.       FLoaded := GlobalLoaded else
  3592.       FLoaded := TList.Create;
  3593.     try
  3594.       FLoaded.Add(FRoot);
  3595.       FOwner := FRoot;
  3596.       Include(FRoot.FComponentState, csLoading);
  3597.       Include(FRoot.FComponentState, csReading);
  3598.       FRoot.ReadState(Self);
  3599.       Exclude(FRoot.FComponentState, csReading);
  3600.       if GlobalLoaded = nil then
  3601.         for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded;
  3602.     finally
  3603.       if GlobalLoaded = nil then FLoaded.Free;
  3604.       FLoaded := nil;
  3605.     end;
  3606.     GlobalFixupReferences;
  3607.   except
  3608.     RemoveFixupReferences(Root, '');
  3609.     if Root = nil then Result.Free;
  3610.     raise;
  3611.   end;
  3612. end;
  3613.  
  3614. procedure TReader.ReadComponents(AOwner, AParent: TComponent;
  3615.   Proc: TReadComponentsProc);
  3616. var
  3617.   Component: TComponent;
  3618. begin
  3619.   Root := AOwner;
  3620.   Owner := AOwner;
  3621.   Parent := AParent;
  3622.   BeginReferences;
  3623.   try
  3624.     while not EndOfList do
  3625.     begin
  3626.       ReadSignature;
  3627.       Component := ReadComponent(nil);
  3628.       Proc(Component);
  3629.     end;
  3630.     FixupReferences;
  3631.   finally
  3632.     EndReferences;
  3633.   end;
  3634. end;
  3635.  
  3636. function TReader.ReadSet(SetType: Pointer): Integer;
  3637. var
  3638.   EnumType: PTypeInfo;
  3639.   EnumName: string;
  3640. begin
  3641.   try
  3642.     if ReadValue <> vaSet then PropValueError;
  3643.     EnumType := GetTypeData(SetType)^.CompType;
  3644.     Result := 0;
  3645.     while True do
  3646.     begin
  3647.       EnumName := ReadStr;
  3648.       if EnumName = '' then Break;
  3649.       Include(TIntegerSet(Result), EnumValue(EnumType, EnumName));
  3650.     end;
  3651.   except
  3652.     SkipSetBody;
  3653.     raise;
  3654.   end;
  3655. end;
  3656.  
  3657. procedure TReader.ReadSignature;
  3658. var
  3659.   Signature: Longint;
  3660. begin
  3661.   Read(Signature, SizeOf(Signature));
  3662.   if Signature <> Longint(FilerSignature) then ReadError(SInvalidImage);
  3663. end;
  3664.  
  3665. function TReader.ReadStr: string;
  3666. var
  3667.   L: Byte;
  3668. begin
  3669.   Read(L, SizeOf(Byte));
  3670.   SetString(Result, PChar(nil), L);
  3671.   Read(Result[1], L);
  3672. end;
  3673.  
  3674. function TReader.ReadString: string;
  3675. var
  3676.   L: Integer;
  3677. begin
  3678.   L := 0;
  3679.   case ReadValue of
  3680.     vaString:
  3681.       Read(L, SizeOf(Byte));
  3682.     vaLString:
  3683.       Read(L, SizeOf(Integer));
  3684.   else
  3685.     PropValueError;
  3686.   end;
  3687.   SetString(Result, PChar(nil), L);
  3688.   Read(Pointer(Result)^, L);
  3689. end;
  3690.  
  3691. function TReader.ReadValue: TValueType;
  3692. begin
  3693.   Read(Result, SizeOf(Result));
  3694. end;
  3695.  
  3696. procedure TReader.SetPosition(Value: Longint);
  3697. begin
  3698.   FStream.Position := Value;
  3699.   FBufPos := 0;
  3700.   FBufEnd := 0;
  3701. end;
  3702.  
  3703. procedure TReader.SkipSetBody;
  3704. begin
  3705.   while ReadStr <> '' do begin end;
  3706. end;
  3707.  
  3708. procedure TReader.SkipValue;
  3709.  
  3710.   procedure SkipList;
  3711.   begin
  3712.     while not EndOfList do SkipValue;
  3713.     ReadListEnd;
  3714.   end;
  3715.  
  3716.   procedure SkipBytes(Count: Longint);
  3717.   var
  3718.     Bytes: array[0..255] of Char;
  3719.   begin
  3720.     while Count > 0 do
  3721.       if Count > SizeOf(Bytes) then
  3722.       begin
  3723.         Read(Bytes, SizeOf(Bytes));
  3724.         Dec(Count, SizeOf(Bytes));
  3725.       end
  3726.       else
  3727.       begin
  3728.         Read(Bytes, Count);
  3729.         Count := 0;
  3730.       end;
  3731.   end;
  3732.  
  3733.   procedure SkipBinary;
  3734.   var
  3735.     Count: Longint;
  3736.   begin
  3737.     Read(Count, SizeOf(Count));
  3738.     SkipBytes(Count);
  3739.   end;
  3740.  
  3741. begin
  3742.   case ReadValue of
  3743.     vaNull: begin end;
  3744.     vaList: SkipList;
  3745.     vaInt8: SkipBytes(1);
  3746.     vaInt16: SkipBytes(2);
  3747.     vaInt32: SkipBytes(4);
  3748.     vaExtended: SkipBytes(SizeOf(Extended));
  3749.     vaString, vaIdent: ReadStr;
  3750.     vaFalse, vaTrue: begin end;
  3751.     vaBinary: SkipBinary;
  3752.     vaSet: SkipSetBody;
  3753.   end;
  3754. end;
  3755.  
  3756. procedure TReader.SkipProperty;
  3757. begin
  3758.   ReadStr; { Skips property name }
  3759.   SkipValue;
  3760. end;
  3761.  
  3762. procedure TReader.SkipComponent(SkipHeader: Boolean);
  3763. var
  3764.   Flags: TFilerFlags;
  3765.   Position: Integer;
  3766. begin
  3767.   if SkipHeader then
  3768.   begin
  3769.     ReadPrefix(Flags, Position);
  3770.     ReadStr;
  3771.     ReadStr;
  3772.   end;
  3773.   while not EndOfList do SkipProperty;
  3774.   ReadListEnd;
  3775.   while not EndOfList do SkipComponent(True);
  3776.   ReadListEnd;
  3777. end;
  3778.  
  3779. procedure TReader.SetName(Component: TComponent; var Name: string);
  3780. begin
  3781.   if Assigned(FOnSetName) then FOnSetName(Self, Component, Name);
  3782.   Component.Name := Name;
  3783. end;
  3784.  
  3785. { TWriter }
  3786.  
  3787. destructor TWriter.Destroy;
  3788. begin
  3789.   WriteBuffer;
  3790.   inherited Destroy;
  3791. end;
  3792.  
  3793. procedure TWriter.AddAncestor(Component: TComponent);
  3794. begin
  3795.   FAncestorList.Add(Component);
  3796. end;
  3797.  
  3798. procedure TWriter.DefineProperty(const Name: string;
  3799.   ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean);
  3800. begin
  3801.   if HasData then
  3802.   begin
  3803.     WritePropName(Name);
  3804.     WriteData(Self);
  3805.   end;
  3806. end;
  3807.  
  3808. procedure TWriter.DefineBinaryProperty(const Name: string;
  3809.   ReadData, WriteData: TStreamProc; HasData: Boolean);
  3810. begin
  3811.   if HasData then
  3812.   begin
  3813.     WritePropName(Name);
  3814.     WriteBinary(WriteData);
  3815.   end;
  3816. end;
  3817.  
  3818. function TWriter.GetPosition: Longint;
  3819. begin
  3820.   Result := FStream.Position + FBufPos;
  3821. end;
  3822.  
  3823. procedure TWriter.FlushBuffer;
  3824. begin
  3825.   WriteBuffer;
  3826. end;
  3827.  
  3828. procedure TWriter.SetPosition(Value: Longint);
  3829. var
  3830.   StreamPosition: Longint;
  3831. begin
  3832.   StreamPosition := FStream.Position;
  3833.   { Only flush the buffer if the repostion is outside the buffer range }
  3834.   if (Value < StreamPosition) or (Value > StreamPosition + FBufPos) then
  3835.   begin
  3836.     WriteBuffer;
  3837.     FStream.Position := Value;
  3838.   end
  3839.   else FBufPos := Value - StreamPosition;
  3840. end;
  3841.  
  3842. procedure TWriter.Write(const Buf; Count: Longint); assembler;
  3843. asm
  3844.         PUSH    ESI
  3845.         PUSH    EDI
  3846.         PUSH    EBX
  3847.         MOV     ESI,EDX
  3848.         MOV     EBX,ECX
  3849.         MOV     EDI,EAX
  3850.         JMP     @@6
  3851. @@1:    MOV     ECX,[EDI].TWriter.FBufSize
  3852.         SUB     ECX,[EDI].TWriter.FBufPos
  3853.         JA      @@2
  3854.         MOV     EAX,EDI
  3855.         CALL    TWriter.WriteBuffer
  3856.         MOV     ECX,[EDI].TWriter.FBufSize
  3857. @@2:    CMP     ECX,EBX
  3858.         JB      @@3
  3859.         MOV     ECX,EBX
  3860. @@3:    SUB     EBX,ECX
  3861.         PUSH    EDI
  3862.         MOV     EAX,[EDI].TWriter.FBuffer
  3863.         ADD     EAX,[EDI].TWriter.FBufPos
  3864.         ADD     [EDI].TWriter.FBufPos,ECX
  3865. @@5:    MOV     EDI,EAX
  3866.         MOV     EDX,ECX
  3867.         SHR     ECX,2
  3868.         CLD
  3869.         REP     MOVSD
  3870.         MOV     ECX,EDX
  3871.         AND     ECX,3
  3872.         REP     MOVSB
  3873.         POP     EDI
  3874. @@6:    OR      EBX,EBX
  3875.         JNE     @@1
  3876.         POP     EBX
  3877.         POP     EDI
  3878.         POP     ESI
  3879. end;
  3880.  
  3881. procedure TWriter.WriteBinary(WriteData: TStreamProc);
  3882. var
  3883.   Stream: TMemoryStream;
  3884.   Count: Longint;
  3885. begin
  3886.   Stream := TMemoryStream.Create;
  3887.   try
  3888.     WriteData(Stream);
  3889.     WriteValue(vaBinary);
  3890.     Count := Stream.Size;
  3891.     Write(Count, SizeOf(Count));
  3892.     Write(Stream.Memory^, Count);
  3893.   finally
  3894.     Stream.Free;
  3895.   end;
  3896. end;
  3897.  
  3898. procedure TWriter.WriteBuffer;
  3899. begin
  3900.   FStream.WriteBuffer(FBuffer^, FBufPos);
  3901.   FBufPos := 0;
  3902. end;
  3903.  
  3904. procedure TWriter.WriteBoolean(Value: Boolean);
  3905. begin
  3906.   if Value then
  3907.     WriteValue(vaTrue) else
  3908.     WriteValue(vaFalse);
  3909. end;
  3910.  
  3911. procedure TWriter.WriteChar(Value: Char);
  3912. begin
  3913.   WriteString(Value);
  3914. end;
  3915.  
  3916. procedure TWriter.WriteCollection(Value: TCollection);
  3917. var
  3918.   I: Integer;
  3919. begin
  3920.   WriteValue(vaCollection);
  3921.   for I := 0 to Value.Count - 1 do
  3922.   begin
  3923.     WriteListBegin;
  3924.     WriteProperties(Value.Items[I]);
  3925.     WriteListEnd;
  3926.   end;
  3927.   WriteListEnd;
  3928. end;
  3929.  
  3930. procedure TWriter.WriteComponent(Component: TComponent);
  3931.  
  3932.   function FindAncestor(const Name: string): TComponent;
  3933.   var
  3934.     I: Integer;
  3935.   begin
  3936.     for I := 0 to FAncestorList.Count - 1 do
  3937.     begin
  3938.       Result := FAncestorList[I];
  3939.       if CompareText(Result.Name, Name) = 0 then Exit;
  3940.     end;
  3941.     Result := nil;
  3942.   end;
  3943.  
  3944. begin
  3945.   Include(Component.FComponentState, csWriting);
  3946.   if Assigned(FAncestorList) then
  3947.     Ancestor := FindAncestor(Component.Name);
  3948.   Component.WriteState(Self);
  3949.   Exclude(Component.FComponentState, csWriting);
  3950. end;
  3951.  
  3952. procedure TWriter.WriteData(Instance: TComponent);
  3953. var
  3954.   PreviousPosition, PropertiesPosition: Longint;
  3955.   OldAncestorList: TList;
  3956.   OldAncestorPos, OldChildPos: Integer;
  3957.   Flags: TFilerFlags;
  3958. begin
  3959.   if FBufSize - FBufPos < Length(Instance.ClassName) +
  3960.     Length(Instance.Name) + 1+5+3 then WriteBuffer;
  3961.      { Prefix + vaInt + integer + 2 end lists }
  3962.   PreviousPosition := Position;
  3963.   Flags := [];
  3964.   if Ancestor <> nil then Include(Flags, ffInherited);
  3965.   if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) and
  3966.     ((Ancestor = nil) or (FAncestorList[FAncestorPos] <> Ancestor)) then
  3967.     Include(Flags, ffChildPos);
  3968.   WritePrefix(Flags, FChildPos);
  3969.   WriteStr(Instance.ClassName);
  3970.   WriteStr(Instance.Name);
  3971.   PropertiesPosition := Position;
  3972.   if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) then
  3973.   begin
  3974.     if Ancestor <> nil then Inc(FAncestorPos);
  3975.     Inc(FChildPos);
  3976.   end;
  3977.   WriteProperties(Instance);
  3978.   WriteListEnd;
  3979.   OldAncestorList := FAncestorList;
  3980.   OldAncestorPos := FAncestorPos;
  3981.   OldChildPos := FChildPos;
  3982.   try
  3983.     FAncestorList := nil;
  3984.     FAncestorPos := 0;
  3985.     FChildPos := 0;
  3986.     if not IgnoreChildren then
  3987.       try
  3988.         if (FAncestor <> nil) and (FAncestor is TComponent) then
  3989.         begin
  3990.           FAncestorList := TList.Create;
  3991.           TComponent(FAncestor).GetChildren(AddAncestor);
  3992.         end;
  3993.         Instance.GetChildren(WriteComponent);
  3994.       finally
  3995.         FAncestorList.Free;
  3996.       end;
  3997.   finally
  3998.     FAncestorList := OldAncestorList;
  3999.     FAncestorPos := OldAncestorPos;
  4000.     FChildPos := OldChildPos;
  4001.   end;
  4002.   WriteListEnd;
  4003.   if (Instance <> Root) and (Flags = [ffInherited]) and
  4004.     (Position = PropertiesPosition + (1 + 1)) then { (1 + 1) is two end lists }
  4005.     Position := PreviousPosition;
  4006. end;
  4007.  
  4008. procedure TWriter.WriteDescendent(Root: TComponent; AAncestor: TComponent);
  4009. begin
  4010.   FRootAncestor := AAncestor;
  4011.   FAncestor := AAncestor;
  4012.   FRoot := Root;
  4013.   WriteSignature;
  4014.   WriteComponent(Root);
  4015. end;
  4016.  
  4017. procedure TWriter.WriteFloat(Value: Extended);
  4018. begin
  4019.   WriteValue(vaExtended);
  4020.   Write(Value, SizeOf(Extended));
  4021. end;
  4022.  
  4023. procedure TWriter.WriteIdent(const Ident: string);
  4024. begin
  4025.   if CompareText(Ident, 'False') = 0 then WriteValue(vaFalse) else
  4026.   if CompareText(Ident ,'True') = 0 then WriteValue(vaTrue) else
  4027.   if CompareText(Ident, 'nil') = 0 then WriteValue(vaNil) else
  4028.   begin
  4029.     WriteValue(vaIdent);
  4030.     WriteStr(Ident);
  4031.   end;
  4032. end;
  4033.  
  4034. procedure TWriter.WriteInteger(Value: Longint);
  4035. begin
  4036.   if (Value >= -128) and (Value <= 127) then
  4037.   begin
  4038.     WriteValue(vaInt8);
  4039.     Write(Value, SizeOf(Shortint));
  4040.   end else
  4041.   if (Value >= -32768) and (Value <= 32767) then
  4042.   begin
  4043.     WriteValue(vaInt16);
  4044.     Write(Value, SizeOf(Smallint));
  4045.   end else
  4046.   begin
  4047.     WriteValue(vaInt32);
  4048.     Write(Value, SizeOf(Longint));
  4049.   end;
  4050. end;
  4051.  
  4052. procedure TWriter.WriteListBegin;
  4053. begin
  4054.   WriteValue(vaList);
  4055. end;
  4056.  
  4057. procedure TWriter.WriteListEnd;
  4058. begin
  4059.   WriteValue(vaNull);
  4060. end;
  4061.  
  4062. procedure TWriter.WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  4063. var
  4064.   Prefix: Byte;
  4065. begin
  4066.   if Flags <> [] then
  4067.   begin
  4068.     Prefix := $F0 or Byte(Flags);
  4069.     Write(Prefix, SizeOf(Prefix));
  4070.     if ffChildPos in Flags then WriteInteger(AChildPos);
  4071.   end;
  4072. end;
  4073.  
  4074. procedure TWriter.WriteProperties(Instance: TPersistent);
  4075. var
  4076.   I, Count: Integer;
  4077.   PropInfo: PPropInfo;
  4078.   PropList: PPropList;
  4079. begin
  4080.   Count := GetTypeData(Instance.ClassInfo)^.PropCount;
  4081.   if Count > 0 then
  4082.   begin
  4083.     GetMem(PropList, Count * SizeOf(Pointer));
  4084.     try
  4085.       GetPropInfos(Instance.ClassInfo, PropList);
  4086.       for I := 0 to Count - 1 do
  4087.       begin
  4088.         PropInfo := PropList^[I];
  4089.         if IsStoredProp(Instance, PropInfo) then
  4090.           WriteProperty(Instance, PropInfo);
  4091.       end;
  4092.     finally
  4093.       FreeMem(PropList, Count * SizeOf(Pointer));
  4094.     end;
  4095.   end;
  4096.   Instance.DefineProperties(Self);
  4097. end;
  4098.  
  4099. procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  4100. var
  4101.   PropType: PTypeInfo;
  4102.  
  4103.   function AncestorValid: Boolean;
  4104.   begin
  4105.     Result := (Ancestor <> nil) and ((Instance.ClassType = Ancestor.ClassType) or
  4106.       (Instance = Root));
  4107.   end;
  4108.  
  4109.   procedure WritePropPath;
  4110.   begin
  4111.     WritePropName(PPropInfo(PropInfo)^.Name);
  4112.   end;
  4113.  
  4114.   procedure WriteSet(Value: Longint);
  4115.   var
  4116.     I: Integer;
  4117.     BaseType: PTypeInfo;
  4118.   begin
  4119.     BaseType := GetTypeData(PropType)^.CompType;
  4120.     WriteValue(vaSet);
  4121.     for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do
  4122.       if I in TIntegerSet(Value) then WriteStr(GetEnumName(BaseType, I));
  4123.     WriteStr('');
  4124.   end;
  4125.  
  4126.   procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
  4127.   var
  4128.     I: Integer;
  4129.     Ident: string;
  4130.   begin
  4131.     for I := 0 to IntConstList.Count - 1 do
  4132.       with TIntConst(IntConstList[I]) do
  4133.         if IntType = IntegerType then
  4134.           if IntToIdent(Value, Ident) then
  4135.           begin
  4136.             WriteIdent(Ident);
  4137.             Exit;
  4138.           end
  4139.           else Break;
  4140.     WriteInteger(Value);
  4141.   end;
  4142.  
  4143.   procedure WriteCollectionProp(Collection: TCollection);
  4144.   var
  4145.     SavePropPath: string;
  4146.   begin
  4147.     WritePropPath;
  4148.     SavePropPath := FPropPath;
  4149.     try
  4150.       FPropPath := '';
  4151.       WriteCollection(Collection);
  4152.     finally
  4153.       FPropPath := SavePropPath;
  4154.     end;
  4155.   end;
  4156.  
  4157.   procedure WriteOrdProp;
  4158.   var
  4159.     Value: Longint;
  4160.  
  4161.     function IsDefaultValue: Boolean;
  4162.     begin
  4163.       if AncestorValid then
  4164.         Result := Value = GetOrdProp(Ancestor, PropInfo) else
  4165.         Result := Value = PPropInfo(PropInfo)^.Default;
  4166.     end;
  4167.  
  4168.   begin
  4169.     Value := GetOrdProp(Instance, PropInfo);
  4170.     if not IsDefaultValue then
  4171.     begin
  4172.       WritePropPath;
  4173.       case PropType^.Kind of
  4174.         tkInteger:
  4175.           WriteIntProp(PPropInfo(PropInfo)^.PropType, Value);
  4176.         tkChar:
  4177.           WriteChar(Chr(Value));
  4178.         tkSet:
  4179.           WriteSet(Value);
  4180.         tkEnumeration:
  4181.           WriteIdent(GetEnumName(PropType, Value));
  4182.       end;
  4183.     end;
  4184.   end;
  4185.  
  4186.   procedure WriteFloatProp;
  4187.   var
  4188.     Value: Extended;
  4189.  
  4190.     function IsDefaultValue: Boolean;
  4191.     begin
  4192.       if AncestorValid then
  4193.         Result := Value = GetFloatProp(Ancestor, PropInfo) else
  4194.         Result := Value = 0;
  4195.     end;
  4196.  
  4197.   begin
  4198.     Value := GetFloatProp(Instance, PropInfo);
  4199.     if not IsDefaultValue then
  4200.     begin
  4201.       WritePropPath;
  4202.       WriteFloat(Value);
  4203.     end;
  4204.   end;
  4205.  
  4206.   procedure WriteStrProp;
  4207.   var
  4208.     Value: string;
  4209.  
  4210.     function IsDefault: Boolean;
  4211.     begin
  4212.       if AncestorValid then
  4213.         Result := Value = GetStrProp(Ancestor, PropInfo) else
  4214.         Result := Value = '';
  4215.     end;
  4216.  
  4217.   begin
  4218.     Value := GetStrProp(Instance, PropInfo);
  4219.     if not IsDefault then
  4220.     begin
  4221.       WritePropPath;
  4222.       WriteString(Value);
  4223.     end;
  4224.   end;
  4225.  
  4226.   procedure WriteObjectProp;
  4227.   var
  4228.     Value: TObject;
  4229.     OldAncestor: TPersistent;
  4230.     SavePropPath, ComponentValue: string;
  4231.  
  4232.     function IsDefault: Boolean;
  4233.     var
  4234.       AncestorValue: TObject;
  4235.     begin
  4236.       AncestorValue := nil;
  4237.       if AncestorValid then
  4238.       begin
  4239.         AncestorValue := TObject(GetOrdProp(Ancestor, PropInfo));
  4240.         if (AncestorValue <> nil) and (TComponent(AncestorValue).Owner = FRootAncestor) and
  4241.           (Value <> nil) and (TComponent(Value).Owner = Root) and
  4242.           (CompareText(TComponent(AncestorValue).Name, TComponent(Value).Name) = 0) then
  4243.           AncestorValue := Value;
  4244.       end;
  4245.       Result := Value = AncestorValue;
  4246.     end;
  4247.  
  4248.     function GetComponentValue(Component: TComponent): string;
  4249.     begin
  4250.       if Component.Owner = Root then
  4251.         Result := Component.Name
  4252.       else if Component.Owner <> nil then
  4253.         Result := Component.Owner.Name + '.' + Component.Name
  4254.       else Result := '';
  4255.     end;
  4256.  
  4257.   begin
  4258.     Value := TObject(GetOrdProp(Instance, PropInfo));
  4259.     if (Value = nil) and not IsDefault then
  4260.     begin
  4261.       WritePropPath;
  4262.       WriteValue(vaNil);
  4263.     end
  4264.     else if Value is TPersistent then
  4265.       if Value is TComponent then
  4266.       begin
  4267.         if not IsDefault then
  4268.         begin
  4269.           ComponentValue := GetComponentValue(TComponent(Value));
  4270.           if ComponentValue <> '' then
  4271.           begin
  4272.             WritePropPath;
  4273.             WriteIdent(ComponentValue);
  4274.           end
  4275.         end
  4276.       end else if Value is TCollection then
  4277.       begin
  4278.         if not AncestorValid or
  4279.           not CollectionsEqual(TCollection(Value),
  4280.             TCollection(GetOrdProp(Ancestor, PropInfo))) then
  4281.             WriteCollectionProp(TCollection(Value));
  4282.       end else
  4283.       begin
  4284.         OldAncestor := Ancestor;
  4285.         SavePropPath := FPropPath;
  4286.         FPropPath := FPropPath + PPropInfo(PropInfo)^.Name + '.';
  4287.         if AncestorValid then
  4288.           Ancestor := TPersistent(GetOrdProp(Ancestor, PropInfo));
  4289.         WriteProperties(TPersistent(Value));
  4290.         Ancestor := OldAncestor;
  4291.         FPropPath := SavePropPath;
  4292.       end
  4293.   end;
  4294.  
  4295.   procedure WriteMethodProp;
  4296.   var
  4297.     Value: TMethod;
  4298.  
  4299.     function IsDefaultValue: Boolean;
  4300.     var
  4301.       DefaultCode: Pointer;
  4302.     begin
  4303.       DefaultCode := nil;
  4304.       if AncestorValid then DefaultCode := GetMethodProp(Ancestor, PropInfo).Code;
  4305.       Result := (Value.Code = DefaultCode) or
  4306.         ((Value.Code <> nil) and (Root.MethodName(Value.Code) = ''));
  4307.     end;
  4308.  
  4309.   begin
  4310.     Value := GetMethodProp(Instance, PropInfo);
  4311.     if not IsDefaultValue then
  4312.     begin
  4313.       WritePropPath;
  4314.       if Value.Code = nil then
  4315.         WriteValue(vaNil) else
  4316.         WriteIdent(Root.MethodName(Value.Code));
  4317.     end;
  4318.   end;
  4319.  
  4320. begin
  4321.   if PPropInfo(PropInfo)^.SetProc <> nil then
  4322.   begin
  4323.     PropType := PPropInfo(PropInfo)^.PropType;
  4324.     case PropType^.Kind of
  4325.       tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp;
  4326.       tkFloat: WriteFloatProp;
  4327.       tkString, tkLString: WriteStrProp;
  4328.       tkClass: WriteObjectProp;
  4329.       tkMethod: WriteMethodProp;
  4330.     end;
  4331.   end;
  4332. end;
  4333.  
  4334. procedure TWriter.WritePropName(const PropName: string);
  4335. begin
  4336.   WriteStr(FPropPath + PropName);
  4337. end;
  4338.  
  4339. procedure TWriter.WriteRootComponent(Root: TComponent);
  4340. begin
  4341.   WriteDescendent(Root, nil);
  4342. end;
  4343.  
  4344. procedure TWriter.WriteSignature;
  4345. begin
  4346.   Write(FilerSignature, SizeOf(FilerSignature));
  4347. end;
  4348.  
  4349. procedure TWriter.WriteStr(const Value: string);
  4350. var
  4351.   L: Integer;
  4352. begin
  4353.   L := Length(Value);
  4354.   if L > 255 then L := 255;
  4355.   Write(L, SizeOf(Byte));
  4356.   Write(Value[1], L);
  4357. end;
  4358.  
  4359. procedure TWriter.WriteString(const Value: string);
  4360. var
  4361.   L: Integer;
  4362. begin
  4363.   L := Length(Value);
  4364.   if L <= 255 then
  4365.   begin
  4366.     WriteValue(vaString);
  4367.     Write(L, SizeOf(Byte));
  4368.   end else
  4369.   begin
  4370.     WriteValue(vaLString);
  4371.     Write(L, SizeOf(Integer));
  4372.   end;
  4373.   Write(Pointer(Value)^, L);
  4374. end;
  4375.  
  4376. procedure TWriter.WriteValue(Value: TValueType);
  4377. begin
  4378.   Write(Value, SizeOf(Value));
  4379. end;
  4380.  
  4381. { TParser }
  4382.  
  4383. const
  4384.   ParseBufSize = 4096;
  4385.  
  4386. procedure BinToHex(Buffer, Text: PChar; BufSize: Integer); assembler;
  4387. asm
  4388.         PUSH    ESI
  4389.         PUSH    EDI
  4390.         MOV     ESI,EAX
  4391.         MOV     EDI,EDX
  4392.         MOV     EDX,0
  4393.         JMP     @@1
  4394. @@0:    DB      '0123456789ABCDEF'
  4395. @@1:    LODSB
  4396.         MOV     DL,AL
  4397.         AND     DL,0FH
  4398.         MOV     AH,@@0.Byte[EDX]
  4399.         MOV     DL,AL
  4400.         SHR     DL,4
  4401.         MOV     AL,@@0.Byte[EDX]
  4402.         STOSW
  4403.         DEC     ECX
  4404.         JNE     @@1
  4405.         POP     EDI
  4406.         POP     ESI
  4407. end;
  4408.  
  4409. function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer; assembler;
  4410. asm
  4411.         PUSH    ESI
  4412.         PUSH    EDI
  4413.         PUSH    EBX
  4414.         MOV     ESI,EAX
  4415.         MOV     EDI,EDX
  4416.         MOV     EBX,EDX
  4417.         MOV     EDX,0
  4418.         JMP     @@1
  4419. @@0:    DB       0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1
  4420.         DB      -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1
  4421.         DB      -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1
  4422.         DB      -1,10,11,12,13,14,15
  4423. @@1:    LODSW
  4424.         CMP     AL,'0'
  4425.         JB      @@2
  4426.         CMP     AL,'f'
  4427.         JA      @@2
  4428.         MOV     DL,AL
  4429.         MOV     AL,@@0.Byte[EDX-'0']
  4430.         CMP     AL,-1
  4431.         JE      @@2
  4432.         SHL     AL,4
  4433.         CMP     AH,'0'
  4434.         JB      @@2
  4435.         CMP     AH,'f'
  4436.         JA      @@2
  4437.         MOV     DL,AH
  4438.         MOV     AH,@@0.Byte[EDX-'0']
  4439.         CMP     AH,-1
  4440.         JE      @@2
  4441.         OR      AL,AH
  4442.         STOSB
  4443.         DEC     ECX
  4444.         JNE     @@1
  4445. @@2:    MOV     EAX,EDI
  4446.         SUB     EAX,EBX
  4447.         POP     EBX
  4448.         POP     EDI
  4449.         POP     ESI
  4450. end;
  4451.  
  4452. constructor TParser.Create(Stream: TStream);
  4453. begin
  4454.   FStream := Stream;
  4455.   GetMem(FBuffer, ParseBufSize);
  4456.   FBuffer[0] := #0;
  4457.   FBufPtr := FBuffer;
  4458.   FBufEnd := FBuffer + ParseBufSize;
  4459.   FSourcePtr := FBuffer;
  4460.   FSourceEnd := FBuffer;
  4461.   FTokenPtr := FBuffer;
  4462.   FSourceLine := 1;
  4463.   NextToken;
  4464. end;
  4465.  
  4466. destructor TParser.Destroy;
  4467. begin
  4468.   if FBuffer <> nil then
  4469.   begin
  4470.     FStream.Seek(Longint(FTokenPtr) - Longint(FBufPtr), 1);
  4471.     FreeMem(FBuffer, ParseBufSize);
  4472.   end;
  4473. end;
  4474.  
  4475. procedure TParser.CheckToken(T: Char);
  4476. begin
  4477.   if Token <> T then
  4478.     case T of
  4479.       toSymbol:
  4480.         Error(SIdentifierExpected);
  4481.       toString:
  4482.         Error(SStringExpected);
  4483.       toInteger, toFloat:
  4484.         Error(SNumberExpected);
  4485.     else
  4486.       ErrorFmt(SCharExpected, [T]);
  4487.     end;
  4488. end;
  4489.  
  4490. procedure TParser.CheckTokenSymbol(const S: string);
  4491. begin
  4492.   if not TokenSymbolIs(S) then ErrorFmt(SSymbolExpected, [S]);
  4493. end;
  4494.  
  4495. procedure TParser.Error(Ident: Integer);
  4496. begin
  4497.   ErrorStr(LoadStr(Ident));
  4498. end;
  4499.  
  4500. procedure TParser.ErrorFmt(Ident: Integer; const Args: array of const);
  4501. begin
  4502.   ErrorStr(FmtLoadStr(Ident, Args));
  4503. end;
  4504.  
  4505. procedure TParser.ErrorStr(const Message: string);
  4506. begin
  4507.   raise EParserError.CreateResFmt(SParseError, [Message, FSourceLine]);
  4508. end;
  4509.  
  4510. procedure TParser.HexToBinary(Stream: TStream);
  4511. var
  4512.   Count: Integer;
  4513.   Buffer: array[0..255] of Char;
  4514. begin
  4515.   SkipBlanks;
  4516.   while FSourcePtr^ <> '}' do
  4517.   begin
  4518.     Count := HexToBin(FSourcePtr, Buffer, SizeOf(Buffer));
  4519.     if Count = 0 then Error(SInvalidBinary);
  4520.     Stream.Write(Buffer, Count);
  4521.     Inc(FSourcePtr, Count * 2);
  4522.     SkipBlanks;
  4523.   end;
  4524.   NextToken;
  4525. end;
  4526.  
  4527. function TParser.NextToken: Char;
  4528. var
  4529.   I: Integer;
  4530.   P, S: PChar;
  4531. begin
  4532.   SkipBlanks;
  4533.   P := FSourcePtr;
  4534.   FTokenPtr := P;
  4535.   case P^ of
  4536.     'A'..'Z', 'a'..'z', '_':
  4537.       begin
  4538.         Inc(P);
  4539.         while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P);
  4540.         Result := toSymbol;
  4541.       end;
  4542.     '#', '''':
  4543.       begin
  4544.         S := P;
  4545.         while True do
  4546.           case P^ of
  4547.             '#':
  4548.               begin
  4549.                 Inc(P);
  4550.                 I := 0;
  4551.                 while P^ in ['0'..'9'] do
  4552.                 begin
  4553.                   I := I * 10 + (Ord(P^) - Ord('0'));
  4554.                   Inc(P);
  4555.                 end;
  4556.                 S^ := Chr(I);
  4557.                 Inc(S);
  4558.               end;
  4559.             '''':
  4560.               begin
  4561.                 Inc(P);
  4562.                 while True do
  4563.                 begin
  4564.                   case P^ of
  4565.                     #0, #10, #13:
  4566.                       Error(SInvalidString);
  4567.                     '''':
  4568.                       begin
  4569.                         Inc(P);
  4570.                         if P^ <> '''' then Break;
  4571.                       end;
  4572.                   end;
  4573.                   S^ := P^;
  4574.                   Inc(S);
  4575.                   Inc(P);
  4576.                 end;
  4577.               end;
  4578.           else
  4579.             Break;
  4580.           end;
  4581.         FStringPtr := S;
  4582.         Result := toString;
  4583.       end;
  4584.     '$':
  4585.       begin
  4586.         Inc(P);
  4587.         while P^ in ['0'..'9', 'A'..'F', 'a'..'f'] do Inc(P);
  4588.         Result := toInteger;
  4589.       end;
  4590.     '-', '0'..'9':
  4591.       begin
  4592.         Inc(P);
  4593.         while P^ in ['0'..'9'] do Inc(P);
  4594.         Result := toInteger;
  4595.         while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do
  4596.         begin
  4597.           Inc(P);
  4598.           Result := toFloat;
  4599.         end;
  4600.       end;
  4601.   else
  4602.     Result := P^;
  4603.     if Result <> toEOF then Inc(P);
  4604.   end;
  4605.   FSourcePtr := P;
  4606.   FToken := Result;
  4607. end;
  4608.  
  4609. procedure TParser.ReadBuffer;
  4610. var
  4611.   Count: Integer;
  4612. begin
  4613.   Inc(FOrigin, FSourcePtr - FBuffer);
  4614.   FSourceEnd[0] := FSaveChar;
  4615.   Count := FBufPtr - FSourcePtr;
  4616.   if Count <> 0 then Move(FSourcePtr[0], FBuffer[0], Count);
  4617.   FBufPtr := FBuffer + Count;
  4618.   Inc(FBufPtr, FStream.Read(FBufPtr[0], FBufEnd - FBufPtr));
  4619.   FSourcePtr := FBuffer;
  4620.   FSourceEnd := FBufPtr;
  4621.   if FSourceEnd = FBufEnd then
  4622.   begin
  4623.     FSourceEnd := LineStart(FBuffer, FSourceEnd - 1);
  4624.     if FSourceEnd = FBuffer then Error(SLineTooLong);
  4625.   end;
  4626.   FSaveChar := FSourceEnd[0];
  4627.   FSourceEnd[0] := #0;
  4628. end;
  4629.  
  4630. procedure TParser.SkipBlanks;
  4631. begin
  4632.   while True do
  4633.   begin
  4634.     case FSourcePtr^ of
  4635.       #0:
  4636.         begin
  4637.           ReadBuffer;
  4638.           if FSourcePtr^ = #0 then Exit;
  4639.           Continue;
  4640.         end;
  4641.       #10:
  4642.         Inc(FSourceLine);
  4643.       #33..#255:
  4644.         Exit;
  4645.     end;
  4646.     Inc(FSourcePtr);
  4647.   end;
  4648. end;
  4649.  
  4650. function TParser.SourcePos: Longint;
  4651. begin
  4652.   Result := FOrigin + (FTokenPtr - FBuffer);
  4653. end;
  4654.  
  4655. function TParser.TokenFloat: Extended;
  4656. begin
  4657.   Result := StrToFloat(TokenString);
  4658. end;
  4659.  
  4660. function TParser.TokenInt: Longint;
  4661. begin
  4662.   Result := StrToInt(TokenString);
  4663. end;
  4664.  
  4665. function TParser.TokenString: string;
  4666. var
  4667.   L: Integer;
  4668. begin
  4669.   if FToken = toString then
  4670.     L := FStringPtr - FTokenPtr else
  4671.     L := FSourcePtr - FTokenPtr;
  4672.   SetString(Result, FTokenPtr, L);
  4673. end;
  4674.  
  4675. function TParser.TokenSymbolIs(const S: string): Boolean;
  4676. begin
  4677.   Result := (Token = toSymbol) and (CompareText(S, TokenString) = 0);
  4678. end;
  4679.  
  4680. function TParser.TokenComponentIdent: String;
  4681. var
  4682.   P: PChar;
  4683. begin
  4684.   CheckToken(toSymbol);
  4685.   P := FSourcePtr;
  4686.   while P^ = '.' do
  4687.   begin
  4688.     Inc(P);
  4689.     if not (P^ in ['A'..'Z', 'a'..'z', '_']) then
  4690.       Error(SIdentifierExpected);
  4691.     repeat
  4692.       Inc(P)
  4693.     until not (P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_']);
  4694.   end;
  4695.   FSourcePtr := P;
  4696.   Result := TokenString;
  4697. end;
  4698.  
  4699. { Binary to text conversion }
  4700.  
  4701. procedure ObjectBinaryToText(Input, Output: TStream);
  4702. var
  4703.   NestingLevel: Integer;
  4704.   SaveSeparator: Char;
  4705.   Reader: TReader;
  4706.   Writer: TWriter;
  4707.  
  4708.   procedure WriteIndent;
  4709.   const
  4710.     Blanks: array[0..1] of Char = '  ';
  4711.   var
  4712.     I: Integer;
  4713.   begin
  4714.     for I := 1 to NestingLevel do Writer.Write(Blanks, SizeOf(Blanks));
  4715.   end;
  4716.  
  4717.   procedure WriteStr(const S: string);
  4718.   begin
  4719.     Writer.Write(S[1], Length(S));
  4720.   end;
  4721.  
  4722.   procedure NewLine;
  4723.   begin
  4724.     WriteStr(#13#10);
  4725.     WriteIndent;
  4726.   end;
  4727.  
  4728.   procedure ConvertValue; forward;
  4729.  
  4730.   procedure ConvertHeader;
  4731.   var
  4732.     ClassName, ObjectName: string;
  4733.     Flags: TFilerFlags;
  4734.     Position: Integer;
  4735.   begin
  4736.     Reader.ReadPrefix(Flags, Position);
  4737.     ClassName := Reader.ReadStr;
  4738.     ObjectName := Reader.ReadStr;
  4739.     WriteIndent;
  4740.     if ffInherited in Flags then
  4741.       WriteStr('inherited ')
  4742.     else
  4743.       WriteStr('object ');
  4744.     if ObjectName <> '' then
  4745.     begin
  4746.       WriteStr(ObjectName);
  4747.       WriteStr(': ');
  4748.     end;
  4749.     WriteStr(ClassName);
  4750.     if ffChildPos in Flags then
  4751.     begin
  4752.       WriteStr(' [');
  4753.       WriteStr(IntToStr(Position));
  4754.       WriteStr(']');
  4755.     end;
  4756.     WriteStr(#13#10);
  4757.   end;
  4758.  
  4759.   procedure ConvertBinary;
  4760.   const
  4761.     BytesPerLine = 32;
  4762.   var
  4763.     MultiLine: Boolean;
  4764.     I: Integer;
  4765.     Count: Longint;
  4766.     Buffer: array[0..BytesPerLine - 1] of Char;
  4767.     Text: array[0..BytesPerLine * 2 - 1] of Char;
  4768.   begin
  4769.     Reader.ReadValue;
  4770.     WriteStr('{');
  4771.     Inc(NestingLevel);
  4772.     Reader.Read(Count, SizeOf(Count));
  4773.     MultiLine := Count >= BytesPerLine;
  4774.     while Count > 0 do
  4775.     begin
  4776.       if MultiLine then NewLine;
  4777.       if Count >= 32 then I := 32 else I := Count;
  4778.       Reader.Read(Buffer, I);
  4779.       BinToHex(Buffer, Text, I);
  4780.       Writer.Write(Text, I * 2);
  4781.       Dec(Count, I);
  4782.     end;
  4783.     Dec(NestingLevel);
  4784.     WriteStr('}');
  4785.   end;
  4786.  
  4787.   procedure ConvertProperty; forward;
  4788.  
  4789.   procedure ConvertValue;
  4790.   var
  4791.     I, J, L: Integer;
  4792.     S: string;
  4793.   begin
  4794.     case Reader.NextValue of
  4795.       vaList:
  4796.         begin
  4797.           Reader.ReadValue;
  4798.           WriteStr('(');
  4799.           Inc(NestingLevel);
  4800.           while not Reader.EndOfList do
  4801.           begin
  4802.             NewLine;
  4803.             ConvertValue;
  4804.           end;
  4805.           Reader.ReadListEnd;
  4806.           Dec(NestingLevel);
  4807.           WriteStr(')');
  4808.         end;
  4809.       vaInt8, vaInt16, vaInt32:
  4810.         WriteStr(IntToStr(Reader.ReadInteger));
  4811.       vaExtended:
  4812.         WriteStr(FloatToStr(Reader.ReadFloat));
  4813.       vaString, vaLString:
  4814.         begin
  4815.           S := Reader.ReadString;
  4816.           L := Length(S);
  4817.           if L = 0 then WriteStr('''''') else
  4818.           begin
  4819.             I := 1;
  4820.             repeat
  4821.               if (S[I] >= ' ') and (S[I] <> '''') then
  4822.               begin
  4823.                 J := I;
  4824.                 repeat Inc(I) until (I > L) or (S[I] < ' ') or (S[I] = '''');
  4825.                 WriteStr('''');
  4826.                 Writer.Write(S[J], I - J);
  4827.                 WriteStr('''');
  4828.               end else
  4829.               begin
  4830.                 WriteStr('#');
  4831.                 WriteStr(IntToStr(Ord(S[I])));
  4832.                 Inc(I);
  4833.               end;
  4834.             until I > L;
  4835.           end;
  4836.         end;
  4837.       vaIdent, vaFalse, vaTrue, vaNil:
  4838.         WriteStr(Reader.ReadIdent);
  4839.       vaBinary:
  4840.         ConvertBinary;
  4841.       vaSet:
  4842.         begin
  4843.           Reader.ReadValue;
  4844.           WriteStr('[');
  4845.           I := 0;
  4846.           while True do
  4847.           begin
  4848.             S := Reader.ReadStr;
  4849.             if S = '' then Break;
  4850.             if I > 0 then WriteStr(', ');
  4851.             WriteStr(S);
  4852.             Inc(I);
  4853.           end;
  4854.           WriteStr(']');
  4855.         end;
  4856.       vaCollection:
  4857.         begin
  4858.           Reader.ReadValue;
  4859.           WriteStr('<');
  4860.           Inc(NestingLevel);
  4861.           while not Reader.EndOfList do
  4862.           begin
  4863.             NewLine;
  4864.             WriteStr('item');
  4865.             if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then
  4866.             begin
  4867.               WriteStr(' [');
  4868.               ConvertValue;
  4869.               WriteStr(']');
  4870.             end;
  4871.             WriteStr(#13#10);
  4872.             Reader.CheckValue(vaList);
  4873.             Inc(NestingLevel);
  4874.             while not Reader.EndOfList do ConvertProperty;
  4875.             Reader.ReadListEnd;
  4876.             Dec(NestingLevel);
  4877.             WriteIndent;
  4878.             WriteStr('end');
  4879.           end;
  4880.           Reader.ReadListEnd;
  4881.           Dec(NestingLevel);
  4882.           WriteStr('>');
  4883.         end;
  4884.     end;
  4885.   end;
  4886.  
  4887.   procedure ConvertProperty;
  4888.   begin
  4889.     WriteIndent;
  4890.     WriteStr(Reader.ReadStr);
  4891.     WriteStr(' = ');
  4892.     ConvertValue;
  4893.     WriteStr(#13#10);
  4894.   end;
  4895.  
  4896.   procedure ConvertObject;
  4897.   begin
  4898.     ConvertHeader;
  4899.     Inc(NestingLevel);
  4900.     while not Reader.EndOfList do ConvertProperty;
  4901.     Reader.ReadListEnd;
  4902.     while not Reader.EndOfList do ConvertObject;
  4903.     Reader.ReadListEnd;
  4904.     Dec(NestingLevel);
  4905.     WriteIndent;
  4906.     WriteStr('end'#13#10);
  4907.   end;
  4908.  
  4909. begin
  4910.   NestingLevel := 0;
  4911.   Reader := TReader.Create(Input, 4096);
  4912.   SaveSeparator := DecimalSeparator;
  4913.   DecimalSeparator := '.';
  4914.   try
  4915.     Writer := TWriter.Create(Output, 4096);
  4916.     try
  4917.       Reader.ReadSignature;
  4918.       ConvertObject;
  4919.     finally
  4920.       Writer.Free;
  4921.     end;
  4922.   finally
  4923.     DecimalSeparator := SaveSeparator;
  4924.     Reader.Free;
  4925.   end;
  4926. end;
  4927.  
  4928. { Text to binary conversion }
  4929.  
  4930. procedure ObjectTextToBinary(Input, Output: TStream);
  4931. var
  4932.   SaveSeparator: Char;
  4933.   Parser: TParser;
  4934.   Writer: TWriter;
  4935.  
  4936.   function ConvertOrderModifier: Integer;
  4937.   begin
  4938.     Result := -1;
  4939.     if Parser.Token = '[' then
  4940.     begin
  4941.       Parser.NextToken;
  4942.       Parser.CheckToken(toInteger);
  4943.       Result := Parser.TokenInt;
  4944.       Parser.NextToken;
  4945.       Parser.CheckToken(']');
  4946.       Parser.NextToken;
  4947.     end;
  4948.   end;
  4949.  
  4950.   procedure ConvertHeader(IsInherited: Boolean);
  4951.   var
  4952.     ClassName, ObjectName: string;
  4953.     Flags: TFilerFlags;
  4954.     Position: Integer;
  4955.   begin
  4956.     Parser.CheckToken(toSymbol);
  4957.     ClassName := Parser.TokenString;
  4958.     ObjectName := '';
  4959.     if Parser.NextToken = ':' then
  4960.     begin
  4961.       Parser.NextToken;
  4962.       Parser.CheckToken(toSymbol);
  4963.       ObjectName := ClassName;
  4964.       ClassName := Parser.TokenString;
  4965.       Parser.NextToken;
  4966.     end;
  4967.     Flags := [];
  4968.     Position := ConvertOrderModifier;
  4969.     if IsInherited then
  4970.       Include(Flags, ffInherited);
  4971.     if Position > 0 then
  4972.       Include(Flags, ffChildPos);
  4973.     Writer.WritePrefix(Flags, Position);
  4974.     Writer.WriteStr(ClassName);
  4975.     Writer.WriteStr(ObjectName);
  4976.   end;
  4977.  
  4978.   procedure ConvertProperty; forward;
  4979.  
  4980.   procedure ConvertValue;
  4981.   var
  4982.     Order: Integer;
  4983.   begin
  4984.     case Parser.Token of
  4985.       toSymbol:
  4986.         Writer.WriteIdent(Parser.TokenComponentIdent);
  4987.       toString:
  4988.         Writer.WriteString(Parser.TokenString);
  4989.       toInteger:
  4990.         Writer.WriteInteger(Parser.TokenInt);
  4991.       toFloat:
  4992.         Writer.WriteFloat(Parser.TokenFloat);
  4993.       '[':
  4994.         begin
  4995.           Parser.NextToken;
  4996.           Writer.WriteValue(vaSet);
  4997.           if Parser.Token <> ']' then
  4998.             while True do
  4999.             begin
  5000.               Parser.CheckToken(toSymbol);
  5001.               Writer.WriteStr(Parser.TokenString);
  5002.               if Parser.NextToken = ']' then Break;
  5003.               Parser.CheckToken(',');
  5004.               Parser.NextToken;
  5005.             end;
  5006.           Writer.WriteStr('');
  5007.         end;
  5008.       '(':
  5009.         begin
  5010.           Parser.NextToken;
  5011.           Writer.WriteListBegin;
  5012.           while Parser.Token <> ')' do ConvertValue;
  5013.           Writer.WriteListEnd;
  5014.         end;
  5015.       '{':
  5016.         Writer.WriteBinary(Parser.HexToBinary);
  5017.       '<':
  5018.         begin
  5019.           Parser.NextToken;
  5020.           Writer.WriteValue(vaCollection);
  5021.           while Parser.Token <> '>' do
  5022.           begin
  5023.             Parser.CheckTokenSymbol('item');
  5024.             Parser.NextToken;
  5025.             Order := ConvertOrderModifier;
  5026.             if Order <> -1 then Writer.WriteInteger(Order);
  5027.             Writer.WriteListBegin;
  5028.             while not Parser.TokenSymbolIs('end') do ConvertProperty;
  5029.             Writer.WriteListEnd;
  5030.             Parser.NextToken;
  5031.           end;
  5032.           Writer.WriteListEnd;
  5033.         end;
  5034.     else
  5035.       Parser.Error(SInvalidProperty);
  5036.     end;
  5037.     Parser.NextToken;
  5038.   end;
  5039.  
  5040.   procedure ConvertProperty;
  5041.   var
  5042.     PropName: string;
  5043.   begin
  5044.     Parser.CheckToken(toSymbol);
  5045.     PropName := Parser.TokenString;
  5046.     Parser.NextToken;
  5047.     while Parser.Token = '.' do
  5048.     begin
  5049.       Parser.NextToken;
  5050.       Parser.CheckToken(toSymbol);
  5051.       PropName := PropName + '.' + Parser.TokenString;
  5052.       Parser.NextToken;
  5053.     end;
  5054.     Writer.WriteStr(PropName);
  5055.     Parser.CheckToken('=');
  5056.     Parser.NextToken;
  5057.     ConvertValue;
  5058.   end;
  5059.  
  5060.   procedure ConvertObject;
  5061.   var
  5062.     InheritedObject: Boolean;
  5063.   begin
  5064.     InheritedObject := False;
  5065.     if Parser.TokenSymbolIs('INHERITED') then
  5066.       InheritedObject := True else
  5067.       Parser.CheckTokenSymbol('OBJECT');
  5068.     Parser.NextToken;
  5069.     ConvertHeader(InheritedObject);
  5070.     while not Parser.TokenSymbolIs('END') and
  5071.       not Parser.TokenSymbolIs('OBJECT') and
  5072.       not Parser.TokenSymbolIs('INHERITED') do ConvertProperty;
  5073.     Writer.WriteListEnd;
  5074.     while not Parser.TokenSymbolIs('END') do ConvertObject;
  5075.     Writer.WriteListEnd;
  5076.     Parser.NextToken;
  5077.   end;
  5078.  
  5079. begin
  5080.   Parser := TParser.Create(Input);
  5081.   SaveSeparator := DecimalSeparator;
  5082.   DecimalSeparator := '.';
  5083.   try
  5084.     Writer := TWriter.Create(Output, 4096);
  5085.     try
  5086.       Writer.WriteSignature;
  5087.       ConvertObject;
  5088.     finally
  5089.       Writer.Free;
  5090.     end;
  5091.   finally
  5092.     DecimalSeparator := SaveSeparator;
  5093.     Parser.Free;
  5094.   end;
  5095. end;
  5096.  
  5097. { Resource to text conversion }
  5098.  
  5099. procedure ObjectResourceToText(Input, Output: TStream);
  5100. begin
  5101.   Input.ReadResHeader;
  5102.   ObjectBinaryToText(Input, Output);
  5103. end;
  5104.  
  5105. { Text to resource conversion }
  5106.  
  5107. procedure ObjectTextToResource(Input, Output: TStream);
  5108. var
  5109.   Len: Byte;
  5110.   Tmp: Longint;
  5111.   MemoryStream: TMemoryStream;
  5112.   MemorySize: Longint;
  5113.   Header: array[0..79] of Char;
  5114. begin
  5115.   MemoryStream := TMemoryStream.Create;
  5116.   try
  5117.     ObjectTextToBinary(Input, MemoryStream);
  5118.     MemorySize := MemoryStream.Size;
  5119.     FillChar(Header, SizeOf(Header), 0);
  5120.     MemoryStream.Position := SizeOf(Longint); { Skip header }
  5121.     MemoryStream.Read(Len, 1);
  5122.  
  5123.     { Skip over object prefix if it is present }
  5124.     if Len and $F0 = $F0 then
  5125.     begin
  5126.       if ffChildPos in TFilerFlags((Len and $F0)) then
  5127.       begin
  5128.         MemoryStream.Read(Len, 1);
  5129.         case TValueType(Len) of
  5130.           vaInt8: Len := 1;
  5131.           vaInt16: Len := 2;
  5132.           vaInt32: Len := 4;
  5133.         end;
  5134.         MemoryStream.Read(Tmp, Len);
  5135.       end;
  5136.       MemoryStream.Read(Len, 1);
  5137.     end;
  5138.  
  5139.     MemoryStream.Read(Header[3], Len);
  5140.     StrUpper(@Header[3]);
  5141.     Byte((@Header[0])^) := $FF;
  5142.     Word((@Header[1])^) := 10;
  5143.     Word((@Header[Len + 4])^) := $1030;
  5144.     Longint((@Header[Len + 6])^) := MemorySize;
  5145.     Output.Write(Header, Len + 10);
  5146.     Output.Write(MemoryStream.Memory^, MemorySize);
  5147.   finally
  5148.     MemoryStream.Free;
  5149.   end;
  5150. end;
  5151.  
  5152. { Thread management routines }
  5153.  
  5154. const
  5155.   CM_EXECPROC = $8FFF;
  5156.  
  5157. type
  5158.   PRaiseFrame = ^TRaiseFrame;
  5159.   TRaiseFrame = record
  5160.     NextRaise: PRaiseFrame;
  5161.     ExceptAddr: Pointer;
  5162.     ExceptObject: TObject;
  5163.     ExceptionRecord: PExceptionRecord;
  5164.   end;
  5165.  
  5166. var
  5167.   ThreadWindow: HWND;
  5168.   ThreadCount: Integer;
  5169.  
  5170. function ThreadWndProc(Window: HWND; Message, wParam, lParam: Longint): Longint; stdcall;
  5171. begin
  5172.   case Message of
  5173.     CM_EXECPROC:
  5174.       with TThread(lParam) do
  5175.       begin
  5176.         Result := 0;
  5177.         try
  5178.           FSynchronizeException := nil;
  5179.           FMethod;
  5180.         except
  5181.           if RaiseList <> nil then
  5182.           begin
  5183.             FSynchronizeException := PRaiseFrame(RaiseList)^.ExceptObject;
  5184.             PRaiseFrame(RaiseList)^.ExceptObject := nil;
  5185.           end;
  5186.         end;
  5187.       end;
  5188.   else
  5189.     Result := DefWindowProc(Window, Message, wParam, lParam);
  5190.   end;
  5191. end;
  5192.  
  5193. var
  5194.   ThreadWindowClass: TWndClass = (
  5195.     style: 0;
  5196.     lpfnWndProc: @ThreadWndProc;
  5197.     cbClsExtra: 0;
  5198.     cbWndExtra: 0;
  5199.     hInstance: 0;
  5200.     hIcon: 0;
  5201.     hCursor: 0;
  5202.     hbrBackground: 0;
  5203.     lpszMenuName: nil;
  5204.     lpszClassName: 'TThreadWindow');
  5205.  
  5206. procedure AddThread;
  5207.  
  5208.   function AllocateWindow: HWND;
  5209.   var
  5210.     TempClass: TWndClass;
  5211.     ClassRegistered: Boolean;
  5212.   begin
  5213.     ThreadWindowClass.hInstance := HInstance;
  5214.     ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName,
  5215.       TempClass);
  5216.     if not ClassRegistered or (TempClass.lpfnWndProc <> @ThreadWndProc) then
  5217.     begin
  5218.       if ClassRegistered then
  5219.         Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance);
  5220.       Windows.RegisterClass(ThreadWindowClass);
  5221.     end;
  5222.     Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0,
  5223.       0, 0, 0, 0, 0, 0, HInstance, nil);
  5224.   end;
  5225.  
  5226. begin
  5227.   if ThreadCount = 0 then
  5228.     ThreadWindow := AllocateWindow;
  5229.   Inc(ThreadCount);
  5230. end;
  5231.  
  5232. procedure RemoveThread;
  5233. begin
  5234.   Dec(ThreadCount);
  5235.   if ThreadCount = 0 then DestroyWindow(ThreadWindow);
  5236. end;
  5237.  
  5238. { TThread }
  5239.  
  5240. function ThreadProc(Thread: TThread): Integer;
  5241. var
  5242.   FreeThread: Boolean;
  5243. begin
  5244.   Thread.Execute;
  5245.   FreeThread := Thread.FFreeOnTerminate;
  5246.   Result := Thread.FReturnValue;
  5247.   Thread.FFinished := True;
  5248.   Thread.DoTerminate;
  5249.   if FreeThread then Thread.Free;
  5250.   EndThread(Result);
  5251. end;
  5252.  
  5253. constructor TThread.Create(CreateSuspended: Boolean);
  5254. var
  5255.   Flags: Integer;
  5256. begin
  5257.   inherited Create;
  5258.   AddThread;
  5259.   FSuspended := CreateSuspended;
  5260.   Flags := 0;
  5261.   if CreateSuspended then Flags := CREATE_SUSPENDED;
  5262.   FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), Flags, FThreadID);
  5263. end;
  5264.  
  5265. destructor TThread.Destroy;
  5266. begin
  5267.   if not FFinished and not Suspended then
  5268.   begin
  5269.     Terminate;
  5270.     WaitFor;
  5271.   end;
  5272.   if FHandle <> 0 then CloseHandle(FHandle);
  5273.   inherited Destroy;
  5274.   RemoveThread;
  5275. end;
  5276.  
  5277. procedure TThread.CallOnTerminate;
  5278. begin
  5279.   FOnTerminate(Self);
  5280. end;
  5281.  
  5282. procedure TThread.DoTerminate;
  5283. begin
  5284.   if Assigned(FOnTerminate) then Synchronize(CallOnTerminate);
  5285. end;
  5286.  
  5287. const
  5288.   Priorities: array [TThreadPriority] of Integer =
  5289.    (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
  5290.     THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
  5291.     THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
  5292.  
  5293. function TThread.GetPriority: TThreadPriority;
  5294. var
  5295.   P: Integer;
  5296.   I: TThreadPriority;
  5297. begin
  5298.   P := GetThreadPriority(FHandle);
  5299.   Result := tpNormal;
  5300.   for I := Low(TThreadPriority) to High(TThreadPriority) do
  5301.     if Priorities[I] = P then Result := I;
  5302. end;
  5303.  
  5304. procedure TThread.SetPriority(Value: TThreadPriority);
  5305. begin
  5306.   SetThreadPriority(FHandle, Priorities[Value]);
  5307. end;
  5308.  
  5309. procedure TThread.Synchronize(Method: TThreadMethod);
  5310. begin
  5311.   if FMainThreadWaiting then
  5312.     raise EThread.CreateRes(SMainThreadWaiting);
  5313.   FSynchronizeException := nil;
  5314.   FMethod := Method;
  5315.   SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
  5316.   if Assigned(FSynchronizeException) then raise FSynchronizeException;
  5317. end;
  5318.  
  5319. procedure TThread.SetSuspended(Value: Boolean);
  5320. begin
  5321.   if Value <> FSuspended then
  5322.     if Value then
  5323.       Suspend else
  5324.       Resume;
  5325. end;
  5326.  
  5327. procedure TThread.Suspend;
  5328. begin
  5329.   FSuspended := True;
  5330.   SuspendThread(FHandle);
  5331. end;
  5332.  
  5333. procedure TThread.Resume;
  5334. begin
  5335.   if ResumeThread(FHandle) = 1 then FSuspended := False;
  5336. end;
  5337.  
  5338. procedure TThread.Terminate;
  5339. begin
  5340.   FTerminated := True;
  5341. end;
  5342.  
  5343. function TThread.WaitFor: Integer;
  5344. begin
  5345.   if GetCurrentThreadID = MainThreadID then FMainThreadWaiting := True;
  5346.   WaitForSingleObject(FHandle, INFINITE);
  5347.   GetExitCodeThread(FHandle, Result);
  5348. end;
  5349.  
  5350. { TComponent }
  5351.  
  5352. constructor TComponent.Create(AOwner: TComponent);
  5353. begin
  5354.   FComponentStyle := [csInheritable];
  5355.   if AOwner <> nil then AOwner.InsertComponent(Self);
  5356. end;
  5357.  
  5358. destructor TComponent.Destroy;
  5359. var
  5360.   I: Integer;
  5361. begin
  5362.   if FFreeNotifies <> nil then
  5363.   begin
  5364.     for I := 0 to FFreeNotifies.Count - 1 do
  5365.       TComponent(FFreeNotifies[I]).Notification(Self, opRemove);
  5366.     FFreeNotifies.Free;
  5367.     FFreeNotifies := nil;
  5368.   end;
  5369.   Destroying;
  5370.   DestroyComponents;
  5371.   if FOwner <> nil then FOwner.RemoveComponent(Self);
  5372. end;
  5373.  
  5374. procedure TComponent.FreeNotification(AComponent: TComponent);
  5375. begin
  5376.   if (Owner = nil) or (AComponent.Owner <> Owner) then
  5377.   begin
  5378.     if not Assigned(FFreeNotifies) then FFreeNotifies := TList.Create;
  5379.     if FFreeNotifies.IndexOf(AComponent) < 0 then
  5380.     begin
  5381.       FFreeNotifies.Add(AComponent);
  5382.       AComponent.FreeNotification(Self);
  5383.     end;
  5384.   end;
  5385. end;
  5386.  
  5387. procedure TComponent.ReadLeft(Reader: TReader);
  5388. begin
  5389.   LongRec(FDesignInfo).Lo := Reader.ReadInteger;
  5390. end;
  5391.  
  5392. procedure TComponent.ReadTop(Reader: TReader);
  5393. begin
  5394.   LongRec(FDesignInfo).Hi := Reader.ReadInteger;
  5395. end;
  5396.  
  5397. procedure TComponent.WriteLeft(Writer: TWriter);
  5398. begin
  5399.   Writer.WriteInteger(LongRec(FDesignInfo).Lo);
  5400. end;
  5401.  
  5402. procedure TComponent.WriteTop(Writer: TWriter);
  5403. begin
  5404.   Writer.WriteInteger(LongRec(FDesignInfo).Hi);
  5405. end;
  5406.  
  5407. procedure TComponent.Insert(AComponent: TComponent);
  5408. begin
  5409.   if FComponents = nil then FComponents := TList.Create;
  5410.   FComponents.Add(AComponent);
  5411.   AComponent.FOwner := Self;
  5412. end;
  5413.  
  5414. procedure TComponent.Remove(AComponent: TComponent);
  5415. begin
  5416.   AComponent.FOwner := nil;
  5417.   FComponents.Remove(AComponent);
  5418.   if FComponents.Count = 0 then
  5419.   begin
  5420.     FComponents.Free;
  5421.     FComponents := nil;
  5422.   end;
  5423. end;
  5424.  
  5425. procedure TComponent.InsertComponent(AComponent: TComponent);
  5426. begin
  5427.   ValidateRename(AComponent, '', AComponent.FName);
  5428.   Insert(AComponent);
  5429.   AComponent.SetReference(True);
  5430.   if csDesigning in ComponentState then
  5431.     AComponent.SetDesigning(True);
  5432.   Notification(AComponent, opInsert);
  5433. end;
  5434.  
  5435. procedure TComponent.RemoveComponent(AComponent: TComponent);
  5436. begin
  5437.   Notification(AComponent, opRemove);
  5438.   AComponent.SetReference(False);
  5439.   Remove(AComponent);
  5440.   AComponent.SetDesigning(False);
  5441.   ValidateRename(AComponent, AComponent.FName, '');
  5442. end;
  5443.  
  5444. procedure TComponent.DestroyComponents;
  5445. var
  5446.   Instance: TComponent;
  5447. begin
  5448.   while FComponents <> nil do
  5449.   begin
  5450.     Instance := FComponents.Last;
  5451.     Remove(Instance);
  5452.     Instance.Destroy;
  5453.   end;
  5454. end;
  5455.  
  5456. procedure TComponent.Destroying;
  5457. var
  5458.   I: Integer;
  5459. begin
  5460.   if not (csDestroying in FComponentState) then
  5461.   begin
  5462.     Include(FComponentState, csDestroying);
  5463.     if FComponents <> nil then
  5464.       for I := 0 to FComponents.Count - 1 do
  5465.         TComponent(FComponents[I]).Destroying;
  5466.   end;
  5467. end;
  5468.  
  5469. procedure TComponent.Notification(AComponent: TComponent;
  5470.   Operation: TOperation);
  5471. var
  5472.   I: Integer;
  5473. begin
  5474.   if (FFreeNotifies <> nil) and (Operation = opRemove) then
  5475.   begin
  5476.     FFreeNotifies.Remove(AComponent);
  5477.     if FFreeNotifies.Count = 0 then
  5478.     begin
  5479.       FFreeNotifies.Free;
  5480.       FFreeNotifies := nil;
  5481.     end;
  5482.   end;
  5483.   if FComponents <> nil then
  5484.     for I := 0 to FComponents.Count - 1 do
  5485.       TComponent(FComponents[I]).Notification(AComponent, Operation);
  5486. end;
  5487.  
  5488. procedure TComponent.DefineProperties(Filer: TFiler);
  5489. var
  5490.   Ancestor: TComponent;
  5491.  
  5492.   function DoWriteLeft: Boolean;
  5493.   begin
  5494.     if Ancestor <> nil then
  5495.       Result := LongRec(FDesignInfo).Lo <> LongRec(Ancestor.FDesignInfo).Lo
  5496.     else
  5497.       Result := LongRec(FDesignInfo).Lo <> 0;
  5498.   end;
  5499.  
  5500.   function DoWriteTop: Boolean;
  5501.   begin
  5502.     if Ancestor <> nil then
  5503.       Result := LongRec(FDesignInfo).Hi <> LongRec(Ancestor.FDesignInfo).Hi
  5504.     else
  5505.       Result := LongRec(FDesignInfo).Hi <> 0;
  5506.   end;
  5507.  
  5508. begin
  5509.   Ancestor := TComponent(Filer.Ancestor);
  5510.   Filer.DefineProperty('Left', ReadLeft, WriteLeft, DoWriteLeft);
  5511.   Filer.DefineProperty('Top', ReadTop, WriteTop, DoWriteTop);
  5512. end;
  5513.  
  5514. function TComponent.HasParent: Boolean;
  5515. begin
  5516.   Result := False;
  5517. end;
  5518.  
  5519. procedure TComponent.GetChildren(Proc: TGetChildProc);
  5520. begin
  5521. end;
  5522.  
  5523. function TComponent.GetChildOwner: TComponent;
  5524. begin
  5525.   Result := nil;
  5526. end;
  5527.  
  5528. function TComponent.GetChildParent: TComponent;
  5529. begin
  5530.   Result := Self;
  5531. end;
  5532.  
  5533. procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer);
  5534. begin
  5535. end;
  5536.  
  5537. function TComponent.GetParentComponent: TComponent;
  5538. begin
  5539.   Result := nil;
  5540. end;
  5541.  
  5542. procedure TComponent.SetParentComponent(Value: TComponent);
  5543. begin
  5544. end;
  5545.  
  5546. procedure TComponent.Updating;
  5547. begin
  5548.   Include(FComponentState, csUpdating);
  5549. end;
  5550.  
  5551. procedure TComponent.Updated;
  5552. begin
  5553.   Exclude(FComponentState, csUpdating);
  5554. end;
  5555.  
  5556. procedure TComponent.Loaded;
  5557. begin
  5558.   Exclude(FComponentState, csLoading);
  5559. end;
  5560.  
  5561. procedure TComponent.ReadState(Reader: TReader);
  5562. begin
  5563.   Reader.ReadData(Self);
  5564. end;
  5565.  
  5566. procedure TComponent.WriteState(Writer: TWriter);
  5567. begin
  5568.   Writer.WriteData(Self);
  5569. end;
  5570.  
  5571. procedure TComponent.ValidateRename(AComponent: TComponent;
  5572.   const CurName, NewName: string);
  5573. begin
  5574.   if (AComponent <> nil) and (CompareText(CurName, NewName) <> 0) and
  5575.     (FindComponent(NewName) <> nil) then
  5576.     raise EComponentError.CreateResFmt(SDuplicateName, [NewName]);
  5577.   if (csDesigning in ComponentState) and (Owner <> nil) then
  5578.     Owner.ValidateRename(AComponent, CurName, NewName);
  5579. end;
  5580.  
  5581. function TComponent.FindComponent(const AName: string): TComponent;
  5582. var
  5583.   I: Integer;
  5584. begin
  5585.   if (AName <> '') and (FComponents <> nil) then
  5586.     for I := 0 to FComponents.Count - 1 do
  5587.     begin
  5588.       Result := FComponents[I];
  5589.       if CompareText(Result.FName, AName) = 0 then Exit;
  5590.     end;
  5591.   Result := nil;
  5592. end;
  5593.  
  5594. procedure TComponent.SetName(const NewName: TComponentName);
  5595. begin
  5596.   if FName <> NewName then
  5597.   begin
  5598.     if (NewName <> '') and not IsValidIdent(NewName) then
  5599.       raise EComponentError.CreateResFmt(SInvalidName, [NewName]);
  5600.     if FOwner <> nil then
  5601.       FOwner.ValidateRename(Self, FName, NewName) else
  5602.       ValidateRename(nil, FName, NewName);
  5603.     SetReference(False);
  5604.     ChangeName(NewName);
  5605.     SetReference(True);
  5606.   end;
  5607. end;
  5608.  
  5609. procedure TComponent.ChangeName(const NewName: TComponentName);
  5610. begin
  5611.   FName := NewName;
  5612. end;
  5613.  
  5614. function TComponent.GetComponentIndex: Integer;
  5615. begin
  5616.   if (FOwner <> nil) and (FOwner.FComponents <> nil) then
  5617.     Result := FOwner.FComponents.IndexOf(Self) else
  5618.     Result := -1;
  5619. end;
  5620.  
  5621. function TComponent.GetComponent(AIndex: Integer): TComponent;
  5622. begin
  5623.   if FComponents = nil then ListError(SListIndexError);
  5624.   Result := FComponents[AIndex];
  5625. end;
  5626.  
  5627. function TComponent.GetComponentCount: Integer;
  5628. begin
  5629.   if FComponents <> nil then
  5630.     Result := FComponents.Count else
  5631.     Result := 0;
  5632. end;
  5633.  
  5634. procedure TComponent.SetComponentIndex(Value: Integer);
  5635. var
  5636.   I, Count: Integer;
  5637. begin
  5638.   if FOwner <> nil then
  5639.   begin
  5640.     I := FOwner.FComponents.IndexOf(Self);
  5641.     if I >= 0 then
  5642.     begin
  5643.       Count := FOwner.FComponents.Count;
  5644.       if Value < 0 then Value := 0;
  5645.       if Value >= Count then Value := Count - 1;
  5646.       if Value <> I then
  5647.       begin
  5648.         FOwner.FComponents.Delete(I);
  5649.         FOwner.FComponents.Insert(Value, Self);
  5650.       end;
  5651.     end;
  5652.   end;
  5653. end;
  5654.  
  5655. procedure TComponent.SetAncestor(Value: Boolean);
  5656. var
  5657.   I: Integer;
  5658. begin
  5659.   if Value then
  5660.     Include(FComponentState, csAncestor) else
  5661.     Exclude(FComponentState, csAncestor);
  5662.   for I := 0 to ComponentCount - 1 do
  5663.     Components[I].SetAncestor(Value);
  5664. end;
  5665.  
  5666. procedure TComponent.SetDesigning(Value: Boolean);
  5667. var
  5668.   I: Integer;
  5669. begin
  5670.   if Value then
  5671.     Include(FComponentState, csDesigning) else
  5672.     Exclude(FComponentState, csDesigning);
  5673.   for I := 0 to ComponentCount - 1 do Components[I].SetDesigning(Value);
  5674. end;
  5675.  
  5676. procedure TComponent.SetReference(Enable: Boolean);
  5677. var
  5678.   Field: ^TComponent;
  5679. begin
  5680.   if FOwner <> nil then
  5681.   begin
  5682.     Field := FOwner.FieldAddress(FName);
  5683.     if Field <> nil then
  5684.       if Enable then Field^ := Self else Field^ := nil;
  5685.   end;
  5686. end;
  5687.  
  5688. procedure FreeIntConstList;
  5689. var
  5690.   I: Integer;
  5691. begin
  5692.   for I := 0 to IntConstList.Count - 1 do
  5693.     TIntConst(IntConstList[I]).Free;
  5694.   IntConstList.Free;
  5695. end;
  5696.  
  5697. initialization
  5698.   ClassList := TList.Create;
  5699.   ClassAliasList := TStringList.Create;
  5700.   IntConstList := TList.Create;
  5701.   GlobalFixupList := TList.Create;
  5702.   MainThreadID := GetCurrentThreadID;
  5703.   GlobalLists := TList.Create;
  5704.  
  5705. finalization
  5706.   ClassList.Free;
  5707.   ClassAliasList.Free;
  5708.   FreeIntConstList;
  5709.   RemoveFixupReferences(nil, '');
  5710.   GlobalFixupList.Free;
  5711.   GlobalLists.Free;
  5712.  
  5713. end.
  5714.