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