home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 May / PCP163A.iso / Runimage / Cbuilder4 / Doc / CLASSES.INT < prev    next >
Encoding:
Text File  |  1999-01-26  |  35.2 KB  |  996 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,98 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit Classes;
  11.  
  12. {$R-}
  13.  
  14. { ACTIVEX.HPP is not required by CLASSES.HPP }
  15. (*$NOINCLUDE ActiveX*)
  16.  
  17.  
  18. interface
  19.  
  20. uses SysUtils, Windows, ActiveX;
  21.  
  22. const
  23.  
  24. { Maximum TList size }
  25.  
  26.   MaxListSize = Maxint div 16;
  27.  
  28. { TStream seek origins }
  29.  
  30.   soFromBeginning = 0;
  31.   soFromCurrent = 1;
  32.   soFromEnd = 2;
  33.  
  34. { TFileStream create mode }
  35.  
  36.   fmCreate = $FFFF;
  37.  
  38. { TParser special tokens }
  39.  
  40.   toEOF     = Char(0);
  41.   toSymbol  = Char(1);
  42.   toString  = Char(2);
  43.   toInteger = Char(3);
  44.   toFloat   = Char(4);
  45.   toWString = Char(5);
  46.  
  47.   {!! Moved here from menus.pas !!}
  48.   { TShortCut special values }
  49.   
  50.   scShift = $2000;
  51.   scCtrl = $4000;
  52.   scAlt = $8000;
  53.   scNone = 0;
  54.  
  55. type
  56.  
  57. { Text alignment types }
  58.  
  59.   TAlignment = (taLeftJustify, taRightJustify, taCenter);
  60.   TLeftRight = taLeftJustify..taRightJustify;
  61.   TBiDiMode = (bdLeftToRight, bdRightToLeft, bdRightToLeftNoAlign,
  62.     bdRightToLeftReadingOnly);
  63.  
  64. { Types used by standard events }
  65.  
  66.   TShiftState = set of (ssShift, ssAlt, ssCtrl,
  67.     ssLeft, ssRight, ssMiddle, ssDouble);
  68.  
  69.   THelpContext = -MaxLongint..MaxLongint;
  70.  
  71.   {!! Moved here from menus.pas !!}
  72.   TShortCut = Low(Word)..High(Word);
  73.     
  74. { Standard events }
  75.  
  76.   TNotifyEvent = procedure(Sender: TObject) of object;
  77.   THelpEvent = function (Command: Word; Data: Longint;
  78.     var CallHelp: Boolean): Boolean of object;
  79.   TGetStrProc = procedure(const S: string) of object;
  80.  
  81. { Exception classes }
  82.  
  83.   EStreamError = class(Exception);
  84.   EFCreateError = class(EStreamError);
  85.   EFOpenError = class(EStreamError);
  86.   EFilerError = class(EStreamError);
  87.   EReadError = class(EFilerError);
  88.   EWriteError = class(EFilerError);
  89.   EClassNotFound = class(EFilerError);
  90.   EMethodNotFound = class(EFilerError);
  91.   EInvalidImage = class(EFilerError);
  92.   EResNotFound = class(Exception);
  93.   EListError = class(Exception);
  94.   EBitsError = class(Exception);
  95.   EStringListError = class(Exception);
  96.   EComponentError = class(Exception);
  97.   EParserError = class(Exception);
  98.   EOutOfResources = class(EOutOfMemory);
  99.   EInvalidOperation = class(Exception);
  100.  
  101. { Forward class declarations }
  102.  
  103.   TStream = class;
  104.   TFiler = class;
  105.   TReader = class;
  106.   TWriter = class;
  107.   TComponent = class;
  108.  
  109. { TList class }
  110.  
  111.   PPointerList = ^TPointerList;
  112.   TPointerList = array[0..MaxListSize - 1] of Pointer;
  113.   TListSortCompare = function (Item1, Item2: Pointer): Integer;
  114.  
  115.   TList = class(TObject)
  116.   protected
  117.     function Get(Index: Integer): Pointer;
  118.     procedure Grow; virtual;
  119.     procedure Put(Index: Integer; Item: Pointer);
  120.     procedure SetCapacity(NewCapacity: Integer);
  121.     procedure SetCount(NewCount: Integer);
  122.   public
  123.     destructor Destroy; override;
  124.     function Add(Item: Pointer): Integer;
  125.     procedure Clear; dynamic;
  126.     procedure Delete(Index: Integer);
  127.     class procedure Error(const Msg: string; Data: Integer); virtual;
  128.     procedure Exchange(Index1, Index2: Integer);
  129.     function Expand: TList;
  130.     function First: Pointer;
  131.     function IndexOf(Item: Pointer): Integer;
  132.     procedure Insert(Index: Integer; Item: Pointer);
  133.     function Last: Pointer;
  134.     procedure Move(CurIndex, NewIndex: Integer);
  135.     function Remove(Item: Pointer): Integer;
  136.     procedure Pack;
  137.     procedure Sort(Compare: TListSortCompare);
  138.     property Capacity: Integer;
  139.     property Count: Integer;
  140.     property Items[Index: Integer]: Pointer; default;
  141.     property List: PPointerList;
  142.   end;
  143.  
  144. { TThreadList class }
  145.  
  146.   TThreadList = class
  147.   public
  148.     constructor Create;
  149.     destructor Destroy; override;
  150.     procedure Add(Item: Pointer);
  151.     procedure Clear;
  152.     function  LockList: TList;
  153.     procedure Remove(Item: Pointer);
  154.     procedure UnlockList;
  155.   end;
  156.  
  157. { IInterfaceList interface }
  158.  
  159.   IInterfaceList = interface
  160.   ['{285DEA8A-B865-11D1-AAA7-00C04FB17A72}']
  161.     function Get(Index: Integer): IUnknown;
  162.     function GetCapacity: Integer;
  163.     function GetCount: Integer;
  164.     procedure Put(Index: Integer; Item: IUnknown);
  165.     procedure SetCapacity(NewCapacity: Integer);
  166.     procedure SetCount(NewCount: Integer);
  167.  
  168.     procedure Clear;
  169.     procedure Delete(Index: Integer);
  170.     procedure Exchange(Index1, Index2: Integer);
  171.     function First: IUnknown;
  172.     function IndexOf(Item: IUnknown): Integer;
  173.     function Add(Item: IUnknown): Integer;
  174.     procedure Insert(Index: Integer; Item: IUnknown);
  175.     function Last: IUnknown;
  176.     function Remove(Item: IUnknown): Integer;
  177.     procedure Lock;
  178.     procedure Unlock;
  179.     property Capacity: Integer;
  180.     property Count: Integer;
  181.     property Items[Index: Integer]: IUnknown; default;
  182.   end;
  183.  
  184. { EXTERNALSYM IInterfaceList}
  185.  
  186. { TInterfaceList class }
  187.  
  188.   TInterfaceList = class(TInterfacedObject, IInterfaceList)
  189.   protected
  190.     { IInterfaceList }
  191.     function Get(Index: Integer): IUnknown;
  192.     function GetCapacity: Integer;
  193.     function GetCount: Integer;
  194.     procedure Put(Index: Integer; Item: IUnknown);
  195.     procedure SetCapacity(NewCapacity: Integer);
  196.     procedure SetCount(NewCount: Integer);
  197.   public
  198.     constructor Create;
  199.     destructor Destroy; override;
  200.     procedure Clear;
  201.     procedure Delete(Index: Integer);
  202.     procedure Exchange(Index1, Index2: Integer);
  203.     function Expand: TInterfaceList;
  204.     function First: IUnknown;
  205.     function IndexOf(Item: IUnknown): Integer;
  206.     function Add(Item: IUnknown): Integer;
  207.     procedure Insert(Index: Integer; Item: IUnknown);
  208.     function Last: IUnknown;
  209.     function Remove(Item: IUnknown): Integer;
  210.     procedure Lock;
  211.     procedure Unlock;
  212.     property Capacity: Integer;
  213.     property Count: Integer;
  214.     property Items[Index: Integer]: IUnknown; default;
  215.   end;
  216.  
  217. { EXTERNALSYM TInterfaceList}
  218.  
  219. { TBits class }
  220.  
  221.   TBits = class
  222.   public
  223.     destructor Destroy; override;
  224.     function OpenBit: Integer;
  225.     property Bits[Index: Integer]: Boolean; default;
  226.     property Size: Integer;
  227.   end;
  228.  
  229. { TPersistent abstract class }
  230.  
  231. {$M+}
  232.  
  233.   TPersistent = class(TObject)
  234.   protected
  235.     procedure AssignTo(Dest: TPersistent); virtual;
  236.     procedure DefineProperties(Filer: TFiler); virtual;
  237.     function  GetOwner: TPersistent; dynamic;
  238.   public
  239.     destructor Destroy; override;
  240.     procedure Assign(Source: TPersistent); virtual;
  241.     function  GetNamePath: string; dynamic;
  242.   end;
  243.  
  244. {$M-}
  245.  
  246. { TPersistent class reference type }
  247.  
  248.   TPersistentClass = class of TPersistent;
  249.  
  250. { TCollection class }
  251.  
  252.   TCollection = class;
  253.  
  254.   TCollectionItem = class(TPersistent)
  255.   protected
  256.     procedure Changed(AllItems: Boolean);
  257.     function GetOwner: TPersistent; override;
  258.     function GetDisplayName: string; virtual;
  259.     procedure SetIndex(Value: Integer); virtual;
  260.     procedure SetDisplayName(const Value: string); virtual;
  261.   public
  262.     constructor Create(Collection: TCollection); virtual;
  263.     destructor Destroy; override;
  264.     function GetNamePath: string; override;
  265.     property Collection: TCollection;
  266.     property ID: Integer;
  267.     property Index: Integer;
  268.     property DisplayName: string;
  269.   end;
  270.  
  271.   TCollectionItemClass = class of TCollectionItem;
  272.  
  273.   TCollection = class(TPersistent)
  274.   protected
  275.     { Design-time editor support }
  276.     function GetAttrCount: Integer; dynamic;
  277.     function GetAttr(Index: Integer): string; dynamic;
  278.     function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
  279.     procedure Changed;
  280.     function GetItem(Index: Integer): TCollectionItem;
  281.     procedure SetItem(Index: Integer; Value: TCollectionItem);
  282.     procedure SetItemName(Item: TCollectionItem); virtual;
  283.     procedure Update(Item: TCollectionItem); virtual;
  284.     property PropName: string;
  285.     property UpdateCount: Integer;
  286.   public
  287.     constructor Create(ItemClass: TCollectionItemClass);
  288.     destructor Destroy; override;
  289.     function Add: TCollectionItem;
  290.     procedure Assign(Source: TPersistent); override;
  291.     procedure BeginUpdate; virtual;
  292.     procedure Clear;
  293.     procedure EndUpdate; virtual;
  294.     function FindItemID(ID: Integer): TCollectionItem;
  295.     function GetNamePath: string; override;
  296.     function Insert(Index: Integer): TCollectionItem;
  297.     property Count: Integer;
  298.     property ItemClass: TCollectionItemClass;
  299.     property Items[Index: Integer]: TCollectionItem;
  300.   end;
  301.  
  302. { Collection class that maintains an "Owner" in order to obtain property
  303.   path information at design-time }
  304.  
  305.   TOwnedCollection = class(TCollection)
  306.   protected
  307.     function GetOwner: TPersistent; override;
  308.   public
  309.     constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
  310.   end;
  311.  
  312.   TStrings = class;
  313.  
  314. { TGetModuleProc }
  315. { Uses in the TFormDesigner class to allow component/property editors access
  316.   to project specific information }
  317.  
  318.   TGetModuleProc = procedure(const FileName, UnitName, FormName,
  319.     DesignClass: string; CoClasses: TStrings) of object;
  320.  
  321. { IStringsAdapter interface }
  322. { Maintains link between TStrings and IStrings implementations }
  323.  
  324.   IStringsAdapter = interface
  325.     ['{739C2F34-52EC-11D0-9EA6-0020AF3D82DA}']
  326.     procedure ReferenceStrings(S: TStrings);
  327.     procedure ReleaseStrings;
  328.   end;
  329.  
  330. { TStrings class }
  331.  
  332.   TStrings = class(TPersistent)
  333.   protected
  334.     procedure DefineProperties(Filer: TFiler); override;
  335.     procedure Error(const Msg: string; Data: Integer);
  336.     function Get(Index: Integer): string; virtual; abstract;
  337.     function GetCapacity: Integer; virtual;
  338.     function GetCount: Integer; virtual; abstract;
  339.     function GetObject(Index: Integer): TObject; virtual;
  340.     function GetTextStr: string; virtual;
  341.     procedure Put(Index: Integer; const S: string); virtual;
  342.     procedure PutObject(Index: Integer; AObject: TObject); virtual;
  343.     procedure SetCapacity(NewCapacity: Integer); virtual;
  344.     procedure SetTextStr(const Value: string); virtual;
  345.     procedure SetUpdateState(Updating: Boolean); virtual;
  346.   public
  347.     destructor Destroy; override;
  348.     function Add(const S: string): Integer; virtual;
  349.     function AddObject(const S: string; AObject: TObject): Integer; virtual;
  350.     procedure Append(const S: string);
  351.     procedure AddStrings(Strings: TStrings); virtual;
  352.     procedure Assign(Source: TPersistent); override;
  353.     procedure BeginUpdate;
  354.     procedure Clear; virtual; abstract;
  355.     procedure Delete(Index: Integer); virtual; abstract;
  356.     procedure EndUpdate;
  357.     function Equals(Strings: TStrings): Boolean;
  358.     procedure Exchange(Index1, Index2: Integer); virtual;
  359.     function GetText: PChar; virtual;
  360.     function IndexOf(const S: string): Integer; virtual;
  361.     function IndexOfName(const Name: string): Integer;
  362.     function IndexOfObject(AObject: TObject): Integer;
  363.     procedure Insert(Index: Integer; const S: string); virtual; abstract;
  364.     procedure InsertObject(Index: Integer; const S: string;
  365.       AObject: TObject);
  366.     procedure LoadFromFile(const FileName: string); virtual;
  367.     procedure LoadFromStream(Stream: TStream); virtual;
  368.     procedure Move(CurIndex, NewIndex: Integer); virtual;
  369.     procedure SaveToFile(const FileName: string); virtual;
  370.     procedure SaveToStream(Stream: TStream); virtual;
  371.     procedure SetText(Text: PChar); virtual;
  372.     property Capacity: Integer;
  373.     property CommaText: string;
  374.     property Count: Integer;
  375.     property Names[Index: Integer]: string;
  376.     property Objects[Index: Integer]: TObject;
  377.     property Values[const Name: string]: string;
  378.     property Strings[Index: Integer]: string; default;
  379.     property Text: string;
  380.     property StringsAdapter: IStringsAdapter;
  381.   end;
  382.  
  383. { TStringList class }
  384.  
  385.   TDuplicates = (dupIgnore, dupAccept, dupError);
  386.  
  387.   PStringItem = ^TStringItem;
  388.   TStringItem = record
  389.     FString: string;
  390.     FObject: TObject;
  391.   end;
  392.  
  393.   PStringItemList = ^TStringItemList;
  394.   TStringItemList = array[0..MaxListSize] of TStringItem;
  395.  
  396.   TStringList = class(TStrings)
  397.   protected
  398.     procedure Changed; virtual;
  399.     procedure Changing; virtual;
  400.     function Get(Index: Integer): string; override;
  401.     function GetCapacity: Integer; override;
  402.     function GetCount: Integer; override;
  403.     function GetObject(Index: Integer): TObject; override;
  404.     procedure Put(Index: Integer; const S: string); override;
  405.     procedure PutObject(Index: Integer; AObject: TObject); override;
  406.     procedure SetCapacity(NewCapacity: Integer); override;
  407.     procedure SetUpdateState(Updating: Boolean); override;
  408.   public
  409.     destructor Destroy; override;
  410.     function Add(const S: string): Integer; override;
  411.     procedure Clear; override;
  412.     procedure Delete(Index: Integer); override;
  413.     procedure Exchange(Index1, Index2: Integer); override;
  414.     function Find(const S: string; var Index: Integer): Boolean; virtual;
  415.     function IndexOf(const S: string): Integer; override;
  416.     procedure Insert(Index: Integer; const S: string); override;
  417.     procedure Sort; virtual;
  418.     property Duplicates: TDuplicates;
  419.     property Sorted: Boolean;
  420.     property OnChange: TNotifyEvent;
  421.     property OnChanging: TNotifyEvent;
  422.   end;
  423.  
  424. { TStream abstract class }
  425.  
  426.   TStream = class(TObject)
  427.   protected
  428.     procedure SetSize(NewSize: Longint); virtual;
  429.   public
  430.     function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
  431.     function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
  432.     function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
  433.     procedure ReadBuffer(var Buffer; Count: Longint);
  434.     procedure WriteBuffer(const Buffer; Count: Longint);
  435.     function CopyFrom(Source: TStream; Count: Longint): Longint;
  436.     function ReadComponent(Instance: TComponent): TComponent;
  437.     function ReadComponentRes(Instance: TComponent): TComponent;
  438.     procedure WriteComponent(Instance: TComponent);
  439.     procedure WriteComponentRes(const ResName: string; Instance: TComponent);
  440.     procedure WriteDescendent(Instance, Ancestor: TComponent);
  441.     procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
  442.     procedure ReadResHeader;
  443.     property Position: Longint;
  444.     property Size: Longint;
  445.   end;
  446.  
  447. { THandleStream class }
  448.  
  449.   THandleStream = class(TStream)
  450.   protected
  451.     procedure SetSize(NewSize: Longint); override;
  452.   public
  453.     constructor Create(AHandle: Integer);
  454.     function Read(var Buffer; Count: Longint): Longint; override;
  455.     function Write(const Buffer; Count: Longint): Longint; override;
  456.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  457.     property Handle: Integer;
  458.   end;
  459.  
  460. { TFileStream class }
  461.  
  462.   TFileStream = class(THandleStream)
  463.   public
  464.     constructor Create(const FileName: string; Mode: Word);
  465.     destructor Destroy; override;
  466.   end;
  467.  
  468. { TCustomMemoryStream abstract class }
  469.  
  470.   TCustomMemoryStream = class(TStream)
  471.   protected
  472.     procedure SetPointer(Ptr: Pointer; Size: Longint);
  473.   public
  474.     function Read(var Buffer; Count: Longint): Longint; override;
  475.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  476.     procedure SaveToStream(Stream: TStream);
  477.     procedure SaveToFile(const FileName: string);
  478.     property Memory: Pointer;
  479.   end;
  480.  
  481. { TMemoryStream }
  482.  
  483.   TMemoryStream = class(TCustomMemoryStream)
  484.   protected
  485.     function Realloc(var NewCapacity: Longint): Pointer; virtual;
  486.     property Capacity: Longint;
  487.   public
  488.     destructor Destroy; override;
  489.     procedure Clear;
  490.     procedure LoadFromStream(Stream: TStream);
  491.     procedure LoadFromFile(const FileName: string);
  492.     procedure SetSize(NewSize: Longint); override;
  493.     function Write(const Buffer; Count: Longint): Longint; override;
  494.   end;
  495.  
  496. { TStringStream }
  497.  
  498.   TStringStream = class(TStream)
  499.   protected
  500.     procedure SetSize(NewSize: Longint); override;
  501.   public
  502.     constructor Create(const AString: string);
  503.     function Read(var Buffer; Count: Longint): Longint; override;
  504.     function ReadString(Count: Longint): string;
  505.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  506.     function Write(const Buffer; Count: Longint): Longint; override;
  507.     procedure WriteString(const AString: string);
  508.     property DataString: string;
  509.   end;
  510.  
  511. { TResourceStream }
  512.  
  513.   TResourceStream = class(TCustomMemoryStream)
  514.   public
  515.     constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
  516.     constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
  517.     destructor Destroy; override;
  518.     function Write(const Buffer; Count: Longint): Longint; override;
  519.   end;
  520.  
  521. { TStreamAdapter }
  522. { Implements OLE IStream on VCL TStream }
  523.  
  524.   TStreamOwnership = (soReference, soOwned);
  525.  
  526.   TStreamAdapter = class(TInterfacedObject, IStream)
  527.   public
  528.     constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference);
  529.     destructor Destroy; override;
  530.     function Read(pv: Pointer; cb: Longint;
  531.       pcbRead: PLongint): HResult; virtual; stdcall;
  532.     function Write(pv: Pointer; cb: Longint;
  533.       pcbWritten: PLongint): HResult; virtual; stdcall;
  534.     function Seek(dlibMove: Largeint; dwOrigin: Longint;
  535.       out libNewPosition: Largeint): HResult; virtual; stdcall;
  536.     function SetSize(libNewSize: Largeint): HResult; virtual; stdcall;
  537.     function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
  538.       out cbWritten: Largeint): HResult; virtual; stdcall;
  539.     function Commit(grfCommitFlags: Longint): HResult; virtual; stdcall;
  540.     function Revert: HResult; virtual; stdcall;
  541.     function LockRegion(libOffset: Largeint; cb: Largeint;
  542.       dwLockType: Longint): HResult; virtual; stdcall;
  543.     function UnlockRegion(libOffset: Largeint; cb: Largeint;
  544.       dwLockType: Longint): HResult; virtual; stdcall;
  545.     function Stat(out statstg: TStatStg;
  546.       grfStatFlag: Longint): HResult; virtual; stdcall;
  547.     function Clone(out stm: IStream): HResult; virtual; stdcall;
  548.     property Stream: TStream;
  549.     property StreamOwnership: TStreamOwnership;
  550.   end;
  551.  
  552. { TFiler }
  553.  
  554.   TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
  555.     vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
  556.     vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString);
  557.  
  558.   TFilerFlag = (ffInherited, ffChildPos);
  559.   TFilerFlags = set of TFilerFlag;
  560.  
  561.   TReaderProc = procedure(Reader: TReader) of object;
  562.   TWriterProc = procedure(Writer: TWriter) of object;
  563.   TStreamProc = procedure(Stream: TStream) of object;
  564.  
  565.   TFiler = class(TObject)
  566.   public
  567.     constructor Create(Stream: TStream; BufSize: Integer);
  568.     destructor Destroy; override;
  569.     procedure DefineProperty(const Name: string;
  570.       ReadData: TReaderProc; WriteData: TWriterProc;
  571.       HasData: Boolean); virtual; abstract;
  572.     procedure DefineBinaryProperty(const Name: string;
  573.       ReadData, WriteData: TStreamProc;
  574.       HasData: Boolean); virtual; abstract;
  575.     procedure FlushBuffer; virtual; abstract;
  576.     property Root: TComponent;
  577.     property Ancestor: TPersistent;
  578.     property IgnoreChildren: Boolean;
  579.   end;
  580.  
  581. { TReader }
  582.  
  583.   TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
  584.     var Address: Pointer; var Error: Boolean) of object;
  585.   TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
  586.     var Name: string) of object;
  587.   TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object;
  588.   TAncestorNotFoundEvent = procedure(Reader: TReader; const ComponentName: string;
  589.     ComponentClass: TPersistentClass; var Component: TComponent) of object;
  590.   TReadComponentsProc = procedure(Component: TComponent) of object;
  591.   TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;
  592.  
  593.   TReader = class(TFiler)
  594.   protected
  595.     function Error(const Message: string): Boolean; virtual;
  596.     function FindMethod(Root: TComponent; const MethodName: string): Pointer; virtual;
  597.     procedure SetName(Component: TComponent; var Name: string); virtual;
  598.     procedure ReadProperty(AInstance: TPersistent);
  599.     procedure ReferenceName(var Name: string); virtual;
  600.     function FindAncestorComponent(const Name: string;
  601.       ComponentClass: TPersistentClass): TComponent; virtual;
  602.   public
  603.     destructor Destroy; override;
  604.     procedure BeginReferences;
  605.     procedure DefineProperty(const Name: string;
  606.       ReadData: TReaderProc; WriteData: TWriterProc;
  607.       HasData: Boolean); override;
  608.     procedure DefineBinaryProperty(const Name: string;
  609.       ReadData, WriteData: TStreamProc;
  610.       HasData: Boolean); override;
  611.     function EndOfList: Boolean;
  612.     procedure EndReferences;
  613.     procedure FixupReferences;
  614.     procedure FlushBuffer; override;
  615.     function NextValue: TValueType;
  616.     procedure Read(var Buf; Count: Longint);
  617.     function ReadBoolean: Boolean;
  618.     function ReadChar: Char;
  619.     procedure ReadCollection(Collection: TCollection);
  620.     function ReadComponent(Component: TComponent): TComponent;
  621.     procedure ReadComponents(AOwner, AParent: TComponent;
  622.       Proc: TReadComponentsProc);
  623.     function ReadFloat: Extended;
  624.     function ReadSingle: Single;
  625.     function ReadCurrency: Currency;
  626.     function ReadDate: TDateTime;
  627.     function ReadIdent: string;
  628.     function ReadInteger: Longint;
  629.     procedure ReadListBegin;
  630.     procedure ReadListEnd;
  631.     procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); virtual;
  632.     function ReadRootComponent(Root: TComponent): TComponent;
  633.     procedure ReadSignature;
  634.     function ReadStr: string;
  635.     function ReadString: string;
  636.     function ReadWideString: WideString;
  637.     function ReadValue: TValueType;
  638.     procedure CopyValue(Writer: TWriter); {!!!}
  639.     property Owner: TComponent;
  640.     property Parent: TComponent;
  641.     property Position: Longint;
  642.     property OnError: TReaderError;
  643.     property OnFindMethod: TFindMethodEvent;
  644.     property OnSetName: TSetNameEvent;
  645.     property OnReferenceName: TReferenceNameEvent;
  646.     property OnAncestorNotFound: TAncestorNotFoundEvent;
  647.   end;
  648.  
  649. { TWriter }
  650.  
  651.   TWriter = class(TFiler)
  652.   protected
  653.     procedure WriteBinary(WriteData: TStreamProc);
  654.     procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
  655.     procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
  656.     procedure WriteValue(Value: TValueType);
  657.   public
  658.     destructor Destroy; override;
  659.     procedure DefineProperty(const Name: string;
  660.       ReadData: TReaderProc; WriteData: TWriterProc;
  661.       HasData: Boolean); override;
  662.     procedure DefineBinaryProperty(const Name: string;
  663.       ReadData, WriteData: TStreamProc;
  664.       HasData: Boolean); override;
  665.     procedure FlushBuffer; override;
  666.     procedure Write(const Buf; Count: Longint);
  667.     procedure WriteBoolean(Value: Boolean);
  668.     procedure WriteCollection(Value: TCollection);
  669.     procedure WriteComponent(Component: TComponent);
  670.     procedure WriteChar(Value: Char);
  671.     procedure WriteDescendent(Root: TComponent; AAncestor: TComponent);
  672.     procedure WriteFloat(const Value: Extended);
  673.     procedure WriteSingle(const Value: Single);
  674.     procedure WriteCurrency(const Value: Currency);
  675.     procedure WriteDate(const Value: TDateTime);
  676.     procedure WriteIdent(const Ident: string);
  677.     procedure WriteInteger(Value: Longint);
  678.     procedure WriteListBegin;
  679.     procedure WriteListEnd;
  680.     procedure WriteRootComponent(Root: TComponent);
  681.     procedure WriteSignature;
  682.     procedure WriteStr(const Value: string);
  683.     procedure WriteString(const Value: string);
  684.     procedure WriteWideString(const Value: WideString);
  685.     property Position: Longint;
  686.     property RootAncestor: TComponent;
  687.   end;
  688.  
  689. { TParser }
  690.  
  691.   TParser = class(TObject)
  692.   public
  693.     constructor Create(Stream: TStream);
  694.     destructor Destroy; override;
  695.     procedure CheckToken(T: Char);
  696.     procedure CheckTokenSymbol(const S: string);
  697.     procedure Error(const Ident: string);
  698.     procedure ErrorFmt(const Ident: string; const Args: array of const);
  699.     procedure ErrorStr(const Message: string);
  700.     procedure HexToBinary(Stream: TStream);
  701.     function NextToken: Char;
  702.     function SourcePos: Longint;
  703.     function TokenComponentIdent: String;
  704.     function TokenFloat: Extended;
  705.     function TokenInt: Longint;
  706.     function TokenString: string;
  707.     function TokenWideString: WideString;
  708.     function TokenSymbolIs(const S: string): Boolean;
  709.     property FloatType: Char;
  710.     property SourceLine: Integer;
  711.     property Token: Char;
  712.   end;
  713.  
  714. { TThread }
  715.  
  716.   EThread = class(Exception);
  717.  
  718.   TThreadMethod = procedure of object;
  719.   TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
  720.     tpTimeCritical);
  721.  
  722.   TThread = class
  723.   protected
  724.     procedure DoTerminate; virtual;
  725.     procedure Execute; virtual; abstract;
  726.     procedure Synchronize(Method: TThreadMethod);
  727.     property ReturnValue: Integer;
  728.     property Terminated: Boolean;
  729.   public
  730.     constructor Create(CreateSuspended: Boolean);
  731.     destructor Destroy; override;
  732.     procedure Resume;
  733.     procedure Suspend;
  734.     procedure Terminate;
  735.     function WaitFor: LongWord;
  736.     property FreeOnTerminate: Boolean;
  737.     property Handle: THandle;
  738.     property Priority: TT;
  739.     property Suspended: Boolean;
  740.     property T;
  741.     property OnTerminate: TNotifyEvent;
  742.   end;
  743.  
  744. { TComponent class }
  745.  
  746.   TOperation = (opInsert, opRemove);
  747.   TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
  748.     csDesigning, csAncestor, csUpdating, csFixups);
  749.   TComponentStyle = set of (csInheritable, csCheckPropAvail);
  750.   TGetChildProc = procedure (Child: TComponent) of object;
  751.  
  752.   TComponentName = type string;
  753.  
  754.   IVCLComObject = interface
  755.     ['{E07892A0-F52F-11CF-BD2F-0020AF0E5B81}']
  756.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  757.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  758.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  759.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  760.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  761.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  762.     function SafeCallException(ExceptObject: TObject;
  763.       ExceptAddr: Pointer): HResult;
  764.     procedure FreeOnRelease;
  765.   end;
  766.  
  767.   IDesignerNotify = interface
  768.     ['{B971E807-E3A6-11D1-AAB1-00C04FB16FBC}']
  769.     procedure Modified;
  770.     procedure Notification(AnObject: TPersistent; Operation: TOperation);
  771.   end;  
  772.  
  773.   TBasicAction = class;
  774.  
  775.   TComponent = class(TPersistent)
  776.   protected
  777.     FComponentStyle: TComponentStyle;
  778.     procedure ChangeName(const NewName: TComponentName);
  779.     procedure DefineProperties(Filer: TFiler); override;
  780.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic;
  781.     function GetChildOwner: TComponent; dynamic;
  782.     function GetChildParent: TComponent; dynamic;
  783.     function GetOwner: TPersistent; override;
  784.     procedure Loaded; virtual;
  785.     procedure Notification(AComponent: TComponent;
  786.       Operation: TOperation); virtual;
  787.     procedure ReadState(Reader: TReader); virtual;
  788.     procedure SetAncestor(Value: Boolean);
  789.     procedure SetDesigning(Value: Boolean);
  790.     procedure SetName(const NewName: TComponentName); virtual;
  791.     procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic;
  792.     procedure SetParentComponent(Value: TComponent); dynamic;
  793.     procedure Updating; dynamic;
  794.     procedure Updated; dynamic;
  795.     class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); virtual;
  796.     procedure ValidateRename(AComponent: TComponent;
  797.       const CurName, NewName: string); virtual;
  798.     procedure ValidateContainer(AComponent: TComponent); dynamic;
  799.     procedure ValidateInsert(AComponent: TComponent); dynamic;
  800.     procedure WriteState(Writer: TWriter); virtual;
  801.     { IUnknown }
  802.     function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
  803.     function _AddRef: Integer; stdcall;
  804.     function _Release: Integer; stdcall;
  805.     { IDispatch }
  806.     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
  807.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
  808.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  809.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
  810.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  811.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  812.   public
  813.     constructor Create(AOwner: TComponent); virtual;
  814.     destructor Destroy; override;
  815.     procedure DestroyComponents;
  816.     procedure Destroying;
  817.     function ExecuteAction(Action: TBasicAction): Boolean; dynamic;
  818.     function FindComponent(const AName: string): TComponent;
  819.     procedure FreeNotification(AComponent: TComponent);
  820.     procedure FreeOnRelease;
  821.     function GetParentComponent: TComponent; dynamic;
  822.     function GetNamePath: string; override;
  823.     function HasParent: Boolean; dynamic;
  824.     procedure InsertComponent(AComponent: TComponent);
  825.     procedure RemoveComponent(AComponent: TComponent);
  826.     function SafeCallException(ExceptObject: TObject;
  827.       ExceptAddr: Pointer): HResult; override;
  828.     function UpdateAction(Action: TBasicAction): Boolean; dynamic;
  829.     property ComObject: IUnknown;
  830.     property Components[Index: Integer]: TComponent;
  831.     property ComponentCount: Integer;
  832.     property ComponentIndex: Integer;
  833.     property ComponentState: TComponentState;
  834.     property ComponentStyle: TComponentStyle;
  835.     property DesignInfo: Longint;
  836.     property Owner: TComponent;
  837.     property VCLComObject: Pointer;
  838.   published
  839.     property Name: TComponentName;
  840.     property Tag: Longint default 0;
  841.   end;
  842.  
  843. { TComponent class reference type }
  844.  
  845.   TComponentClass = class of TComponent;
  846.  
  847. { TBasicActionLink }
  848.  
  849.   TBasicActionLink = class(TObject)
  850.   protected
  851.     FAction: TBasicAction;
  852.     procedure AssignClient(AClient: TObject); virtual;
  853.     procedure Change; virtual;
  854.     function IsOnExecuteLinked: Boolean; virtual;
  855.     procedure SetAction(Value: TBasicAction); virtual;
  856.     procedure SetOnExecute(Value: TNotifyEvent); virtual;
  857.   public
  858.     constructor Create(AClient: TObject); virtual;
  859.     destructor Destroy; override;
  860.     function Execute: Boolean; dynamic;
  861.     function Update: Boolean; virtual;
  862.     property Action: TBasicAction;
  863.     property OnChange: TNotifyEvent;
  864.   end;
  865.  
  866.   TBasicActionLinkClass = class of TBasicActionLink;
  867.  
  868. { TBasicAction }
  869.  
  870.   TBasicAction = class(TComponent)
  871.   protected
  872.     FClients: TList;
  873.     procedure Change; virtual;
  874.     procedure SetOnExecute(Value: TNotifyEvent); virtual;
  875.     property OnChange: TNotifyEvent;
  876.   public
  877.     constructor Create(AOwner: TComponent); override;
  878.     destructor Destroy; override;
  879.     function HandlesTarget(Target: TObject): Boolean; virtual;
  880.     procedure UpdateTarget(Target: TObject); virtual;
  881.     procedure ExecuteTarget(Target: TObject); virtual;
  882.     function Execute: Boolean; dynamic;
  883.     procedure RegisterChanges(Value: TBasicActionLink);
  884.     procedure UnRegisterChanges(Value: TBasicActionLink);
  885.     function Update: Boolean; virtual;
  886.     property OnExecute: TNotifyEvent;
  887.     property OnUpdate: TNotifyEvent;
  888.   end;
  889.  
  890. { TBasicAction class reference type }
  891.  
  892.   TBasicActionClass = class of TBasicAction;
  893.  
  894. { Component registration handlers }
  895.  
  896.   TActiveXRegType = (axrComponentOnly, axrIncludeDescendants);
  897.  
  898. var
  899.   RegisterComponentsProc: procedure(const Page: string;
  900.     ComponentClasses: array of TComponentClass) = nil;
  901.   RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass) = nil;
  902.   RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
  903.     AxRegType: TActiveXRegType) = nil;
  904.   CurrentGroup: Integer = -1; { Current design group }
  905.   CreateVCLComObjectProc: procedure(Component: TComponent) = nil;
  906.  
  907. { Point and rectangle constructors }
  908.  
  909. function Point(AX, AY: Integer): TPoint;
  910. function SmallPoint(AX, AY: SmallInt): TSmallPoint;
  911. function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
  912. function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
  913.  
  914. { Class registration routines }
  915.  
  916. procedure RegisterClass(AClass: TPersistentClass);
  917. procedure RegisterClasses(AClasses: array of TPersistentClass);
  918. procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
  919. procedure UnRegisterClass(AClass: TPersistentClass);
  920. procedure UnRegisterClasses(AClasses: array of TPersistentClass);
  921. procedure UnRegisterModuleClasses(Module: HMODULE);
  922. function FindClass(const ClassName: string): TPersistentClass;
  923. function GetClass(const AClassName: string): TPersistentClass;
  924.  
  925. { Component registration routines }
  926.  
  927. procedure RegisterComponents(const Page: string;
  928.   ComponentClasses: array of TComponentClass);
  929. procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
  930. procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
  931.   AxRegType: TActiveXRegType);
  932.  
  933. var
  934.   GlobalNameSpace: TMultiReadExclusiveWriteSynchronizer;
  935.  
  936. { Object filing routines }
  937.  
  938. type
  939.   TIdentMapEntry = record
  940.     Value: Integer;
  941.     Name: String;
  942.   end;
  943.  
  944.   TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
  945.   TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
  946.   TFindGlobalComponent = function(const Name: string): TComponent;
  947.  
  948. var
  949.   FindGlobalComponent: TFindGlobalComponent;
  950.  
  951. procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
  952.   IntToIdent: TIntToIdent);
  953. function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
  954. function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
  955.  
  956. function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
  957. function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
  958. function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
  959. function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
  960. function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
  961. procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
  962.  
  963. procedure GlobalFixupReferences;
  964. procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
  965. procedure GetFixupInstanceNames(Root: TComponent;
  966.   const ReferenceRootName: string; Names: TStrings);
  967. procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
  968.   NewRootName: string);
  969. procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
  970. procedure RemoveFixups(Instance: TPersistent);
  971.  
  972. procedure BeginGlobalLoading;
  973. procedure NotifyGlobalLoading;
  974. procedure EndGlobalLoading;
  975.  
  976. function CollectionsEqual(C1, C2: TCollection): Boolean;
  977.  
  978. { Object conversion routines }
  979.  
  980. procedure ObjectBinaryToText(Input, Output: TStream);
  981. procedure ObjectTextToBinary(Input, Output: TStream);
  982.  
  983. procedure ObjectResourceToText(Input, Output: TStream);
  984. procedure ObjectTextToResource(Input, Output: TStream);
  985.  
  986. { Utility routines }
  987.  
  988. function LineStart(Buffer, BufPos: PChar): PChar;
  989. function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar;
  990.   Strings: TStrings): Integer;
  991.  
  992. procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);
  993. function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer;
  994.  
  995. implementation
  996.