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