home *** CD-ROM | disk | FTP | other *** search
Text File | 1999-08-11 | 38.5 KB | 1,065 lines |
-
- {*******************************************************}
- { }
- { Borland Delphi Visual Component Library }
- { }
- { Copyright (c) 1995,99 Inprise Corporation }
- { }
- {*******************************************************}
-
- unit Classes;
-
- {$R-,T-,X+,H+}
-
- { ACTIVEX.HPP is not required by CLASSES.HPP }
- (*$NOINCLUDE ActiveX*)
-
-
- interface
-
- uses SysUtils, Windows, ActiveX;
-
- const
-
- { Maximum TList size }
-
- MaxListSize = Maxint div 16;
-
- { TStream seek origins }
-
- soFromBeginning = 0;
- soFromCurrent = 1;
- soFromEnd = 2;
-
- { TFileStream create mode }
-
- fmCreate = $FFFF;
-
- { TParser special tokens }
-
- toEOF = Char(0);
- toSymbol = Char(1);
- toString = Char(2);
- toInteger = Char(3);
- toFloat = Char(4);
- toWString = Char(5);
-
- {!! Moved here from menus.pas !!}
- { TShortCut special values }
-
- scShift = $2000;
- scCtrl = $4000;
- scAlt = $8000;
- scNone = 0;
-
- type
-
- { Text alignment types }
-
- TAlignment = (taLeftJustify, taRightJustify, taCenter);
- TLeftRight = taLeftJustify..taRightJustify;
- TBiDiMode = (bdLeftToRight, bdRightToLeft, bdRightToLeftNoAlign,
- bdRightToLeftReadingOnly);
-
- { Types used by standard events }
-
- TShiftState = set of (ssShift, ssAlt, ssCtrl,
- ssLeft, ssRight, ssMiddle, ssDouble);
-
- THelpContext = -MaxLongint..MaxLongint;
-
- {!! Moved here from menus.pas !!}
- TShortCut = Low(Word)..High(Word);
-
- { Standard events }
-
- TNotifyEvent = procedure(Sender: TObject) of object;
- THelpEvent = function (Command: Word; Data: Longint;
- var CallHelp: Boolean): Boolean of object;
- TGetStrProc = procedure(const S: string) of object;
-
- { Exception classes }
-
- EStreamError = class(Exception);
- EFCreateError = class(EStreamError);
- EFOpenError = class(EStreamError);
- EFilerError = class(EStreamError);
- EReadError = class(EFilerError);
- EWriteError = class(EFilerError);
- EClassNotFound = class(EFilerError);
- EMethodNotFound = class(EFilerError);
- EInvalidImage = class(EFilerError);
- EResNotFound = class(Exception);
- EListError = class(Exception);
- EBitsError = class(Exception);
- EStringListError = class(Exception);
- EComponentError = class(Exception);
- EParserError = class(Exception);
- EOutOfResources = class(EOutOfMemory);
- EInvalidOperation = class(Exception);
-
- { Duplicate management }
-
- TDuplicates = (dupIgnore, dupAccept, dupError);
-
- { Forward class declarations }
-
- TStream = class;
- TFiler = class;
- TReader = class;
- TWriter = class;
- TComponent = class;
-
- { TList class }
-
- PPointerList = ^TPointerList;
- TPointerList = array[0..MaxListSize - 1] of Pointer;
- TListSortCompare = function (Item1, Item2: Pointer): Integer;
- TListNotification = (lnAdded, lnExtracted, lnDeleted);
-
- TList = class(TObject)
- protected
- function Get(Index: Integer): Pointer;
- procedure Grow; virtual;
- procedure Put(Index: Integer; Item: Pointer);
- procedure Notify(Ptr: Pointer; Action: TListNotification); virtual;
- procedure SetCapacity(NewCapacity: Integer);
- procedure SetCount(NewCount: Integer);
- public
- destructor Destroy; override;
- function Add(Item: Pointer): Integer;
- procedure Clear; virtual;
- procedure Delete(Index: Integer);
- class procedure Error(const Msg: string; Data: Integer); overload; virtual;
- class procedure Error(Msg: PResStringRec; Data: Integer); overload;
- procedure Exchange(Index1, Index2: Integer);
- function Expand: TList;
- function Extract(Item: Pointer): Pointer;
- function First: Pointer;
- function IndexOf(Item: Pointer): Integer;
- procedure Insert(Index: Integer; Item: Pointer);
- function Last: Pointer;
- procedure Move(CurIndex, NewIndex: Integer);
- function Remove(Item: Pointer): Integer;
- procedure Pack;
- procedure Sort(Compare: TListSortCompare);
- property Capacity: Integer;
- property Count: Integer;
- property Items[Index: Integer]: Pointer; default;
- property List: PPointerList;
- end;
-
- { TThreadList class }
-
- TThreadList = class
- public
- constructor Create;
- destructor Destroy; override;
- procedure Add(Item: Pointer);
- procedure Clear;
- function LockList: TList;
- procedure Remove(Item: Pointer);
- procedure UnlockList;
- property Duplicates: TDuplicates;
- end;
-
- { IInterfaceList interface }
-
- IInterfaceList = interface
- ['{285DEA8A-B865-11D1-AAA7-00C04FB17A72}']
- function Get(Index: Integer): IUnknown;
- function GetCapacity: Integer;
- function GetCount: Integer;
- procedure Put(Index: Integer; Item: IUnknown);
- procedure SetCapacity(NewCapacity: Integer);
- procedure SetCount(NewCount: Integer);
-
- procedure Clear;
- procedure Delete(Index: Integer);
- procedure Exchange(Index1, Index2: Integer);
- function First: IUnknown;
- function IndexOf(Item: IUnknown): Integer;
- function Add(Item: IUnknown): Integer;
- procedure Insert(Index: Integer; Item: IUnknown);
- function Last: IUnknown;
- function Remove(Item: IUnknown): Integer;
- procedure Lock;
- procedure Unlock;
- property Capacity: Integer;
- property Count: Integer;
- property Items[Index: Integer]: IUnknown; default;
- end;
-
- { EXTERNALSYM IInterfaceList}
-
- { TInterfaceList class }
-
- TInterfaceList = class(TInterfacedObject, IInterfaceList)
- protected
- { IInterfaceList }
- function Get(Index: Integer): IUnknown;
- function GetCapacity: Integer;
- function GetCount: Integer;
- procedure Put(Index: Integer; Item: IUnknown);
- procedure SetCapacity(NewCapacity: Integer);
- procedure SetCount(NewCount: Integer);
- public
- constructor Create;
- destructor Destroy; override;
- procedure Clear;
- procedure Delete(Index: Integer);
- procedure Exchange(Index1, Index2: Integer);
- function Expand: TInterfaceList;
- function First: IUnknown;
- function IndexOf(Item: IUnknown): Integer;
- function Add(Item: IUnknown): Integer;
- procedure Insert(Index: Integer; Item: IUnknown);
- function Last: IUnknown;
- function Remove(Item: IUnknown): Integer;
- procedure Lock;
- procedure Unlock;
- property Capacity: Integer;
- property Count: Integer;
- property Items[Index: Integer]: IUnknown; default;
- end;
-
- { EXTERNALSYM TInterfaceList}
-
- { TBits class }
-
- TBits = class
- public
- destructor Destroy; override;
- function OpenBit: Integer;
- property Bits[Index: Integer]: Boolean; default;
- property Size: Integer;
- end;
-
- { TPersistent abstract class }
-
- {$M+}
-
- TPersistent = class(TObject)
- protected
- procedure AssignTo(Dest: TPersistent); virtual;
- procedure DefineProperties(Filer: TFiler); virtual;
- function GetOwner: TPersistent; dynamic;
- public
- destructor Destroy; override;
- procedure Assign(Source: TPersistent); virtual;
- function GetNamePath: string; dynamic;
- end;
-
- {$M-}
-
- { TPersistent class reference type }
-
- TPersistentClass = class of TPersistent;
-
- { TCollection class }
-
- TCollection = class;
-
- TCollectionItem = class(TPersistent)
- protected
- procedure Changed(AllItems: Boolean);
- function GetOwner: TPersistent; override;
- function GetDisplayName: string; virtual;
- procedure SetIndex(Value: Integer); virtual;
- procedure SetDisplayName(const Value: string); virtual;
- public
- constructor Create(Collection: TCollection); virtual;
- destructor Destroy; override;
- function GetNamePath: string; override;
- property Collection: TCollection;
- property ID: Integer;
- property Index: Integer;
- property DisplayName: string;
- end;
-
- TCollectionItemClass = class of TCollectionItem;
-
- TCollection = class(TPersistent)
- protected
- property NextID: Integer;
- { Design-time editor support }
- function GetAttrCount: Integer; dynamic;
- function GetAttr(Index: Integer): string; dynamic;
- function GetItemAttr(Index, ItemIndex: Integer): string; dynamic;
- procedure Changed;
- function GetItem(Index: Integer): TCollectionItem;
- procedure SetItem(Index: Integer; Value: TCollectionItem);
- procedure SetItemName(Item: TCollectionItem); virtual;
- procedure Update(Item: TCollectionItem); virtual;
- property PropName: string;
- property UpdateCount: Integer;
- public
- constructor Create(ItemClass: TCollectionItemClass);
- destructor Destroy; override;
- function Add: TCollectionItem;
- procedure Assign(Source: TPersistent); override;
- procedure BeginUpdate; virtual;
- procedure Clear;
- procedure Delete(Index: Integer);
- procedure EndUpdate; virtual;
- function FindItemID(ID: Integer): TCollectionItem;
- function GetNamePath: string; override;
- function Insert(Index: Integer): TCollectionItem;
- property Count: Integer;
- property ItemClass: TCollectionItemClass;
- property Items[Index: Integer]: TCollectionItem;
- end;
-
- { Collection class that maintains an "Owner" in order to obtain property
- path information at design-time }
-
- TOwnedCollection = class(TCollection)
- protected
- function GetOwner: TPersistent; override;
- public
- constructor Create(AOwner: TPersistent; ItemClass: TCollectionItemClass);
- end;
-
- TStrings = class;
-
- { TGetModuleProc }
- { Used in the TFormDesigner class to allow component/property editors access
- to project specific information }
-
- TGetModuleProc = procedure(const FileName, UnitName, FormName,
- DesignClass: string; CoClasses: TStrings) of object;
-
- { IStringsAdapter interface }
- { Maintains link between TStrings and IStrings implementations }
-
- IStringsAdapter = interface
- ['{739C2F34-52EC-11D0-9EA6-0020AF3D82DA}']
- procedure ReferenceStrings(S: TStrings);
- procedure ReleaseStrings;
- end;
-
- { TStrings class }
-
- TStrings = class(TPersistent)
- protected
- procedure DefineProperties(Filer: TFiler); override;
- procedure Error(const Msg: string; Data: Integer); overload;
- procedure Error(Msg: PResStringRec; Data: Integer); overload;
- function Get(Index: Integer): string; virtual; abstract;
- function GetCapacity: Integer; virtual;
- function GetCount: Integer; virtual; abstract;
- function GetObject(Index: Integer): TObject; virtual;
- function GetTextStr: string; virtual;
- procedure Put(Index: Integer; const S: string); virtual;
- procedure PutObject(Index: Integer; AObject: TObject); virtual;
- procedure SetCapacity(NewCapacity: Integer); virtual;
- procedure SetTextStr(const Value: string); virtual;
- procedure SetUpdateState(Updating: Boolean); virtual;
- public
- destructor Destroy; override;
- function Add(const S: string): Integer; virtual;
- function AddObject(const S: string; AObject: TObject): Integer; virtual;
- procedure Append(const S: string);
- procedure AddStrings(Strings: TStrings); virtual;
- procedure Assign(Source: TPersistent); override;
- procedure BeginUpdate;
- procedure Clear; virtual; abstract;
- procedure Delete(Index: Integer); virtual; abstract;
- procedure EndUpdate;
- function Equals(Strings: TStrings): Boolean;
- procedure Exchange(Index1, Index2: Integer); virtual;
- function GetText: PChar; virtual;
- function IndexOf(const S: string): Integer; virtual;
- function IndexOfName(const Name: string): Integer;
- function IndexOfObject(AObject: TObject): Integer;
- procedure Insert(Index: Integer; const S: string); virtual; abstract;
- procedure InsertObject(Index: Integer; const S: string;
- AObject: TObject);
- procedure LoadFromFile(const FileName: string); virtual;
- procedure LoadFromStream(Stream: TStream); virtual;
- procedure Move(CurIndex, NewIndex: Integer); virtual;
- procedure SaveToFile(const FileName: string); virtual;
- procedure SaveToStream(Stream: TStream); virtual;
- procedure SetText(Text: PChar); virtual;
- property Capacity: Integer;
- property CommaText: string;
- property Count: Integer;
- property Names[Index: Integer]: string;
- property Objects[Index: Integer]: TObject;
- property Values[const Name: string]: string;
- property Strings[Index: Integer]: string; default;
- property Text: string;
- property StringsAdapter: IStringsAdapter;
- end;
-
- { TStringList class }
-
- TStringList = class;
-
- PStringItem = ^TStringItem;
- TStringItem = record
- FString: string;
- FObject: TObject;
- end;
-
- PStringItemList = ^TStringItemList;
- TStringItemList = array[0..MaxListSize] of TStringItem;
- TStringListSortCompare = function(List: TStringList; Index1, Index2: Integer): Integer;
-
- TStringList = class(TStrings)
- protected
- procedure Changed; virtual;
- procedure Changing; virtual;
- function Get(Index: Integer): string; override;
- function GetCapacity: Integer; override;
- function GetCount: Integer; override;
- function GetObject(Index: Integer): TObject; override;
- procedure Put(Index: Integer; const S: string); override;
- procedure PutObject(Index: Integer; AObject: TObject); override;
- procedure SetCapacity(NewCapacity: Integer); override;
- procedure SetUpdateState(Updating: Boolean); override;
- public
- destructor Destroy; override;
- function Add(const S: string): Integer; override;
- procedure Clear; override;
- procedure Delete(Index: Integer); override;
- procedure Exchange(Index1, Index2: Integer); override;
- function Find(const S: string; var Index: Integer): Boolean; virtual;
- function IndexOf(const S: string): Integer; override;
- procedure Insert(Index: Integer; const S: string); override;
- procedure Sort; virtual;
- procedure CustomSort(Compare: TStringListSortCompare); virtual;
- property Duplicates: TDuplicates;
- property Sorted: Boolean;
- property OnChange: TNotifyEvent;
- property OnChanging: TNotifyEvent;
- end;
-
- { TStream abstract class }
-
- TStream = class(TObject)
- protected
- procedure SetSize(NewSize: Longint); virtual;
- public
- function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
- function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
- function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
- procedure ReadBuffer(var Buffer; Count: Longint);
- procedure WriteBuffer(const Buffer; Count: Longint);
- function CopyFrom(Source: TStream; Count: Longint): Longint;
- function ReadComponent(Instance: TComponent): TComponent;
- function ReadComponentRes(Instance: TComponent): TComponent;
- procedure WriteComponent(Instance: TComponent);
- procedure WriteComponentRes(const ResName: string; Instance: TComponent);
- procedure WriteDescendent(Instance, Ancestor: TComponent);
- procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
- procedure WriteResourceHeader(const ResName: string; out FixupInfo: Integer);
- procedure FixupResourceHeader(FixupInfo: Integer);
- procedure ReadResHeader;
- property Position: Longint;
- property Size: Longint;
- end;
-
- { THandleStream class }
-
- THandleStream = class(TStream)
- protected
- procedure SetSize(NewSize: Longint); override;
- public
- constructor Create(AHandle: Integer);
- function Read(var Buffer; Count: Longint): Longint; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- property Handle: Integer;
- end;
-
- { TFileStream class }
-
- TFileStream = class(THandleStream)
- public
- constructor Create(const FileName: string; Mode: Word);
- destructor Destroy; override;
- end;
-
- { TCustomMemoryStream abstract class }
-
- TCustomMemoryStream = class(TStream)
- protected
- procedure SetPointer(Ptr: Pointer; Size: Longint);
- public
- function Read(var Buffer; Count: Longint): Longint; override;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- procedure SaveToStream(Stream: TStream);
- procedure SaveToFile(const FileName: string);
- property Memory: Pointer;
- end;
-
- { TMemoryStream }
-
- TMemoryStream = class(TCustomMemoryStream)
- protected
- function Realloc(var NewCapacity: Longint): Pointer; virtual;
- property Capacity: Longint;
- public
- destructor Destroy; override;
- procedure Clear;
- procedure LoadFromStream(Stream: TStream);
- procedure LoadFromFile(const FileName: string);
- procedure SetSize(NewSize: Longint); override;
- function Write(const Buffer; Count: Longint): Longint; override;
- end;
-
- { TStringStream }
-
- TStringStream = class(TStream)
- protected
- procedure SetSize(NewSize: Longint); override;
- public
- constructor Create(const AString: string);
- function Read(var Buffer; Count: Longint): Longint; override;
- function ReadString(Count: Longint): string;
- function Seek(Offset: Longint; Origin: Word): Longint; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- procedure WriteString(const AString: string);
- property DataString: string;
- end;
-
- { TResourceStream }
-
- TResourceStream = class(TCustomMemoryStream)
- public
- constructor Create(Instance: THandle; const ResName: string; ResType: PChar);
- constructor CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
- destructor Destroy; override;
- function Write(const Buffer; Count: Longint): Longint; override;
- end;
-
- { TStreamAdapter }
- { Implements OLE IStream on VCL TStream }
-
- TStreamOwnership = (soReference, soOwned);
-
- TStreamAdapter = class(TInterfacedObject, IStream)
- public
- constructor Create(Stream: TStream; Ownership: TStreamOwnership = soReference);
- destructor Destroy; override;
- function Read(pv: Pointer; cb: Longint;
- pcbRead: PLongint): HResult; virtual; stdcall;
- function Write(pv: Pointer; cb: Longint;
- pcbWritten: PLongint): HResult; virtual; stdcall;
- function Seek(dlibMove: Largeint; dwOrigin: Longint;
- out libNewPosition: Largeint): HResult; virtual; stdcall;
- function SetSize(libNewSize: Largeint): HResult; virtual; stdcall;
- function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint;
- out cbWritten: Largeint): HResult; virtual; stdcall;
- function Commit(grfCommitFlags: Longint): HResult; virtual; stdcall;
- function Revert: HResult; virtual; stdcall;
- function LockRegion(libOffset: Largeint; cb: Largeint;
- dwLockType: Longint): HResult; virtual; stdcall;
- function UnlockRegion(libOffset: Largeint; cb: Largeint;
- dwLockType: Longint): HResult; virtual; stdcall;
- function Stat(out statstg: TStatStg;
- grfStatFlag: Longint): HResult; virtual; stdcall;
- function Clone(out stm: IStream): HResult; virtual; stdcall;
- property Stream: TStream;
- property StreamOwnership: TStreamOwnership;
- end;
-
- { TFiler }
-
- TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended,
- vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString,
- vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64);
-
- TFilerFlag = (ffInherited, ffChildPos, ffInline);
- TFilerFlags = set of TFilerFlag;
-
- TReaderProc = procedure(Reader: TReader) of object;
- TWriterProc = procedure(Writer: TWriter) of object;
- TStreamProc = procedure(Stream: TStream) of object;
-
- TFiler = class(TObject)
- protected
- procedure SetRoot(Value: TComponent); virtual;
- public
- constructor Create(Stream: TStream; BufSize: Integer);
- destructor Destroy; override;
- procedure DefineProperty(const Name: string;
- ReadData: TReaderProc; WriteData: TWriterProc;
- HasData: Boolean); virtual; abstract;
- procedure DefineBinaryProperty(const Name: string;
- ReadData, WriteData: TStreamProc;
- HasData: Boolean); virtual; abstract;
- procedure FlushBuffer; virtual; abstract;
- property Root: TComponent;
- property LookupRoot: TComponent;
- property Ancestor: TPersistent;
- property IgnoreChildren: Boolean;
- end;
-
- { TComponent class reference type }
-
- TComponentClass = class of TComponent;
-
- { TReader }
-
- TFindMethodEvent = procedure(Reader: TReader; const MethodName: string;
- var Address: Pointer; var Error: Boolean) of object;
- TSetNameEvent = procedure(Reader: TReader; Component: TComponent;
- var Name: string) of object;
- TReferenceNameEvent = procedure(Reader: TReader; var Name: string) of object;
- TAncestorNotFoundEvent = procedure(Reader: TReader; const ComponentName: string;
- ComponentClass: TPersistentClass; var Component: TComponent) of object;
- TReadComponentsProc = procedure(Component: TComponent) of object;
- TReaderError = procedure(Reader: TReader; const Message: string; var Handled: Boolean) of object;
- TFindComponentClassEvent = procedure(Reader: TReader; const ClassName: string;
- var ComponentClass: TComponentClass) of object;
- TCreateComponentEvent = procedure(Reader: TReader;
- ComponentClass: TComponentClass; var Component: TComponent) of object;
-
- TReader = class(TFiler)
- protected
- function Error(const Message: string): Boolean; virtual;
- function FindAncestorComponent(const Name: string;
- ComponentClass: TPersistentClass): TComponent; virtual;
- function FindMethod(Root: TComponent; const MethodName: string): Pointer; virtual;
- procedure SetName(Component: TComponent; var Name: string); virtual;
- procedure ReadProperty(AInstance: TPersistent);
- procedure ReadPropValue(Instance: TPersistent; PropInfo: Pointer);
- procedure ReferenceName(var Name: string); virtual;
- procedure PropertyError;
- procedure ReadData(Instance: TComponent);
- function ReadSet(SetType: Pointer): Integer;
- procedure SetPosition(Value: Longint);
- procedure SkipSetBody;
- procedure SkipValue;
- procedure SkipProperty;
- procedure SkipComponent(SkipHeader: Boolean);
- property PropName: string;
- property CanHandleExceptions: Boolean;
- public
- destructor Destroy; override;
- procedure BeginReferences;
- procedure CheckValue(Value: TValueType);
- procedure DefineProperty(const Name: string;
- ReadData: TReaderProc; WriteData: TWriterProc;
- HasData: Boolean); override;
- procedure DefineBinaryProperty(const Name: string;
- ReadData, WriteData: TStreamProc;
- HasData: Boolean); override;
- function EndOfList: Boolean;
- procedure EndReferences;
- procedure FixupReferences;
- procedure FlushBuffer; override;
- function NextValue: TValueType;
- procedure Read(var Buf; Count: Longint);
- function ReadBoolean: Boolean;
- function ReadChar: Char;
- procedure ReadCollection(Collection: TCollection);
- function ReadComponent(Component: TComponent): TComponent;
- procedure ReadComponents(AOwner, AParent: TComponent;
- Proc: TReadComponentsProc);
- function ReadFloat: Extended;
- function ReadSingle: Single;
- function ReadCurrency: Currency;
- function ReadDate: TDateTime;
- function ReadIdent: string;
- function ReadInteger: Longint;
- function ReadInt64: Int64;
- procedure ReadListBegin;
- procedure ReadListEnd;
- procedure ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); virtual;
- function ReadRootComponent(Root: TComponent): TComponent;
- procedure ReadSignature;
- function ReadStr: string;
- function ReadString: string;
- function ReadWideString: WideString;
- function ReadValue: TValueType;
- procedure CopyValue(Writer: TWriter);
- property Owner: TComponent;
- property Parent: TComponent;
- property Position: Longint;
- property OnError: TReaderError;
- property OnFindMethod: TFindMethodEvent;
- property OnSetName: TSetNameEvent;
- property OnReferenceName: TReferenceNameEvent;
- property OnAncestorNotFound: TAncestorNotFoundEvent;
- property OnCreateComponent: TCreateComponentEvent;
- property OnFindComponentClass: TFindComponentClassEvent;
- end;
-
- { TWriter }
-
- TFindAncestorEvent = procedure (Writer: TWriter; Component: TComponent;
- const Name: string; var Ancestor, RootAncestor: TComponent) of object;
-
- TWriter = class(TFiler)
- protected
- procedure SetRoot(Value: TComponent); override;
- procedure WriteBinary(WriteData: TStreamProc);
- procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer);
- procedure WriteProperty(Instance: TPersistent; PropInfo: Pointer);
- procedure WriteProperties(Instance: TPersistent);
- procedure WritePropName(const PropName: string);
- procedure WriteValue(Value: TValueType);
- public
- destructor Destroy; override;
- procedure DefineProperty(const Name: string;
- ReadData: TReaderProc; WriteData: TWriterProc;
- HasData: Boolean); override;
- procedure DefineBinaryProperty(const Name: string;
- ReadData, WriteData: TStreamProc;
- HasData: Boolean); override;
- procedure FlushBuffer; override;
- procedure Write(const Buf; Count: Longint);
- procedure WriteBoolean(Value: Boolean);
- procedure WriteCollection(Value: TCollection);
- procedure WriteComponent(Component: TComponent);
- procedure WriteChar(Value: Char);
- procedure WriteDescendent(Root: TComponent; AAncestor: TComponent);
- procedure WriteFloat(const Value: Extended);
- procedure WriteSingle(const Value: Single);
- procedure WriteCurrency(const Value: Currency);
- procedure WriteDate(const Value: TDateTime);
- procedure WriteIdent(const Ident: string);
- procedure WriteInteger(Value: Longint); overload;
- procedure WriteInteger(Value: Int64); overload;
- procedure WriteListBegin;
- procedure WriteListEnd;
- procedure WriteRootComponent(Root: TComponent);
- procedure WriteSignature;
- procedure WriteStr(const Value: string);
- procedure WriteString(const Value: string);
- procedure WriteWideString(const Value: WideString);
- property Position: Longint;
- property RootAncestor: TComponent;
- property OnFindAncestor: TFindAncestorEvent;
- end;
-
- { TParser }
-
- TParser = class(TObject)
- public
- constructor Create(Stream: TStream);
- destructor Destroy; override;
- procedure CheckToken(T: Char);
- procedure CheckTokenSymbol(const S: string);
- procedure Error(const Ident: string);
- procedure ErrorFmt(const Ident: string; const Args: array of const);
- procedure ErrorStr(const Message: string);
- procedure HexToBinary(Stream: TStream);
- function NextToken: Char;
- function SourcePos: Longint;
- function TokenComponentIdent: string;
- function TokenFloat: Extended;
- function TokenInt: Int64;
- function TokenString: string;
- function TokenWideString: WideString;
- function TokenSymbolIs(const S: string): Boolean;
- property FloatType: Char;
- property SourceLine: Integer;
- property Token: Char;
- end;
-
- { TThread }
-
- EThread = class(Exception);
-
- TThreadMethod = procedure of object;
- TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
- tpTimeCritical);
-
- TThread = class
- protected
- procedure DoTerminate; virtual;
- procedure Execute; virtual; abstract;
- procedure Synchronize(Method: TThreadMethod);
- property ReturnValue: Integer;
- property Terminated: Boolean;
- public
- constructor Create(CreateSuspended: Boolean);
- destructor Destroy; override;
- procedure Resume;
- procedure Suspend;
- procedure Terminate;
- function WaitFor: LongWord;
- property FreeOnTerminate: Boolean;
- property Handle: THandle;
- property Priority: TT;
- property Suspended: Boolean;
- property T;
- property OnTerminate: TNotifyEvent;
- end;
-
- { TComponent class }
-
- TOperation = (opInsert, opRemove);
- TComponentState = set of (csLoading, csReading, csWriting, csDestroying,
- csDesigning, csAncestor, csUpdating, csFixups, csFreeNotification,
- csInline, csDesignInstance);
- TComponentStyle = set of (csInheritable, csCheckPropAvail);
- TGetChildProc = procedure (Child: TComponent) of object;
-
- TComponentName = type string;
-
- IVCLComObject = interface
- ['{E07892A0-F52F-11CF-BD2F-0020AF0E5B81}']
- function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
- function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
- function GetIDsOfNames(const IID: TGUID; Names: Pointer;
- NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
- function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
- Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
- function SafeCallException(ExceptObject: TObject;
- ExceptAddr: Pointer): HResult;
- procedure FreeOnRelease;
- end;
-
- IDesignerNotify = interface
- ['{B971E807-E3A6-11D1-AAB1-00C04FB16FBC}']
- procedure Modified;
- procedure Notification(AnObject: TPersistent; Operation: TOperation);
- end;
-
- TBasicAction = class;
-
- TComponent = class(TPersistent)
- protected
- FComponentStyle: TComponentStyle;
- procedure ChangeName(const NewName: TComponentName);
- procedure DefineProperties(Filer: TFiler); override;
- procedure GetChildren(Proc: TGetChildProc; Root: TComponent); dynamic;
- function GetChildOwner: TComponent; dynamic;
- function GetChildParent: TComponent; dynamic;
- function GetOwner: TPersistent; override;
- procedure Loaded; virtual;
- procedure Notification(AComponent: TComponent;
- Operation: TOperation); virtual;
- procedure ReadState(Reader: TReader); virtual;
- procedure SetAncestor(Value: Boolean);
- procedure SetDesigning(Value: Boolean; SetChildren: Boolean = True);
- procedure SetInline(Value: Boolean);
- procedure SetDesignInstance(Value: Boolean);
- procedure SetName(const NewName: TComponentName); virtual;
- procedure SetChildOrder(Child: TComponent; Order: Integer); dynamic;
- procedure SetParentComponent(Value: TComponent); dynamic;
- procedure Updating; dynamic;
- procedure Updated; dynamic;
- class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); virtual;
- procedure ValidateRename(AComponent: TComponent;
- const CurName, NewName: string); virtual;
- procedure ValidateContainer(AComponent: TComponent); dynamic;
- procedure ValidateInsert(AComponent: TComponent); dynamic;
- procedure WriteState(Writer: TWriter); virtual;
- { IUnknown }
- function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
- function _AddRef: Integer; stdcall;
- function _Release: Integer; stdcall;
- { IDispatch }
- function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
- function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
- function GetIDsOfNames(const IID: TGUID; Names: Pointer;
- NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
- function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
- Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
- public
- constructor Create(AOwner: TComponent); virtual;
- destructor Destroy; override;
- procedure BeforeDestruction; override;
- procedure DestroyComponents;
- procedure Destroying;
- function ExecuteAction(Action: TBasicAction): Boolean; dynamic;
- function FindComponent(const AName: string): TComponent;
- procedure FreeNotification(AComponent: TComponent);
- procedure RemoveFreeNotification(AComponent: TComponent);
- procedure FreeOnRelease;
- function GetParentComponent: TComponent; dynamic;
- function GetNamePath: string; override;
- function HasParent: Boolean; dynamic;
- procedure InsertComponent(AComponent: TComponent);
- procedure RemoveComponent(AComponent: TComponent);
- function SafeCallException(ExceptObject: TObject;
- ExceptAddr: Pointer): HResult; override;
- function UpdateAction(Action: TBasicAction): Boolean; dynamic;
- property ComObject: IUnknown;
- property Components[Index: Integer]: TComponent;
- property ComponentCount: Integer;
- property ComponentIndex: Integer;
- property ComponentState: TComponentState;
- property ComponentStyle: TComponentStyle;
- property DesignInfo: Longint;
- property Owner: TComponent;
- property VCLComObject: Pointer;
- published
- property Name: TComponentName;
- property Tag: Longint default 0;
- end;
-
- { TBasicActionLink }
-
- TBasicActionLink = class(TObject)
- protected
- FAction: TBasicAction;
- procedure AssignClient(AClient: TObject); virtual;
- procedure Change; virtual;
- function IsOnExecuteLinked: Boolean; virtual;
- procedure SetAction(Value: TBasicAction); virtual;
- procedure SetOnExecute(Value: TNotifyEvent); virtual;
- public
- constructor Create(AClient: TObject); virtual;
- destructor Destroy; override;
- function Execute: Boolean; virtual;
- function Update: Boolean; virtual;
- property Action: TBasicAction;
- property OnChange: TNotifyEvent;
- end;
-
- TBasicActionLinkClass = class of TBasicActionLink;
-
- { TBasicAction }
-
- TBasicAction = class(TComponent)
- protected
- FClients: TList;
- procedure Change; virtual;
- procedure SetOnExecute(Value: TNotifyEvent); virtual;
- property OnChange: TNotifyEvent;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- function HandlesTarget(Target: TObject): Boolean; virtual;
- procedure UpdateTarget(Target: TObject); virtual;
- procedure ExecuteTarget(Target: TObject); virtual;
- function Execute: Boolean; dynamic;
- procedure RegisterChanges(Value: TBasicActionLink);
- procedure UnRegisterChanges(Value: TBasicActionLink);
- function Update: Boolean; virtual;
- property OnExecute: TNotifyEvent;
- property OnUpdate: TNotifyEvent;
- end;
-
- { TBasicAction class reference type }
-
- TBasicActionClass = class of TBasicAction;
-
- { Component registration handlers }
-
- TActiveXRegType = (axrComponentOnly, axrIncludeDescendants);
-
- var
- RegisterComponentsProc: procedure(const Page: string;
- ComponentClasses: array of TComponentClass) = nil;
- RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass) = nil;
- RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass;
- AxRegType: TActiveXRegType) = nil;
- CurrentGroup: Integer = -1; { Current design group }
- CreateVCLComObjectProc: procedure(Component: TComponent) = nil;
-
- { Point and rectangle constructors }
-
- function Point(AX, AY: Integer): TPoint;
- function SmallPoint(AX, AY: SmallInt): TSmallPoint;
- function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect;
- function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect;
-
- { Class registration routines }
-
- procedure RegisterClass(AClass: TPersistentClass);
- procedure RegisterClasses(AClasses: array of TPersistentClass);
- procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
- procedure UnRegisterClass(AClass: TPersistentClass);
- procedure UnRegisterClasses(AClasses: array of TPersistentClass);
- procedure UnRegisterModuleClasses(Module: HMODULE);
- function FindClass(const ClassName: string): TPersistentClass;
- function GetClass(const AClassName: string): TPersistentClass;
-
- { Component registration routines }
-
- procedure RegisterComponents(const Page: string;
- ComponentClasses: array of TComponentClass);
- procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
- procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
- AxRegType: TActiveXRegType);
-
- var
- GlobalNameSpace: TMultiReadExclusiveWriteSynchronizer;
-
- { Object filing routines }
-
- type
- TIdentMapEntry = record
- Value: Integer;
- Name: String;
- end;
-
- TIdentToInt = function(const Ident: string; var Int: Longint): Boolean;
- TIntToIdent = function(Int: Longint; var Ident: string): Boolean;
- TFindGlobalComponent = function(const Name: string): TComponent;
-
- var
- FindGlobalComponent: TFindGlobalComponent;
-
- procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToInt: TIdentToInt;
- IntToIdent: TIntToIdent);
- function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean;
- function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean;
- function FindIntToIdent(AIntegerType: Pointer): TIntToIdent;
- function FindIdentToInt(AIntegerType: Pointer): TIdentToInt;
-
- function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean;
- function InitComponentRes(const ResName: string; Instance: TComponent): Boolean;
- function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent;
- function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent;
- function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent;
- procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
-
- procedure GlobalFixupReferences;
- procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings);
- procedure GetFixupInstanceNames(Root: TComponent;
- const ReferenceRootName: string; Names: TStrings);
- procedure RedirectFixupReferences(Root: TComponent; const OldRootName,
- NewRootName: string);
- procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
- procedure RemoveFixups(Instance: TPersistent);
- function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent;
-
- procedure BeginGlobalLoading;
- procedure NotifyGlobalLoading;
- procedure EndGlobalLoading;
-
- function CollectionsEqual(C1, C2: TCollection): Boolean;
-
- { Object conversion routines }
-
- type
- TStreamOriginalFormat = (sofUnknown, sofBinary, sofText);
-
- procedure ObjectBinaryToText(Input, Output: TStream); overload;
- procedure ObjectBinaryToText(Input, Output: TStream;
- var OriginalFormat: TStreamOriginalFormat); overload;
- procedure ObjectTextToBinary(Input, Output: TStream); overload;
- procedure ObjectTextToBinary(Input, Output: TStream;
- var OriginalFormat: TStreamOriginalFormat); overload;
-
- procedure ObjectResourceToText(Input, Output: TStream); overload;
- procedure ObjectResourceToText(Input, Output: TStream;
- var OriginalFormat: TStreamOriginalFormat); overload;
- procedure ObjectTextToResource(Input, Output: TStream); overload;
- procedure ObjectTextToResource(Input, Output: TStream;
- var OriginalFormat: TStreamOriginalFormat); overload;
-
- function TestStreamFormat(Stream: TStream): TStreamOriginalFormat;
-
- { Utility routines }
-
- function LineStart(Buffer, BufPos: PChar): PChar;
- function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar;
- Strings: TStrings): Integer;
-
- procedure BinToHex(Buffer, Text: PChar; BufSize: Integer);
- function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer;
-
- function FindRootDesigner(Obj: TPersistent): IDesignerNotify;
-
- implementation
-