home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / vp21beta.zip / ARTLSRC.RAR / CLASSES.PAS < prev    next >
Pascal/Delphi Source File  |  2000-08-15  |  33KB  |  930 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {       Delphi Visual Component Library                 }
  4. {                                                       }
  5. {       Copyright (c) 1995,96 Borland International     }
  6. {                                                       }
  7. {*******************************************************}
  8.  
  9. unit Classes;
  10.  
  11. {$R-,H+,X+,T-}
  12. {&Delphi+,Frame-,PureInt+,SmartLink+}
  13.  
  14. interface
  15.  
  16. uses
  17.   VpSysLow, SysUtils;
  18.  
  19. const
  20.  
  21. { Maximum TList size }
  22.  
  23.   MaxListSize = Maxint div 16;
  24.  
  25. { TStream seek origins }
  26.  
  27.   soFromBeginning = 0;
  28.   soFromCurrent = 1;
  29.   soFromEnd = 2;
  30.  
  31. { TFileStream create mode }
  32.  
  33.   fmCreate = $FFFF;
  34.  
  35. { TParser special tokens }
  36.  
  37.   toEOF     = Char(0);
  38.   toSymbol  = Char(1);
  39.   toString  = Char(2);
  40.   toInteger = Char(3);
  41.   toFloat   = Char(4);
  42.  
  43. type
  44.  
  45. { Text alignment types }
  46.  
  47.   TAlignment = (taLeftJustify, taRightJustify, taCenter);
  48.   TLeftRight = taLeftJustify..taRightJustify;
  49.  
  50. { Types used by standard events }
  51.  
  52.   TShiftState = set of (ssShift, ssAlt, ssCtrl,
  53.     ssLeft, ssRight, ssMiddle, ssDouble);
  54.  
  55.   THelpContext = -MaxLongint..MaxLongint;
  56.  
  57. { Standard events }
  58.  
  59.   TNotifyEvent = procedure(Sender: TObject) of object;
  60.   THelpEvent = function (Command: Word; Data: Longint;
  61.     var CallHelp: Boolean): Boolean of object;
  62.   TGetStrProc = procedure(const S: string) of object;
  63.  
  64. { Exception classes }
  65.  
  66.   EStreamError = class(Exception);
  67.   EFCreateError = class(EStreamError);
  68.   EFOpenError = class(EStreamError);
  69.   EFilerError = class(EStreamError);
  70.   EReadError = class(EFilerError);
  71.   EWriteError = class(EFilerError);
  72.   EClassNotFound = class(EFilerError);
  73.   EMethodNotFound = class(EFilerError);
  74.   EInvalidImage = class(EFilerError);
  75.   EResNotFound = class(Exception);
  76.   EListError = class(Exception);
  77.   EBitsError = class(Exception);
  78.   EStringListError = class(Exception);
  79.   EComponentError = class(Exception);
  80.   EParserError = class(Exception);
  81. { Duplicate management }
  82.  
  83.   TDuplicates = (dupIgnore, dupAccept, dupError);
  84.  
  85. { Forward class declarations }
  86.  
  87.   TStream = class;
  88.   TFiler = class;
  89.   TReader = class;
  90.   TWriter = class;
  91.   TComponent = class;
  92.  
  93. { TList class }
  94.  
  95.   PPointerList = ^TPointerList;
  96.   TPointerList = array[0..MaxListSize - 1] of Pointer;
  97.   TListSortCompare = function (Item1, Item2: Pointer): Integer;
  98.  
  99.   TList = class(TObject)
  100.   private
  101.     FList: PPointerList;
  102.     FCount: Integer;
  103.     FCapacity: Integer;
  104.   protected
  105.     procedure Error; virtual;
  106.     function Get(Index: Integer): Pointer;
  107.     procedure Grow; virtual;
  108.     procedure Put(Index: Integer; Item: Pointer);
  109.     procedure SetCapacity(NewCapacity: Integer);
  110.     procedure SetCount(NewCount: Integer);
  111.   public
  112.     destructor Destroy; override;
  113.     function Add(Item: Pointer): Integer;
  114.     procedure Clear;
  115.     procedure Delete(Index: Integer);
  116.     procedure Exchange(Index1, Index2: Integer);
  117.     function Expand: TList;
  118.     function First: Pointer;
  119.     function IndexOf(Item: Pointer): Integer;
  120.     procedure Insert(Index: Integer; Item: Pointer);
  121.     function Last: Pointer;
  122.     procedure Move(CurIndex, NewIndex: Integer);
  123.     function Remove(Item: Pointer): Integer;
  124.     procedure Pack;
  125.     procedure Sort(Compare: TListSortCompare);
  126.     property Capacity: Integer read FCapacity write SetCapacity;
  127.     property Count: Integer read FCount write SetCount;
  128.     property Items[Index: Integer]: Pointer read Get write Put; default;
  129.     property List: PPointerList read FList;
  130.   end;
  131.  
  132. { TThreadList class }
  133.  
  134.   TThreadList = class
  135.   private
  136.     FList: TList;
  137.     FLock: TSemHandle;
  138.     FDuplicates: TDuplicates;
  139.   public
  140.     constructor Create;
  141.     destructor Destroy; override;
  142.     procedure Add(Item: Pointer);
  143.     procedure Clear;
  144.     function  LockList: TList;
  145.     procedure Remove(Item: Pointer);
  146.     procedure UnlockList;
  147.     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  148.   end;
  149.  
  150. { TBits class }
  151.  
  152.   TBits = class
  153.   private
  154.     FSize: Integer;
  155.     FBits: Pointer;
  156.     procedure Error;
  157.     procedure SetSize(Value: Integer);
  158.     procedure SetBit(Index: Integer; Value: Boolean);
  159.     function GetBit(Index: Integer): Boolean;
  160.   public
  161.     destructor Destroy; override;
  162.     function OpenBit: Integer;
  163.     property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
  164.     property Size: Integer read FSize write SetSize;
  165.   end;
  166.  
  167. { TPersistent abstract class }
  168.  
  169. {$M+}
  170.  
  171.   TPersistent = class(TObject)
  172.   private
  173.     procedure AssignError(Source: TPersistent);
  174.   protected
  175.     procedure AssignTo(Dest: TPersistent); virtual;
  176.     procedure DefineProperties(Filer: TFiler); virtual;
  177.     function  GetOwner: TPersistent; dynamic;
  178.   public
  179.     procedure Assign(Source: TPersistent); virtual;
  180.     function  GetNamePath: string; dynamic;
  181.   end;
  182.  
  183. {$M-}
  184.  
  185. { TPersistent class reference type }
  186.  
  187.   TPersistentClass = class of TPersistent;
  188.  
  189. { TCollection class }
  190.  
  191.   TCollection = class;
  192.  
  193.   TCollectionItem = class(TPersistent)
  194.   private
  195.     FCollection: TCollection;
  196.     function GetIndex: Integer;
  197.     procedure SetCollection(Value: TCollection);
  198.   protected
  199.     procedure Changed(AllItems: Boolean);
  200.     function GetOwner: TPersistent; override;
  201.     function GetDisplayName: string; virtual;
  202.     procedure SetIndex(Value: Integer); virtual;
  203.     procedure SetDisplayName(const Value: string); virtual;
  204.   public
  205.     constructor Create(Collection: TCollection); virtual;
  206.     destructor Destroy; override;
  207.     function GetNamePath: string; override;
  208.     property Collection: TCollection read FCollection write SetCollection;
  209.     property Index: Integer read GetIndex write SetIndex;
  210.     property DisplayName: string read GetDisplayName write SetDisplayName;
  211.   end;
  212.  
  213.   TCollectionItemClass = class of TCollectionItem;
  214.  
  215.   TCollection = class(TPersistent)
  216.   private
  217.     FItemClass: TCollectionItemClass;
  218.     FItems: TList;
  219.     FUpdateCount: Integer;
  220.     FPropName: string;
  221.     function GetCount: Integer;
  222.     function GetPropName: string;
  223.     procedure InsertItem(Item: TCollectionItem);
  224.     procedure RemoveItem(Item: TCollectionItem);
  225.   protected
  226.     procedure Changed;
  227.     function GetItem(Index: Integer): TCollectionItem;
  228.     procedure SetItem(Index: Integer; Value: TCollectionItem);
  229.     procedure Update(Item: TCollectionItem); virtual;
  230.     property PropName: string read GetPropName write FPropName;
  231.   public
  232.     constructor Create(ItemClass: TCollectionItemClass);
  233.     destructor Destroy; override;
  234.     function Add: TCollectionItem;
  235.     procedure Assign(Source: TPersistent); override;
  236.     procedure BeginUpdate;
  237.     procedure Clear;
  238.     procedure EndUpdate;
  239.     function GetNamePath: string; override;
  240.     function Insert(Index: Integer): TCollectionItem;
  241.     property Count: Integer read GetCount;
  242.     property ItemClass: TCollectionItemClass read FItemClass;
  243.     property Items[Index: Integer]: TCollectionItem read GetItem write SetItem;
  244.   end;
  245.  
  246. { TStrings class }
  247.  
  248.   TStrings = class(TPersistent)
  249.   private
  250.     FUpdateCount: Integer;
  251.     function GetCommaText: string;
  252.     function GetName(Index: Integer): string;
  253.     function GetValue(const Name: string): string;
  254.     procedure ReadData(Reader: TReader);
  255.     procedure SetCommaText(const Value: string);
  256.     procedure SetValue(const Name, Value: string);
  257.     procedure WriteData(Writer: TWriter);
  258.   protected
  259.     procedure DefineProperties(Filer: TFiler); override;
  260.     function Get(Index: Integer): string; virtual; abstract;
  261.     function GetCapacity: Integer; virtual;
  262.     function GetCount: Integer; virtual; abstract;
  263.     function GetObject(Index: Integer): TObject; virtual;
  264.     function GetTextStr: string; virtual;
  265.     procedure Put(Index: Integer; const S: string); virtual;
  266.     procedure PutObject(Index: Integer; AObject: TObject); virtual;
  267.     procedure SetCapacity(NewCapacity: Integer); virtual;
  268.     procedure SetTextStr(const Value: string); virtual;
  269.     procedure SetUpdateState(Updating: Boolean); virtual;
  270.   public
  271.     function Add(const S: string): Integer; virtual;
  272.     function AddObject(const S: string; AObject: TObject): Integer; virtual;
  273.     procedure Append(const S: string);
  274.     procedure AddStrings(Strings: TStrings); virtual;
  275.     procedure Assign(Source: TPersistent); override;
  276.     procedure BeginUpdate;
  277.     procedure Clear; virtual; abstract;
  278.     procedure Delete(Index: Integer); virtual; abstract;
  279.     procedure EndUpdate;
  280.     function Equals(Strings: TStrings): Boolean;
  281.     procedure Exchange(Index1, Index2: Integer); virtual;
  282.     function GetText: PChar; virtual;
  283.     function IndexOf(const S: string): Integer; virtual;
  284.     function IndexOfName(const Name: string): Integer;
  285.     function IndexOfObject(AObject: TObject): Integer;
  286.     procedure Insert(Index: Integer; const S: string); virtual; abstract;
  287.     procedure InsertObject(Index: Integer; const S: string;
  288.       AObject: TObject);
  289.     procedure LoadFromFile(const FileName: string); virtual;
  290.     procedure LoadFromStream(Stream: TStream); virtual;
  291.     procedure Move(CurIndex, NewIndex: Integer); virtual;
  292.     procedure SaveToFile(const FileName: string); virtual;
  293.     procedure SaveToStream(Stream: TStream); virtual;
  294.     procedure SetText(Text: PChar); virtual;
  295.     property Capacity: Integer read GetCapacity write SetCapacity;
  296.     property CommaText: string read GetCommaText write SetCommaText;
  297.     property Count: Integer read GetCount;
  298.     property Names[Index: Integer]: string read GetName;
  299.     property Objects[Index: Integer]: TObject read GetObject write PutObject;
  300.     property Values[const Name: string]: string read GetValue write SetValue;
  301.     property Strings[Index: Integer]: string read Get write Put; default;
  302.     property Text: string read GetTextStr write SetTextStr;
  303.   end;
  304.  
  305. { TStringList class }
  306.  
  307.   TStringList = class;
  308.  
  309.   PStringItem = ^TStringItem;
  310.   TStringItem = record
  311.     FString: string;
  312.     FObject: TObject;
  313.   end;
  314.  
  315.   PStringItemList = ^TStringItemList;
  316.   TStringItemList = array[0..MaxListSize] of TStringItem;
  317.   TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
  318.  
  319.   TStringList = class(TStrings)
  320.   private
  321.     FList: PStringItemList;
  322.     FCount: Integer;
  323.     FCapacity: Integer;
  324.     FSorted: Boolean;
  325.     FDuplicates: TDuplicates;
  326.     FOnChange: TNotifyEvent;
  327.     FOnChanging: TNotifyEvent;
  328.     procedure ExchangeItems(Index1, Index2: Integer);
  329.     procedure Grow;
  330.     procedure QuickSort(L, R: Integer; SCompare: TStringListSortCompare);
  331.     procedure InsertItem(Index: Integer; const S: string);
  332.     procedure SetSorted(Value: Boolean);
  333.   protected
  334.     procedure Changed; virtual;
  335.     procedure Changing; virtual;
  336.     function Get(Index: Integer): string; override;
  337.     function GetCapacity: Integer; override;
  338.     function GetCount: Integer; override;
  339.     function GetObject(Index: Integer): TObject; override;
  340.     procedure Put(Index: Integer; const S: string); override;
  341.     procedure PutObject(Index: Integer; AObject: TObject); override;
  342.     procedure SetCapacity(NewCapacity: Integer); override;
  343.     procedure SetUpdateState(Updating: Boolean); override;
  344.   public
  345.     destructor Destroy; override;
  346.     function Add(const S: string): Integer; override;
  347.     procedure Clear; override;
  348.     procedure Delete(Index: Integer); override;
  349.     procedure Exchange(Index1, Index2: Integer); override;
  350.     function Find(const S: string; var Index: Integer): Boolean; virtual;
  351.     function IndexOf(const S: string): Integer; override;
  352.     procedure Insert(Index: Integer; const S: string); override;
  353.     procedure Sort; virtual;
  354.     procedure CustomSort(Compare: TStringListSortCompare); virtual;
  355.     property Duplicates: TDuplicates read FDuplicates write FDuplicates;
  356.     property Sorted: Boolean read FSorted write SetSorted;
  357.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  358.     property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
  359.   end;
  360.  
  361. { TStream abstract class }
  362.  
  363.   TStream = class(TObject)
  364.   private
  365.     function GetPosition: Longint;
  366.     procedure SetPosition(Pos: Longint);
  367.     function GetSize: Longint;
  368.   protected
  369.     procedure SetSize(NewSize: Longint); virtual;
  370.   public
  371.     function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
  372.     function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
  373.     function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
  374.     procedure ReadBuffer(var Buffer; Count: Longint);
  375.     procedure WriteBuffer(const Buffer; Count: Longint);
  376.     function CopyFrom(Source: TStream; Count: Longint): Longint;
  377.     function ReadComponent(Instance: TComponent): TComponent;
  378.     function ReadComponentRes(Instance: TComponent): TComponent;
  379.     procedure WriteComponent(Instance: TComponent);
  380.     procedure WriteComponentRes(const ResName: string; Instance: TComponent);
  381.     procedure WriteDescendent(Instance, Ancestor: TComponent);
  382.     procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
  383.     procedure ReadResHeader;
  384.     property Position: Longint read GetPosition write SetPosition;
  385.     property Size: Longint read GetSize write SetSize;
  386.   end;
  387.  
  388. { THandleStream class }
  389.  
  390.   THandleStream = class(TStream)
  391.   private
  392.     FHandle: Integer;
  393.   protected
  394.     procedure SetSize(NewSize: Longint); override;
  395.   public
  396.     constructor Create(AHandle: Integer);
  397.     function Read(var Buffer; Count: Longint): Longint; override;
  398.     function Write(const Buffer; Count: Longint): Longint; override;
  399.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  400.     property Handle: Integer read FHandle;
  401.   end;
  402.  
  403. { TFileStream class }
  404.  
  405.   TFileStream = class(THandleStream)
  406.   public
  407.     constructor Create(const FileName: string; Mode: Word);
  408.     destructor Destroy; override;
  409.   end;
  410.  
  411. { TCustomMemoryStream abstract class }
  412.  
  413.   TCustomMemoryStream = class(TStream)
  414.   private
  415.     FMemory: Pointer;
  416.     FSize, FPosition: Longint;
  417.   protected
  418.     procedure SetPointer(Ptr: Pointer; Size: Longint);
  419.   public
  420.     function Read(var Buffer; Count: Longint): Longint; override;
  421.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  422.     procedure SaveToStream(Stream: TStream);
  423.     procedure SaveToFile(const FileName: string);
  424.     property Memory: Pointer read FMemory;
  425.   end;
  426.  
  427. { TMemoryStream }
  428.  
  429.   TMemoryStream = class(TCustomMemoryStream)
  430.   private
  431.     FCapacity: Longint;
  432.     procedure SetCapacity(NewCapacity: Longint);
  433.   protected
  434.     function Realloc(var NewCapacity: Longint): Pointer; virtual;
  435.     property Capacity: Longint read FCapacity write SetCapacity;
  436.   public
  437.     destructor Destroy; override;
  438.     procedure Clear;
  439.     procedure LoadFromStream(Stream: TStream);
  440.     procedure LoadFromFile(const FileName: string);
  441.     procedure SetSize(NewSize: Longint); override;
  442.     function Write(const Buffer; Count: Longint): Longint; override;
  443.   end;
  444.  
  445. { TStringStream }
  446.  
  447.   TStringStream = class(TStream)
  448.   private
  449.     FDataString: string;
  450.     FPosition: Integer;
  451.   protected
  452.     procedure SetSize(NewSize: Longint); override;
  453.   public
  454.     constructor Create(const AString: string);
  455.     function Read(var Buffer; Count: Longint): Longint; override;
  456.     function ReadString(Count: Longint): string;
  457.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  458.     function Write(const Buffer; Count: Longint): Longint; override;
  459.     procedure WriteString(const AString: string);
  460.     property DataString: string read FDataString;
  461.   end;
  462.  
  463. { TResourceStream }
  464.  
  465.   TResourceStream = class(TCustomMemoryStream)
  466.   private
  467.   {$IFDEF OS2}
  468.     HResInfo: Pointer;
  469.   {$ENDIF}
  470.   {$IFDEF WIN32}
  471.     HResInfo: THandle;
  472.     HGlobal: THandle;
  473.   {$ENDIF}
  474.   {$IFDEF DPMI32}
  475.     // Named resources not supported
  476.   {$ENDIF}
  477.     procedure Initialize(Instance: THandle; Name, ResType: PChar);
  478.   public
  479.     constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
  480.     constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
  481.     destructor Destroy; override;
  482.     function Write(const Buffer; Count: Longint): Longint; override;
  483.   end;
  484.  
  485. { TFiler }
  486.  
  487.   TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
  488.     vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
  489.     vaNil, vaCollection, vaSingle, vaCurrency, vaDate);
  490.  
  491.   TFilerFlag = (ffInherited, ffChildPos);
  492.   TFilerFlags = set of TFilerFlag;
  493.  
  494.   TReaderProc = procedure(Reader: TReader) of object;
  495.   TWriterProc = procedure(Writer: TWriter) of object;
  496.   TStreamProc = procedure(Stream: TStream) of object;
  497.  
  498.   TFiler = class(TObject)
  499.   private
  500.     FStream: TStream;
  501.     FBuffer: Pointer;
  502.     FBufSize: Integer;
  503.     FBufPos: Integer;
  504.     FBufEnd: Integer;
  505.     FRoot: TComponent;
  506.     FAncestor: TPersistent;
  507.     FIgnoreChildren: Boolean;
  508.   public
  509.     constructor Create(Stream: TStream; BufSize: Integer);
  510.     destructor Destroy; override;
  511.     procedure DefineProperty(const Name: string;
  512.       ReadData: TReaderProc; WriteData: TWriterProc;
  513.       HasData: Boolean); virtual; abstract;
  514.     procedure DefineBinaryProperty(const Name: string;
  515.       ReadData, WriteData: TStreamProc;
  516.       HasData: Boolean); virtual; abstract;
  517.     procedure FlushBuffer; virtual; abstract;
  518.     property Root: TComponent read FRoot write FRoot;
  519.     property Ancestor: TPersistent read FAncestor write FAncestor;
  520.     property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren;
  521.   end;
  522.  
  523. { TReader }
  524.  
  525.   TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
  526.     var Address: Pointer; var Error: Boolean) of object;
  527.   TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
  528.     var Name: string) of object;
  529.   TReadComponentsProc = procedure(Component: TComponent) of object;
  530.   TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;
  531.  
  532.   TReader = class(TFiler)
  533.   private
  534.     FOwner: TComponent;
  535.     FParent: TComponent;
  536.     FFixups: TList;
  537.     FLoaded: TList;
  538.     FOnFindMethod: TFindMethodEvent;
  539.     FOnSetName: TSetNameEvent;
  540.     FOnError: TReaderError;
  541.     FCanHandleExcepts: Boolean;
  542.     FPropName: string;
  543.     procedure CheckValue(Value: TValueType);
  544.     procedure DoFixupReferences;
  545.     procedure FreeFixups;
  546.     function GetPosition: Longint;
  547.     procedure PropertyError;
  548.     procedure ReadBuffer;
  549.     procedure ReadData(Instance: TComponent);
  550.     procedure ReadDataInner(Instance: TComponent);
  551.     procedure ReadProperty(AInstance: TPersistent);
  552.     procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
  553.     function ReadSet(SetType: Pointer): Integer;
  554.     procedure SetPosition(Value: Longint);
  555.     procedure SkipSetBody;
  556.     procedure SkipValue;
  557.     procedure SkipProperty;
  558.     procedure SkipComponent(SkipHeader: Boolean);
  559.   protected
  560.     function Error(const Message: string): Boolean; virtual;
  561.     function FindMethod(Root: TComponent; const MethodName: string): Pointer; virtual;
  562.     function NextValue: TValueType;
  563.     procedure SetName(Component: TComponent; var Name: string); virtual;
  564.   public
  565.     destructor Destroy; override;
  566.     procedure BeginReferences;
  567.     procedure DefineProperty(const Name: string;
  568.       ReadData: TReaderProc; WriteData: TWriterProc;
  569.       HasData: Boolean); override;
  570.     procedure DefineBinaryProperty(const Name: string;
  571.       ReadData, WriteData: TStreamProc;
  572.       HasData: Boolean); override;
  573.     function EndOfList: Boolean;
  574.     procedure EndReferences;
  575.     procedure FixupReferences;
  576.     procedure FlushBuffer; override;
  577.     procedure Read(var Buf; Count: Longint);
  578.     function ReadBoolean: Boolean;
  579.     function ReadChar: Char;
  580.     procedure ReadCollection(Collection: TCollection);
  581.     function ReadComponent(Component: TComponent): TComponent;
  582.     procedure ReadComponents(AOwner, AParent: TComponent;
  583.       Proc: TReadComponentsProc);
  584.     function ReadFloat: Extended;
  585.     function ReadSingle: Single;
  586.     function ReadCurrency: Currency;
  587.     function ReadDate: TDateTime;
  588.     function ReadIdent: string;
  589.     function ReadInteger: Longint;
  590.     procedure ReadListBegin;
  591.     procedure ReadListEnd;
  592.     procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer);
  593.     function ReadRootComponent(Root: TComponent): TComponent;
  594.     procedure ReadSignature;
  595.     function ReadStr: string;
  596.     function ReadString: string;
  597.     function ReadValue: TValueType;
  598.     property Owner: TComponent read FOwner write FOwner;
  599.     property Parent: TComponent read FParent write FParent;
  600.     property Position: Longint read GetPosition write SetPosition;
  601.     property OnError: TReaderError read FOnError write FOnError;
  602.     property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod;
  603.     property OnSetName: TSetNameEvent read FOnSetName write FOnSetName;
  604.   end;
  605.  
  606. { TWriter }
  607.  
  608.   TWriter = class(TFiler)
  609.   private
  610.     FRootAncestor: TComponent;
  611.     FPropPath: string;
  612.     FAncestorList: TList;
  613.     FAncestorPos: Integer;
  614.     FChildPos: Integer;
  615.     procedure AddAncestor(Component: TComponent);
  616.     function GetPosition: Longint;
  617.     procedure SetPosition(Value: Longint);
  618.     procedure WriteBinary(WriteData: TStreamProc);
  619.     procedure WriteBuffer;
  620.     procedure WriteData(Instance: TComponent); virtual; // linker optimization
  621.     procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  622.     procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  623.     procedure WriteProperties(Instance: TPersistent);
  624.     procedure WritePropName(const PropName: string);
  625.     procedure WriteValue(Value: TValueType);
  626.   public
  627.     destructor Destroy; override;
  628.     procedure DefineProperty(const Name: string;
  629.       ReadData: TReaderProc; WriteData: TWriterProc;
  630.       HasData: Boolean); override;
  631.     procedure DefineBinaryProperty(const Name: string;
  632.       ReadData, WriteData: TStreamProc;
  633.       HasData: Boolean); override;
  634.     procedure FlushBuffer; override;
  635.     procedure Write(const Buf; Count: Longint);
  636.     procedure WriteBoolean(Value: Boolean);
  637.     procedure WriteCollection(Value: TCollection);
  638.     procedure WriteComponent(Component: TComponent);
  639.     procedure WriteChar(Value: Char);
  640.     procedure WriteDescendent(Root: TComponent; AAncestor: TComponent);
  641.     procedure WriteFloat(const Value: Extended);
  642.     procedure WriteSingle(const Value: Single);
  643.     procedure WriteCurrency(const Value: Currency);
  644.     procedure WriteDate(const Value: TDateTime);
  645.     procedure WriteIdent(const Ident: string);
  646.     procedure WriteInteger(Value: Longint);
  647.     procedure WriteListBegin;
  648.     procedure WriteListEnd;
  649.     procedure WriteRootComponent(Root: TComponent);
  650.     procedure WriteSignature;
  651.     procedure WriteStr(const Value: string);
  652.     procedure WriteString(const Value: string);
  653.     property Position: Longint read GetPosition write SetPosition;
  654.     property RootAncestor: TComponent read FRootAncestor write FRootAncestor;
  655.   end;
  656.  
  657. { TParser }
  658.  
  659.   TParser = class(TObject)
  660.   private
  661.     FStream: TStream;
  662.     FOrigin: Longint;
  663.     FBuffer: PChar;
  664.     FBufPtr: PChar;
  665.     FBufEnd: PChar;
  666.     FSourcePtr: PChar;
  667.     FSourceEnd: PChar;
  668.     FTokenPtr: PChar;
  669.     FStringPtr: PChar;
  670.     FSourceLine: Integer;
  671.     FSaveChar: Char;
  672.     FToken: Char;
  673.     FFloatType: Char;
  674.     procedure ReadBuffer;
  675.     procedure SkipBlanks;
  676.   public
  677.     constructor Create(Stream: TStream);
  678.     destructor Destroy; override;
  679.     procedure CheckToken(T: Char);
  680.     procedure CheckTokenSymbol(const S: string);
  681.     procedure Error(Ident: Integer);
  682.     procedure ErrorFmt(Ident: Integer; const Args: array of const);
  683.     procedure ErrorStr(const Message: string);
  684.     procedure HexToBinary(Stream: TStream);
  685.     function NextToken: Char;
  686.     function SourcePos: Longint;
  687.     function TokenComponentIdent: String;
  688.     function TokenFloat: Extended;
  689.     function TokenInt: Longint;
  690.     function TokenString: string;
  691.     function TokenSymbolIs(const S: string): Boolean;
  692.     property FloatType: Char read FFloatType;
  693.     property SourceLine: Integer read FSourceLine;
  694.     property Token: Char read FToken;
  695.   end;
  696. (*
  697. { TThread }
  698.  
  699.   EThread = class(Exception);
  700.  
  701.   TThreadMethod = procedure of object;
  702.   TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  703.     tpTimeCritical);
  704.  
  705.   TThread = class
  706.   private
  707. //    FHandle: THandle;
  708.     FThreadID: THandle;
  709.     FTerminated: Boolean;
  710.     FSuspended: Boolean;
  711.     FMainThreadWaiting: Boolean;
  712.     FFreeOnTerminate: Boolean;
  713.     FFinished: Boolean;
  714.     FReturnValue: Integer;
  715.     FOnTerminate: TNotifyEvent;
  716.     FMethod: TThreadMethod;
  717.     FSynchronizeException: TObject;
  718.     procedure CallOnTerminate;
  719.     function GetPriority: TThreadPriority;
  720.     procedure SetPriority(Value: TThreadPriority);
  721.     procedure SetSuspended(Value: Boolean);
  722.   protected
  723.     procedure DoTerminate; virtual;
  724.     procedure Execute; virtual; abstract;
  725.     procedure Synchronize(Method: TThreadMethod);
  726.     property ReturnValue: Integer read FReturnValue write FReturnValue;
  727.     property Terminated: Boolean read FTerminated;
  728.   public
  729.     constructor Create(CreateSuspended: Boolean);
  730.     destructor Destroy; override;
  731.     procedure Resume;
  732.     procedure Suspend;
  733.     procedure Terminate;
  734.     function WaitFor: Integer;
  735.     property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
  736.     property Handle: THandle read FHandle;
  737.     property Priority: TThreadPriority read GetPriority write SetPriority;
  738.     property Suspended: Boolean read FSuspended write SetSuspended;
  739.     property ThreadID: THandle read FThreadID;
  740.     property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
  741.   end;
  742. *)
  743. { TComponent class }
  744.  
  745.   TOperation = (opInsert, opRemove);
  746.   TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
  747.     csDesigning, csAncestor, csUpdating, csFixups);
  748.   TComponentStyle = set of (csInheritable, csCheckPropAvail);
  749.   TGetChildProc = procedure (Child: TComponent) of object;
  750.  
  751.   TComponentName = string;
  752.  
  753.   TComponent = class(TPersistent)
  754.   private
  755.     FOwner: TComponent;
  756.     FName: TComponentName;
  757.     FTag: Longint;
  758.     FComponents: TList;
  759.     FFreeNotifies: TList;
  760.     FDesignInfo: Longint;
  761.     FComponentState: TComponentState;
  762.     function GetComponent(AIndex: Integer): TComponent;
  763.     function GetComponentCount: Integer;
  764.     function GetComponentIndex: Integer;
  765.     procedure Insert(AComponent: TComponent);
  766.     procedure ReadLeft(Reader: TReader);
  767.     procedure ReadTop(Reader: TReader);
  768.     procedure Remove(AComponent: TComponent);
  769.     procedure SetComponentIndex(Value: Integer);
  770.     procedure SetReference(Enable: Boolean);
  771.     procedure WriteLeft(Writer: TWriter);
  772.     procedure WriteTop(Writer: TWriter);
  773.   protected
  774.     FComponentStyle: TComponentStyle;
  775.     procedure ChangeName(const NewName: TComponentName);
  776.     procedure DefineProperties(Filer: TFiler); override;
  777.     procedure GetChildren(Proc: TGetChildProc); dynamic;
  778.     function GetChildOwner: TComponent; dynamic;
  779.     function GetChildParent: TComponent; dynamic;
  780.     function GetOwner: TPersistent; override;
  781.     procedure Loaded; virtual;
  782.     procedure Notification(AComponent: TComponent;
  783.       Operation: TOperation); virtual;
  784.     procedure ReadState(Reader: TReader); virtual;
  785.     procedure SetAncestor(Value: Boolean);
  786.     procedure SetDesigning(Value: Boolean);
  787.     procedure SetName(const NewName: TComponentName); virtual;
  788.     procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic;
  789.     procedure SetParentComponent(Value: TComponent); dynamic;
  790.     procedure Updating; dynamic;
  791.     procedure Updated; dynamic;
  792.     procedure ValidateRename(AComponent: TComponent;
  793.       const CurName, NewName: string); virtual;
  794.     procedure WriteState(Writer: TWriter); virtual;
  795.   public
  796.     constructor Create(AOwner: TComponent); virtual;
  797.     destructor Destroy; override;
  798.     procedure DestroyComponents;
  799.     procedure Destroying;
  800.     function FindComponent(const AName: string): TComponent;
  801.     function GetParentComponent: TComponent; dynamic;
  802.     function HasParent: Boolean; dynamic;
  803.     procedure FreeNotification(AComponent: TComponent);
  804.     function GetNamePath: string; override;
  805.     procedure InsertComponent(AComponent: TComponent);
  806.     procedure RemoveComponent(AComponent: TComponent);
  807.     property Components[Index: Integer]: TComponent read GetComponent;
  808.     property ComponentCount: Integer read GetComponentCount;
  809.     property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex;
  810.     property ComponentState: TComponentState read FComponentState;
  811.     property ComponentStyle: TComponentStyle read FComponentStyle;
  812.     property DesignInfo: Longint read FDesignInfo write FDesignInfo;
  813.     property Owner: TComponent read FOwner;
  814.   published
  815.     property Name: TComponentName read FName write SetName stored False;
  816.     property Tag: Longint read FTag write FTag default 0;
  817.   end;
  818.  
  819. { TComponent class reference type }
  820.  
  821.   TComponentClass = class of TComponent;
  822.  
  823. { Component registration handlers }
  824.  
  825. const
  826.   RegisterComponentsProc: procedure(const Page: string;
  827.     ComponentClasses: array of TComponentClass) = nil;
  828.   RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass) = nil;
  829.  
  830. { Point and rectangle constructors }
  831. {
  832. function Point(AX, AY: Integer): TPoint;
  833. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  834. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  835. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  836. }
  837. { Class registration routines }
  838.  
  839. procedure RegisterClass(AClass: TPersistentClass);
  840. procedure RegisterClasses(AClasses: array of TPersistentClass);
  841. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  842. procedure UnRegisterClass(AClass: TPersistentClass);
  843. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  844. function FindClass(const ClassName: string): TPersistentClass;
  845. function GetClass(const AClassName: string): TPersistentClass;
  846.  
  847. { Component registration routines }
  848.  
  849. procedure RegisterComponents(const Page: string;
  850.   ComponentClasses: array of TComponentClass);
  851. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  852.  
  853. { Object filing routines }
  854.  
  855. type
  856.   TIdentMapEntry = record
  857.     Value: Integer;
  858.     Name: String;
  859.   end;
  860.  
  861.   TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
  862.   TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
  863.   TFindGlobalComponent = function(const Name: string): TComponent;
  864.  
  865. var
  866.   MainThreadID: THandle;
  867.   FindGlobalComponent: TFindGlobalComponent;
  868.  
  869. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  870.   IntToIdent: TIntToIdent);
  871. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  872. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  873. function FindIntToIdent(AIntegerType: Pointer): TIntToIdent;
  874. function FindIdentToInt(AIntegerType: Pointer): TIdentToInt;
  875.  
  876. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  877. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  878. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  879. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  880. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  881.  
  882. procedure GlobalFixupReferences;
  883. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  884. procedure GetFixupInstanceNames(Root: TComponent;
  885.   const ReferenceRootName: string; Names: TStrings);
  886. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  887.   NewRootName: string);
  888. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  889.  
  890. procedure BeginGlobalLoading;
  891. procedure NotifyGlobalLoading;
  892. procedure EndGlobalLoading;
  893.  
  894. function CollectionsEqual(C1, C2: TCollection): Boolean;
  895.  
  896. { Object conversion routines }
  897.  
  898. procedure ObjectBinaryToText(Input, Output: TStream);
  899. procedure ObjectTextToBinary(Input, Output: TStream);
  900.  
  901. procedure ObjectResourceToText(Input, Output: TStream);
  902. procedure ObjectTextToResource(Input, Output: TStream);
  903.  
  904. { Utility routines }
  905.  
  906. function LineStart(Buffer, BufPos: PChar): PChar;
  907.  
  908. procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);
  909. function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer;
  910.  
  911. implementation
  912.  
  913. uses
  914. {$IFDEF OS2}
  915.   Os2Def, Os2Base,
  916. {$ENDIF}
  917. {$IFDEF WIN32}
  918.   Windows,
  919. {$ENDIF}
  920. {$IFDEF Linux}
  921.   LnxRes,
  922. {$ENDIF}
  923. {$IFDEF DPMI32}
  924.   Resource,
  925. {$ENDIF}
  926.   Consts, TypInfo;
  927.  
  928. begin
  929. end.
  930.