{ *************************************************************************** } { } { Delphi and Kylix Cross-Platform Visual Component Library } { } { Copyright (c) 1995, 2001 Borland Software Corporation } { } { *************************************************************************** } unit Classes; {$R-,T-,X+,H+,B-} {$IFDEF MSWINDOWS} { ACTIVEX.HPP is not required by CLASSES.HPP } (*$NOINCLUDE ActiveX*) {$ENDIF} {$IFDEF LINUX} {$DEFINE _WIN32} {$ENDIF} {$IFDEF MSWINDOWS} {$DEFINE _WIN32} {$ENDIF} interface {$IFDEF MSWINDOWS} uses Windows, Messages, SysUtils, Variants, TypInfo, ActiveX; {$ENDIF} {$IFDEF LINUX} uses Libc, SysUtils, Variants, TypInfo, Types; {$ENDIF} const { Maximum TList size } MaxListSize = Maxint div 16; { TStream seek origins } soFromBeginning = 0; soFromCurrent = 1; soFromEnd = 2; type { TStream seek origins } TSeekOrigin = (soBeginning, soCurrent, soEnd); const { 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; THelpType = (htKeyword, htContext); {!! Moved here from menus.pas !!} TShortCut = Low(Word)..High(Word); { Standard events } TNotifyEvent = procedure(Sender: TObject) 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); // these operators are used in Assign and go beyond simply copying // laCopy = dest becomes a copy of the source // laAnd = intersection of the two lists // laOr = union of the two lists // laXor = only those not in both lists // the last two operators can actually be thought of as binary operators but // their implementation has been optimized over their binary equivalent. // laSrcUnique = only those unique to source (same as laAnd followed by laXor) // laDestUnique = only those unique to dest (same as laOr followed by laXor) TListAssignOp = (laCopy, laAnd, laOr, laXor, laSrcUnique, laDestUnique); TList = class(TObject) private FList: PPointerList; FCount: Integer; FCapacity: Integer; 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); procedure Assign(ListA: TList; AOperator: TListAssignOp = laCopy; ListB: TList = nil); property Capacity: Integer read FCapacity write SetCapacity; property Count: Integer read FCount write SetCount; property Items[Index: Integer]: Pointer read Get write Put; default; property List: PPointerList read FList; end; { TThreadList class } TThreadList = class private FList: TList; FLock: TRTLCriticalSection; FDuplicates: TDuplicates; public constructor Create; destructor Destroy; override; procedure Add(Item: Pointer); procedure Clear; function LockList: TList; procedure Remove(Item: Pointer); procedure UnlockList; property Duplicates: TDuplicates read FDuplicates write FDuplicates; end; { IInterfaceList interface } IInterfaceList = interface ['{285DEA8A-B865-11D1-AAA7-00C04FB17A72}'] function Get(Index: Integer): IInterface; function GetCapacity: Integer; function GetCount: Integer; procedure Put(Index: Integer; const Item: IInterface); procedure SetCapacity(NewCapacity: Integer); procedure SetCount(NewCount: Integer); procedure Clear; procedure Delete(Index: Integer); procedure Exchange(Index1, Index2: Integer); function First: IInterface; function IndexOf(const Item: IInterface): Integer; function Add(const Item: IInterface): Integer; procedure Insert(Index: Integer; const Item: IInterface); function Last: IInterface; function Remove(const Item: IInterface): Integer; procedure Lock; procedure Unlock; property Capacity: Integer read GetCapacity write SetCapacity; property Count: Integer read GetCount write SetCount; property Items[Index: Integer]: IInterface read Get write Put; default; end; { EXTERNALSYM IInterfaceList} { TInterfaceList class } TInterfaceList = class(TInterfacedObject, IInterfaceList) private FList: TThreadList; protected { IInterfaceList } function Get(Index: Integer): IInterface; function GetCapacity: Integer; function GetCount: Integer; procedure Put(Index: Integer; const Item: IInterface); 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: IInterface; function IndexOf(const Item: IInterface): Integer; function Add(const Item: IInterface): Integer; procedure Insert(Index: Integer; const Item: IInterface); function Last: IInterface; function Remove(const Item: IInterface): Integer; procedure Lock; procedure Unlock; property Capacity: Integer read GetCapacity write SetCapacity; property Count: Integer read GetCount write SetCount; property Items[Index: Integer]: IInterface read Get write Put; default; end; { EXTERNALSYM TInterfaceList} { TBits class } TBits = class private FSize: Integer; FBits: Pointer; procedure Error; procedure SetSize(Value: Integer); procedure SetBit(Index: Integer; Value: Boolean); function GetBit(Index: Integer): Boolean; public destructor Destroy; override; function OpenBit: Integer; property Bits[Index: Integer]: Boolean read GetBit write SetBit; default; property Size: Integer read FSize write SetSize; end; { TPersistent abstract class } {$M+} TPersistent = class(TObject) private procedure AssignError(Source: TPersistent); 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; { TInterfaced Persistent } TInterfacedPersistent = class(TPersistent, IInterface) private FOwnerInterface: IInterface; protected { IInterface } function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; public function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; procedure AfterConstruction; override; end; { TRecall class } TRecall = class(TObject) private FStorage, FReference: TPersistent; public constructor Create(AStorage, AReference: TPersistent); destructor Destroy; override; procedure Store; procedure Forget; property Reference: TPersistent read FReference; end; { TCollection class } TCollection = class; TCollectionItem = class(TPersistent) private FCollection: TCollection; FID: Integer; function GetIndex: Integer; protected procedure Changed(AllItems: Boolean); function GetOwner: TPersistent; override; function GetDisplayName: string; virtual; procedure SetCollection(Value: TCollection); 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 read FCollection write SetCollection; property ID: Integer read FID; property Index: Integer read GetIndex write SetIndex; property DisplayName: string read GetDisplayName write SetDisplayName; end; TCollectionItemClass = class of TCollectionItem; TCollectionNotification = (cnAdded, cnExtracting, cnDeleting); TCollection = class(TPersistent) private FItemClass: TCollectionItemClass; FItems: TList; FUpdateCount: Integer; FNextID: Integer; FPropName: string; function GetCount: Integer; function GetPropName: string; procedure InsertItem(Item: TCollectionItem); procedure RemoveItem(Item: TCollectionItem); protected procedure Added(var Item: TCollectionItem); virtual; deprecated; procedure Deleting(Item: TCollectionItem); virtual; deprecated; property NextID: Integer read FNextID; procedure Notify(Item: TCollectionItem; Action: TCollectionNotification); virtual; { 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 read GetPropName write FPropName; property UpdateCount: Integer read FUpdateCount; public constructor Create(ItemClass: TCollectionItemClass); destructor Destroy; override; function Owner: TPersistent; 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 read GetCount; property ItemClass: TCollectionItemClass read FItemClass; property Items[Index: Integer]: TCollectionItem read GetItem write SetItem; end; { Collection class that maintains an "Owner" in order to obtain property path information at design-time } TOwnedCollection = class(TCollection) private FOwner: TPersistent; 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 } TStringsDefined = set of (sdDelimiter, sdQuoteChar); TStrings = class(TPersistent) private FDefined: TStringsDefined; FDelimiter: Char; FQuoteChar: Char; FUpdateCount: Integer; FAdapter: IStringsAdapter; function GetCommaText: string; function GetDelimitedText: string; function GetName(Index: Integer): string; function GetValue(const Name: string): string; procedure ReadData(Reader: TReader); procedure SetCommaText(const Value: string); procedure SetDelimitedText(const Value: string); procedure SetStringsAdapter(const Value: IStringsAdapter); procedure SetValue(const Name, Value: string); procedure WriteData(Writer: TWriter); function GetDelimiter: Char; procedure SetDelimiter(const Value: Char); function GetQuoteChar: Char; procedure SetQuoteChar(const Value: Char); protected procedure DefineProperties(Filer: TFiler); override; procedure Error(const Msg: string; Data: Integer); overload; procedure Error(Msg: PResStringRec; Data: Integer); overload; function ExtractName(const S: string): string; 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; property UpdateCount: Integer read FUpdateCount; function CompareStrings(const S1, S2: string): Integer; 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; virtual; function IndexOfObject(AObject: TObject): Integer; virtual; procedure Insert(Index: Integer; const S: string); virtual; abstract; procedure InsertObject(Index: Integer; const S: string; AObject: TObject); virtual; 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 read GetCapacity write SetCapacity; property CommaText: string read GetCommaText write SetCommaText; property Count: Integer read GetCount; property Delimiter: Char read GetDelimiter write SetDelimiter; property DelimitedText: string read GetDelimitedText write SetDelimitedText; property Names[Index: Integer]: string read GetName; property Objects[Index: Integer]: TObject read GetObject write PutObject; property QuoteChar: Char read GetQuoteChar write SetQuoteChar; property Values[const Name: string]: string read GetValue write SetValue; property Strings[Index: Integer]: string read Get write Put; default; property Text: string read GetTextStr write SetTextStr; property StringsAdapter: IStringsAdapter read FAdapter write SetStringsAdapter; 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) private FList: PStringItemList; FCount: Integer; FCapacity: Integer; FSorted: Boolean; FDuplicates: TDuplicates; FCaseSensitive: Boolean; FOnChange: TNotifyEvent; FOnChanging: TNotifyEvent; procedure ExchangeItems(Index1, Index2: Integer); procedure Grow; procedure QuickSort(L, R: Integer; SCompare: TStringListSortCompare); procedure SetSorted(Value: Boolean); procedure SetCaseSensitive(const Value: Boolean); 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; function CompareStrings(const S1, S2: string): Integer; override; procedure InsertItem(Index: Integer; const S: string; AObject: TObject); virtual; public destructor Destroy; override; function Add(const S: string): Integer; override; function AddObject(const S: string; AObject: TObject): 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 InsertObject(Index: Integer; const S: string; AObject: TObject); override; procedure Sort; virtual; procedure CustomSort(Compare: TStringListSortCompare); virtual; property Duplicates: TDuplicates read FDuplicates write FDuplicates; property Sorted: Boolean read FSorted write SetSorted; property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; end; { TStream abstract class } TStream = class(TObject) private function GetPosition: Int64; procedure SetPosition(const Pos: Int64); function GetSize: Int64; procedure SetSize64(const NewSize: Int64); protected procedure SetSize(NewSize: Longint); overload; virtual; procedure SetSize(const NewSize: Int64); overload; 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; overload; virtual; function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; overload; virtual; procedure ReadBuffer(var Buffer; Count: Longint); procedure WriteBuffer(const Buffer; Count: Longint); function CopyFrom(Source: TStream; Count: Int64): Int64; 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); virtual; procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent); procedure WriteResourceHeader(const ResName: string; out FixupInfo: Integer); procedure FixupResourceHeader(FixupInfo: Integer); procedure ReadResHeader; property Position: Int64 read GetPosition write SetPosition; property Size: Int64 read GetSize write SetSize64; end; IStreamPersist = interface ['{B8CD12A3-267A-11D4-83DA-00C04F60B2DD}'] procedure LoadFromStream(Stream: TStream); procedure SaveToStream(Stream: TStream); end; { THandleStream class } THandleStream = class(TStream) protected FHandle: Integer; procedure SetSize(NewSize: Longint); override; procedure SetSize(const NewSize: Int64); override; public constructor Create(AHandle: Integer); function Read(var Buffer; Count: Longint): Longint; override; function Write(const Buffer; Count: Longint): Longint; override; function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; property Handle: Integer read FHandle; end; { TFileStream class } TFileStream = class(THandleStream) public constructor Create(const FileName: string; Mode: Word); overload; constructor Create(const FileName: string; Mode: Word; Rights: Cardinal); overload; destructor Destroy; override; end; { TCustomMemoryStream abstract class } TCustomMemoryStream = class(TStream) private FMemory: Pointer; FSize, FPosition: Longint; 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 read FMemory; end; { TMemoryStream } TMemoryStream = class(TCustomMemoryStream) private FCapacity: Longint; procedure SetCapacity(NewCapacity: Longint); protected function Realloc(var NewCapacity: Longint): Pointer; virtual; property Capacity: Longint read FCapacity write SetCapacity; 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) private FDataString: string; FPosition: Integer; 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 read FDataString; end; { TResourceStream } TResourceStream = class(TCustomMemoryStream) private HResInfo: THandle; HGlobal: THandle; procedure Initialize(Instance: THandle; Name, ResType: PChar); 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) private FStream: TStream; FOwnership: TStreamOwnership; 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 read FStream; property StreamOwnership: TStreamOwnership read FOwnership write FOwnership; end; { TClassFinder } TGetClass = procedure (AClass: TPersistentClass) of object; TClassFinder = class private FGroups: TList; public constructor Create(AClass: TPersistentClass = nil; AIncludeActiveGroups: Boolean = False); destructor Destroy; override; function GetClass(const AClassName: string): TPersistentClass; procedure GetClasses(Proc: TGetClass); end; { TFiler } TValueType = (vaNull, vaList, vaInt8, vaInt16, vaInt32, vaExtended, vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, vaLString, vaNil, vaCollection, vaSingle, vaCurrency, vaDate, vaWString, vaInt64, vaUTF8String); 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; IInterfaceComponentReference = interface ['{E28B1858-EC86-4559-8FCD-6B4F824151ED}'] function GetComponent: TComponent; end; TFiler = class(TObject) private FStream: TStream; FBuffer: Pointer; FBufSize: Integer; FBufPos: Integer; FBufEnd: Integer; FRoot: TComponent; FLookupRoot: TComponent; FAncestor: TPersistent; FIgnoreChildren: Boolean; 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 read FRoot write SetRoot; property LookupRoot: TComponent read FLookupRoot; property Ancestor: TPersistent read FAncestor write FAncestor; property IgnoreChildren: Boolean read FIgnoreChildren write FIgnoreChildren; end; { TComponent class reference type } TComponentClass = class of TComponent; { Custom variant stream support } IVarStreamable = interface ['{D60BA026-5E42-4C2A-BB01-3F1C8F30A28E}'] procedure StreamIn(var Dest: TVarData; const Stream: TStream); procedure StreamOut(const Source: TVarData; const Stream: TStream); end; { 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) private FOwner: TComponent; FParent: TComponent; FFixups: TList; FLoaded: TList; FOnFindMethod: TFindMethodEvent; FOnSetName: TSetNameEvent; FOnReferenceName: TReferenceNameEvent; FOnAncestorNotFound: TAncestorNotFoundEvent; FOnError: TReaderError; FOnFindComponentClass: TFindComponentClassEvent; FOnCreateComponent: TCreateComponentEvent; FPropName: string; FFinder: TClassFinder; FCanHandleExcepts: Boolean; procedure DoFixupReferences; procedure FreeFixups; function GetFieldClass(Instance: TObject; const ClassName: string): TPersistentClass; function GetPosition: Longint; procedure ReadBuffer; procedure ReadDataInner(Instance: TComponent); function FindComponentClass(const ClassName: string): TComponentClass; 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(const Name: string); procedure ReadData(Instance: TComponent); function ReadSet(SetType: Pointer): Integer; procedure SetPosition(Value: Longint); procedure SkipBytes(Count: Integer); procedure SkipSetBody; procedure SkipProperty; procedure SkipComponent(SkipHeader: Boolean); property PropName: string read FPropName; property CanHandleExceptions: Boolean read FCanHandleExcepts; 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; function ReadVariant: Variant; procedure CopyValue(Writer: TWriter); procedure SkipValue; property Owner: TComponent read FOwner write FOwner; property Parent: TComponent read FParent write FParent; property Position: Longint read GetPosition write SetPosition; property OnError: TReaderError read FOnError write FOnError; property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod; property OnSetName: TSetNameEvent read FOnSetName write FOnSetName; property OnReferenceName: TReferenceNameEvent read FOnReferenceName write FOnReferenceName; property OnAncestorNotFound: TAncestorNotFoundEvent read FOnAncestorNotFound write FOnAncestorNotFound; property OnCreateComponent: TCreateComponentEvent read FOnCreateComponent write FOnCreateComponent; property OnFindComponentClass: TFindComponentClassEvent read FOnFindComponentClass write FOnFindComponentClass; end; { TWriter } TFindAncestorEvent = procedure (Writer: TWriter; Component: TComponent; const Name: string; var Ancestor, RootAncestor: TComponent) of object; TWriter = class(TFiler) private FRootAncestor: TComponent; FPropPath: string; FAncestorList: TList; FAncestorPos: Integer; FChildPos: Integer; FOnFindAncestor: TFindAncestorEvent; FUseQualifiedNames: Boolean; procedure AddAncestor(Component: TComponent); function GetPosition: Longint; procedure SetPosition(Value: Longint); procedure WriteBuffer; procedure WriteData(Instance: TComponent); virtual; // linker optimization procedure WriteMinStr(const LocaleStr: string; const UTF8Str: UTF8String); protected procedure SetRoot(Value: TComponent); override; procedure WriteBinary(WriteData: TStreamProc); procedure WritePrefix(Flags: TFilerFlags; AChildPos: Integer); procedure WriteProperty(Instance: TPersistent; PropInfo: PPropInfo); 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); procedure WriteVariant(const Value: Variant); property Position: Longint read GetPosition write SetPosition; property RootAncestor: TComponent read FRootAncestor write FRootAncestor; property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor; property UseQualifiedNames: Boolean read FUseQualifiedNames write FUseQualifiedNames; end; { TParser } TParser = class(TObject) private FStream: TStream; FOrigin: Longint; FBuffer: PChar; FBufPtr: PChar; FBufEnd: PChar; FSourcePtr: PChar; FSourceEnd: PChar; FTokenPtr: PChar; FStringPtr: PChar; FSourceLine: Integer; FSaveChar: Char; FToken: Char; FFloatType: Char; FWideStr: WideString; procedure ReadBuffer; procedure SkipBlanks; 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 read FFloatType; property SourceLine: Integer read FSourceLine; property Token: Char read FToken; end; { TThread } EThread = class(Exception); TThreadMethod = procedure of object; {$IFDEF MSWINDOWS} TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest, tpTimeCritical); {$ENDIF} TThread = class private FHandle: THandle; {$IFDEF MSWINDOWS} FThreadID: THandle; {$ENDIF} {$IFDEF LINUX} // ** FThreadID is not THandle in Linux ** FThreadID: Cardinal; FCreateSuspendedSem: TSemaphore; FInitialSuspendDone: Boolean; {$ENDIF} FCreateSuspended: Boolean; FTerminated: Boolean; FSuspended: Boolean; FFreeOnTerminate: Boolean; FFinished: Boolean; FReturnValue: Integer; FOnTerminate: TNotifyEvent; FMethod: TThreadMethod; FSynchronizeException: TObject; FFatalException: TObject; procedure CheckThreadError(ErrCode: Integer); overload; procedure CheckThreadError(Success: Boolean); overload; procedure CallOnTerminate; {$IFDEF MSWINDOWS} function GetPriority: TThreadPriority; procedure SetPriority(Value: TThreadPriority); procedure SetSuspended(Value: Boolean); {$ENDIF} {$IFDEF LINUX} // ** Priority is an Integer value in Linux function GetPriority: Integer; procedure SetPriority(Value: Integer); function GetPolicy: Integer; procedure SetPolicy(Value: Integer); procedure SetSuspended(Value: Boolean); {$ENDIF} protected procedure DoTerminate; virtual; procedure Execute; virtual; abstract; procedure Synchronize(Method: TThreadMethod); property ReturnValue: Integer read FReturnValue write FReturnValue; property Terminated: Boolean read FTerminated; public constructor Create(CreateSuspended: Boolean); destructor Destroy; override; procedure AfterConstruction; override; procedure Resume; procedure Suspend; procedure Terminate; function WaitFor: LongWord; property FatalException: TObject read FFatalException; property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate; property Handle: THandle read FHandle; {$IFDEF MSWINDOWS} property Priority: TThreadPriority read GetPriority write SetPriority; {$ENDIF} {$IFDEF LINUX} // ** Priority is an Integer ** property Priority: Integer read GetPriority write SetPriority; property Policy: Integer read GetPolicy write SetPolicy; {$ENDIF} property Suspended: Boolean read FSuspended write SetSuspended; {$IFDEF MSWINDOWS} property ThreadID: THandle read FThreadID; {$ENDIF} {$IFDEF LINUX} // ** ThreadId is Cardinal ** property ThreadID: Cardinal read FThreadID; {$ENDIF} property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate; 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, csSubComponent, csTransient); 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, IInterface, IInterfaceComponentReference) private FOwner: TComponent; FName: TComponentName; FTag: Longint; FComponents: TList; FFreeNotifies: TList; FDesignInfo: Longint; FComponentState: TComponentState; FVCLComObject: Pointer; function GetComObject: IUnknown; function GetComponent(AIndex: Integer): TComponent; function GetComponentCount: Integer; function GetComponentIndex: Integer; procedure Insert(AComponent: TComponent); procedure ReadLeft(Reader: TReader); procedure ReadTop(Reader: TReader); procedure Remove(AComponent: TComponent); procedure RemoveNotification(AComponent: TComponent); procedure SetComponentIndex(Value: Integer); procedure SetReference(Enable: Boolean); procedure WriteLeft(Writer: TWriter); procedure WriteTop(Writer: TWriter); { IInterfaceComponentReference } function IInterfaceComponentReference.GetComponent = IntfGetComponent; function IntfGetComponent: TComponent; 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 PaletteCreated; dynamic; 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; { IInterface } 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); procedure SetSubComponent(IsSubComponent: Boolean); function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override; function UpdateAction(Action: TBasicAction): Boolean; dynamic; function IsImplementorOf(const I: IInterface): Boolean; function ReferenceInterface(const I: IInterface; Operation: TOperation): Boolean; property ComObject: IUnknown read GetComObject; property Components[Index: Integer]: TComponent read GetComponent; property ComponentCount: Integer read GetComponentCount; property ComponentIndex: Integer read GetComponentIndex write SetComponentIndex; property ComponentState: TComponentState read FComponentState; property ComponentStyle: TComponentStyle read FComponentStyle; property DesignInfo: Longint read FDesignInfo write FDesignInfo; property Owner: TComponent read FOwner; property VCLComObject: Pointer read FVCLComObject write FVCLComObject; published property Name: TComponentName read FName write SetName stored False; property Tag: Longint read FTag write FTag default 0; end; { TBasicActionLink } TBasicActionLink = class(TObject) private FOnChange: TNotifyEvent; 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(AComponent: TComponent = nil): Boolean; virtual; function Update: Boolean; virtual; property Action: TBasicAction read FAction write SetAction; property OnChange: TNotifyEvent read FOnChange write FOnChange; end; TBasicActionLinkClass = class of TBasicActionLink; { TBasicAction } TBasicAction = class(TComponent) private FActionComponent: TComponent; FOnChange: TNotifyEvent; FOnExecute: TNotifyEvent; FOnUpdate: TNotifyEvent; protected FClients: TList; procedure Change; virtual; procedure SetOnExecute(Value: TNotifyEvent); virtual; property OnChange: TNotifyEvent read FOnChange write FOnChange; procedure Notification(AComponent: TComponent; Operation: TOperation); override; 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 ActionComponent: TComponent read FActionComponent write FActionComponent; property OnExecute: TNotifyEvent read FOnExecute write SetOnExecute; property OnUpdate: TNotifyEvent read FOnUpdate write FOnUpdate; end; { TBasicAction class reference type } TBasicActionClass = class of TBasicAction; { TDataModule } TDataModule = class(TComponent) private FDesignSize: TPoint; FDesignOffset: TPoint; FOnCreate: TNotifyEvent; FOnDestroy: TNotifyEvent; FOldCreateOrder: Boolean; procedure ReadHeight(Reader: TReader); procedure ReadHorizontalOffset(Reader: TReader); procedure ReadVerticalOffset(Reader: TReader); procedure ReadWidth(Reader: TReader); procedure WriteWidth(Writer: TWriter); procedure WriteHorizontalOffset(Writer: TWriter); procedure WriteVerticalOffset(Writer: TWriter); procedure WriteHeight(Writer: TWriter); protected procedure DoCreate; virtual; procedure DoDestroy; virtual; procedure DefineProperties(Filer: TFiler); override; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; function HandleCreateException: Boolean; dynamic; procedure ReadState(Reader: TReader); override; public constructor Create(AOwner: TComponent); override; constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); virtual; destructor Destroy; override; procedure AfterConstruction; override; procedure BeforeDestruction; override; property DesignOffset: TPoint read FDesignOffset write FDesignOffset; property DesignSize: TPoint read FDesignSize write FDesignSize; published property OldCreateOrder: Boolean read FOldCreateOrder write FOldCreateOrder; property OnCreate: TNotifyEvent read FOnCreate write FOnCreate; property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; end; var AddDataModule: procedure (DataModule: TDataModule) of object = nil; RemoveDataModule: procedure (DataModule: TDataModule) of object = nil; ApplicationHandleException: procedure (Sender: TObject) of object = nil; ApplicationShowException: procedure (E: Exception) of object = nil; { Component registration handlers } RegisterComponentsProc: procedure(const Page: string; ComponentClasses: array of TComponentClass) = nil; RegisterNoIconProc: procedure(ComponentClasses: array of TComponentClass) = nil; CurrentGroup: Integer = -1; { Current design group } {$IFDEF MSWINDOWS} type TActiveXRegType = (axrComponentOnly, axrIncludeDescendants); var RegisterNonActiveXProc: procedure(ComponentClasses: array of TComponentClass; AxRegType: TActiveXRegType) = nil; {$ENDIF} CreateVCLComObjectProc: procedure(Component: TComponent) = nil; { Point and rectangle constructors } function Point(AX, AY: Integer): TPoint; function SmallPoint(AX, AY: SmallInt): TSmallPoint; function PointsEqual(const P1, P2: TPoint): Boolean; overload; function PointsEqual(const P1, P2: TSmallPoint): Boolean; overload; function InvalidPoint(X, Y: Integer): Boolean; overload; function InvalidPoint(const At: TPoint): Boolean; overload; function InvalidPoint(const At: TSmallPoint): Boolean; overload; function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect; overload; function Rect(const ATopLeft, ABottomRight: TPoint): TRect; overload; 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; procedure StartClassGroup(AClass: TPersistentClass); procedure GroupDescendentsWith(AClass, AClassGroup: TPersistentClass); function ActivateClassGroup(AClass: TPersistentClass): TPersistentClass; function ClassGroupOf(AClass: TPersistentClass): TPersistentClass; overload; function ClassGroupOf(Instance: TPersistent): TPersistentClass; overload; { Component registration routines } procedure RegisterComponents(const Page: string; ComponentClasses: array of TComponentClass); procedure RegisterNoIcon(ComponentClasses: array of TComponentClass); {$IFDEF MSWINDOWS} procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass; AxRegType: TActiveXRegType); {$ENDIF} 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; TIsUniqueGlobalComponentName = function(const Name: string): Boolean; var IsUniqueGlobalComponentNameProc: TIsUniqueGlobalComponentName; procedure RegisterIntegerConsts(AIntegerType: Pointer; AIdentToInt: TIdentToInt; AIntToIdent: TIntToIdent); procedure UnregisterIntegerConsts(AIntegerType: Pointer; AIdentToInt: TIdentToInt; AIntToIdent: TIntToIdent); procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); function FindGlobalComponent(const Name: string): TComponent; function IsUniqueGlobalComponentName(const Name: string): Boolean; 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; Owner1, Owner2: TComponent): Boolean; { find the ultimate owner of a collection or item (or persistent for that matter) } function GetUltimateOwner(ACollectionItem: TCollectionItem): TPersistent; overload; function GetUltimateOwner(ACollection: TCollection): TPersistent; overload; function GetUltimateOwner(APersistent: TPersistent): TPersistent; overload; { 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; { CountGenerations: Use this helper function to calculate the distance between two related classes. Returns -1 if Descendent is not a descendent of Ancestor. } function CountGenerations(Ancestor, Descendent: TClass): Integer; { Call CheckSynchronize periodically within the main thread in order for background threads to synchronize execution with the main thread. This is mainly for applications that have an event driven UI such as Windows or XWindows (Qt/CLX). The best place this can be called is during Idle processing. This guarantees that the main thread is in a known "good" state so that method calls can be safely made. Returns True if a method was synchronized. Returns False if there was nothing done. } function CheckSynchronize: Boolean; { Assign a method to WakeMainThread in order to properly force an event into the GUI thread's queue. This will make sure that non-GUI threads can quickly synchronize with the GUI thread even if no events are being processed due to an idle state } var WakeMainThread: TNotifyEvent = nil; {$IFDEF MSWINDOWS} type TWndMethod = procedure(var Message: TMessage) of object; function MakeObjectInstance(Method: TWndMethod): Pointer; procedure FreeObjectInstance(ObjectInstance: Pointer); function AllocateHWnd(Method: TWndMethod): HWND; procedure DeallocateHWnd(Wnd: HWND); {$ENDIF} implementation {$IFDEF MSWINDOWS} uses RTLConsts, SysConst, Types; {$ENDIF} {$IFDEF LINUX} uses RTLConsts, SysConst; {$ENDIF} const FilerSignature: array[1..4] of Char = 'TPF0'; var IntConstList: TThreadList; { Point and rectangle constructors } function Point(AX, AY: Integer): TPoint; begin Result := Types.Point(AX, AY); end; function SmallPoint(AX, AY: SmallInt): TSmallPoint; begin with Result do begin X := AX; Y := AY; end; end; function PointsEqual(const P1, P2: TPoint): Boolean; begin Result := (P1.X = P2.X) and (P1.Y = P2.Y); end; function PointsEqual(const P1, P2: TSmallPoint): Boolean; begin Result := (P1.X = P2.X) and (P1.Y = P2.Y); end; function Rect(ALeft, ATop, ARight, ABottom: Integer): TRect; begin Result := Types.Rect(ALeft, ATop, ARight, ABottom); end; function Rect(const ATopLeft, ABottomRight: TPoint): TRect; begin Result := Types.Rect(ATopLeft.X, ATopLeft.Y, ABottomRight.X, ABottomRight.Y); end; function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect; begin Result := Types.Bounds(ALeft, ATop, AWidth, AHeight); end; function InvalidPoint(X, Y: Integer): Boolean; begin Result := (X = -1) and (Y = -1); end; function InvalidPoint(const At: TPoint): Boolean; begin Result := (At.X = -1) and (At.Y = -1); end; function InvalidPoint(const At: TSmallPoint): Boolean; begin Result := (At.X = -1) and (At.Y = -1); end; { Class registration groups } type TRegGroup = class private FClassList: TList; FAliasList: TStringList; FGroupClasses: TList; FActive: Boolean; function BestClass(AClass: TPersistentClass): TPersistentClass; public constructor Create(AClass: TPersistentClass); destructor Destroy; override; class function BestGroup(Group1, Group2: TRegGroup; AClass: TPersistentClass): TRegGroup; procedure AddClass(AClass: TPersistentClass); function GetClass(const AClassName: string): TPersistentClass; procedure GetClasses(Proc: TGetClass); function InGroup(AClass: TPersistentClass): Boolean; procedure RegisterClass(AClass: TPersistentClass); procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string); function Registered(AClass: TPersistentClass): Boolean; procedure UnregisterClass(AClass: TPersistentClass); procedure UnregisterModuleClasses(Module: HMODULE); property Active: Boolean read FActive write FActive; end; TRegGroups = class private FGroups: TList; FLock: TRTLCriticalSection; FActiveClass: TPersistentClass; function FindGroup(AClass: TPersistentClass): TRegGroup; public constructor Create; destructor Destroy; override; procedure Activate(AClass: TPersistentClass); procedure AddClass(ID: Integer; AClass: TPersistentClass); function GetClass(const AClassName: string): TPersistentClass; function GroupedWith(AClass: TPersistentClass): TPersistentClass; procedure GroupWith(AClass, AGroupClass: TPersistentClass); procedure Lock; procedure RegisterClass(AClass: TPersistentClass); procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string); function Registered(AClass: TPersistentClass): Boolean; procedure StartGroup(AClass: TPersistentClass); procedure Unlock; procedure UnregisterClass(AClass: TPersistentClass); procedure UnregisterModuleClasses(Module: HMODULE); property ActiveClass: TPersistentClass read FActiveClass; end; var RegGroups: TRegGroups; { TRegGroup } procedure TRegGroup.AddClass(AClass: TPersistentClass); begin FGroupClasses.Add(AClass); end; function TRegGroup.BestClass(AClass: TPersistentClass): TPersistentClass; var I: Integer; Current: TPersistentClass; begin Result := nil; for I := 0 to FGroupClasses.Count - 1 do begin Current := FGroupClasses[I]; if AClass.InheritsFrom(Current) then if (Result = nil) or Current.InheritsFrom(Result) then Result := Current; end; end; class function TRegGroup.BestGroup(Group1, Group2: TRegGroup; AClass: TPersistentClass): TRegGroup; var Group1Class: TPersistentClass; Group2Class: TPersistentClass; begin if Group1 <> nil then Group1Class := Group1.BestClass(AClass) else Group1Class := nil; if Group2 <> nil then Group2Class := Group2.BestClass(AClass) else Group2Class := nil; if Group1Class = nil then if Group2Class = nil then // AClass is not in either group, no best group Result := nil else // AClass is in Group2 but not Group1, Group2 is best Result := Group2 else if Group2Class = nil then // AClass is in Group1 but not Group2, Group1 is best Result := Group1 else // AClass is in both groups, select the group with the closest ancestor if Group1Class.InheritsFrom(Group2Class) then Result := Group1 else Result := Group2; end; constructor TRegGroup.Create(AClass: TPersistentClass); begin inherited Create; FClassList := TList.Create; FAliasList := TStringList.Create; FGroupClasses := TList.Create; FGroupClasses.Add(AClass); end; destructor TRegGroup.Destroy; begin inherited Destroy; FClassList.Free; FAliasList.Free; FGroupClasses.Free; end; function TRegGroup.GetClass(const AClassName: string): TPersistentClass; var I: Integer; begin for I := 0 to FClassList.Count - 1 do begin Result := FClassList[I]; if Result.ClassNameIs(AClassName) then Exit; end; I := FAliasList.IndexOf(AClassName); if I >= 0 then begin Result := TPersistentClass(FAliasList.Objects[I]); Exit; end; Result := nil; end; procedure TRegGroup.GetClasses(Proc: TGetClass); var I: Integer; begin for I := 0 to FClassList.Count - 1 do Proc(TPersistentClass(FClassList[I])); end; function TRegGroup.InGroup(AClass: TPersistentClass): Boolean; var I: Integer; begin Result := True; for I := 0 to FGroupClasses.Count - 1 do if AClass.InheritsFrom(TPersistentClass(FGroupClasses[I])) then Exit; Result := False; end; procedure TRegGroup.RegisterClass(AClass: TPersistentClass); var LClassName: string; begin LClassName := AClass.ClassName; if GetClass(LClassName) <> nil then raise EFilerError.CreateResFmt(@SDuplicateClass, [LClassName]); FClassList.Add(AClass); end; procedure TRegGroup.RegisterClassAlias(AClass: TPersistentClass; const Alias: string); begin RegisterClass(AClass); FAliasList.AddObject(Alias, TObject(AClass)); end; function TRegGroup.Registered(AClass: TPersistentClass): Boolean; begin Result := FClassList.IndexOf(AClass) >= 0; end; procedure TRegGroup.UnregisterClass(AClass: TPersistentClass); var I: Integer; begin FClassList.Remove(AClass); for I := FAliasList.Count - 1 downto 0 do if FAliasList.Objects[I] = TObject(AClass) then FAliasList.Delete(I); end; function PointerInModule(Ptr: Pointer; Module: HMODULE): Boolean; begin Result := (Module = 0) or (FindHInstance(Ptr) = Module); end; procedure TRegGroup.UnregisterModuleClasses(Module: HMODULE); var I: Integer; begin // Even though the group criterion changes we do not need to recalculate the // groups because the groups are based on ancestry. If an ancestor of a class // is removed because its module was unloaded we can safely assume that all // descendents have also been unloaded or are being unloaded as well. This // means that any classes left in the registry are not descendents of the // classes being removed and, therefore, will not be affected by the change // to the FGroupClasses list. for I := FGroupClasses.Count - 1 downto 0 do if PointerInModule(FGroupClasses[I], Module) then FGroupClasses.Delete(I); for I := FClassList.Count - 1 downto 0 do if PointerInModule(FClassList[I], Module) then FClassList.Delete(I); for I := FAliasList.Count - 1 downto 0 do if PointerInModule(FAliasList.Objects[I], Module) then FAliasList.Delete(I); end; { TRegGroups } procedure TRegGroups.Activate(AClass: TPersistentClass); var I: Integer; begin if FActiveClass <> AClass then begin FActiveClass := AClass; for I := 0 to FGroups.Count - 1 do with TRegGroup(FGroups[I]) do Active := InGroup(AClass); end; end; procedure TRegGroups.AddClass(ID: Integer; AClass: TPersistentClass); begin TRegGroup(FGroups[ID]).AddClass(AClass); end; constructor TRegGroups.Create; var Group: TRegGroup; begin inherited Create; FGroups := TList.Create; InitializeCriticalSection(FLock); // Initialize default group Group := TRegGroup.Create(TPersistent); FGroups.Add(Group); Group.Active := True; end; destructor TRegGroups.Destroy; var I: Integer; begin DeleteCriticalSection(FLock); for I := 0 to FGroups.Count - 1 do TRegGroup(FGroups[I]).Free; FGroups.Free; inherited; end; function TRegGroups.FindGroup(AClass: TPersistentClass): TRegGroup; var I: Integer; Current: TRegGroup; begin Result := nil; for I := 0 to FGroups.Count - 1 do begin Current := FGroups[I]; Result := TRegGroup.BestGroup(Current, Result, AClass); end; end; function TRegGroups.GetClass(const AClassName: string): TPersistentClass; var I: Integer; begin Result := nil; for I := 0 to FGroups.Count - 1 do with TRegGroup(FGroups[I]) do begin if Active then Result := GetClass(AClassName); if Result <> nil then Exit; end; end; function TRegGroups.GroupedWith(AClass: TPersistentClass): TPersistentClass; var Group: TRegGroup; begin Result := nil; Group := FindGroup(AClass); if Group <> nil then Result := TPersistentClass(Group.FClassList[0]); end; procedure TRegGroups.GroupWith(AClass, AGroupClass: TPersistentClass); procedure Error; begin raise EFilerError.CreateFmt(SUnknownGroup, [AGroupClass.ClassName]); end; var Group: TRegGroup; CurrentGroup: TRegGroup; CurrentClass: TPersistentClass; I, J: Integer; begin Group := FindGroup(AGroupClass); if Group = nil then Error; Group.AddClass(AClass); // The group criterion has changed. We need to recalculate which groups the // classes that have already been registered belong to. We can skip // Group since we would just be moving a class to a group it already belongs // to. We also only need to find the new group of classes that descend from // AClass since that is the only criterion being changed. In other words, // we only need to move classes that descend from AClass to Group if they // are in another group. for I := 0 to FGroups.Count - 1 do begin CurrentGroup := FGroups[I]; if CurrentGroup <> Group then for J := CurrentGroup.FClassList.Count - 1 downto 0 do begin CurrentClass := CurrentGroup.FClassList[J]; if CurrentClass.InheritsFrom(AClass) then // Check CurrentClass should be put into Group based on the new // criterion. Their might be a descendent of AClass registered that // overrides Group's criterion. if FindGroup(CurrentClass) = Group then begin CurrentGroup.FClassList.Delete(J); Group.FClassList.Add(CurrentClass); end; end; end; end; procedure TRegGroups.Lock; begin EnterCriticalSection(FLock); end; procedure TRegGroups.RegisterClass(AClass: TPersistentClass); var Group: TRegGroup; begin Group := FindGroup(AClass); if Group <> nil then Group.RegisterClass(AClass); end; procedure TRegGroups.RegisterClassAlias(AClass: TPersistentClass; const Alias: string); var Group: TRegGroup; begin Group := FindGroup(AClass); if Group <> nil then Group.RegisterClassAlias(AClass, Alias); end; function TRegGroups.Registered(AClass: TPersistentClass): Boolean; var I: Integer; begin Result := True; for I := 0 to FGroups.Count - 1 do if TRegGroup(FGroups[I]).Registered(AClass) then Exit; Result := False; end; procedure TRegGroups.StartGroup(AClass: TPersistentClass); var I: Integer; begin // Do not start a group that already exists for I := 0 to FGroups.Count - 1 do if TRegGroup(FGroups[I]).FGroupClasses.IndexOf(AClass) >= 0 then Exit; // Create the group FGroups.Add(TRegGroup.Create(AClass)); end; procedure TRegGroups.Unlock; begin LeaveCriticalSection(FLock); end; procedure TRegGroups.UnregisterClass(AClass: TPersistentClass); var I: Integer; begin for I := 0 to FGroups.Count - 1 do TRegGroup(FGroups[I]).UnregisterClass(AClass); end; procedure TRegGroups.UnregisterModuleClasses(Module: HMODULE); var I: Integer; begin for I := FGroups.Count - 1 downto 0 do TRegGroup(FGroups[I]).UnregisterModuleClasses(Module); end; { TClassFinder } constructor TClassFinder.Create(AClass: TPersistentClass; AIncludeActiveGroups: Boolean); var I: Integer; Group: TRegGroup; begin inherited Create; FGroups := TList.Create; RegGroups.Lock; try if AClass = nil then AClass := RegGroups.ActiveClass; for I := 0 to RegGroups.FGroups.Count - 1 do begin Group := RegGroups.FGroups[I]; if Group.InGroup(AClass) then FGroups.Add(Group); end; if AIncludeActiveGroups then for I := 0 to RegGroups.FGroups.Count - 1 do begin Group := RegGroups.FGroups[I]; if Group.Active then FGroups.Add(Group); end; finally RegGroups.Unlock; end; end; destructor TClassFinder.Destroy; begin FGroups.Free; inherited; end; function TClassFinder.GetClass(const AClassName: string): TPersistentClass; var I: Integer; begin Result := nil; RegGroups.Lock; try for I := 0 to FGroups.Count - 1 do with TRegGroup(FGroups[I]) do begin Result := GetClass(AClassName); if Result <> nil then Exit; end; finally RegGroups.Unlock; end; end; procedure TClassFinder.GetClasses(Proc: TGetClass); var I: Integer; begin RegGroups.Lock; try for I := 0 to FGroups.Count - 1 do TRegGroup(FGroups[I]).GetClasses(Proc); finally RegGroups.Unlock; end; end; { Class registration routines } type PFieldClassTable = ^TFieldClassTable; TFieldClassTable = packed record Count: Smallint; Classes: array[0..8191] of ^TPersistentClass; end; function GetFieldClassTable(AClass: TClass): PFieldClassTable; assembler; asm MOV EAX,[EAX].vmtFieldTable OR EAX,EAX JE @@1 MOV EAX,[EAX+2].Integer @@1: end; procedure ClassNotFound(const ClassName: string); begin raise EClassNotFound.CreateFmt(SClassNotFound, [ClassName]); end; function GetClass(const AClassName: string): TPersistentClass; begin RegGroups.Lock; try Result := RegGroups.GetClass(AClassName); finally RegGroups.Unlock; end; end; function FindClass(const ClassName: string): TPersistentClass; begin Result := GetClass(ClassName); if Result = nil then ClassNotFound(ClassName); end; procedure RegisterClass(AClass: TPersistentClass); begin RegGroups.Lock; try while not RegGroups.Registered(AClass) do begin RegGroups.RegisterClass(AClass); if AClass = TPersistent then Break; AClass := TPersistentClass(AClass.ClassParent); end; finally RegGroups.Unlock; end; end; procedure RegisterClasses(AClasses: array of TPersistentClass); var I: Integer; begin for I := Low(AClasses) to High(AClasses) do RegisterClass(AClasses[I]); end; procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string); begin RegGroups.Lock; try RegGroups.RegisterClassAlias(AClass, Alias); finally RegGroups.Unlock; end; end; procedure UnRegisterClass(AClass: TPersistentClass); begin RegGroups.Lock; try RegGroups.UnregisterClass(AClass); finally RegGroups.Unlock; end; end; procedure UnRegisterClasses(AClasses: array of TPersistentClass); var I: Integer; begin for I := Low(AClasses) to High(AClasses) do UnRegisterClass(AClasses[I]); end; procedure UnRegisterModuleClasses(Module: HMODULE); begin RegGroups.Lock; try RegGroups.UnregisterModuleClasses(Module); finally RegGroups.Unlock; end; end; procedure StartClassGroup(AClass: TPersistentClass); begin RegGroups.Lock; try RegGroups.StartGroup(AClass); finally RegGroups.Unlock; end; end; procedure GroupDescendentsWith(AClass, AClassGroup: TPersistentClass); begin RegGroups.Lock; try RegGroups.GroupWith(AClass, AClassGroup); finally RegGroups.Unlock; end; end; function ActivateClassGroup(AClass: TPersistentClass): TPersistentClass; begin RegGroups.Lock; try Result := RegGroups.ActiveClass; RegGroups.Activate(AClass); finally RegGroups.Unlock; end; end; function ClassGroupOf(AClass: TPersistentClass): TPersistentClass; begin RegGroups.Lock; try Result := RegGroups.GroupedWith(AClass); finally RegGroups.Unlock; end; end; function ClassGroupOf(Instance: TPersistent): TPersistentClass; begin RegGroups.Lock; try Result := nil; while Instance <> nil do begin Result := RegGroups.GroupedWith(TPersistentClass(Instance.ClassType)); if Result <> nil then Exit else Instance := Instance.GetOwner; end; finally RegGroups.Unlock; end; end; { Component registration routines } procedure RegisterComponents(const Page: string; ComponentClasses: array of TComponentClass); begin if Assigned(RegisterComponentsProc) then RegisterComponentsProc(Page, ComponentClasses) else raise EComponentError.CreateRes(@SRegisterError); end; procedure RegisterNoIcon(ComponentClasses: array of TComponentClass); begin if Assigned(RegisterNoIconProc) then RegisterNoIconProc(ComponentClasses) else raise EComponentError.CreateRes(@SRegisterError); end; {$IFDEF MSWINDOWS} procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass; AxRegType: TActiveXRegType); begin if not Assigned(RegisterNonActiveXProc) then raise EComponentError.CreateRes(@SRegisterError); RegisterNonActiveXProc(ComponentClasses, AxRegType) end; {$ENDIF} { Component filing } type TIntConst = class IntegerType: PTypeInfo; IdentToInt: TIdentToInt; IntToIdent: TIntToIdent; constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt; AIntToIdent: TIntToIdent); end; constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt; AIntToIdent: TIntToIdent); begin IntegerType := AIntegerType; IdentToInt := AIdentToInt; IntToIdent := AIntToIdent; end; procedure RegisterIntegerConsts(AIntegerType: Pointer; AIdentToInt: TIdentToInt; AIntToIdent: TIntToIdent); begin IntConstList.Add(TIntConst.Create(AIntegerType, AIdentToInt, AIntToIdent)); end; procedure UnregisterIntegerConsts(AIntegerType: Pointer; AIdentToInt: TIdentToInt; AIntToIdent: TIntToIdent); var I: Integer; begin with IntConstList.LockList do try for I := Count-1 downto 0 do with TIntConst(Items[I]) do if (IntegerType = AIntegerType) and (@IntToIdent = @AIntToIdent) and (@IdentToInt = @AIdentToInt) then Delete(I); finally IntConstList.UnlockList; end; end; function FindIntToIdent(AIntegerType: Pointer): TIntToIdent; var I: Integer; begin Result := nil; with IntConstList.LockList do try for I := Count - 1 downto 0 do with TIntConst(Items[I]) do if AIntegerType = IntegerType then begin Result := @IntToIdent; Exit; end; finally IntConstList.UnlockList; end; end; function FindIdentToInt(AIntegerType: Pointer): TIdentToInt; var I: Integer; begin Result := nil; with IntConstList.LockList do try for I := Count - 1 downto 0 do with TIntConst(Items[I]) do if AIntegerType = IntegerType then begin Result := @IdentToInt; Exit; end; finally IntConstList.UnlockList; end; end; function IdentToInt(const Ident: string; var Int: Longint; const Map: array of TIdentMapEntry): Boolean; var I: Integer; begin for I := Low(Map) to High(Map) do if SameText(Map[I].Name, Ident) then begin Result := True; Int := Map[I].Value; Exit; end; Result := False; end; function IntToIdent(Int: Longint; var Ident: string; const Map: array of TIdentMapEntry): Boolean; var I: Integer; begin for I := Low(Map) to High(Map) do if Map[I].Value = Int then begin Result := True; Ident := Map[I].Name; Exit; end; Result := False; end; var FindGlobalComponentProcs: TList; procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); begin if FindGlobalComponentProcs = nil then FindGlobalComponentProcs := TList.Create; if FindGlobalComponentProcs.IndexOf(@AFindGlobalComponent) < 0 then FindGlobalComponentProcs.Add(@AFindGlobalComponent); end; procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); begin if FindGlobalComponentProcs <> nil then FindGlobalComponentProcs.Remove(@AFindGlobalComponent); end; function FindGlobalComponent(const Name: string): TComponent; var I: Integer; begin Result := nil; if FindGlobalComponentProcs <> nil then begin for I := FindGlobalComponentProcs.Count - 1 downto 0 do begin Result := TFindGlobalComponent(FindGlobalComponentProcs[I])(Name); if Result <> nil then Exit; end; end; end; function IsUniqueGlobalComponentName(const Name: string): Boolean; begin if Assigned(IsUniqueGlobalComponentNameProc) then Result := IsUniqueGlobalComponentNameProc(Name) else Result := FindGlobalComponent(Name) = nil; end; function InternalReadComponentRes(const ResName: string; HInst: THandle; var Instance: TComponent): Boolean; var HRsrc: THandle; begin { avoid possible EResNotFound exception } if HInst = 0 then HInst := HInstance; HRsrc := FindResource(HInst, PChar(ResName), RT_RCDATA); Result := HRsrc <> 0; if not Result then Exit; with TResourceStream.Create(HInst, ResName, RT_RCDATA) do try Instance := ReadComponent(Instance); finally Free; end; Result := True; end; threadvar GlobalLoaded: TList; GlobalLists: TList; procedure BeginGlobalLoading; var G: TList; begin G := GlobalLists; if G = nil then begin G := TList.Create; GlobalLists := G; end; G.Add(GlobalLoaded); GlobalLoaded := TList.Create; end; procedure NotifyGlobalLoading; var I: Integer; G: TList; begin G := GlobalLoaded; // performance: eliminate repeated trips through TLS lookup for I := 0 to G.Count - 1 do TComponent(G[I]).Loaded; end; procedure EndGlobalLoading; var G: TList; begin GlobalLoaded.Free; G := GlobalLists; GlobalLoaded := G.Last; G.Delete(G.Count - 1); if G.Count = 0 then begin GlobalLists := nil; G.Free; end; end; function InitInheritedComponent(Instance: TComponent; RootAncestor: TClass): Boolean; function InitComponent(ClassType: TClass): Boolean; begin Result := False; if (ClassType = TComponent) or (ClassType = RootAncestor) then Exit; Result := InitComponent(ClassType.ClassParent); Result := InternalReadComponentRes(ClassType.ClassName, FindResourceHInstance( FindClassHInstance(ClassType)), Instance) or Result; end; var LocalizeLoading: Boolean; begin {$IFDEF MSWINDOWS} GlobalNameSpace.BeginWrite; // hold lock across all ancestor loads (performance) try {$ENDIF} LocalizeLoading := (Instance.ComponentState * [csInline, csLoading]) = []; if LocalizeLoading then BeginGlobalLoading; // push new loadlist onto stack try Result := InitComponent(Instance.ClassType); if LocalizeLoading then NotifyGlobalLoading; // call Loaded finally if LocalizeLoading then EndGlobalLoading; // pop loadlist off stack end; {$IFDEF MSWINDOWS} finally GlobalNameSpace.EndWrite; end; {$ENDIF} end; function InitComponentRes(const ResName: string; Instance: TComponent): Boolean; begin Result := InternalReadComponentRes(ResName, FindResourceHInstance( FindClassHInstance(Instance.ClassType)), Instance); end; function ReadComponentRes(const ResName: string; Instance: TComponent): TComponent; var HInstance: THandle; begin if Instance <> nil then HInstance := FindResourceHInstance(FindClassHInstance(Instance.ClassType)) else HInstance := 0; if InternalReadComponentRes(ResName, HInstance, Instance) then Result := Instance else raise EResNotFound.CreateFmt(SResNotFound, [ResName]); end; function ReadComponentResEx(HInstance: THandle; const ResName: string): TComponent; var Instance: TComponent; begin Instance := nil; if InternalReadComponentRes(ResName, HInstance, Instance) then Result := Instance else raise EResNotFound.CreateFmt(SResNotFound, [ResName]); end; function ReadComponentResFile(const FileName: string; Instance: TComponent): TComponent; var Stream: TStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try Result := Stream.ReadComponentRes(Instance); finally Stream.Free; end; end; procedure WriteComponentResFile(const FileName: string; Instance: TComponent); var Stream: TStream; begin Stream := TFileStream.Create(FileName, fmCreate); try Stream.WriteComponentRes(Instance.ClassName, Instance); finally Stream.Free; end; end; function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean; var S1, S2: TMemoryStream; procedure WriteCollection(Stream: TStream; Collection: TCollection; CollectionOwner: TComponent); var Writer: TWriter; begin Writer := TWriter.Create(Stream, 1024); Writer.Root := CollectionOwner; Writer.FLookupRoot := CollectionOwner; try Writer.WriteCollection(Collection); finally Writer.Free; end; end; begin Result := False; if C1.ClassType <> C2.ClassType then Exit; if C1.Count <> C2.Count then Exit; S1 := TMemoryStream.Create; try WriteCollection(S1, C1, Owner1); S2 := TMemoryStream.Create; try WriteCollection(S2, C2, Owner2); Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size); finally S2.Free; end; finally S1.Free; end; end; { Utility routines } function LineStart(Buffer, BufPos: PChar): PChar; assembler; asm PUSH EDI MOV EDI,EDX MOV ECX,EDX SUB ECX,EAX SUB ECX,1 JBE @@1 MOV EDX,EAX DEC EDI MOV AL,0AH STD REPNE SCASB CLD MOV EAX,EDX JNE @@1 LEA EAX,[EDI+2] @@1: POP EDI end; function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar; Strings: TStrings): Integer; var Head, Tail: PChar; EOS, InQuote: Boolean; QuoteChar: Char; Item: string; begin Result := 0; if (Content = nil) or (Content^=#0) or (Strings = nil) then Exit; Tail := Content; InQuote := False; QuoteChar := #0; Strings.BeginUpdate; try repeat while Tail^ in WhiteSpace + [#13, #10] do Inc(Tail); Head := Tail; while True do begin while (InQuote and not (Tail^ in ['''', '"', #0])) or not (Tail^ in Separators + [#0, #13, #10, '''', '"']) do Inc(Tail); if Tail^ in ['''', '"'] then begin if (QuoteChar <> #0) and (QuoteChar = Tail^) then QuoteChar := #0 else QuoteChar := Tail^; InQuote := QuoteChar <> #0; Inc(Tail); end else Break; end; EOS := Tail^ = #0; if (Head <> Tail) and (Head^ <> #0) then begin if Strings <> nil then begin SetString(Item, Head, Tail - Head); Strings.Add(Item); end; Inc(Result); end; Inc(Tail); until EOS; finally Strings.EndUpdate; end; end; { TList } destructor TList.Destroy; begin Clear; end; function TList.Add(Item: Pointer): Integer; begin Result := FCount; if Result = FCapacity then Grow; FList^[Result] := Item; Inc(FCount); if Item <> nil then Notify(Item, lnAdded); end; procedure TList.Clear; begin SetCount(0); SetCapacity(0); end; procedure TList.Delete(Index: Integer); var Temp: Pointer; begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Temp := Items[Index]; Dec(FCount); if Index < FCount then System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(Pointer)); if Temp <> nil then Notify(Temp, lnDeleted); end; class procedure TList.Error(const Msg: string; Data: Integer); function ReturnAddr: Pointer; asm MOV EAX,[EBP+4] end; begin raise EListError.CreateFmt(Msg, [Data]) at ReturnAddr; end; class procedure TList.Error(Msg: PResStringRec; Data: Integer); begin TList.Error(LoadResString(Msg), Data); end; procedure TList.Exchange(Index1, Index2: Integer); var Item: Pointer; begin if (Index1 < 0) or (Index1 >= FCount) then Error(@SListIndexError, Index1); if (Index2 < 0) or (Index2 >= FCount) then Error(@SListIndexError, Index2); Item := FList^[Index1]; FList^[Index1] := FList^[Index2]; FList^[Index2] := Item; end; function TList.Expand: TList; begin if FCount = FCapacity then Grow; Result := Self; end; function TList.First: Pointer; begin Result := Get(0); end; function TList.Get(Index: Integer): Pointer; begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Result := FList^[Index]; end; procedure TList.Grow; var Delta: Integer; begin if FCapacity > 64 then Delta := FCapacity div 4 else if FCapacity > 8 then Delta := 16 else Delta := 4; SetCapacity(FCapacity + Delta); end; function TList.IndexOf(Item: Pointer): Integer; begin Result := 0; while (Result < FCount) and (FList^[Result] <> Item) do Inc(Result); if Result = FCount then Result := -1; end; procedure TList.Insert(Index: Integer; Item: Pointer); begin if (Index < 0) or (Index > FCount) then Error(@SListIndexError, Index); if FCount = FCapacity then Grow; if Index < FCount then System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(Pointer)); FList^[Index] := Item; Inc(FCount); if Item <> nil then Notify(Item, lnAdded); end; function TList.Last: Pointer; begin Result := Get(FCount - 1); end; procedure TList.Move(CurIndex, NewIndex: Integer); var Item: Pointer; begin if CurIndex <> NewIndex then begin if (NewIndex < 0) or (NewIndex >= FCount) then Error(@SListIndexError, NewIndex); Item := Get(CurIndex); FList^[CurIndex] := nil; Delete(CurIndex); Insert(NewIndex, nil); FList^[NewIndex] := Item; end; end; procedure TList.Put(Index: Integer; Item: Pointer); var Temp: Pointer; begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); if Item <> FList^[Index] then begin Temp := FList^[Index]; FList^[Index] := Item; if Temp <> nil then Notify(Temp, lnDeleted); if Item <> nil then Notify(Item, lnAdded); end; end; function TList.Remove(Item: Pointer): Integer; begin Result := IndexOf(Item); if Result >= 0 then Delete(Result); end; procedure TList.Pack; var I: Integer; begin for I := FCount - 1 downto 0 do if Items[I] = nil then Delete(I); end; procedure TList.SetCapacity(NewCapacity: Integer); begin if (NewCapacity < FCount) or (NewCapacity > MaxListSize) then Error(@SListCapacityError, NewCapacity); if NewCapacity <> FCapacity then begin ReallocMem(FList, NewCapacity * SizeOf(Pointer)); FCapacity := NewCapacity; end; end; procedure TList.SetCount(NewCount: Integer); var I: Integer; begin if (NewCount < 0) or (NewCount > MaxListSize) then Error(@SListCountError, NewCount); if NewCount > FCapacity then SetCapacity(NewCount); if NewCount > FCount then FillChar(FList^[FCount], (NewCount - FCount) * SizeOf(Pointer), 0) else for I := FCount - 1 downto NewCount do Delete(I); FCount := NewCount; end; procedure QuickSort(SortList: PPointerList; L, R: Integer; SCompare: TListSortCompare); var I, J: Integer; P, T: Pointer; begin repeat I := L; J := R; P := SortList^[(L + R) shr 1]; repeat while SCompare(SortList^[I], P) < 0 do Inc(I); while SCompare(SortList^[J], P) > 0 do Dec(J); if I <= J then begin T := SortList^[I]; SortList^[I] := SortList^[J]; SortList^[J] := T; Inc(I); Dec(J); end; until I > J; if L < J then QuickSort(SortList, L, J, SCompare); L := I; until I >= R; end; procedure TList.Sort(Compare: TListSortCompare); begin if (FList <> nil) and (Count > 0) then QuickSort(FList, 0, Count - 1, Compare); end; function TList.Extract(Item: Pointer): Pointer; var I: Integer; begin Result := nil; I := IndexOf(Item); if I >= 0 then begin Result := Item; FList^[I] := nil; Delete(I); Notify(Result, lnExtracted); end; end; procedure TList.Notify(Ptr: Pointer; Action: TListNotification); begin end; procedure TList.Assign(ListA: TList; AOperator: TListAssignOp; ListB: TList); var I: Integer; LTemp, LSource: TList; begin // ListB given? if ListB <> nil then begin LSource := ListB; Assign(ListA); end else LSource := ListA; // on with the show case AOperator of // 12345, 346 = 346 : only those in the new list laCopy: begin Clear; Capacity := LSource.Capacity; for I := 0 to LSource.Count - 1 do Add(LSource[I]); end; // 12345, 346 = 34 : intersection of the two lists laAnd: for I := Count - 1 downto 0 do if LSource.IndexOf(Items[I]) = -1 then Delete(I); // 12345, 346 = 123456 : union of the two lists laOr: for I := 0 to LSource.Count - 1 do if IndexOf(LSource[I]) = -1 then Add(LSource[I]); // 12345, 346 = 1256 : only those not in both lists laXor: begin LTemp := TList.Create; // Temp holder of 4 byte values try LTemp.Capacity := LSource.Count; for I := 0 to LSource.Count - 1 do if IndexOf(LSource[I]) = -1 then LTemp.Add(LSource[I]); for I := Count - 1 downto 0 do if LSource.IndexOf(Items[I]) <> -1 then Delete(I); I := Count + LTemp.Count; if Capacity < I then Capacity := I; for I := 0 to LTemp.Count - 1 do Add(LTemp[I]); finally LTemp.Free; end; end; // 12345, 346 = 125 : only those unique to source laSrcUnique: for I := Count - 1 downto 0 do if LSource.IndexOf(Items[I]) <> -1 then Delete(I); // 12345, 346 = 6 : only those unique to dest laDestUnique: begin LTemp := TList.Create; try LTemp.Capacity := LSource.Count; for I := LSource.Count - 1 downto 0 do if IndexOf(LSource[I]) = -1 then LTemp.Add(LSource[I]); Assign(LTemp); finally LTemp.Free; end; end; end; end; { TThreadList } constructor TThreadList.Create; begin inherited Create; InitializeCriticalSection(FLock); FList := TList.Create; FDuplicates := dupIgnore; end; destructor TThreadList.Destroy; begin LockList; // Make sure nobody else is inside the list. try FList.Free; inherited Destroy; finally UnlockList; DeleteCriticalSection(FLock); end; end; procedure TThreadList.Add(Item: Pointer); begin LockList; try if (Duplicates = dupAccept) or (FList.IndexOf(Item) = -1) then FList.Add(Item) else if Duplicates = dupError then FList.Error(@SDuplicateItem, Integer(Item)); finally UnlockList; end; end; procedure TThreadList.Clear; begin LockList; try FList.Clear; finally UnlockList; end; end; function TThreadList.LockList: TList; begin EnterCriticalSection(FLock); Result := FList; end; procedure TThreadList.Remove(Item: Pointer); begin LockList; try FList.Remove(Item); finally UnlockList; end; end; procedure TThreadList.UnlockList; begin LeaveCriticalSection(FLock); end; { TInterfaceList } constructor TInterfaceList.Create; begin inherited Create; FList := TThreadList.Create; end; destructor TInterfaceList.Destroy; begin Clear; FList.Free; inherited Destroy; end; procedure TInterfaceList.Clear; var I: Integer; begin if FList <> nil then begin with FList.LockList do try for I := 0 to Count - 1 do IInterface(List[I]) := nil; Clear; finally Self.FList.UnlockList; end; end; end; procedure TInterfaceList.Delete(Index: Integer); begin with FList.LockList do try Self.Put(Index, nil); Delete(Index); finally Self.FList.UnlockList; end; end; function TInterfaceList.Expand: TInterfaceList; begin with FList.LockList do try Expand; Result := Self; finally Self.FList.Unlocklist; end; end; function TInterfaceList.First: IInterface; begin Result := Get(0); end; function TInterfaceList.Get(Index: Integer): IInterface; begin with FList.LockList do try if (Index < 0) or (Index >= Count) then Error(@SListIndexError, Index); Result := IInterface(List[Index]); finally Self.FList.UnlockList; end; end; function TInterfaceList.GetCapacity: Integer; begin with FList.LockList do try Result := Capacity; finally Self.FList.UnlockList; end; end; function TInterfaceList.GetCount: Integer; begin with FList.LockList do try Result := Count; finally Self.FList.UnlockList; end; end; function TInterfaceList.IndexOf(const Item: IInterface): Integer; begin with FList.LockList do try Result := IndexOf(Pointer(Item)); finally Self.FList.UnlockList; end; end; function TInterfaceList.Add(const Item: IInterface): Integer; begin with FList.LockList do try Result := Add(nil); IInterface(List[Result]) := Item; finally Self.FList.UnlockList; end; end; procedure TInterfaceList.Insert(Index: Integer; const Item: IInterface); begin with FList.LockList do try Insert(Index, nil); IInterface(List[Index]) := Item; finally Self.FList.UnlockList; end; end; function TInterfaceList.Last: IInterface; begin with FList.LockList do try Result := Self.Get(Count - 1); finally Self.FList.UnlockList; end; end; procedure TInterfaceList.Put(Index: Integer; const Item: IInterface); begin with FList.LockList do try if (Index < 0) or (Index >= Count) then Error(@SListIndexError, Index); IInterface(List[Index]) := Item; finally Self.FList.UnlockList; end; end; function TInterfaceList.Remove(const Item: IInterface): Integer; begin with FList.LockList do try Result := IndexOf(Pointer(Item)); if Result > -1 then begin IInterface(List[Result]) := nil; Delete(Result); end; finally Self.FList.UnlockList; end; end; procedure TInterfaceList.SetCapacity(NewCapacity: Integer); begin with FList.LockList do try Capacity := NewCapacity; finally Self.FList.UnlockList; end; end; procedure TInterfaceList.SetCount(NewCount: Integer); begin with FList.LockList do try Count := NewCount; finally Self.FList.UnlockList; end; end; procedure TInterfaceList.Exchange(Index1, Index2: Integer); begin with FList.LockList do try Exchange(Index1, Index2); finally Self.FList.UnlockList; end; end; procedure TInterfaceList.Lock; begin FList.LockList; end; procedure TInterfaceList.Unlock; begin FList.UnlockList; end; { TBits } const BitsPerInt = SizeOf(Integer) * 8; type TBitEnum = 0..BitsPerInt - 1; TBitSet = set of TBitEnum; PBitArray = ^TBitArray; TBitArray = array[0..4096] of TBitSet; destructor TBits.Destroy; begin SetSize(0); inherited Destroy; end; procedure TBits.Error; begin raise EBitsError.CreateRes(@SBitsIndexError); end; procedure TBits.SetSize(Value: Integer); var NewMem: Pointer; NewMemSize: Integer; OldMemSize: Integer; function Min(X, Y: Integer): Integer; begin Result := X; if X > Y then Result := Y; end; begin if Value <> Size then begin if Value < 0 then Error; NewMemSize := ((Value + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer); OldMemSize := ((Size + BitsPerInt - 1) div BitsPerInt) * SizeOf(Integer); if NewMemSize <> OldMemSize then begin NewMem := nil; if NewMemSize <> 0 then begin GetMem(NewMem, NewMemSize); FillChar(NewMem^, NewMemSize, 0); end; if OldMemSize <> 0 then begin if NewMem <> nil then Move(FBits^, NewMem^, Min(OldMemSize, NewMemSize)); FreeMem(FBits, OldMemSize); end; FBits := NewMem; end; FSize := Value; end; end; procedure TBits.SetBit(Index: Integer; Value: Boolean); assembler; asm CMP Index,[EAX].FSize JAE @@Size @@1: MOV EAX,[EAX].FBits OR Value,Value JZ @@2 BTS [EAX],Index RET @@2: BTR [EAX],Index RET @@Size: CMP Index,0 JL TBits.Error PUSH Self PUSH Index PUSH ECX {Value} INC Index CALL TBits.SetSize POP ECX {Value} POP Index POP Self JMP @@1 end; function TBits.GetBit(Index: Integer): Boolean; assembler; asm CMP Index,[EAX].FSize JAE TBits.Error MOV EAX,[EAX].FBits BT [EAX],Index SBB EAX,EAX AND EAX,1 end; function TBits.OpenBit: Integer; var I: Integer; B: TBitSet; J: TBitEnum; E: Integer; begin E := (Size + BitsPerInt - 1) div BitsPerInt - 1; for I := 0 to E do if PBitArray(FBits)^[I] <> [0..BitsPerInt - 1] then begin B := PBitArray(FBits)^[I]; for J := Low(J) to High(J) do begin if not (J in B) then begin Result := I * BitsPerInt + J; if Result >= Size then Result := Size; Exit; end; end; end; Result := Size; end; { TPersistent } destructor TPersistent.Destroy; begin RemoveFixups(Self); inherited Destroy; end; procedure TPersistent.Assign(Source: TPersistent); begin if Source <> nil then Source.AssignTo(Self) else AssignError(nil); end; procedure TPersistent.AssignError(Source: TPersistent); var SourceName: string; begin if Source <> nil then SourceName := Source.ClassName else SourceName := 'nil'; raise EConvertError.CreateResFmt(@SAssignError, [SourceName, ClassName]); end; procedure TPersistent.AssignTo(Dest: TPersistent); begin Dest.AssignError(Self); end; procedure TPersistent.DefineProperties(Filer: TFiler); begin end; function TPersistent.GetNamePath: string; var S: string; begin Result := ClassName; if (GetOwner <> nil) then begin S := GetOwner.GetNamePath; if S <> '' then Result := S + '.' + Result; end; end; function TPersistent.GetOwner: TPersistent; begin Result := nil; end; { TInterfacedPersistent } procedure TInterfacedPersistent.AfterConstruction; begin inherited; if GetOwner <> nil then GetOwner.GetInterface(IInterface, FOwnerInterface); end; function TInterfacedPersistent._AddRef: Integer; begin if FOwnerInterface <> nil then Result := FOwnerInterface._AddRef else Result := -1; end; function TInterfacedPersistent._Release: Integer; begin if FOwnerInterface <> nil then Result := FOwnerInterface._Release else Result := -1; end; function TInterfacedPersistent.QueryInterface(const IID: TGUID; out Obj): HResult; const E_NOINTERFACE = HResult($80004002); begin if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE; end; // Out param is more code efficient for interfaces than function result procedure GetDesigner(Obj: TPersistent; out Result: IDesignerNotify); var Temp: TPersistent; begin Result := nil; if Obj = nil then Exit; Temp := Obj.GetOwner; if Temp = nil then begin if (Obj is TComponent) and (csDesigning in TComponent(Obj).ComponentState) then TComponent(Obj).QueryInterface(IDesignerNotify, Result); end else begin if (Obj is TComponent) and not (csDesigning in TComponent(Obj).ComponentState) then Exit; GetDesigner(Temp, Result); end; end; function FindRootDesigner(Obj: TPersistent): IDesignerNotify; begin GetDesigner(Obj, Result); end; function CountGenerations(Ancestor, Descendent: TClass): Integer; var R: Integer; begin R := 0; while Ancestor <> Descendent do begin if Descendent = nil then begin // Descendent wasn't a descendent of Ancestor. Result := -1; Exit; end; Descendent := Descendent.ClassParent; Inc(R); end; Result := R; end; procedure NotifyDesigner(Self, Item: TPersistent; Operation: TOperation); var Designer: IDesignerNotify; begin GetDesigner(Self, Designer); if Designer <> nil then Designer.Notification(Item, Operation); end; { TRecall } constructor TRecall.Create(AStorage, AReference: TPersistent); begin inherited Create; FStorage := AStorage; FReference := AReference; Store; end; destructor TRecall.Destroy; begin if Assigned(FReference) then FReference.Assign(FStorage); Forget; inherited; end; procedure TRecall.Forget; begin FReference := nil; FreeAndNil(FStorage); end; procedure TRecall.Store; begin if Assigned(FReference) then FStorage.Assign(FReference); end; { TCollectionItem } constructor TCollectionItem.Create(Collection: TCollection); begin SetCollection(Collection); end; destructor TCollectionItem.Destroy; begin SetCollection(nil); inherited Destroy; end; procedure TCollectionItem.Changed(AllItems: Boolean); var Item: TCollectionItem; begin if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then begin if AllItems then Item := nil else Item := Self; FCollection.Update(Item); end; end; function TCollectionItem.GetIndex: Integer; begin if FCollection <> nil then Result := FCollection.FItems.IndexOf(Self) else Result := -1; end; function TCollectionItem.GetDisplayName: string; begin Result := ClassName; end; function TCollectionItem.GetNamePath: string; begin if FCollection <> nil then Result := Format('%s[%d]',[FCollection.GetNamePath, Index]) else Result := ClassName; end; function TCollectionItem.GetOwner: TPersistent; begin Result := FCollection; end; procedure TCollectionItem.SetCollection(Value: TCollection); begin if FCollection <> Value then begin if FCollection <> nil then FCollection.RemoveItem(Self); if Value <> nil then Value.InsertItem(Self); end; end; procedure TCollectionItem.SetDisplayName(const Value: string); begin Changed(False); end; procedure TCollectionItem.SetIndex(Value: Integer); var CurIndex: Integer; begin CurIndex := GetIndex; if (CurIndex >= 0) and (CurIndex <> Value) then begin FCollection.FItems.Move(CurIndex, Value); Changed(True); end; end; { TCollection } constructor TCollection.Create(ItemClass: TCollectionItemClass); begin FItemClass := ItemClass; FItems := TList.Create; NotifyDesigner(Self, Self, opInsert); end; destructor TCollection.Destroy; begin FUpdateCount := 1; if FItems <> nil then Clear; NotifyDesigner(Self, Self, opRemove); FItems.Free; inherited Destroy; end; function TCollection.Add: TCollectionItem; begin Result := FItemClass.Create(Self); end; procedure TCollection.Assign(Source: TPersistent); var I: Integer; begin if Source is TCollection then begin BeginUpdate; try Clear; for I := 0 to TCollection(Source).Count - 1 do Add.Assign(TCollection(Source).Items[I]); finally EndUpdate; end; Exit; end; inherited Assign(Source); end; procedure TCollection.BeginUpdate; begin Inc(FUpdateCount); end; procedure TCollection.Changed; begin if FUpdateCount = 0 then Update(nil); end; procedure TCollection.Clear; begin if FItems.Count > 0 then begin BeginUpdate; try while FItems.Count > 0 do TCollectionItem(FItems.Last).Free; finally EndUpdate; end; end; end; procedure TCollection.EndUpdate; begin Dec(FUpdateCount); Changed; end; function TCollection.FindItemID(ID: Integer): TCollectionItem; var I: Integer; begin for I := 0 to FItems.Count-1 do begin Result := TCollectionItem(FItems[I]); if Result.ID = ID then Exit; end; Result := nil; end; function TCollection.GetAttrCount: Integer; begin Result := 0; end; function TCollection.GetAttr(Index: Integer): string; begin Result := ''; end; function TCollection.GetItemAttr(Index, ItemIndex: Integer): string; begin Result := Items[ItemIndex].DisplayName; end; function TCollection.GetCount: Integer; begin Result := FItems.Count; end; function TCollection.GetItem(Index: Integer): TCollectionItem; begin Result := FItems[Index]; end; function TCollection.GetNamePath: string; var S, P: string; begin Result := ClassName; if GetOwner = nil then Exit; S := GetOwner.GetNamePath; if S = '' then Exit; P := PropName; if P = '' then Exit; Result := S + '.' + P; end; function TCollection.GetPropName: string; var I: Integer; Props: PPropList; TypeData: PTypeData; Owner: TPersistent; begin Result := FPropName; Owner := GetOwner; if (Result <> '') or (Owner = nil) or (Owner.ClassInfo = nil) then Exit; TypeData := GetTypeData(Owner.ClassInfo); if (TypeData = nil) or (TypeData^.PropCount = 0) then Exit; GetMem(Props, TypeData^.PropCount * sizeof(Pointer)); try GetPropInfos(Owner.ClassInfo, Props); for I := 0 to TypeData^.PropCount-1 do begin with Props^[I]^ do if (PropType^^.Kind = tkClass) and (GetOrdProp(Owner, Props^[I]) = Integer(Self)) then FPropName := Name; end; finally Freemem(Props); end; Result := FPropName; end; function TCollection.Insert(Index: Integer): TCollectionItem; begin Result := Add; Result.Index := Index; end; procedure TCollection.InsertItem(Item: TCollectionItem); begin if not (Item is FItemClass) then TList.Error(@SInvalidProperty, 0); FItems.Add(Item); Item.FCollection := Self; Item.FID := FNextID; Inc(FNextID); SetItemName(Item); Notify(Item, cnAdded); Changed; NotifyDesigner(Self, Item, opInsert); end; procedure TCollection.RemoveItem(Item: TCollectionItem); begin Notify(Item, cnExtracting); if Item = FItems.Last then FItems.Delete(FItems.Count - 1) else FItems.Remove(Item); Item.FCollection := nil; NotifyDesigner(Self, Item, opRemove); Changed; end; procedure TCollection.SetItem(Index: Integer; Value: TCollectionItem); begin TCollectionItem(FItems[Index]).Assign(Value); end; procedure TCollection.SetItemName(Item: TCollectionItem); begin end; procedure TCollection.Update(Item: TCollectionItem); begin end; procedure TCollection.Delete(Index: Integer); begin Notify(TCollectionItem(FItems[Index]), cnDeleting); TCollectionItem(FItems[Index]).Free; end; function TCollection.Owner: TPersistent; begin Result := GetOwner; end; procedure TCollection.Added(var Item: TCollectionItem); begin end; procedure TCollection.Deleting(Item: TCollectionItem); begin end; procedure TCollection.Notify(Item: TCollectionItem; Action: TCollectionNotification); begin case Action of cnAdded: Added(Item); cnDeleting: Deleting(Item); end; end; { TOwnedCollection } constructor TOwnedCollection.Create(AOwner: TPersistent; ItemClass: TCollectionItemClass); begin FOwner := AOwner; inherited Create(ItemClass); end; function TOwnedCollection.GetOwner: TPersistent; begin Result := FOwner; end; { find the ultimate owner of a collection or item (or persistent for that matter) } function GetUltimateOwner(ACollectionItem: TCollectionItem): TPersistent; begin Result := ACollectionItem.GetOwner; if Result <> nil then Result := GetUltimateOwner(TCollection(Result)); end; function GetUltimateOwner(ACollection: TCollection): TPersistent; begin Result := ACollection.GetOwner; if Result <> nil then Result := GetUltimateOwner(Result); end; function GetUltimateOwner(APersistent: TPersistent): TPersistent; begin Result := APersistent.GetOwner; end; { TStrings } destructor TStrings.Destroy; begin StringsAdapter := nil; inherited Destroy; end; function TStrings.Add(const S: string): Integer; begin Result := GetCount; Insert(Result, S); end; function TStrings.AddObject(const S: string; AObject: TObject): Integer; begin Result := Add(S); PutObject(Result, AObject); end; procedure TStrings.Append(const S: string); begin Add(S); end; procedure TStrings.AddStrings(Strings: TStrings); var I: Integer; begin BeginUpdate; try for I := 0 to Strings.Count - 1 do AddObject(Strings[I], Strings.Objects[I]); finally EndUpdate; end; end; procedure TStrings.Assign(Source: TPersistent); begin if Source is TStrings then begin BeginUpdate; try Clear; FDefined := TStrings(Source).FDefined; FQuoteChar := TStrings(Source).FQuoteChar; FDelimiter := TStrings(Source).FDelimiter; AddStrings(TStrings(Source)); finally EndUpdate; end; Exit; end; inherited Assign(Source); end; procedure TStrings.BeginUpdate; begin if FUpdateCount = 0 then SetUpdateState(True); Inc(FUpdateCount); end; procedure TStrings.DefineProperties(Filer: TFiler); function DoWrite: Boolean; begin if Filer.Ancestor <> nil then begin Result := True; if Filer.Ancestor is TStrings then Result := not Equals(TStrings(Filer.Ancestor)) end else Result := Count > 0; end; begin Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite); end; procedure TStrings.EndUpdate; begin Dec(FUpdateCount); if FUpdateCount = 0 then SetUpdateState(False); end; function TStrings.Equals(Strings: TStrings): Boolean; var I, Count: Integer; begin Result := False; Count := GetCount; if Count <> Strings.GetCount then Exit; for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit; Result := True; end; procedure TStrings.Error(const Msg: string; Data: Integer); function ReturnAddr: Pointer; asm MOV EAX,[EBP+4] end; begin raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr; end; procedure TStrings.Error(Msg: PResStringRec; Data: Integer); begin Error(LoadResString(Msg), Data); end; procedure TStrings.Exchange(Index1, Index2: Integer); var TempObject: TObject; TempString: string; begin BeginUpdate; try TempString := Strings[Index1]; TempObject := Objects[Index1]; Strings[Index1] := Strings[Index2]; Objects[Index1] := Objects[Index2]; Strings[Index2] := TempString; Objects[Index2] := TempObject; finally EndUpdate; end; end; function TStrings.ExtractName(const S: string): string; var P: Integer; begin Result := S; P := AnsiPos('=', Result); if P <> 0 then SetLength(Result, P-1) else SetLength(Result, 0); end; function TStrings.GetCapacity: Integer; begin // descendants may optionally override/replace this default implementation Result := Count; end; function TStrings.GetCommaText: string; var FOldDefined: TStringsDefined; FOldDelimiter: Char; FOldQuoteChar: Char; begin FOldDefined := FDefined; FOldDelimiter := FDelimiter; FOldQuoteChar := FQuoteChar; Delimiter := ','; QuoteChar := '"'; try Result := GetDelimitedText; finally FDelimiter := FOldDelimiter; FQuoteChar := FOldQuoteChar; FDefined := FDefined; end; end; function TStrings.GetDelimitedText: string; var S: string; P: PChar; I, Count: Integer; begin Count := GetCount; if (Count = 1) and (Get(0) = '') then Result := QuoteChar + QuoteChar else begin Result := ''; for I := 0 to Count - 1 do begin S := Get(I); P := PChar(S); while not (P^ in [#0..' ', QuoteChar, Delimiter]) do {$IFDEF MSWINDOWS} P := CharNext(P); {$ELSE} Inc(P); {$ENDIF} if (P^ <> #0) then S := AnsiQuotedStr(S, QuoteChar); Result := Result + S + Delimiter; end; System.Delete(Result, Length(Result), 1); end; end; function TStrings.GetName(Index: Integer): string; begin Result := ExtractName(Get(Index)); end; function TStrings.GetObject(Index: Integer): TObject; begin Result := nil; end; function TStrings.GetText: PChar; begin Result := StrNew(PChar(GetTextStr)); end; function TStrings.GetTextStr: string; var I, L, Size, Count: Integer; P: PChar; S, LB: string; begin Count := GetCount; Size := 0; LB := sLineBreak; for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + Length(LB)); SetString(Result, nil, Size); P := Pointer(Result); for I := 0 to Count - 1 do begin S := Get(I); L := Length(S); if L <> 0 then begin System.Move(Pointer(S)^, P^, L); Inc(P, L); end; L := Length(LB); if L <> 0 then begin System.Move(Pointer(LB)^, P^, L); Inc(P, L); end; end; end; function TStrings.GetValue(const Name: string): string; var I: Integer; begin I := IndexOfName(Name); if I >= 0 then Result := Copy(Get(I), Length(Name) + 2, MaxInt) else Result := ''; end; function TStrings.IndexOf(const S: string): Integer; begin for Result := 0 to GetCount - 1 do if CompareStrings(Get(Result), S) = 0 then Exit; Result := -1; end; function TStrings.IndexOfName(const Name: string): Integer; var P: Integer; S: string; begin for Result := 0 to GetCount - 1 do begin S := Get(Result); P := AnsiPos('=', S); if (P <> 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then Exit; end; Result := -1; end; function TStrings.IndexOfObject(AObject: TObject): Integer; begin for Result := 0 to GetCount - 1 do if GetObject(Result) = AObject then Exit; Result := -1; end; procedure TStrings.InsertObject(Index: Integer; const S: string; AObject: TObject); begin Insert(Index, S); PutObject(Index, AObject); end; procedure TStrings.LoadFromFile(const FileName: string); var Stream: TStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try LoadFromStream(Stream); finally Stream.Free; end; end; procedure TStrings.LoadFromStream(Stream: TStream); var Size: Integer; S: string; begin BeginUpdate; try Size := Stream.Size - Stream.Position; SetString(S, nil, Size); Stream.Read(Pointer(S)^, Size); SetTextStr(S); finally EndUpdate; end; end; procedure TStrings.Move(CurIndex, NewIndex: Integer); var TempObject: TObject; TempString: string; begin if CurIndex <> NewIndex then begin BeginUpdate; try TempString := Get(CurIndex); TempObject := GetObject(CurIndex); Delete(CurIndex); InsertObject(NewIndex, TempString, TempObject); finally EndUpdate; end; end; end; procedure TStrings.Put(Index: Integer; const S: string); var TempObject: TObject; begin TempObject := GetObject(Index); Delete(Index); InsertObject(Index, S, TempObject); end; procedure TStrings.PutObject(Index: Integer; AObject: TObject); begin end; procedure TStrings.ReadData(Reader: TReader); begin Reader.ReadListBegin; BeginUpdate; try Clear; while not Reader.EndOfList do Add(Reader.ReadString); finally EndUpdate; end; Reader.ReadListEnd; end; procedure TStrings.SaveToFile(const FileName: string); var Stream: TStream; begin Stream := TFileStream.Create(FileName, fmCreate); try SaveToStream(Stream); finally Stream.Free; end; end; procedure TStrings.SaveToStream(Stream: TStream); var S: string; begin S := GetTextStr; Stream.WriteBuffer(Pointer(S)^, Length(S)); end; procedure TStrings.SetCapacity(NewCapacity: Integer); begin // do nothing - descendants may optionally implement this method end; procedure TStrings.SetCommaText(const Value: string); begin Delimiter := ','; QuoteChar := '"'; SetDelimitedText(Value); end; procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter); begin if FAdapter <> nil then FAdapter.ReleaseStrings; FAdapter := Value; if FAdapter <> nil then FAdapter.ReferenceStrings(Self); end; procedure TStrings.SetText(Text: PChar); begin SetTextStr(Text); end; procedure TStrings.SetTextStr(const Value: string); var P, Start: PChar; S: string; begin BeginUpdate; try Clear; P := Pointer(Value); if P <> nil then while P^ <> #0 do begin Start := P; while not (P^ in [#0, #10, #13]) do Inc(P); SetString(S, Start, P - Start); Add(S); if P^ = #13 then Inc(P); if P^ = #10 then Inc(P); end; finally EndUpdate; end; end; procedure TStrings.SetUpdateState(Updating: Boolean); begin end; procedure TStrings.SetValue(const Name, Value: string); var I: Integer; begin I := IndexOfName(Name); if Value <> '' then begin if I < 0 then I := Add(''); Put(I, Name + '=' + Value); end else begin if I >= 0 then Delete(I); end; end; procedure TStrings.WriteData(Writer: TWriter); var I: Integer; begin Writer.WriteListBegin; for I := 0 to Count - 1 do Writer.WriteString(Get(I)); Writer.WriteListEnd; end; procedure TStrings.SetDelimitedText(const Value: string); var P, P1: PChar; S: string; begin BeginUpdate; try Clear; P := PChar(Value); while P^ in [#1..' '] do {$IFDEF MSWINDOWS} P := CharNext(P); {$ELSE} Inc(P); {$ENDIF} while P^ <> #0 do begin if P^ = QuoteChar then S := AnsiExtractQuotedStr(P, QuoteChar) else begin P1 := P; while (P^ > ' ') and (P^ <> Delimiter) do {$IFDEF MSWINDOWS} P := CharNext(P); {$ELSE} Inc(P); {$ENDIF} SetString(S, P1, P - P1); end; Add(S); while P^ in [#1..' '] do {$IFDEF MSWINDOWS} P := CharNext(P); {$ELSE} Inc(P); {$ENDIF} if P^ = Delimiter then begin P1 := P; {$IFDEF MSWINDOWS} if CharNext(P1)^ = #0 then {$ELSE} Inc(P1); if P1^ = #0 then {$ENDIF} Add(''); repeat {$IFDEF MSWINDOWS} P := CharNext(P); {$ELSE} Inc(P); {$ENDIF} until not (P^ in [#1..' ']); end; end; finally EndUpdate; end; end; function TStrings.GetDelimiter: Char; begin if not (sdDelimiter in FDefined) then Delimiter := ','; Result := FDelimiter; end; function TStrings.GetQuoteChar: Char; begin if not (sdQuoteChar in FDefined) then QuoteChar := '"'; Result := FQuoteChar; end; procedure TStrings.SetDelimiter(const Value: Char); begin if (FDelimiter <> Value) or not (sdDelimiter in FDefined) then begin Include(FDefined, sdDelimiter); FDelimiter := Value; end end; procedure TStrings.SetQuoteChar(const Value: Char); begin if (FQuoteChar <> Value) or not (sdQuoteChar in FDefined) then begin Include(FDefined, sdQuoteChar); FQuoteChar := Value; end end; function TStrings.CompareStrings(const S1, S2: string): Integer; begin Result := AnsiCompareText(S1, S2); end; { TStringList } destructor TStringList.Destroy; begin FOnChange := nil; FOnChanging := nil; inherited Destroy; if FCount <> 0 then Finalize(FList^[0], FCount); FCount := 0; SetCapacity(0); end; function TStringList.Add(const S: string): Integer; begin Result := AddObject(S, nil); end; function TStringList.AddObject(const S: string; AObject: TObject): Integer; begin if not Sorted then Result := FCount else if Find(S, Result) then case Duplicates of dupIgnore: Exit; dupError: Error(@SDuplicateString, 0); end; InsertItem(Result, S, AObject); end; procedure TStringList.Changed; begin if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self); end; procedure TStringList.Changing; begin if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self); end; procedure TStringList.Clear; begin if FCount <> 0 then begin Changing; Finalize(FList^[0], FCount); FCount := 0; SetCapacity(0); Changed; end; end; procedure TStringList.Delete(Index: Integer); begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Changing; Finalize(FList^[Index]); Dec(FCount); if Index < FCount then System.Move(FList^[Index + 1], FList^[Index], (FCount - Index) * SizeOf(TStringItem)); Changed; end; procedure TStringList.Exchange(Index1, Index2: Integer); begin if (Index1 < 0) or (Index1 >= FCount) then Error(@SListIndexError, Index1); if (Index2 < 0) or (Index2 >= FCount) then Error(@SListIndexError, Index2); Changing; ExchangeItems(Index1, Index2); Changed; end; procedure TStringList.ExchangeItems(Index1, Index2: Integer); var Temp: Integer; Item1, Item2: PStringItem; begin Item1 := @FList^[Index1]; Item2 := @FList^[Index2]; Temp := Integer(Item1^.FString); Integer(Item1^.FString) := Integer(Item2^.FString); Integer(Item2^.FString) := Temp; Temp := Integer(Item1^.FObject); Integer(Item1^.FObject) := Integer(Item2^.FObject); Integer(Item2^.FObject) := Temp; end; function TStringList.Find(const S: string; var Index: Integer): Boolean; var L, H, I, C: Integer; begin Result := False; L := 0; H := FCount - 1; while L <= H do begin I := (L + H) shr 1; C := CompareStrings(FList^[I].FString, S); if C < 0 then L := I + 1 else begin H := I - 1; if C = 0 then begin Result := True; if Duplicates <> dupAccept then L := I; end; end; end; Index := L; end; function TStringList.Get(Index: Integer): string; begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Result := FList^[Index].FString; end; function TStringList.GetCapacity: Integer; begin Result := FCapacity; end; function TStringList.GetCount: Integer; begin Result := FCount; end; function TStringList.GetObject(Index: Integer): TObject; begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Result := FList^[Index].FObject; end; procedure TStringList.Grow; var Delta: Integer; begin if FCapacity > 64 then Delta := FCapacity div 4 else if FCapacity > 8 then Delta := 16 else Delta := 4; SetCapacity(FCapacity + Delta); end; function TStringList.IndexOf(const S: string): Integer; begin if not Sorted then Result := inherited IndexOf(S) else if not Find(S, Result) then Result := -1; end; procedure TStringList.Insert(Index: Integer; const S: string); begin InsertObject(Index, S, nil); end; procedure TStringList.InsertObject(Index: Integer; const S: string; AObject: TObject); begin if Sorted then Error(@SSortedListError, 0); if (Index < 0) or (Index > FCount) then Error(@SListIndexError, Index); InsertItem(Index, S, AObject); end; procedure TStringList.InsertItem(Index: Integer; const S: string; AObject: TObject); begin Changing; if FCount = FCapacity then Grow; if Index < FCount then System.Move(FList^[Index], FList^[Index + 1], (FCount - Index) * SizeOf(TStringItem)); with FList^[Index] do begin Pointer(FString) := nil; FObject := AObject; FString := S; end; Inc(FCount); Changed; end; procedure TStringList.Put(Index: Integer; const S: string); begin if Sorted then Error(@SSortedListError, 0); if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Changing; FList^[Index].FString := S; Changed; end; procedure TStringList.PutObject(Index: Integer; AObject: TObject); begin if (Index < 0) or (Index >= FCount) then Error(@SListIndexError, Index); Changing; FList^[Index].FObject := AObject; Changed; end; procedure TStringList.QuickSort(L, R: Integer; SCompare: TStringListSortCompare); var I, J, P: Integer; begin repeat I := L; J := R; P := (L + R) shr 1; repeat while SCompare(Self, I, P) < 0 do Inc(I); while SCompare(Self, J, P) > 0 do Dec(J); if I <= J then begin ExchangeItems(I, J); if P = I then P := J else if P = J then P := I; Inc(I); Dec(J); end; until I > J; if L < J then QuickSort(L, J, SCompare); L := I; until I >= R; end; procedure TStringList.SetCapacity(NewCapacity: Integer); begin ReallocMem(FList, NewCapacity * SizeOf(TStringItem)); FCapacity := NewCapacity; end; procedure TStringList.SetSorted(Value: Boolean); begin if FSorted <> Value then begin if Value then Sort; FSorted := Value; end; end; procedure TStringList.SetUpdateState(Updating: Boolean); begin if Updating then Changing else Changed; end; function StringListCompareStrings(List: TStringList; Index1, Index2: Integer): Integer; begin Result := List.CompareStrings(List.FList^[Index1].FString, List.FList^[Index2].FString); end; procedure TStringList.Sort; begin CustomSort(StringListCompareStrings); end; procedure TStringList.CustomSort(Compare: TStringListSortCompare); begin if not Sorted and (FCount > 1) then begin Changing; QuickSort(0, FCount - 1, Compare); Changed; end; end; function TStringList.CompareStrings(const S1, S2: string): Integer; begin if CaseSensitive then Result := AnsiCompareStr(S1, S2) else Result := AnsiCompareText(S1, S2); end; procedure TStringList.SetCaseSensitive(const Value: Boolean); begin if Value <> FCaseSensitive then begin FCaseSensitive := Value; if Sorted then Sort; end; end; { TStream } function TStream.GetPosition: Int64; begin Result := Seek(0, soCurrent); end; procedure TStream.SetPosition(const Pos: Int64); begin Seek(Pos, soBeginning); end; function TStream.GetSize: Int64; var Pos: Int64; begin Pos := Seek(0, soCurrent); Result := Seek(0, soEnd); Seek(Pos, soBeginning); end; procedure TStream.SetSize(NewSize: Longint); begin // default = do nothing (read-only streams, etc) // descendents should implement this method to call the Int64 sibling end; procedure TStream.SetSize64(const NewSize: Int64); begin SetSize(NewSize); end; procedure TStream.SetSize(const NewSize: Int64); begin { For compatibility with old stream implementations, this new 64 bit SetSize calls the old 32 bit SetSize. Descendent classes that override this 64 bit SetSize MUST NOT call inherited. Descendent classes that implement 64 bit SetSize should reimplement their 32 bit SetSize to call their 64 bit version.} if (NewSize < Low(Longint)) or (NewSize > High(Longint)) then raise ERangeError.CreateRes(@SRangeError); SetSize(Longint(NewSize)); end; function TStream.Seek(Offset: Longint; Origin: Word): Longint; procedure RaiseException; begin raise EStreamError.CreateResFmt(@sSeekNotImplemented, [Classname]); end; type TSeek64 = function (const Offset: Int64; Origin: TSeekOrigin): Int64 of object; var Impl: TSeek64; Base: TSeek64; ClassTStream: TClass; begin { Deflect 32 seek requests to the 64 bit seek, if 64 bit is implemented. No existing TStream classes should call this method, since it was originally abstract. Descendent classes MUST implement at least one of either the 32 bit or the 64 bit version, and must not call the inherited default implementation. } Impl := Seek; ClassTStream := Self.ClassType; while (ClassTStream <> nil) and (ClassTStream <> TStream) do ClassTStream := ClassTStream.ClassParent; if ClassTStream = nil then RaiseException; Base := TStream(@ClassTStream).Seek; if TMethod(Impl).Code = TMethod(Base).Code then RaiseException; Result := Seek(Int64(Offset), TSeekOrigin(Origin)); end; function TStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; begin { Default implementation of 64 bit seek is to deflect to existing 32 bit seek. Descendents that override 64 bit seek must not call this default implementation. } if (Offset < Low(Longint)) or (Offset > High(Longint)) then raise ERangeError.CreateRes(@SRangeError); Result := Seek(Longint(Offset), Ord(Origin)); end; procedure TStream.ReadBuffer(var Buffer; Count: Longint); begin if (Count <> 0) and (Read(Buffer, Count) <> Count) then raise EReadError.CreateRes(@SReadError); end; procedure TStream.WriteBuffer(const Buffer; Count: Longint); begin if (Count <> 0) and (Write(Buffer, Count) <> Count) then raise EWriteError.CreateRes(@SWriteError); end; function TStream.CopyFrom(Source: TStream; Count: Int64): Int64; const MaxBufSize = $F000; var BufSize, N: Integer; Buffer: PChar; begin if Count = 0 then begin Source.Position := 0; Count := Source.Size; end; Result := Count; if Count > MaxBufSize then BufSize := MaxBufSize else BufSize := Count; GetMem(Buffer, BufSize); try while Count <> 0 do begin if Count > BufSize then N := BufSize else N := Count; Source.ReadBuffer(Buffer^, N); WriteBuffer(Buffer^, N); Dec(Count, N); end; finally FreeMem(Buffer, BufSize); end; end; function TStream.ReadComponent(Instance: TComponent): TComponent; var Reader: TReader; begin Reader := TReader.Create(Self, 4096); try Result := Reader.ReadRootComponent(Instance); finally Reader.Free; end; end; procedure TStream.WriteComponent(Instance: TComponent); begin WriteDescendent(Instance, nil); end; procedure TStream.WriteDescendent(Instance, Ancestor: TComponent); var Writer: TWriter; begin Writer := TWriter.Create(Self, 4096); try Writer.WriteDescendent(Instance, Ancestor); finally Writer.Free; end; end; function TStream.ReadComponentRes(Instance: TComponent): TComponent; begin ReadResHeader; Result := ReadComponent(Instance); end; procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent); begin WriteDescendentRes(ResName, Instance, nil); end; procedure TStream.WriteResourceHeader(const ResName: string; out FixupInfo: Integer); var HeaderSize: Integer; Header: array[0..79] of Char; begin Byte((@Header[0])^) := $FF; Word((@Header[1])^) := 10; HeaderSize := StrLen(StrUpper(StrPLCopy(@Header[3], ResName, 63))) + 10; Word((@Header[HeaderSize - 6])^) := $1030; Longint((@Header[HeaderSize - 4])^) := 0; WriteBuffer(Header, HeaderSize); FixupInfo := Position; end; procedure TStream.FixupResourceHeader(FixupInfo: Integer); var ImageSize: Integer; begin ImageSize := Position - FixupInfo; Position := FixupInfo - 4; WriteBuffer(ImageSize, SizeOf(Longint)); Position := FixupInfo + ImageSize; end; procedure TStream.WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent); var FixupInfo: Integer; begin WriteResourceHeader(ResName, FixupInfo); WriteDescendent(Instance, Ancestor); FixupResourceHeader(FixupInfo); end; procedure TStream.ReadResHeader; var ReadCount: Cardinal; Header: array[0..79] of Char; begin FillChar(Header, SizeOf(Header), 0); ReadCount := Read(Header, SizeOf(Header) - 1); if (Byte((@Header[0])^) = $FF) and (Word((@Header[1])^) = 10) then Seek(StrLen(Header + 3) + 10 - ReadCount, 1) else raise EInvalidImage.CreateRes(@SInvalidImage); end; { THandleStream } constructor THandleStream.Create(AHandle: Integer); begin inherited Create; FHandle := AHandle; end; function THandleStream.Read(var Buffer; Count: Longint): Longint; begin Result := FileRead(FHandle, Buffer, Count); if Result = -1 then Result := 0; end; function THandleStream.Write(const Buffer; Count: Longint): Longint; begin Result := FileWrite(FHandle, Buffer, Count); if Result = -1 then Result := 0; end; function THandleStream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; begin Result := FileSeek(FHandle, Offset, Ord(Origin)); end; procedure THandleStream.SetSize(NewSize: Longint); begin SetSize(Int64(NewSize)); end; procedure THandleStream.SetSize(const NewSize: Int64); begin Seek(NewSize, soBeginning); {$IFDEF MSWINDOWS} Win32Check(SetEndOfFile(FHandle)); {$ELSE} if ftruncate(FHandle, Position) = -1 then raise EStreamError(sStreamSetSize); {$ENDIF} end; { TFileStream } constructor TFileStream.Create(const FileName: string; Mode: Word); begin {$IFDEF MSWINDOWS} Create(Filename, Mode, 0); {$ELSE} Create(Filename, Mode, FileAccessRights); {$ENDIF} end; constructor TFileStream.Create(const FileName: string; Mode: Word; Rights: Cardinal); begin if Mode = fmCreate then begin inherited Create(FileCreate(FileName, Rights)); if FHandle < 0 then raise EFCreateError.CreateResFmt(@SFCreateError, [FileName]); end else begin inherited Create(FileOpen(FileName, Mode)); if FHandle < 0 then raise EFOpenError.CreateResFmt(@SFOpenError, [FileName]); end; end; destructor TFileStream.Destroy; begin if FHandle >= 0 then FileClose(FHandle); inherited Destroy; end; { TCustomMemoryStream } procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; Size: Longint); begin FMemory := Ptr; FSize := Size; end; function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint; begin if (FPosition >= 0) and (Count >= 0) then begin Result := FSize - FPosition; if Result > 0 then begin if Result > Count then Result := Count; Move(Pointer(Longint(FMemory) + FPosition)^, Buffer, Result); Inc(FPosition, Result); Exit; end; end; Result := 0; end; function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint; begin case Origin of soFromBeginning: FPosition := Offset; soFromCurrent: Inc(FPosition, Offset); soFromEnd: FPosition := FSize + Offset; end; Result := FPosition; end; procedure TCustomMemoryStream.SaveToStream(Stream: TStream); begin if FSize <> 0 then Stream.WriteBuffer(FMemory^, FSize); end; procedure TCustomMemoryStream.SaveToFile(const FileName: string); var Stream: TStream; begin Stream := TFileStream.Create(FileName, fmCreate); try SaveToStream(Stream); finally Stream.Free; end; end; { TMemoryStream } const MemoryDelta = $2000; { Must be a power of 2 } destructor TMemoryStream.Destroy; begin Clear; inherited Destroy; end; procedure TMemoryStream.Clear; begin SetCapacity(0); FSize := 0; FPosition := 0; end; procedure TMemoryStream.LoadFromStream(Stream: TStream); var Count: Longint; begin Stream.Position := 0; Count := Stream.Size; SetSize(Count); if Count <> 0 then Stream.ReadBuffer(FMemory^, Count); end; procedure TMemoryStream.LoadFromFile(const FileName: string); var Stream: TStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try LoadFromStream(Stream); finally Stream.Free; end; end; procedure TMemoryStream.SetCapacity(NewCapacity: Longint); begin SetPointer(Realloc(NewCapacity), FSize); FCapacity := NewCapacity; end; procedure TMemoryStream.SetSize(NewSize: Longint); var OldPosition: Longint; begin OldPosition := FPosition; SetCapacity(NewSize); FSize := NewSize; if OldPosition > NewSize then Seek(0, soFromEnd); end; function TMemoryStream.Realloc(var NewCapacity: Longint): Pointer; begin if (NewCapacity > 0) and (NewCapacity <> FSize) then NewCapacity := (NewCapacity + (MemoryDelta - 1)) and not (MemoryDelta - 1); Result := Memory; if NewCapacity <> FCapacity then begin if NewCapacity = 0 then begin {$IFDEF MSWINDOWS} GlobalFreePtr(Memory); {$ELSE} FreeMem(Memory); {$ENDIF} Result := nil; end else begin {$IFDEF MSWINDOWS} if Capacity = 0 then Result := GlobalAllocPtr(HeapAllocFlags, NewCapacity) else Result := GlobalReallocPtr(Memory, NewCapacity, HeapAllocFlags); {$ELSE} if Capacity = 0 then GetMem(Result, NewCapacity) else ReallocMem(Result, NewCapacity); {$ENDIF} if Result = nil then raise EStreamError.CreateRes(@SMemoryStreamError); end; end; end; function TMemoryStream.Write(const Buffer; Count: Longint): Longint; var Pos: Longint; begin if (FPosition >= 0) and (Count >= 0) then begin Pos := FPosition + Count; if Pos > 0 then begin if Pos > FSize then begin if Pos > FCapacity then SetCapacity(Pos); FSize := Pos; end; System.Move(Buffer, Pointer(Longint(FMemory) + FPosition)^, Count); FPosition := Pos; Result := Count; Exit; end; end; Result := 0; end; { TStringStream } constructor TStringStream.Create(const AString: string); begin inherited Create; FDataString := AString; end; function TStringStream.Read(var Buffer; Count: Longint): Longint; begin Result := Length(FDataString) - FPosition; if Result > Count then Result := Count; Move(PChar(@FDataString[FPosition + 1])^, Buffer, Result); Inc(FPosition, Result); end; function TStringStream.Write(const Buffer; Count: Longint): Longint; begin Result := Count; SetLength(FDataString, (FPosition + Result)); Move(Buffer, PChar(@FDataString[FPosition + 1])^, Result); Inc(FPosition, Result); end; function TStringStream.Seek(Offset: Longint; Origin: Word): Longint; begin case Origin of soFromBeginning: FPosition := Offset; soFromCurrent: FPosition := FPosition + Offset; soFromEnd: FPosition := Length(FDataString) - Offset; end; if FPosition > Length(FDataString) then FPosition := Length(FDataString) else if FPosition < 0 then FPosition := 0; Result := FPosition; end; function TStringStream.ReadString(Count: Longint): string; var Len: Integer; begin Len := Length(FDataString) - FPosition; if Len > Count then Len := Count; SetString(Result, PChar(@FDataString[FPosition + 1]), Len); Inc(FPosition, Len); end; procedure TStringStream.WriteString(const AString: string); begin Write(PChar(AString)^, Length(AString)); end; procedure TStringStream.SetSize(NewSize: Longint); begin SetLength(FDataString, NewSize); if FPosition > NewSize then FPosition := NewSize; end; { TResourceStream } constructor TResourceStream.Create(Instance: THandle; const ResName: string; ResType: PChar); begin inherited Create; Initialize(Instance, PChar(ResName), ResType); end; constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar); begin inherited Create; Initialize(Instance, PChar(ResID), ResType); end; procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar); procedure Error; begin raise EResNotFound.CreateFmt(SResNotFound, [Name]); end; begin HResInfo := FindResource(Instance, Name, ResType); if HResInfo = 0 then Error; HGlobal := LoadResource(Instance, HResInfo); if HGlobal = 0 then Error; SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo)); end; destructor TResourceStream.Destroy; begin UnlockResource(HGlobal); FreeResource(HGlobal); inherited Destroy; end; function TResourceStream.Write(const Buffer; Count: Longint): Longint; begin raise EStreamError.CreateRes(@SCantWriteResourceStreamError); end; { TFiler } constructor TFiler.Create(Stream: TStream; BufSize: Integer); begin FStream := Stream; GetMem(FBuffer, BufSize); FBufSize := BufSize; end; destructor TFiler.Destroy; begin if FBuffer <> nil then FreeMem(FBuffer, FBufSize); end; procedure TFiler.SetRoot(Value: TComponent); begin FRoot := Value; end; { TPropFixup } type TPropFixup = class FInstance: TPersistent; FInstanceRoot: TComponent; FPropInfo: PPropInfo; FRootName: string; FName: string; constructor Create(Instance: TPersistent; InstanceRoot: TComponent; PropInfo: PPropInfo; const RootName, Name: string); function MakeGlobalReference: Boolean; procedure ResolveReference(Reference: Pointer); virtual; end; TPropIntfFixup = class(TPropFixup) procedure ResolveReference(Reference: Pointer); override; end; var GlobalFixupList: TThreadList; constructor TPropFixup.Create(Instance: TPersistent; InstanceRoot: TComponent; PropInfo: PPropInfo; const RootName, Name: string); begin FInstance := Instance; FInstanceRoot := InstanceRoot; FPropInfo := PropInfo; FRootName := RootName; FName := Name; end; function TPropFixup.MakeGlobalReference: Boolean; var S: PChar; P: PChar; begin Result := False; S := PChar(Pointer(FName)); P := S; while not (P^ in ['.', #0]) do Inc(P); if P^ = #0 then Exit; SetString(FRootName, S, P - S); Delete(FName, 1, P - S + 1); Result := True; end; procedure TPropFixup.ResolveReference(Reference: Pointer); begin SetOrdProp(FInstance, FPropInfo, Longint(Reference)); end; procedure TPropIntfFixup.ResolveReference(Reference: Pointer); var Intf: IInterface; begin Intf := nil; if Reference <> nil then if not Supports(TObject(Reference), GetTypeData(FPropInfo^.PropType^)^.Guid, Intf) then Intf := nil; SetInterfaceProp(FInstance, FPropInfo, Intf); end; function FindNestedComponent(Root: TComponent; const NamePath: string): TComponent; var Current, Found: TComponent; S, P: PChar; Name: string; begin Result := nil; if NamePath = '' then Exit; Current := Root; P := PChar(Pointer(NamePath)); while P^ <> #0 do begin S := P; while not (P^ in ['.', '-', #0]) do Inc(P); SetString(Name, S, P - S); Found := Current.FindComponent(Name); if (Found = nil) and SameText(Name, 'Owner') then { Do not translate } Found := Current; if Found = nil then Exit; if P^ = '.' then Inc(P); if P^ = '-' then Inc(P); if P^ = '>' then Inc(P); Current := Found; end; Result := Current; end; procedure GlobalFixupReferences; var FinishedList: TList; NotFinishedList: TList; GlobalList: TList; I: Integer; Root: TComponent; Instance: TPersistent; Reference: Pointer; procedure AddFinished(Instance: TPersistent); begin if (FinishedList.IndexOf(Instance) < 0) and (NotFinishedList.IndexOf(Instance) >= 0) then FinishedList.Add(Instance); end; procedure AddNotFinished(Instance: TPersistent); var Index: Integer; begin Index := FinishedList.IndexOf(Instance); if Index <> -1 then FinishedList.Delete(Index); if NotFinishedList.IndexOf(Instance) < 0 then NotFinishedList.Add(Instance); end; begin // Fixup resolution requires a stable component / name space // Block construction and destruction of forms / datamodules during fixups {$IFDEF MSWINDOWS} GlobalNameSpace.BeginWrite; try {$ENDIF} GlobalList := GlobalFixupList.LockList; try if GlobalList.Count > 0 then begin FinishedList := TList.Create; try NotFinishedList := TList.Create; try I := 0; while I < GlobalList.Count do with TPropFixup(GlobalList[I]) do begin Root := FindGlobalComponent(FRootName); if (Root <> nil) or (GetOrdProp(FInstance, FPropInfo) <> 0) then begin if Root <> nil then begin Reference := FindNestedComponent(Root, FName); ResolveReference(Reference); end; AddFinished(FInstance); GlobalList.Delete(I); Free; end else begin AddNotFinished(FInstance); Inc(I); end; end; finally NotFinishedList.Free; end; for I := 0 to FinishedList.Count - 1 do begin Instance := FinishedList[I]; if Instance is TComponent then Exclude(TComponent(Instance).FComponentState, csFixups); end; finally FinishedList.Free; end; end; finally GlobalFixupList.UnlockList; end; {$IFDEF MSWINDOWS} finally GlobalNameSpace.EndWrite; end; {$ENDIF} end; function NameInStrings(Strings: TStrings; const Name: string): Boolean; var I: Integer; begin Result := True; for I := 0 to Strings.Count - 1 do if SameText(Name, Strings[I]) then Exit; Result := False; end; procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings); var I: Integer; Fixup: TPropFixup; begin with GlobalFixupList.LockList do try for I := 0 to Count - 1 do begin Fixup := Items[I]; if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and not NameInStrings(Names, Fixup.FRootName) then Names.Add(Fixup.FRootName); end; finally GlobalFixupList.UnlockList; end; end; procedure RedirectFixupReferences(Root: TComponent; const OldRootName, NewRootName: string); var I: Integer; Fixup: TPropFixup; begin with GlobalFixupList.LockList do try for I := 0 to Count - 1 do begin Fixup := Items[I]; if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and SameText(OldRootName, Fixup.FRootName) then Fixup.FRootName := NewRootName; end; GlobalFixupReferences; finally GlobalFixupList.Unlocklist; end; end; procedure RemoveFixupReferences(Root: TComponent; const RootName: string); var I: Integer; Fixup: TPropFixup; begin if GlobalFixupList = nil then Exit; with GlobalFixupList.LockList do try for I := Count - 1 downto 0 do begin Fixup := Items[I]; if ((Root = nil) or (Fixup.FInstanceRoot = Root)) and ((RootName = '') or SameText(RootName, Fixup.FRootName)) then begin Delete(I); Fixup.Free; end; end; finally GlobalFixupList.UnlockList; end; end; procedure RemoveFixups(Instance: TPersistent); var I: Integer; Fixup: TPropFixup; begin if GlobalFixupList = nil then Exit; with GlobalFixupList.LockList do try for I := Count - 1 downto 0 do begin Fixup := Items[I]; if (Fixup.FInstance = Instance) then begin Delete(I); Fixup.Free; end; end; finally GlobalFixupList.UnlockList; end; end; procedure GetFixupInstanceNames(Root: TComponent; const ReferenceRootName: string; Names: TStrings); var I: Integer; Fixup: TPropFixup; begin with GlobalFixupList.LockList do try for I := 0 to Count - 1 do begin Fixup := Items[I]; if (Fixup.FInstanceRoot = Root) and SameText(ReferenceRootName, Fixup.FRootName) and not NameInStrings(Names, Fixup.FName) then Names.Add(Fixup.FName); end; finally GlobalFixupList.UnlockList; end; end; { TReader } procedure ReadError(Ident: PResStringRec); begin raise EReadError.CreateRes(Ident); end; procedure PropValueError; begin ReadError(@SInvalidPropertyValue); end; procedure PropertyNotFound(const Name: string); begin raise EReadError.CreateResFmt(@SUnknownProperty, [Name]); end; destructor TReader.Destroy; begin FStream.Seek(Integer(FBufPos) - Integer(FBufEnd), 1); inherited Destroy; end; procedure TReader.BeginReferences; begin FLoaded := TList.Create; try FFixups := TList.Create; except FLoaded.Free; raise; end; end; procedure TReader.CheckValue(Value: TValueType); begin if ReadValue <> Value then begin Dec(FBufPos); SkipValue; PropValueError; end; end; procedure TReader.DefineProperty(const Name: string; ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean); begin if SameText(Name, FPropName) and Assigned(ReadData) then begin ReadData(Self); FPropName := ''; end; end; procedure TReader.DefineBinaryProperty(const Name: string; ReadData, WriteData: TStreamProc; HasData: Boolean); var Stream: TMemoryStream; Count: Longint; begin if SameText(Name, FPropName) and Assigned(ReadData) then begin if ReadValue <> vaBinary then begin Dec(FBufPos); SkipValue; FCanHandleExcepts := True; PropValueError; end; Stream := TMemoryStream.Create; try Read(Count, SizeOf(Count)); Stream.SetSize(Count); Read(Stream.Memory^, Count); FCanHandleExcepts := True; ReadData(Stream); finally Stream.Free; end; FPropName := ''; end; end; function TReader.EndOfList: Boolean; begin Result := ReadValue = vaNull; Dec(FBufPos); end; procedure TReader.EndReferences; begin FreeFixups; FLoaded.Free; FLoaded := nil; end; function TReader.Error(const Message: string): Boolean; begin Result := False; if Assigned(FOnError) then FOnError(Self, Message, Result); end; function TReader.FindMethod(Root: TComponent; const MethodName: string): Pointer; var Error: Boolean; begin Result := Root.MethodAddress(MethodName); Error := Result = nil; if Assigned(FOnFindMethod) then FOnFindMethod(Self, MethodName, Result, Error); if Error then PropValueError; end; procedure RemoveGlobalFixup(Fixup: TPropFixup); var I: Integer; begin with GlobalFixupList.LockList do try for I := Count-1 downto 0 do with TPropFixup(Items[I]) do if (FInstance = Fixup.FInstance) and (FPropInfo = Fixup.FPropInfo) then begin Free; Delete(I); end; finally GlobalFixupList.UnlockList; end; end; procedure TReader.DoFixupReferences; var I: Integer; CompName: string; Reference: Pointer; begin if FFixups <> nil then try for I := 0 to FFixups.Count - 1 do with TPropFixup(FFixups[I]) do begin CompName := FName; ReferenceName(CompName); Reference := FindNestedComponent(FInstanceRoot, CompName); { Free any preexisting global fixups for this instance/property. Last fixup added is the only one that counts. In particular, fixups created when streaming inherited forms/frames must be destroyed when overriding references are found later in the stream. } RemoveGlobalFixup(FFixups[I]); if (Reference = nil) and MakeGlobalReference then begin GlobalFixupList.Add(FFixups[I]); FFixups[I] := nil; end else ResolveReference(Reference); end; finally FreeFixups; end; end; procedure TReader.FixupReferences; var I: Integer; begin DoFixupReferences; GlobalFixupReferences; for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded; end; procedure TReader.FlushBuffer; begin FStream.Position := Position; FBufPos := 0; FBufEnd := 0; end; procedure TReader.FreeFixups; var I: Integer; begin if FFixups <> nil then begin for I := 0 to FFixups.Count - 1 do TPropFixup(FFixups[I]).Free; FFixups.Free; FFixups := nil; end; end; function TReader.GetFieldClass(Instance: TObject; const ClassName: string): TPersistentClass; var I: Integer; ClassTable: PFieldClassTable; ClassType: TClass; begin ClassType := Instance.ClassType; while ClassType <> TPersistent do begin ClassTable := GetFieldClassTable(ClassType); if ClassTable <> nil then for I := 0 to ClassTable^.Count - 1 do begin Result := ClassTable^.Classes[I]^; if Result.ClassNameIs(ClassName) then Exit; end; ClassType := ClassType.ClassParent; end; if FFinder <> nil then Result := FFinder.GetClass(ClassName) else Result := GetClass(ClassName); end; function TReader.GetPosition: Longint; begin Result := FStream.Position - (FBufEnd - FBufPos); end; function TReader.NextValue: TValueType; begin Result := ReadValue; Dec(FBufPos); end; procedure TReader.PropertyError(const Name: string); begin SkipValue; PropertyNotFound(Name); end; procedure TReader.Read(var Buf; Count: Longint); assembler; asm PUSH ESI PUSH EDI PUSH EBX MOV EDI,EDX MOV EBX,ECX MOV ESI,EAX JMP @@6 @@1: MOV ECX,[ESI].TReader.FBufEnd SUB ECX,[ESI].TReader.FBufPos JA @@2 MOV EAX,ESI CALL TReader.ReadBuffer MOV ECX,[ESI].TReader.FBufEnd @@2: CMP ECX,EBX JB @@3 MOV ECX,EBX @@3: PUSH ESI SUB EBX,ECX MOV EAX,[ESI].TReader.FBuffer ADD EAX,[ESI].TReader.FBufPos ADD [ESI].TReader.FBufPos,ECX MOV ESI,EAX MOV EDX,ECX SHR ECX,2 CLD REP MOVSD MOV ECX,EDX AND ECX,3 REP MOVSB POP ESI @@6: OR EBX,EBX JNE @@1 POP EBX POP EDI POP ESI end; procedure TReader.ReadBuffer; begin FBufEnd := FStream.Read(FBuffer^, FBufSize); if FBufEnd = 0 then raise EReadError.CreateRes(@SReadError); FBufPos := 0; end; function TReader.ReadBoolean: Boolean; begin Result := ReadValue = vaTrue; end; function TReader.ReadChar: Char; var Temp: string; begin Temp := ReadString; if Length(Temp) > 1 then PropValueError; Result := Temp[1]; end; procedure TReader.ReadCollection(Collection: TCollection); var Item: TPersistent; begin Collection.BeginUpdate; try if not EndOfList then Collection.Clear; while not EndOfList do begin if NextValue in [vaInt8, vaInt16, vaInt32] then ReadInteger; Item := Collection.Add; ReadListBegin; while not EndOfList do ReadProperty(Item); ReadListEnd; end; ReadListEnd; finally Collection.EndUpdate; end; end; function TReader.ReadComponent(Component: TComponent): TComponent; var CompClass, CompName: string; Flags: TFilerFlags; Position: Integer; OldParent, OldLookupRoot: TComponent; function ComponentCreated: Boolean; begin Result := not (ffInherited in Flags) and (Component = nil); end; function Recover(var Component: TComponent): Boolean; begin Result := False; if not (ExceptObject is Exception) then Exit; if ComponentCreated then Component.Free; Component := nil; SkipComponent(False); Result := Error(Exception(ExceptObject).Message); end; procedure CreateComponent; var ComponentClass: TComponentClass; begin try ComponentClass := FindComponentClass(CompClass); Result := nil; if Assigned(FOnCreateComponent) then FOnCreateComponent(Self, ComponentClass, Result); if Result = nil then begin Result := TComponent(ComponentClass.NewInstance); if ffInline in Flags then begin Include(Result.FComponentState, csLoading); Include(Result.FComponentState, csInline); end; try Result.Create(Owner); except Result := nil; raise; end; end; Include(Result.FComponentState, csLoading); except if not Recover(Result) then raise; end; end; procedure SetCompName; begin try Result.SetParentComponent(Parent); SetName(Result, CompName); if (csDesigning in Result.ComponentState) and (FindGlobalComponent(CompName) = Result) then Include(Result.FComponentState, csInline); except if not Recover(Result) then raise; end; end; procedure FindExistingComponent; begin try Result := FindAncestorComponent(CompName, FindComponentClass(CompClass)); Parent := Result.GetParentComponent; if Parent = nil then Parent := Root; except if not Recover(Result) then raise; end; end; begin ReadPrefix(Flags, Position); CompClass := ReadStr; CompName := ReadStr; OldParent := Parent; OldLookupRoot := FLookupRoot; try Result := Component; if Result = nil then if ffInherited in Flags then FindExistingComponent else CreateComponent; if Result <> nil then try Include(Result.FComponentState, csLoading); if not (ffInherited in Flags) then SetCompName; if Result = nil then Exit; if csInline in Result.ComponentState then FLookupRoot := Result; Include(Result.FComponentState, csReading); Result.ReadState(Self); Exclude(Result.FComponentState, csReading); if ffChildPos in Flags then Parent.SetChildOrder(Result, Position); if (ffInherited in Flags) or (csInline in Result.ComponentState) then begin if FLoaded.IndexOf(Result) < 0 then FLoaded.Add(Result) end else FLoaded.Add(Result); except if ComponentCreated then Result.Free; raise; end; finally Parent := OldParent; FLookupRoot := OldLookupRoot; end; end; procedure TReader.ReadData(Instance: TComponent); begin if FFixups = nil then begin FFixups := TList.Create; try ReadDataInner(Instance); DoFixupReferences; finally FreeFixups; end; end else ReadDataInner(Instance); end; procedure TReader.ReadDataInner(Instance: TComponent); var OldParent, OldOwner: TComponent; begin while not EndOfList do ReadProperty(Instance); ReadListEnd; OldParent := Parent; OldOwner := Owner; Parent := Instance.GetChildParent; try Owner := Instance.GetChildOwner; if not Assigned(Owner) then Owner := Root; while not EndOfList do ReadComponent(nil); ReadListEnd; finally Parent := OldParent; Owner := OldOwner; end; end; function TReader.ReadFloat: Extended; begin if ReadValue = vaExtended then Read(Result, SizeOf(Result)) else begin Dec(FBufPos); Result := ReadInteger; end; end; function TReader.ReadSingle: Single; begin if ReadValue = vaSingle then Read(Result, SizeOf(Result)) else begin Dec(FBufPos); Result := ReadInteger; end; end; function TReader.ReadCurrency: Currency; begin if ReadValue = vaCurrency then Read(Result, SizeOf(Result)) else begin Dec(FBufPos); Result := ReadInteger; end; end; function TReader.ReadDate: TDateTime; begin if ReadValue = vaDate then Read(Result, SizeOf(Result)) else begin Dec(FBufPos); Result := ReadInteger; end; end; function TReader.ReadIdent: string; var L: Byte; begin case ReadValue of vaIdent: begin Read(L, SizeOf(Byte)); SetString(Result, PChar(nil), L); Read(Result[1], L); end; vaFalse: Result := 'False'; vaTrue: Result := 'True'; vaNil: Result := 'nil'; vaNull: Result := 'Null'; else PropValueError; end; end; function TReader.ReadInteger: Longint; var S: Shortint; I: Smallint; begin case ReadValue of vaInt8: begin Read(S, SizeOf(Shortint)); Result := S; end; vaInt16: begin Read(I, SizeOf(I)); Result := I; end; vaInt32: Read(Result, SizeOf(Result)); else PropValueError; end; end; function TReader.ReadInt64: Int64; begin if NextValue = vaInt64 then begin ReadValue; Read(Result, Sizeof(Result)); end else Result := ReadInteger; end; procedure TReader.ReadListBegin; begin CheckValue(vaList); end; procedure TReader.ReadListEnd; begin CheckValue(vaNull); end; procedure TReader.ReadPrefix(var Flags: TFilerFlags; var AChildPos: Integer); var Prefix: Byte; begin Flags := []; if Byte(NextValue) and $F0 = $F0 then begin Prefix := Byte(ReadValue); Byte(Flags) := Prefix and $0F; if ffChildPos in Flags then AChildPos := ReadInteger; end; end; procedure TReader.ReadProperty(AInstance: TPersistent); var I, J, L: Integer; Instance: TPersistent; PropInfo: PPropInfo; PropValue: TObject; PropPath: string; procedure HandleException(E: Exception); var Name: string; begin Name := ''; if AInstance is TComponent then Name := TComponent(AInstance).Name; if Name = '' then Name := AInstance.ClassName; raise EReadError.CreateResFmt(@SPropertyException, [Name, DotSep, PropPath, E.Message]); end; procedure PropPathError; begin SkipValue; ReadError(@SInvalidPropertyPath); end; begin try PropPath := ReadStr; try I := 1; L := Length(PropPath); Instance := AInstance; FCanHandleExcepts := True; while True do begin J := I; while (I <= L) and (PropPath[I] <> '.') do Inc(I); FPropName := Copy(PropPath, J, I - J); if I > L then Break; PropInfo := GetPropInfo(Instance.ClassInfo, FPropName); if PropInfo = nil then PropertyError(FPropName); PropValue := nil; if PropInfo^.PropType^.Kind = tkClass then PropValue := TObject(GetOrdProp(Instance, PropInfo)); if not (PropValue is TPersistent) then PropPathError; Instance := TPersistent(PropValue); Inc(I); end; PropInfo := GetPropInfo(Instance.ClassInfo, FPropName); if PropInfo <> nil then ReadPropValue(Instance, PropInfo) else begin { Cannot reliably recover from an error in a defined property } FCanHandleExcepts := False; Instance.DefineProperties(Self); FCanHandleExcepts := True; if FPropName <> '' then PropertyError(FPropName); end; except on E: Exception do HandleException(E); end; except on E: Exception do if not FCanHandleExcepts or not Error(E.Message) then raise; end; end; procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: Pointer); const NilMethod: TMethod = (Code: nil; Data: nil); var PropType: PTypeInfo; Method: TMethod; procedure SetIntIdent(Instance: TPersistent; PropInfo: Pointer; const Ident: string); var V: Longint; IdentToInt: TIdentToInt; begin IdentToInt := FindIdentToInt(PPropInfo(PropInfo)^.PropType^); if Assigned(IdentToInt) and IdentToInt(Ident, V) then SetOrdProp(Instance, PropInfo, V) else PropValueError; end; procedure SetObjectIdent(Instance: TPersistent; PropInfo: Pointer; const Ident: string); begin FFixups.Add(TPropFixup.Create(Instance, Root, PropInfo, '', Ident)); end; procedure SetInterfaceReference; var Intf: IInterface; begin if NextValue = vaNil then begin ReadValue; Intf := nil; SetInterfaceProp(Instance, PropInfo, Intf); end else FFixups.Add(TPropIntfFixup.Create(Instance, Root, PropInfo, '', ReadIdent)); end; begin if PPropInfo(PropInfo)^.SetProc = nil then if not ((PPropInfo(PropInfo)^.PropType^.Kind = tkClass) and (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle)) then ReadError(@SReadOnlyProperty); PropType := PPropInfo(PropInfo)^.PropType^; case PropType^.Kind of tkInteger: if NextValue = vaIdent then SetIntIdent(Instance, PropInfo, ReadIdent) else SetOrdProp(Instance, PropInfo, ReadInteger); tkChar: SetOrdProp(Instance, PropInfo, Ord(ReadChar)); tkEnumeration: SetOrdProp(Instance, PropInfo, GetEnumValue(PropType, ReadIdent)); tkFloat: SetFloatProp(Instance, PropInfo, ReadFloat); tkString, tkLString: SetStrProp(Instance, PropInfo, ReadString); tkWString: SetWideStrProp(Instance, PropInfo, ReadWideString); tkSet: SetOrdProp(Instance, PropInfo, ReadSet(PropType)); tkClass: case NextValue of vaNil: begin ReadValue; SetOrdProp(Instance, PropInfo, 0) end; vaCollection: begin ReadValue; ReadCollection(TCollection(GetOrdProp(Instance, PropInfo))); end else SetObjectIdent(Instance, PropInfo, ReadIdent); end; tkMethod: if NextValue = vaNil then begin ReadValue; SetMethodProp(Instance, PropInfo, NilMethod); end else begin Method.Code := FindMethod(Root, ReadIdent); Method.Data := Root; if Method.Code <> nil then SetMethodProp(Instance, PropInfo, Method); end; tkVariant: SetVariantProp(Instance, PropInfo, ReadVariant); tkInt64: SetInt64Prop(Instance, PropInfo, ReadInt64); tkInterface: SetInterfaceReference; end; end; function TReader.ReadRootComponent(Root: TComponent): TComponent; function FindUniqueName(const Name: string): string; var I: Integer; begin I := 0; Result := Name; while not IsUniqueGlobalComponentName(Result) do begin Inc(I); Result := Format('%s_%d', [Name, I]); end; end; var I: Integer; Flags: TFilerFlags; G: TList; begin ReadSignature; Result := nil; {$IFDEF MSWINDOWS} GlobalNameSpace.BeginWrite; // Loading from stream adds to name space try {$ENDIF} try ReadPrefix(Flags, I); if Root = nil then begin Result := TComponentClass(FindClass(ReadStr)).Create(nil); Result.Name := ReadStr; end else begin Result := Root; ReadStr; { Ignore class name } if csDesigning in Result.ComponentState then ReadStr else begin Include(Result.FComponentState, csLoading); Include(Result.FComponentState, csReading); Result.Name := FindUniqueName(ReadStr); end; end; FRoot := Result; FFinder := TClassFinder.Create(TPersistentClass(Result.ClassType), True); try FLookupRoot := Result; G := GlobalLoaded; if G <> nil then FLoaded := G else FLoaded := TList.Create; try if FLoaded.IndexOf(FRoot) < 0 then FLoaded.Add(FRoot); FOwner := FRoot; Include(FRoot.FComponentState, csLoading); Include(FRoot.FComponentState, csReading); FRoot.ReadState(Self); Exclude(FRoot.FComponentState, csReading); if G = nil then for I := 0 to FLoaded.Count - 1 do TComponent(FLoaded[I]).Loaded; finally if G = nil then FLoaded.Free; FLoaded := nil; end; finally FFinder.Free; end; while True do try // Try to fix up all references until no exceptions or the exception // itself terminates the loop. This will loop if the error is ignored // in, for example, the form designer. GlobalFixupReferences; Break; except if not Error(Exception(ExceptObject).Message) then raise; end; except RemoveFixupReferences(Root, ''); if Root = nil then Result.Free; raise; end; {$IFDEF MSWINDOWS} finally GlobalNameSpace.EndWrite; end; {$ENDIF} end; procedure TReader.ReadComponents(AOwner, AParent: TComponent; Proc: TReadComponentsProc); var Component: TComponent; begin Root := AOwner; Owner := AOwner; Parent := AParent; BeginReferences; try FFinder := TClassFinder.Create(TPersistentClass(AOwner.ClassType), True); try while not EndOfList do begin ReadSignature; Component := ReadComponent(nil); if Assigned(Proc) then Proc(Component); end; ReadListEnd; FixupReferences; finally FFinder.Free; end; finally EndReferences; end; end; function TReader.ReadSet(SetType: Pointer): Integer; var EnumType: PTypeInfo; EnumName: string; begin try if ReadValue <> vaSet then PropValueError; EnumType := GetTypeData(SetType)^.CompType^; Result := 0; while True do begin EnumName := ReadStr; if EnumName = '' then Break; Include(TIntegerSet(Result), GetEnumValue(EnumType, EnumName)); end; except SkipSetBody; raise; end; end; procedure TReader.ReadSignature; var Signature: Longint; begin Read(Signature, SizeOf(Signature)); if Signature <> Longint(FilerSignature) then ReadError(@SInvalidImage); end; function TReader.ReadStr: string; var L: Byte; begin Read(L, SizeOf(Byte)); SetString(Result, PChar(nil), L); Read(Result[1], L); end; function TReader.ReadString: string; var L: Integer; begin if NextValue in [vaWString, vaUTF8String] then Result := ReadWideString else begin L := 0; case ReadValue of vaString: Read(L, SizeOf(Byte)); vaLString: Read(L, SizeOf(Integer)); else PropValueError; end; SetLength(Result, L); Read(Pointer(Result)^, L); end; end; function TReader.ReadWideString: WideString; var L: Integer; Temp: UTF8String; begin if NextValue in [vaString, vaLString] then Result := ReadString else begin L := 0; case ReadValue of vaWString: begin Read(L, SizeOf(Integer)); SetLength(Result, L); Read(Pointer(Result)^, L * 2); end; vaUtf8String: begin Read(L, SizeOf(Integer)); SetLength(Temp, L); Read(Pointer(Temp)^, L); Result := Utf8Decode(Temp); end; else PropValueError; end; end; end; function TReader.ReadValue: TValueType; begin Read(Result, SizeOf(Result)); end; procedure TReader.SetPosition(Value: Longint); begin FStream.Position := Value; FBufPos := 0; FBufEnd := 0; end; procedure TReader.SkipSetBody; begin while ReadStr <> '' do begin end; end; procedure TReader.SkipValue; procedure SkipList; begin while not EndOfList do SkipValue; ReadListEnd; end; procedure SkipBinary(BytesPerUnit: Integer); var Count: Longint; begin Read(Count, SizeOf(Count)); SkipBytes(Count * BytesPerUnit); end; procedure SkipCollection; begin while not EndOfList do begin if NextValue in [vaInt8, vaInt16, vaInt32] then SkipValue; SkipBytes(1); while not EndOfList do SkipProperty; ReadListEnd; end; ReadListEnd; end; begin case ReadValue of vaNull: { no value field, just an identifier }; vaList: SkipList; vaInt8: SkipBytes(SizeOf(Byte)); vaInt16: SkipBytes(SizeOf(Word)); vaInt32: SkipBytes(SizeOf(LongInt)); vaExtended: SkipBytes(SizeOf(Extended)); vaString, vaIdent: ReadStr; vaFalse, vaTrue: { no value field, just an identifier }; vaBinary: SkipBinary(1); vaSet: SkipSetBody; vaLString: SkipBinary(1); vaCollection: SkipCollection; vaSingle: SkipBytes(Sizeof(Single)); vaCurrency: SkipBytes(SizeOf(Currency)); vaDate: SkipBytes(Sizeof(TDateTime)); vaWString: SkipBinary(Sizeof(WideChar)); vaInt64: SkipBytes(Sizeof(Int64)); vaUTF8String: SkipBinary(1); end; end; procedure TReader.CopyValue(Writer: TWriter); procedure CopySetBody; var s: string; begin Writer.WriteValue(ReadValue); repeat s := ReadStr; Writer.WriteStr(s); until s = ''; end; procedure CopyList; begin Writer.WriteValue(ReadValue); while not EndOfList do CopyValue(Writer); ReadListEnd; Writer.WriteListEnd; end; procedure CopyBytes(Count: Longint); var Bytes: array[0..8191] of Char; begin while Count > SizeOf(Bytes) do begin Read(Bytes, SizeOf(Bytes)); Writer.Write(Bytes, SizeOf(Bytes)); Dec(Count, SizeOf(Bytes)); end; if Count > 0 then begin Read(Bytes, Count); Writer.Write(Bytes, Count); end; end; procedure CopyBinary(BytesPerUnit: Integer); var Count: Longint; begin Writer.WriteValue(ReadValue); Read(Count, SizeOf(Count)); Writer.Write(Count, SizeOf(Count)); CopyBytes(Count * BytesPerUnit); end; begin case NextValue of vaNull, vaFalse, vaTrue, vaNil: Writer.WriteValue(ReadValue); vaList, vaCollection: CopyList; vaInt8, vaInt16, vaInt32: Writer.WriteInteger(ReadInteger); vaExtended: Writer.WriteFloat(ReadFloat); vaString: Writer.WriteString(ReadString); vaIdent: Writer.WriteIdent(ReadIdent); vaBinary, vaLString, vaUTF8String: CopyBinary(1); vaWString: CopyBinary(Sizeof(WideChar)); vaSet: CopySetBody; vaSingle: Writer.WriteSingle(ReadSingle); vaCurrency: Writer.WriteCurrency(ReadCurrency); vaDate: Writer.WriteDate(ReadDate); vaInt64: Writer.WriteInteger(ReadInt64); end; end; procedure TReader.SkipProperty; begin ReadStr; { Skips property name } SkipValue; end; procedure TReader.SkipComponent(SkipHeader: Boolean); var Flags: TFilerFlags; Position: Integer; begin if SkipHeader then begin ReadPrefix(Flags, Position); ReadStr; ReadStr; end; while not EndOfList do SkipProperty; ReadListEnd; while not EndOfList do SkipComponent(True); ReadListEnd; end; function TReader.FindAncestorComponent(const Name: string; ComponentClass: TPersistentClass): TComponent; var CompName: string; begin CompName := Name; Result := nil; if FLookupRoot <> nil then Result := FLookupRoot.FindComponent(CompName); if Result = nil then begin if Assigned(FOnAncestorNotFound) then FOnAncestorNotFound(Self, CompName, ComponentClass, Result); if Result = nil then raise EReadError.CreateResFmt(@SAncestorNotFound, [CompName]); end; end; procedure TReader.ReferenceName(var Name: string); begin if Assigned(FOnReferenceName) then FOnReferenceName(Self, Name); end; procedure TReader.SetName(Component: TComponent; var Name: string); begin if Assigned(FOnSetName) then FOnSetName(Self, Component, Name); Component.Name := Name; end; function TReader.FindComponentClass(const ClassName: string): TComponentClass; begin TPersistentClass(Result) := GetFieldClass(Root, ClassName); if not Assigned(Result) and Assigned(FLookupRoot) and (FLookupRoot <> Root) then TPersistentClass(Result) := GetFieldClass(FLookupRoot, ClassName); if Assigned(FOnFindComponentClass) then FOnFindComponentClass(Self, ClassName, Result); if (Result = nil) or not Result.InheritsFrom(TComponent) then ClassNotFound(ClassName); end; procedure TReader.SkipBytes(Count: Integer); var Bytes: array[0..255] of Char; begin while Count > 0 do if Count > SizeOf(Bytes) then begin Read(Bytes, SizeOf(Bytes)); Dec(Count, SizeOf(Bytes)); end else begin Read(Bytes, Count); Count := 0; end; end; function TReader.ReadVariant: Variant; function ReadCustomVariant: Variant; var OuterStream, InnerStream: TMemoryStream; OuterReader: TReader; StreamSize: Integer; CustomType: TCustomVariantType; CustomTypeClassName: string; VarStreamer: IVarStreamable; begin CheckValue(vaBinary); OuterStream := TMemoryStream.Create; InnerStream := TMemoryStream.Create; try Read(StreamSize, SizeOf(StreamSize)); OuterStream.Size := StreamSize; Read(OuterStream.Memory^, StreamSize); OuterReader := TReader.Create(OuterStream, 1024); try CustomTypeClassName := OuterReader.ReadString; OuterReader.Read(StreamSize, SizeOf(StreamSize)); InnerStream.Size := StreamSize; OuterReader.Read(InnerStream.Memory^, StreamSize); if not FindCustomVariantType(CustomTypeClassName, CustomType) or not Supports(TObject(CustomType), IVarStreamable, VarStreamer) then raise EReadError.CreateRes(@SReadError); TVarData(Result).VType := CustomType.VarType; VarStreamer.StreamIn(TVarData(Result), InnerStream); finally OuterReader.Free; end; finally InnerStream.Free; OuterStream.Free; end; end; const ValTypeToVarType: array [TValueType] of TVarType = (varError, // vaNull { set via NULL } varError, // vaList { NOT SUPPORTED } varByte, // vaInt8 varSmallInt, // vaInt16 varInteger, // vaInt32 varDouble, // vaExtended varError, // vaString { set via ReadString } varError, // vaIdent { NOT SUPPORTED } varBoolean, // vaFalse varBoolean, // vaTrue varError, // vaBinary { set via ReadCustomVariant } varError, // vaSet { NOT SUPPORTED } varError, // vaLString { set via ReadString } varError, // vaNil { set via initial clear } varError, // vaCollection { NOT SUPPORTED } varSingle, // vaSingle varCurrency, // vaCurrency varDate, // vaDate varError, // vaWString { set via ReadWideString } varInt64, // vaInt64 varError); // vaUTF8String { set via Read(Wide)String } var ValType: TValueType; begin VarClear(Result); ValType := NextValue; case ValType of vaNil, vaNull: if ReadValue <> vaNil then Result := NULL; vaInt8: TVarData(Result).VByte := Byte(ReadInteger); vaInt16: TVarData(Result).VSmallint := Smallint(ReadInteger); vaInt32: TVarData(Result).VInteger := ReadInteger; vaExtended: TVarData(Result).VDouble := ReadFloat; vaSingle: TVarData(Result).VSingle := ReadSingle; vaCurrency: TVarData(Result).VCurrency := ReadCurrency; vaDate: TVarData(Result).VDate := ReadDate; vaString, vaLString: Result := ReadString; vaWString: Result := ReadWideString; vaFalse, vaTrue: TVarData(Result).VBoolean := ReadValue = vaTrue; vaBinary: Result := ReadCustomVariant; vaInt64: TVarData(Result).VInt64 := ReadInt64; else raise EReadError.CreateRes(@SReadError); end; if ValTypeToVarType[ValType] <> varError then TVarData(Result).VType := ValTypeToVarType[ValType]; end; { TWriter } destructor TWriter.Destroy; begin WriteBuffer; inherited Destroy; end; procedure TWriter.AddAncestor(Component: TComponent); begin FAncestorList.Add(Component); end; procedure TWriter.DefineProperty(const Name: string; ReadData: TReaderProc; WriteData: TWriterProc; HasData: Boolean); begin if HasData and Assigned(WriteData) then begin WritePropName(Name); WriteData(Self); end; end; procedure TWriter.DefineBinaryProperty(const Name: string; ReadData, WriteData: TStreamProc; HasData: Boolean); begin if HasData and Assigned(WriteData) then begin WritePropName(Name); WriteBinary(WriteData); end; end; function TWriter.GetPosition: Longint; begin Result := FStream.Position + FBufPos; end; procedure TWriter.FlushBuffer; begin WriteBuffer; end; procedure TWriter.SetPosition(Value: Longint); var StreamPosition: Longint; begin StreamPosition := FStream.Position; { Only flush the buffer if the repostion is outside the buffer range } if (Value < StreamPosition) or (Value > StreamPosition + FBufPos) then begin WriteBuffer; FStream.Position := Value; end else FBufPos := Value - StreamPosition; end; procedure TWriter.SetRoot(Value: TComponent); begin inherited SetRoot(Value); FLookupRoot := Value; end; procedure TWriter.Write(const Buf; Count: Longint); assembler; asm PUSH ESI PUSH EDI PUSH EBX MOV ESI,EDX MOV EBX,ECX MOV EDI,EAX JMP @@6 @@1: MOV ECX,[EDI].TWriter.FBufSize SUB ECX,[EDI].TWriter.FBufPos JA @@2 MOV EAX,EDI CALL TWriter.WriteBuffer MOV ECX,[EDI].TWriter.FBufSize @@2: CMP ECX,EBX JB @@3 MOV ECX,EBX @@3: SUB EBX,ECX PUSH EDI MOV EAX,[EDI].TWriter.FBuffer ADD EAX,[EDI].TWriter.FBufPos ADD [EDI].TWriter.FBufPos,ECX @@5: MOV EDI,EAX MOV EDX,ECX SHR ECX,2 CLD REP MOVSD MOV ECX,EDX AND ECX,3 REP MOVSB POP EDI @@6: OR EBX,EBX JNE @@1 POP EBX POP EDI POP ESI end; procedure TWriter.WriteBinary(WriteData: TStreamProc); var Stream: TMemoryStream; Count: Longint; begin Stream := TMemoryStream.Create; try WriteData(Stream); WriteValue(vaBinary); Count := Stream.Size; Write(Count, SizeOf(Count)); Write(Stream.Memory^, Count); finally Stream.Free; end; end; procedure TWriter.WriteBuffer; begin FStream.WriteBuffer(FBuffer^, FBufPos); FBufPos := 0; end; procedure TWriter.WriteBoolean(Value: Boolean); begin if Value then WriteValue(vaTrue) else WriteValue(vaFalse); end; procedure TWriter.WriteChar(Value: Char); begin WriteString(Value); end; procedure TWriter.WriteCollection(Value: TCollection); var I: Integer; OldAncestor: TPersistent; begin OldAncestor := Ancestor; Ancestor := nil; try WriteValue(vaCollection); if Value <> nil then for I := 0 to Value.Count - 1 do begin WriteListBegin; WriteProperties(Value.Items[I]); WriteListEnd; end; WriteListEnd; finally Ancestor := OldAncestor; end; end; procedure TWriter.WriteComponent(Component: TComponent); function FindAncestor(const Name: string): TComponent; var I: Integer; begin for I := 0 to FAncestorList.Count - 1 do begin Result := FAncestorList[I]; if SameText(Result.Name, Name) then Exit; end; Result := nil; end; var OldAncestor: TPersistent; OldRootAncestor: TComponent; AncestorComponent: TComponent; begin OldAncestor := Ancestor; OldRootAncestor := RootAncestor; try Include(Component.FComponentState, csWriting); if Assigned(FAncestorList) then Ancestor := FindAncestor(Component.Name); if Assigned(FOnFindAncestor) and ((Ancestor = nil) or (Ancestor is TComponent)) then begin AncestorComponent := TComponent(Ancestor); FOnFindAncestor(Self, Component, Component.Name, AncestorComponent, FRootAncestor); Ancestor := AncestorComponent; end; Component.WriteState(Self); Exclude(Component.FComponentState, csWriting); finally Ancestor := OldAncestor; FRootAncestor := OldRootAncestor; end; end; procedure TWriter.WriteData(Instance: TComponent); var PreviousPosition, PropertiesPosition: Longint; OldAncestorList: TList; OldAncestorPos, OldChildPos: Integer; OldRoot, OldRootAncestor: TComponent; Flags: TFilerFlags; begin if FBufSize - FBufPos < Length(Instance.ClassName) + Length(Instance.Name) + 1+5+3 then WriteBuffer; { Prefix + vaInt + integer + 2 end lists } PreviousPosition := Position; Flags := []; if csInline in Instance.ComponentState then if (Ancestor <> nil) and (csAncestor in Instance.ComponentState) and (FAncestorList <> nil) then // If the AncestorList is not nil, this really came from an ancestor form Include(Flags, ffInherited) else // otherwise the Ancestor is the original frame Include(Flags, ffInline) else if Ancestor <> nil then Include(Flags, ffInherited); if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) and ((Ancestor = nil) or (FAncestorList[FAncestorPos] <> Ancestor)) then Include(Flags, ffChildPos); WritePrefix(Flags, FChildPos); if UseQualifiedNames then WriteStr(GetTypeData(PTypeInfo(Instance.ClassType.ClassInfo)).UnitName + '.' + Instance.ClassName) else WriteStr(Instance.ClassName); WriteStr(Instance.Name); PropertiesPosition := Position; if (FAncestorList <> nil) and (FAncestorPos < FAncestorList.Count) then begin if Ancestor <> nil then Inc(FAncestorPos); Inc(FChildPos); end; WriteProperties(Instance); WriteListEnd; OldAncestorList := FAncestorList; OldAncestorPos := FAncestorPos; OldChildPos := FChildPos; OldRoot := FRoot; OldRootAncestor := FRootAncestor; try FAncestorList := nil; FAncestorPos := 0; FChildPos := 0; if not IgnoreChildren then try if (FAncestor <> nil) and (FAncestor is TComponent) then begin if (FAncestor is TComponent) and (csInline in TComponent(FAncestor).ComponentState) then FRootAncestor := TComponent(FAncestor); FAncestorList := TList.Create; TComponent(FAncestor).GetChildren(AddAncestor, FRootAncestor); end; if csInline in Instance.ComponentState then FRoot := Instance; Instance.GetChildren(WriteComponent, FRoot); finally FAncestorList.Free; end; finally FAncestorList := OldAncestorList; FAncestorPos := OldAncestorPos; FChildPos := OldChildPos; FRoot := OldRoot; FRootAncestor := OldRootAncestor; end; WriteListEnd; if (Instance <> Root) and (Flags = [ffInherited]) and (Position = PropertiesPosition + (1 + 1)) then { (1 + 1) is two end lists } Position := PreviousPosition; end; procedure TWriter.WriteDescendent(Root: TComponent; AAncestor: TComponent); begin FRootAncestor := AAncestor; FAncestor := AAncestor; FRoot := Root; FLookupRoot := Root; WriteSignature; WriteComponent(Root); end; procedure TWriter.WriteFloat(const Value: Extended); begin WriteValue(vaExtended); Write(Value, SizeOf(Extended)); end; procedure TWriter.WriteSingle(const Value: Single); begin WriteValue(vaSingle); Write(Value, SizeOf(Single)); end; procedure TWriter.WriteCurrency(const Value: Currency); begin WriteValue(vaCurrency); Write(Value, SizeOf(Currency)); end; procedure TWriter.WriteDate(const Value: TDateTime); begin WriteValue(vaDate); Write(Value, SizeOf(TDateTime)); end; procedure TWriter.WriteIdent(const Ident: string); begin if SameText(Ident, 'False') then WriteValue(vaFalse) else if SameText(Ident ,'True') then WriteValue(vaTrue) else if SameText(Ident ,'Null') then WriteValue(vaNull) else if SameText(Ident, 'nil') then WriteValue(vaNil) else begin WriteValue(vaIdent); WriteStr(Ident); end; end; procedure TWriter.WriteInteger(Value: Longint); begin if (Value >= Low(ShortInt)) and (Value <= High(ShortInt)) then begin WriteValue(vaInt8); Write(Value, SizeOf(Shortint)); end else if (Value >= Low(SmallInt)) and (Value <= High(SmallInt)) then begin WriteValue(vaInt16); Write(Value, SizeOf(Smallint)); end else begin WriteValue(vaInt32); Write(Value, SizeOf(Integer)); end; end; procedure TWriter.WriteInteger(Value: Int64); begin if (Value >= Low(Integer)) and (Value <= High(Integer)) then WriteInteger(Longint(Value)) else begin WriteValue(vaInt64); Write(Value, Sizeof(Int64)); end; end; procedure TWriter.WriteListBegin; begin WriteValue(vaList); end; procedure TWriter.WriteListEnd; begin WriteValue(vaNull); end; procedure TWriter.WritePrefix(Flags: TFilerFlags; AChildPos: Integer); var Prefix: Byte; begin if Flags <> [] then begin Prefix := $F0 or Byte(Flags); Write(Prefix, SizeOf(Prefix)); if ffChildPos in Flags then WriteInteger(AChildPos); end; end; procedure TWriter.WriteProperties(Instance: TPersistent); var I, Count: Integer; PropInfo: PPropInfo; PropList: PPropList; begin Count := GetTypeData(Instance.ClassInfo)^.PropCount; if Count > 0 then begin GetMem(PropList, Count * SizeOf(Pointer)); try GetPropInfos(Instance.ClassInfo, PropList); for I := 0 to Count - 1 do begin PropInfo := PropList^[I]; if PropInfo = nil then break; if IsStoredProp(Instance, PropInfo) then WriteProperty(Instance, PropInfo); end; finally FreeMem(PropList, Count * SizeOf(Pointer)); end; end; Instance.DefineProperties(Self); end; procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: PPropInfo); var PropType: PTypeInfo; function AncestorValid: Boolean; begin Result := (Ancestor <> nil) and (RootAncestor <> nil) and Root.InheritsFrom(RootAncestor.ClassType); end; procedure WritePropPath; begin WritePropName(PPropInfo(PropInfo)^.Name); end; procedure WriteSet(Value: Longint); var I: Integer; BaseType: PTypeInfo; begin BaseType := GetTypeData(PropType)^.CompType^; WriteValue(vaSet); for I := 0 to SizeOf(TIntegerSet) * 8 - 1 do if I in TIntegerSet(Value) then WriteStr(GetEnumName(BaseType, I)); WriteStr(''); end; procedure WriteIntProp(IntType: PTypeInfo; Value: Longint); var Ident: string; IntToIdent: TIntToIdent; begin IntToIdent := FindIntToIdent(IntType); if Assigned(IntToIdent) and IntToIdent(Value, Ident) then WriteIdent(Ident) else WriteInteger(Value); end; procedure WriteCollectionProp(Collection: TCollection); var SavePropPath: string; begin WritePropPath; SavePropPath := FPropPath; try FPropPath := ''; WriteCollection(Collection); finally FPropPath := SavePropPath; end; end; procedure WriteOrdProp; var Value: Longint; function IsDefaultValue: Boolean; var Default: LongInt; begin if AncestorValid then Result := Value = GetOrdProp(Ancestor, PropInfo) else begin Default := PPropInfo(PropInfo)^.Default; Result := (Default <> LongInt($80000000)) and (Value = Default); end; end; begin Value := GetOrdProp(Instance, PropInfo); if not IsDefaultValue then begin WritePropPath; case PropType^.Kind of tkInteger: WriteIntProp(PPropInfo(PropInfo)^.PropType^, Value); tkChar: WriteChar(Chr(Value)); tkSet: WriteSet(Value); tkEnumeration: WriteIdent(GetEnumName(PropType, Value)); end; end; end; procedure WriteFloatProp; var Value: Extended; function IsDefaultValue: Boolean; begin if AncestorValid then Result := Value = GetFloatProp(Ancestor, PropInfo) else Result := Value = 0; end; begin Value := GetFloatProp(Instance, PropInfo); if not IsDefaultValue then begin WritePropPath; WriteFloat(Value); end; end; procedure WriteInt64Prop; var Value: Int64; function IsDefaultValue: Boolean; begin if AncestorValid then Result := Value = GetInt64Prop(Ancestor, PropInfo) else Result := Value = 0; end; begin Value := GetInt64Prop(Instance, PropInfo); if not IsDefaultValue then begin WritePropPath; WriteInteger(Value); end; end; procedure WriteStrProp; var Value: WideString; function IsDefault: Boolean; begin if AncestorValid then Result := Value = GetWideStrProp(Ancestor, PropInfo) else Result := Value = ''; end; begin Value := GetWideStrProp(Instance, PropInfo); if not IsDefault then begin WritePropPath; WriteWideString(Value); end; end; function OwnedBy(Component, Owner: TComponent): Boolean; begin Result := True; while Component <> nil do if Component = Owner then Exit else Component := Component.Owner; Result := False; end; function GetComponentValue(Component: TComponent): string; begin if Component.Owner = LookupRoot then Result := Component.Name else if Component = LookupRoot then Result := 'Owner' { Do not translate } else if (Component.Owner <> nil) and (Component.Owner.Name <> '') and (Component.Name <> '') then if OwnedBy(Component.Owner, LookupRoot) then Result := GetComponentValue(Component.Owner) + '.' + Component.Name else Result := Component.Owner.Name + '.' + Component.Name else if Component.Name <> '' then Result := Component.Name + '.Owner' { Do not translate } else Result := ''; end; function ObjectAncestorMatch(AncestorValue, Value: TComponent): Boolean; begin Result := (AncestorValue <> nil) and (AncestorValue.Owner = FRootAncestor) and (Value <> nil) and (Value.Owner = Root) and SameText(AncestorValue.Name, Value.Name); end; procedure WriteObjectProp; var Value: TObject; OldAncestor: TPersistent; SavePropPath, ComponentValue: string; function IsDefault: Boolean; var AncestorValue: TObject; begin AncestorValue := nil; if AncestorValid then begin AncestorValue := TObject(GetOrdProp(Ancestor, PropInfo)); if ObjectAncestorMatch(TComponent(AncestorValue), TComponent(Value)) then AncestorValue := Value; end; Result := Value = AncestorValue; end; begin Value := TObject(GetOrdProp(Instance, PropInfo)); if (Value = nil) and not IsDefault then begin WritePropPath; WriteValue(vaNil); end else if Value is TPersistent then if (Value is TComponent) and not (csSubComponent in TComponent(Value).ComponentStyle) then begin if not IsDefault then begin ComponentValue := GetComponentValue(TComponent(Value)); if ComponentValue <> '' then begin WritePropPath; WriteIdent(ComponentValue); end end end else begin OldAncestor := Ancestor; SavePropPath := FPropPath; try FPropPath := FPropPath + PropInfo^.Name + '.'; if AncestorValid then Ancestor := TPersistent(GetOrdProp(Ancestor, PropInfo)); WriteProperties(TPersistent(Value)); finally Ancestor := OldAncestor; FPropPath := SavePropPath; end; if Value is TCollection then begin if not AncestorValid or not CollectionsEqual(TCollection(Value), TCollection(GetOrdProp(Ancestor, PropInfo)), FLookupRoot, FRootAncestor) then WriteCollectionProp(TCollection(Value)); end; end; end; procedure WriteInterfaceProp; var Intf: IInterface; Value: TComponent; function IsDefaultValue: Boolean; var AncestorIntf: IInterface; ASR: IInterfaceComponentReference; begin Result := Intf = nil; if AncestorValid then begin AncestorIntf := GetInterfaceProp(Ancestor, PropInfo); Result := Intf = AncestorIntf; if not Result then begin if Supports(AncestorIntf, IInterfaceComponentReference, ASR) then Result := ObjectAncestorMatch(ASR.GetComponent, Value); end; end; end; var SR: IInterfaceComponentReference; RefStr: String; begin Intf := GetInterfaceProp(Instance, PropInfo); if (Intf = nil) or (not Supports(Intf, IInterfaceComponentReference, SR)) then begin if AncestorValid and (GetInterfaceProp(Ancestor, PropInfo) <> nil) then begin WritePropPath; WriteValue(vaNil); end; Exit; end; Value := SR.GetComponent; if not IsDefaultValue then begin RefStr := GetComponentValue(Value); if RefStr <> '' then begin WritePropPath; WriteIdent(RefStr); end; end; end; procedure WriteMethodProp; var Value: TMethod; function IsDefaultValue: Boolean; var DefaultCode: Pointer; begin DefaultCode := nil; if AncestorValid then DefaultCode := GetMethodProp(Ancestor, PropInfo).Code; Result := (Value.Code = DefaultCode) or ((Value.Code <> nil) and (FLookupRoot.MethodName(Value.Code) = '')); end; begin Value := GetMethodProp(Instance, PropInfo); if not IsDefaultValue then begin WritePropPath; if Value.Code = nil then WriteValue(vaNil) else WriteIdent(FLookupRoot.MethodName(Value.Code)); end; end; procedure WriteVariantProp; var Value: Variant; function IsDefaultValue: Boolean; begin if AncestorValid then Result := VarSameValue(Value, GetVariantProp(Ancestor, PropInfo)) else Result := VarIsClear(Value); end; begin Value := GetVariantProp(Instance, PropInfo); if not IsDefaultValue then begin WritePropPath; WriteVariant(Value); end; end; begin if (PropInfo^.GetProc <> nil) and ((PropInfo^.SetProc <> nil) or ((PropInfo^.PropType^.Kind = tkClass) and (TObject(GetOrdProp(Instance, PropInfo)) is TComponent) and (csSubComponent in TComponent(GetOrdProp(Instance, PropInfo)).ComponentStyle))) then begin PropType := PropInfo^.PropType^; case PropType^.Kind of tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp; tkFloat: WriteFloatProp; tkString, tkLString, tkWString: WriteStrProp; tkClass: WriteObjectProp; tkMethod: WriteMethodProp; tkVariant: WriteVariantProp; tkInt64: WriteInt64Prop; tkInterface: WriteInterfaceProp; end; end; end; procedure TWriter.WriteVariant(const Value: Variant); var CustomType: TCustomVariantType; OuterStream, InnerStream: TMemoryStream; OuterWriter: TWriter; StreamSize: Integer; VarStreamer: IVarStreamable; LInt64: Int64; begin if VarIsArray(Value) then raise EWriteError.CreateRes(@SWriteError); case VarType(Value) and varTypeMask of varEmpty: WriteValue(vaNil); varNull: WriteValue(vaNull); varOleStr: WriteWideString(Value); varString: WriteString(Value); varByte, varShortInt, varWord, varSmallInt, varInteger: WriteInteger(Value); varSingle: WriteSingle(Value); varDouble: WriteFloat(Value); varCurrency: WriteCurrency(Value); varDate: WriteDate(Value); varBoolean: if Value then WriteValue(vaTrue) else WriteValue(vaFalse); varLongWord, varInt64: begin LInt64 := Value; WriteInteger(LInt64); end; else try if not FindCustomVariantType(TVarData(Value).VType, CustomType) or not Supports(Value, IVarStreamable, VarStreamer) then WriteString(Value) else begin OuterStream := TMemoryStream.Create; InnerStream := TMemoryStream.Create; try OuterWriter := TWriter.Create(OuterStream, 1024); try VarStreamer.StreamOut(TVarData(Value), InnerStream); StreamSize := InnerStream.Size; OuterWriter.WriteString(CustomType.ClassName); OuterWriter.Write(StreamSize, SizeOf(StreamSize)); OuterWriter.Write(InnerStream.Memory^, StreamSize); finally OuterWriter.Free; end; StreamSize := OuterStream.Size; WriteValue(vaBinary); Write(StreamSize, SizeOf(StreamSize)); Write(OuterStream.Memory^, StreamSize); finally InnerStream.Free; OuterStream.Free; end; end; except raise EWriteError.CreateRes(@SWriteError); end; end; end; procedure TWriter.WritePropName(const PropName: string); begin WriteStr(FPropPath + PropName); end; procedure TWriter.WriteRootComponent(Root: TComponent); begin WriteDescendent(Root, nil); end; procedure TWriter.WriteSignature; begin Write(FilerSignature, SizeOf(FilerSignature)); end; procedure TWriter.WriteStr(const Value: string); var L: Integer; begin L := Length(Value); if L > 255 then L := 255; Write(L, SizeOf(Byte)); Write(Value[1], L); end; procedure TWriter.WriteMinStr(const LocaleStr: string; const UTF8Str: UTF8String); var L: Integer; begin if LocaleStr <> UTF8Str then begin L := Length(UTF8Str); WriteValue(vaUtf8String); Write(L, SizeOf(Integer)); Write(Pointer(UTF8Str)^, L); end else begin L := Length(LocaleStr); if L <= 255 then begin WriteValue(vaString); Write(L, SizeOf(Byte)); end else begin WriteValue(vaLString); Write(L, SizeOf(Integer)); end; Write(Pointer(LocaleStr)^, L); end; end; procedure TWriter.WriteString(const Value: string); begin WriteMinStr(Value, AnsiToUtf8(Value)); end; procedure TWriter.WriteWideString(const Value: WideString); var L: Integer; Utf8Str: UTF8String; begin Utf8Str := Utf8Encode(Value); if Length(Utf8Str) < (Length(Value) * SizeOf(WideChar)) then WriteMinStr(Value, Utf8Str) else begin WriteValue(vaWString); L := Length(Value); Write(L, SizeOf(Integer)); Write(Pointer(Value)^, L * 2); end; end; procedure TWriter.WriteValue(Value: TValueType); begin Write(Value, SizeOf(Value)); end; { TParser } const ParseBufSize = 4096; procedure BinToHex(Buffer, Text: PChar; BufSize: Integer); assembler; const Convert: array[0..15] of Char = '0123456789ABCDEF'; var I: Integer; begin for I := 0 to BufSize - 1 do begin Text[0] := Convert[Byte(Buffer[I]) shr 4]; Text[1] := Convert[Byte(Buffer[I]) and $F]; Inc(Text, 2); end; end; {asm PUSH ESI PUSH EDI MOV ESI,EAX MOV EDI,EDX MOV EDX,0 JMP @@1 @@0: DB '0123456789ABCDEF' @@1: LODSB MOV DL,AL AND DL,0FH MOV AH,@@0.Byte[EDX] MOV DL,AL SHR DL,4 MOV AL,@@0.Byte[EDX] STOSW DEC ECX JNE @@1 POP EDI POP ESI end;} function HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer; assembler; const Convert: array['0'..'f'] of SmallInt = ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1, -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1, -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, -1,10,11,12,13,14,15); var I: Integer; begin I := BufSize; while I > 0 do begin if not (Text[0] in ['0'..'f']) or not (Text[1] in ['0'..'f']) then Break; Buffer[0] := Char((Convert[Text[0]] shl 4) + Convert[Text[1]]); Inc(Buffer); Inc(Text, 2); Dec(I); end; Result := BufSize - I; end; {asm PUSH ESI PUSH EDI PUSH EBX MOV ESI,EAX MOV EDI,EDX MOV EBX,EDX MOV EDX,0 JMP @@1 @@0: DB 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1 DB -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1 DB -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1 DB -1,10,11,12,13,14,15 @@1: LODSW CMP AL,'0' JB @@2 CMP AL,'f' JA @@2 MOV DL,AL MOV AL,@@0.Byte[EDX-'0'] CMP AL,-1 JE @@2 SHL AL,4 CMP AH,'0' JB @@2 CMP AH,'f' JA @@2 MOV DL,AH MOV AH,@@0.Byte[EDX-'0'] CMP AH,-1 JE @@2 OR AL,AH STOSB DEC ECX JNE @@1 @@2: MOV EAX,EDI SUB EAX,EBX POP EBX POP EDI POP ESI end;} constructor TParser.Create(Stream: TStream); begin FStream := Stream; GetMem(FBuffer, ParseBufSize); FBuffer[0] := #0; FBufPtr := FBuffer; FBufEnd := FBuffer + ParseBufSize; FSourcePtr := FBuffer; FSourceEnd := FBuffer; FTokenPtr := FBuffer; FSourceLine := 1; NextToken; end; destructor TParser.Destroy; begin if FBuffer <> nil then begin FStream.Seek(Longint(FTokenPtr) - Longint(FBufPtr), 1); FreeMem(FBuffer, ParseBufSize); end; end; procedure TParser.CheckToken(T: Char); begin if Token <> T then case T of toSymbol: Error(SIdentifierExpected); toString, toWString: Error(SStringExpected); toInteger, toFloat: Error(SNumberExpected); else ErrorFmt(SCharExpected, [T]); end; end; procedure TParser.CheckTokenSymbol(const S: string); begin if not TokenSymbolIs(S) then ErrorFmt(SSymbolExpected, [S]); end; procedure TParser.Error(const Ident: string); begin ErrorStr(Ident); end; procedure TParser.ErrorFmt(const Ident: string; const Args: array of const); begin ErrorStr(Format(Ident, Args)); end; procedure TParser.ErrorStr(const Message: string); begin raise EParserError.CreateResFmt(@SParseError, [Message, FSourceLine]); end; procedure TParser.HexToBinary(Stream: TStream); var Count: Integer; Buffer: array[0..255] of Char; begin SkipBlanks; while FSourcePtr^ <> '}' do begin Count := HexToBin(FSourcePtr, Buffer, SizeOf(Buffer)); if Count = 0 then Error(SInvalidBinary); Stream.Write(Buffer, Count); Inc(FSourcePtr, Count * 2); SkipBlanks; end; NextToken; end; function TParser.NextToken: Char; var I, J: Integer; IsWideStr: Boolean; P, S: PChar; begin SkipBlanks; P := FSourcePtr; FTokenPtr := P; case P^ of 'A'..'Z', 'a'..'z', '_': begin Inc(P); while P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_'] do Inc(P); Result := toSymbol; end; '#', '''': begin IsWideStr := False; J := 0; S := P; while True do case P^ of '#': begin Inc(P); I := 0; while P^ in ['0'..'9'] do begin I := I * 10 + (Ord(P^) - Ord('0')); Inc(P); end; if (I > 127) then IsWideStr := True; Inc(J); end; '''': begin Inc(P); while True do begin case P^ of #0, #10, #13: Error(SInvalidString); '''': begin Inc(P); if P^ <> '''' then Break; end; end; Inc(J); Inc(P); end; end; else Break; end; P := S; if IsWideStr then SetLength(FWideStr, J); J := 1; while True do case P^ of '#': begin Inc(P); I := 0; while P^ in ['0'..'9'] do begin I := I * 10 + (Ord(P^) - Ord('0')); Inc(P); end; if IsWideStr then begin FWideStr[J] := WideChar(SmallInt(I)); Inc(J); end else begin S^ := Chr(I); Inc(S); end; end; '''': begin Inc(P); while True do begin case P^ of #0, #10, #13: Error(SInvalidString); '''': begin Inc(P); if P^ <> '''' then Break; end; end; if IsWideStr then begin FWideStr[J] := WideChar(P^); Inc(J); end else begin S^ := P^; Inc(S); end; Inc(P); end; end; else Break; end; FStringPtr := S; if IsWideStr then Result := toWString else Result := toString; end; '$': begin Inc(P); while P^ in ['0'..'9', 'A'..'F', 'a'..'f'] do Inc(P); Result := toInteger; end; '-', '0'..'9': begin Inc(P); while P^ in ['0'..'9'] do Inc(P); Result := toInteger; while P^ in ['0'..'9', '.', 'e', 'E', '+', '-'] do begin Inc(P); Result := toFloat; end; if (P^ in ['c', 'C', 'd', 'D', 's', 'S']) then begin Result := toFloat; FFloatType := P^; Inc(P); end else FFloatType := #0; end; else Result := P^; if Result <> toEOF then Inc(P); end; FSourcePtr := P; FToken := Result; end; procedure TParser.ReadBuffer; var Count: Integer; begin Inc(FOrigin, FSourcePtr - FBuffer); FSourceEnd[0] := FSaveChar; Count := FBufPtr - FSourcePtr; if Count <> 0 then Move(FSourcePtr[0], FBuffer[0], Count); FBufPtr := FBuffer + Count; Inc(FBufPtr, FStream.Read(FBufPtr[0], FBufEnd - FBufPtr)); FSourcePtr := FBuffer; FSourceEnd := FBufPtr; if FSourceEnd = FBufEnd then begin FSourceEnd := LineStart(FBuffer, FSourceEnd - 1); if FSourceEnd = FBuffer then Error(SLineTooLong); end; FSaveChar := FSourceEnd[0]; FSourceEnd[0] := #0; end; procedure TParser.SkipBlanks; begin while True do begin case FSourcePtr^ of #0: begin ReadBuffer; if FSourcePtr^ = #0 then Exit; Continue; end; #10: Inc(FSourceLine); #33..#255: Exit; end; Inc(FSourcePtr); end; end; function TParser.SourcePos: Longint; begin Result := FOrigin + (FTokenPtr - FBuffer); end; function TParser.TokenFloat: Extended; begin if FFloatType <> #0 then Dec(FSourcePtr); Result := StrToFloat(TokenString); if FFloatType <> #0 then Inc(FSourcePtr); end; function TParser.TokenInt: Int64; begin Result := StrToInt64(TokenString); end; function TParser.TokenString: string; var L: Integer; begin if FToken = toString then L := FStringPtr - FTokenPtr else L := FSourcePtr - FTokenPtr; SetString(Result, FTokenPtr, L); end; function TParser.TokenWideString: WideString; begin if FToken = toString then Result := TokenString else Result := FWideStr; end; function TParser.TokenSymbolIs(const S: string): Boolean; begin Result := (Token = toSymbol) and SameText(S, TokenString); end; function TParser.TokenComponentIdent: string; var P: PChar; begin CheckToken(toSymbol); P := FSourcePtr; while P^ = '.' do begin Inc(P); if not (P^ in ['A'..'Z', 'a'..'z', '_']) then Error(SIdentifierExpected); repeat Inc(P) until not (P^ in ['A'..'Z', 'a'..'z', '0'..'9', '_']); end; FSourcePtr := P; Result := TokenString; end; { Binary to text conversion } procedure ObjectBinaryToText(Input, Output: TStream); var NestingLevel: Integer; SaveSeparator: Char; Reader: TReader; Writer: TWriter; ObjectName, PropName: string; procedure WriteIndent; const Blanks: array[0..1] of Char = ' '; var I: Integer; begin for I := 1 to NestingLevel do Writer.Write(Blanks, SizeOf(Blanks)); end; procedure WriteStr(const S: string); begin Writer.Write(S[1], Length(S)); end; procedure NewLine; begin WriteStr(sLineBreak); WriteIndent; end; procedure ConvertValue; forward; procedure ConvertHeader; var ClassName: string; Flags: TFilerFlags; Position: Integer; begin Reader.ReadPrefix(Flags, Position); ClassName := Reader.ReadStr; ObjectName := Reader.ReadStr; WriteIndent; if ffInherited in Flags then WriteStr('inherited ') else if ffInline in Flags then WriteStr('inline ') else WriteStr('object '); if ObjectName <> '' then begin WriteStr(ObjectName); WriteStr(': '); end; WriteStr(ClassName); if ffChildPos in Flags then begin WriteStr(' ['); WriteStr(IntToStr(Position)); WriteStr(']'); end; if ObjectName = '' then ObjectName := ClassName; // save for error reporting WriteStr(sLineBreak); end; procedure ConvertBinary; const BytesPerLine = 32; var MultiLine: Boolean; I: Integer; Count: Longint; Buffer: array[0..BytesPerLine - 1] of Char; Text: array[0..BytesPerLine * 2 - 1] of Char; begin Reader.ReadValue; WriteStr('{'); Inc(NestingLevel); Reader.Read(Count, SizeOf(Count)); MultiLine := Count >= BytesPerLine; while Count > 0 do begin if MultiLine then NewLine; if Count >= 32 then I := 32 else I := Count; Reader.Read(Buffer, I); BinToHex(Buffer, Text, I); Writer.Write(Text, I * 2); Dec(Count, I); end; Dec(NestingLevel); WriteStr('}'); end; procedure ConvertProperty; forward; procedure ConvertValue; const LineLength = 64; var I, J, K, L: Integer; S: string; W: WideString; LineBreak: Boolean; begin case Reader.NextValue of vaList: begin Reader.ReadValue; WriteStr('('); Inc(NestingLevel); while not Reader.EndOfList do begin NewLine; ConvertValue; end; Reader.ReadListEnd; Dec(NestingLevel); WriteStr(')'); end; vaInt8, vaInt16, vaInt32: WriteStr(IntToStr(Reader.ReadInteger)); vaExtended: WriteStr(FloatToStr(Reader.ReadFloat)); vaSingle: WriteStr(FloatToStr(Reader.ReadSingle) + 's'); vaCurrency: WriteStr(FloatToStr(Reader.ReadCurrency * 10000) + 'c'); vaDate: WriteStr(FloatToStr(Reader.ReadDate) + 'd'); vaWString, vaUTF8String: begin W := Reader.ReadWideString; L := Length(W); if L = 0 then WriteStr('''''') else begin I := 1; Inc(NestingLevel); try if L > LineLength then NewLine; K := I; repeat LineBreak := False; if (W[I] >= ' ') and (W[I] <> '''') and (Ord(W[i]) <= 127) then begin J := I; repeat Inc(I) until (I > L) or (W[I] < ' ') or (W[I] = '''') or ((I - K) >= LineLength) or (Ord(W[i]) > 127); if ((I - K) >= LineLength) then LineBreak := True; WriteStr(''''); while J < I do begin WriteStr(Char(W[J])); Inc(J); end; WriteStr(''''); end else begin WriteStr('#'); WriteStr(IntToStr(Ord(W[I]))); Inc(I); if ((I - K) >= LineLength) then LineBreak := True; end; if LineBreak and (I <= L) then begin WriteStr(' +'); NewLine; K := I; end; until I > L; finally Dec(NestingLevel); end; end; end; vaString, vaLString: begin S := Reader.ReadString; L := Length(S); if L = 0 then WriteStr('''''') else begin I := 1; Inc(NestingLevel); try if L > LineLength then NewLine; K := I; repeat LineBreak := False; if (S[I] >= ' ') and (S[I] <> '''') then begin J := I; repeat Inc(I) until (I > L) or (S[I] < ' ') or (S[I] = '''') or ((I - K) >= LineLength); if ((I - K) >= LineLength) then begin LIneBreak := True; if ByteType(S, I) = mbTrailByte then Dec(I); end; WriteStr(''''); Writer.Write(S[J], I - J); WriteStr(''''); end else begin WriteStr('#'); WriteStr(IntToStr(Ord(S[I]))); Inc(I); if ((I - K) >= LineLength) then LineBreak := True; end; if LineBreak and (I <= L) then begin WriteStr(' +'); NewLine; K := I; end; until I > L; finally Dec(NestingLevel); end; end; end; vaIdent, vaFalse, vaTrue, vaNil, vaNull: WriteStr(Reader.ReadIdent); vaBinary: ConvertBinary; vaSet: begin Reader.ReadValue; WriteStr('['); I := 0; while True do begin S := Reader.ReadStr; if S = '' then Break; if I > 0 then WriteStr(', '); WriteStr(S); Inc(I); end; WriteStr(']'); end; vaCollection: begin Reader.ReadValue; WriteStr('<'); Inc(NestingLevel); while not Reader.EndOfList do begin NewLine; WriteStr('item'); if Reader.NextValue in [vaInt8, vaInt16, vaInt32] then begin WriteStr(' ['); ConvertValue; WriteStr(']'); end; WriteStr(sLineBreak); Reader.CheckValue(vaList); Inc(NestingLevel); while not Reader.EndOfList do ConvertProperty; Reader.ReadListEnd; Dec(NestingLevel); WriteIndent; WriteStr('end'); end; Reader.ReadListEnd; Dec(NestingLevel); WriteStr('>'); end; vaInt64: WriteStr(IntToStr(Reader.ReadInt64)); else raise EReadError.CreateResFmt(@sPropertyException, [ObjectName, DotSep, PropName, Ord(Reader.NextValue)]); end; end; procedure ConvertProperty; begin WriteIndent; PropName := Reader.ReadStr; // save for error reporting WriteStr(PropName); WriteStr(' = '); ConvertValue; WriteStr(sLineBreak); end; procedure ConvertObject; begin ConvertHeader; Inc(NestingLevel); while not Reader.EndOfList do ConvertProperty; Reader.ReadListEnd; while not Reader.EndOfList do ConvertObject; Reader.ReadListEnd; Dec(NestingLevel); WriteIndent; WriteStr('end' + sLineBreak); end; begin NestingLevel := 0; Reader := TReader.Create(Input, 4096); SaveSeparator := DecimalSeparator; DecimalSeparator := '.'; try Writer := TWriter.Create(Output, 4096); try Reader.ReadSignature; ConvertObject; finally Writer.Free; end; finally DecimalSeparator := SaveSeparator; Reader.Free; end; end; type TObjectTextConvertProc = procedure (Input, Output: TStream); procedure InternalBinaryToText(Input, Output: TStream; var OriginalFormat: TStreamOriginalFormat; ConvertProc: TObjectTextConvertProc; BinarySignature: Integer; SignatureLength: Byte); var Pos: Integer; Signature: Integer; begin Pos := Input.Position; Signature := 0; if SignatureLength > sizeof(Signature) then SignatureLength := sizeof(Signature); Input.Read(Signature, SignatureLength); Input.Position := Pos; if Signature = BinarySignature then begin // definitely binary format if OriginalFormat = sofBinary then Output.CopyFrom(Input, Input.Size - Input.Position) else begin if OriginalFormat = sofUnknown then Originalformat := sofBinary; ConvertProc(Input, Output); end; end else // might be text format begin if OriginalFormat = sofBinary then ConvertProc(Input, Output) else begin if OriginalFormat = sofUnknown then begin // text format may begin with "object", "inherited", or whitespace if Char(Signature) in ['o','O','i','I',' ',#13,#11,#9] then OriginalFormat := sofText else // not binary, not text... let it raise the exception begin ConvertProc(Input, Output); Exit; end; end; if OriginalFormat = sofText then Output.CopyFrom(Input, Input.Size - Input.Position); end; end; end; procedure InternalTextToBinary(Input, Output: TStream; var OriginalFormat: TStreamOriginalFormat; ConvertProc: TObjectTextConvertProc; BinarySignature: Integer; SignatureLength: Byte); var Pos: Integer; Signature: Integer; begin Pos := Input.Position; Signature := 0; if SignatureLength > sizeof(Signature) then SignatureLength := sizeof(Signature); Input.Read(Signature, SignatureLength); Input.Position := Pos; if Signature = BinarySignature then begin // definitely binary format if OriginalFormat = sofUnknown then Originalformat := sofBinary; if OriginalFormat = sofBinary then Output.CopyFrom(Input, Input.Size - Input.Position) else // let it raise the exception ConvertProc(Input, Output); end else // might be text format begin case OriginalFormat of sofUnknown: begin // text format may begin with "object", "inherited", or whitespace if Char(Signature) in ['o','O','i','I',' ',#13,#11,#9] then OriginalFormat := sofText; // if its not binary, not text... let it raise the exception ConvertProc(Input, Output); end; sofBinary: ConvertProc(Input, Output); sofText: Output.CopyFrom(Input, Input.Size - Input.Position); end; end; end; procedure ObjectBinaryToText(Input, Output: TStream; var OriginalFormat: TStreamOriginalFormat); begin InternalBinaryToText(Input, Output, OriginalFormat, ObjectBinaryToText, Integer(FilerSignature), sizeof(Integer)); end; { Text to binary conversion } procedure ObjectTextToBinary(Input, Output: TStream); var SaveSeparator: Char; Parser: TParser; Writer: TWriter; function ConvertOrderModifier: Integer; begin Result := -1; if Parser.Token = '[' then begin Parser.NextToken; Parser.CheckToken(toInteger); Result := Parser.TokenInt; Parser.NextToken; Parser.CheckToken(']'); Parser.NextToken; end; end; procedure ConvertHeader(IsInherited, IsInline: Boolean); var ClassName, ObjectName: string; Flags: TFilerFlags; Position: Integer; begin Parser.CheckToken(toSymbol); ClassName := Parser.TokenString; ObjectName := ''; if Parser.NextToken = ':' then begin Parser.NextToken; Parser.CheckToken(toSymbol); ObjectName := ClassName; ClassName := Parser.TokenString; Parser.NextToken; end; Flags := []; Position := ConvertOrderModifier; if IsInherited then Include(Flags, ffInherited); if IsInline then Include(Flags, ffInline); if Position >= 0 then Include(Flags, ffChildPos); Writer.WritePrefix(Flags, Position); Writer.WriteStr(ClassName); Writer.WriteStr(ObjectName); end; procedure ConvertProperty; forward; procedure ConvertValue; var Order: Integer; function CombineWideString: WideString; begin Result := Parser.TokenWideString; while Parser.NextToken = '+' do begin Parser.NextToken; if not (Parser.Token in [toString, toWString]) then Parser.CheckToken(toString); Result := Result + Parser.TokenWideString; end; end; begin if Parser.Token in [toString, toWString] then Writer.WriteWideString(CombineWideString) else begin case Parser.Token of toSymbol: Writer.WriteIdent(Parser.TokenComponentIdent); toInteger: Writer.WriteInteger(Parser.TokenInt); toFloat: begin case Parser.FloatType of 's', 'S': Writer.WriteSingle(Parser.TokenFloat); 'c', 'C': Writer.WriteCurrency(Parser.TokenFloat / 10000); 'd', 'D': Writer.WriteDate(Parser.TokenFloat); else Writer.WriteFloat(Parser.TokenFloat); end; end; '[': begin Parser.NextToken; Writer.WriteValue(vaSet); if Parser.Token <> ']' then while True do begin if Parser.Token <> toInteger then Parser.CheckToken(toSymbol); Writer.WriteStr(Parser.TokenString); if Parser.NextToken = ']' then Break; Parser.CheckToken(','); Parser.NextToken; end; Writer.WriteStr(''); end; '(': begin Parser.NextToken; Writer.WriteListBegin; while Parser.Token <> ')' do ConvertValue; Writer.WriteListEnd; end; '{': Writer.WriteBinary(Parser.HexToBinary); '<': begin Parser.NextToken; Writer.WriteValue(vaCollection); while Parser.Token <> '>' do begin Parser.CheckTokenSymbol('item'); Parser.NextToken; Order := ConvertOrderModifier; if Order <> -1 then Writer.WriteInteger(Order); Writer.WriteListBegin; while not Parser.TokenSymbolIs('end') do ConvertProperty; Writer.WriteListEnd; Parser.NextToken; end; Writer.WriteListEnd; end; else Parser.Error(SInvalidProperty); end; Parser.NextToken; end; end; procedure ConvertProperty; var PropName: string; begin Parser.CheckToken(toSymbol); PropName := Parser.TokenString; Parser.NextToken; while Parser.Token = '.' do begin Parser.NextToken; Parser.CheckToken(toSymbol); PropName := PropName + '.' + Parser.TokenString; Parser.NextToken; end; Writer.WriteStr(PropName); Parser.CheckToken('='); Parser.NextToken; ConvertValue; end; procedure ConvertObject; var InheritedObject: Boolean; InlineObject: Boolean; begin InheritedObject := False; InlineObject := False; if Parser.TokenSymbolIs('INHERITED') then InheritedObject := True else if Parser.TokenSymbolIs('INLINE') then InlineObject := True else Parser.CheckTokenSymbol('OBJECT'); Parser.NextToken; ConvertHeader(InheritedObject, InlineObject); while not Parser.TokenSymbolIs('END') and not Parser.TokenSymbolIs('OBJECT') and not Parser.TokenSymbolIs('INHERITED') and not Parser.TokenSymbolIs('INLINE') do ConvertProperty; Writer.WriteListEnd; while not Parser.TokenSymbolIs('END') do ConvertObject; Writer.WriteListEnd; Parser.NextToken; end; begin Parser := TParser.Create(Input); SaveSeparator := DecimalSeparator; DecimalSeparator := '.'; try Writer := TWriter.Create(Output, 4096); try Writer.WriteSignature; ConvertObject; finally Writer.Free; end; finally DecimalSeparator := SaveSeparator; Parser.Free; end; end; procedure ObjectTextToBinary(Input, Output: TStream; var OriginalFormat: TStreamOriginalFormat); begin InternalTextToBinary(Input, Output, OriginalFormat, ObjectTextToBinary, Integer(FilerSignature), sizeof(Integer)); end; { Resource to text conversion } procedure ObjectResourceToText(Input, Output: TStream); begin Input.ReadResHeader; ObjectBinaryToText(Input, Output); end; procedure ObjectResourceToText(Input, Output: TStream; var OriginalFormat: TStreamOriginalFormat); begin InternalBinaryToText(Input, Output, OriginalFormat, ObjectResourceToText, $FF, 1); end; { Text to resource conversion } procedure ObjectTextToResource(Input, Output: TStream); procedure NameLengthError(Len: Byte; Stream: TStream); var Temp: string; begin SetLength(Temp, Len); Stream.Read(Temp[1], Len); raise EParserError.CreateResFmt(@sComponentNameTooLong, [Temp]); end; var Len: Byte; Tmp: Longint; MemoryStream: TMemoryStream; MemorySize: Longint; Header: array[0..79] of Char; begin MemoryStream := TMemoryStream.Create; try ObjectTextToBinary(Input, MemoryStream); MemorySize := MemoryStream.Size; FillChar(Header, SizeOf(Header), 0); MemoryStream.Position := SizeOf(Longint); { Skip header } MemoryStream.Read(Len, 1); { Skip over object prefix if it is present } if Len and $F0 = $F0 then begin if ffChildPos in TFilerFlags((Len and $F0)) then begin MemoryStream.Read(Len, 1); case TValueType(Len) of vaInt8: Len := 1; vaInt16: Len := 2; vaInt32: Len := 4; end; MemoryStream.Read(Tmp, Len); end; MemoryStream.Read(Len, 1); end; if Len > High(Header) - 10 then NameLengthError(Len, MemoryStream); MemoryStream.Read(Header[3], Len); StrUpper(@Header[3]); Byte((@Header[0])^) := $FF; Word((@Header[1])^) := 10; Word((@Header[Len + 4])^) := $1030; Longint((@Header[Len + 6])^) := MemorySize; Output.Write(Header, Len + 10); Output.Write(MemoryStream.Memory^, MemorySize); finally MemoryStream.Free; end; end; procedure ObjectTextToResource(Input, Output: TStream; var OriginalFormat: TStreamOriginalFormat); begin InternalTextToBinary(Input, Output, OriginalFormat, ObjectTextToResource, $FF, 1); end; function TestStreamFormat(Stream: TStream): TStreamOriginalFormat; var Pos: Integer; Signature: Integer; begin Pos := Stream.Position; Signature := 0; Stream.Read(Signature, sizeof(Signature)); Stream.Position := Pos; if (Byte(Signature) = $FF) or (Signature = Integer(FilerSignature)) then Result := sofBinary // text format may begin with "object", "inherited", or whitespace else if Char(Signature) in ['o','O','i','I',' ',#13,#11,#9] then Result := sofText else Result := sofUnknown; end; type TSyncProc = record Thread: TThread; {$IFDEF MSWINDOWS} Signal: THandle; {$ENDIF} {$IFDEF LINUX} Signal: TCondVar; {$ENDIF} end; PSyncProc = ^TSyncProc; var ProcPosted: Boolean; SyncList: TList = nil; ThreadLock: TRTLCriticalSection; ThreadCount: Integer; procedure AddThread; begin EnterCriticalSection(ThreadLock); try if (ThreadCount = 0) and (SyncList = nil) then SyncList := TList.Create; Inc(ThreadCount); finally LeaveCriticalSection(ThreadLock); end; end; procedure RemoveThread; begin EnterCriticalSection(ThreadLock); try Dec(ThreadCount); finally LeaveCriticalSection(ThreadLock); end; end; function CheckSynchronize: Boolean; var SyncProc: PSyncProc; begin if GetCurrentThreadID <> MainThreadID then raise EThread.CreateResFmt(@SCheckSynchronizeError, [GetCurrentThreadID]); if ProcPosted then begin EnterCriticalSection(ThreadLock); try Result := (SyncList <> nil) and (SyncList.Count > 0); if Result then begin while SyncList.Count > 0 do begin SyncProc := SyncList[0]; SyncList.Delete(0); try SyncProc.Thread.FMethod; except SyncProc.Thread.FSynchronizeException := AcquireExceptionObject; end; {$IFDEF MSWINDOWS} SetEvent(SyncProc.signal); {$ENDIF} {$IFDEF LINUX} pthread_cond_signal(SyncProc.Signal); {$ENDIF} end; ProcPosted := False; end; finally LeaveCriticalSection(ThreadLock); end; end else Result := False; end; function ThreadProc(Thread: TThread): Integer; var FreeThread: Boolean; begin {$IFDEF LINUX} if Thread.FSuspended then sem_wait(Thread.FCreateSuspendedSem); {$ENDIF} try if not Thread.Terminated then try Thread.Execute; except Thread.FFatalException := AcquireExceptionObject; end; finally FreeThread := Thread.FFreeOnTerminate; Result := Thread.FReturnValue; Thread.FFinished := True; Thread.DoTerminate; if FreeThread then Thread.Free; {$IFDEF MSWINDOWS} EndThread(Result); {$ENDIF} {$IFDEF LINUX} // Directly call pthread_exit since EndThread will detach the thread causing // the pthread_join in TThread.WaitFor to fail. Also, make sure the EndThreadProc // is called just like EndThread would do. EndThreadProc should not return // and call pthread_exit itself. if Assigned(EndThreadProc) then EndThreadProc(Result); pthread_exit(Pointer(Result)); {$ENDIF} end; end; constructor TThread.Create(CreateSuspended: Boolean); {$IFDEF LINUX} var ErrCode: Integer; {$ENDIF} begin inherited Create; AddThread; FSuspended := CreateSuspended; FCreateSuspended := CreateSuspended; {$IFDEF MSWINDOWS} FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), CREATE_SUSPENDED, FThreadID); if FHandle = 0 then raise EThread.CreateResFmt(@SThreadCreateError, [SysErrorMessage(GetLastError)]); {$ENDIF} {$IFDEF LINUX} sem_init(FCreateSuspendedSem, False, 0); ErrCode := BeginThread(nil, @ThreadProc, Pointer(Self), FThreadID); if ErrCode <> 0 then raise EThread.CreateResFmt(@SThreadCreateError, [SysErrorMessage(ErrCode)]); {$ENDIF} end; destructor TThread.Destroy; begin if (FThreadID <> 0) and not FFinished then begin Terminate; if FCreateSuspended then Resume; WaitFor; end; {$IFDEF MSWINDOWS} if FHandle <> 0 then CloseHandle(FHandle); {$ENDIF} {$IFDEF LINUX} // This final check is to ensure that even if the thread was never waited on // its resources will be freed. if FThreadID <> 0 then pthread_detach(FThreadID); sem_destroy(FCreateSuspendedSem); {$ENDIF} inherited Destroy; FFatalException.Free; RemoveThread; end; procedure TThread.AfterConstruction; begin if not FCreateSuspended then Resume; end; procedure TThread.CheckThreadError(ErrCode: Integer); begin if ErrCode <> 0 then raise EThread.CreateResFmt(@SThreadError, [SysErrorMessage(ErrCode), ErrCode]); end; procedure TThread.CheckThreadError(Success: Boolean); begin if not Success then CheckThreadError(GetLastError); end; procedure TThread.CallOnTerminate; begin if Assigned(FOnTerminate) then FOnTerminate(Self); end; procedure TThread.DoTerminate; begin if Assigned(FOnTerminate) then Synchronize(CallOnTerminate); end; {$IFDEF MSWINDOWS} const Priorities: array [TThreadPriority] of Integer = (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL, THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL); function TThread.GetPriority: TThreadPriority; var P: Integer; I: TThreadPriority; begin P := GetThreadPriority(FHandle); CheckThreadError(P <> THREAD_PRIORITY_ERROR_RETURN); Result := tpNormal; for I := Low(TThreadPriority) to High(TThreadPriority) do if Priorities[I] = P then Result := I; end; procedure TThread.SetPriority(Value: TThreadPriority); begin CheckThreadError(SetThreadPriority(FHandle, Priorities[Value])); end; {$ENDIF} {$IFDEF LINUX} function TThread.GetPriority: Integer; var P: Integer; J: TSchedParam; begin { Linux Priority is based on the Schedule policy. There are 3 different kinds of policy. See SetPolicy. Policy Type Priority ---------- -------- -------- SCHED_RR RealTime 0-99 SCHED_FIFO RealTime 0-99 SCHED_OTHER Regular 0 SCHED_RR and SCHED_FIFO can only be set by root. } CheckThreadError(pthread_getschedparam(FThreadID, P, J)); Result := J.sched_priority; end; { Note that to fully utilize Linux Scheduling, see SetPolicy. } procedure TThread.SetPriority(Value: Integer); var P: TSchedParam; begin if Value <> Priority then begin P.sched_priority := Value; CheckThreadError(pthread_setschedparam(FThreadID, Policy, @P)); end; end; function TThread.GetPolicy: Integer; var J: TSchedParam; begin CheckThreadError(pthread_getschedparam(FThreadID, Result, J)); end; { Note that to fully utilize Linux Scheduling, SetPolicy needs to be used as well. See SetPriority for the relationship between these methods. } procedure TThread.SetPolicy(Value: Integer); var P: TSchedParam; begin if Value <> Policy then begin P.sched_priority := GetPriority; CheckThreadError(pthread_setschedparam(FThreadID, Value, @P)); end; end; {$ENDIF} procedure TThread.Synchronize(Method: TThreadMethod); var SyncProc: TSyncProc; begin {$IFDEF MSWINDOWS} SyncProc.Signal := CreateEvent(nil, True, False, nil); try {$ENDIF} {$IFDEF LINUX} FillChar(SyncProc, SizeOf(SyncProc), 0); // This also initializes the cond_var {$ENDIF} EnterCriticalSection(ThreadLock); try FSynchronizeException := nil; FMethod := Method; SyncProc.Thread := Self; SyncList.Add(@SyncProc); ProcPosted := True; if Assigned(WakeMainThread) then WakeMainThread(Self); {$IFDEF MSWINDOWS} LeaveCriticalSection(ThreadLock); try WaitForSingleObject(SyncProc.Signal, INFINITE); finally EnterCriticalSection(ThreadLock); end; {$ENDIF} {$IFDEF LINUX} pthread_cond_wait(SyncProc.Signal, ThreadLock); {$ENDIF} finally LeaveCriticalSection(ThreadLock); end; {$IFDEF MSWINDOWS} finally CloseHandle(SyncProc.Signal); end; {$ENDIF} if Assigned(FSynchronizeException) then raise FSynchronizeException; end; procedure TThread.SetSuspended(Value: Boolean); begin if Value <> FSuspended then if Value then Suspend else Resume; end; {$IFDEF MSWINDOWS} procedure TThread.Suspend; begin FSuspended := True; CheckThreadError(Integer(SuspendThread(FHandle)) >= 0); end; procedure TThread.Resume; var SuspendCount: Integer; begin SuspendCount := ResumeThread(FHandle); CheckThreadError(SuspendCount >= 0); if SuspendCount = 1 then FSuspended := False; end; {$ENDIF} {$IFDEF LINUX} { About Suspend and Resume. POSIX does not support suspending/resuming a thread. Suspending a thread is considerd dangerous since it is not guaranteed where the thread would be suspend. It might be holding a lock, mutex or it might be inside a critical section. In order to simulate it in Linux we've used signals. To suspend, a thread SIGSTOP is sent and to resume, SIGCONT is sent. Note that this is Linux only i.e. according to POSIX if a thread receives SIGSTOP then the entire process is stopped. However Linux doesn't entirely exhibit the POSIX-mandated behaviour. If and when it fully complies with the POSIX standard then suspend and resume won't work. } procedure TThread.Suspend; begin FSuspended := True; CheckThreadError(pthread_kill(FThreadID, SIGSTOP)); end; procedure TThread.Resume; begin if not FInitialSuspendDone then begin FInitialSuspendDone := True; sem_post(FCreateSuspendedSem); end else CheckThreadError(pthread_kill(FThreadID, SIGCONT)); FSuspended := False; end; {$ENDIF} procedure TThread.Terminate; begin FTerminated := True; end; function TThread.WaitFor: LongWord; {$IFDEF MSWINDOWS} var H: THandle; WaitResult: Cardinal; Msg: TMsg; begin H := FHandle; if GetCurrentThreadID = MainThreadID then begin WaitResult := 0; repeat { This prevents a potential deadlock if the background thread does a SendMessage to the foreground thread } if WaitResult = WAIT_OBJECT_0 + 1 then PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE); Sleep(0); CheckSynchronize; WaitResult := MsgWaitForMultipleObjects(1, H, False, 0, QS_SENDMESSAGE); Win32Check(WaitResult <> WAIT_FAILED); until WaitResult = WAIT_OBJECT_0; end else WaitForSingleObject(H, INFINITE); CheckThreadError(GetExitCodeThread(H, Result)); end; {$ENDIF} {$IFDEF LINUX} var X: Pointer; ID: Cardinal; begin ID := FThreadID; if GetCurrentThreadID = MainThreadID then while not FFinished do begin sleep(0); CheckSynchronize; end; FThreadID := 0; X := @Result; CheckThreadError(pthread_join(ID, @X)); end; {$ENDIF} { TComponent } constructor TComponent.Create(AOwner: TComponent); begin FComponentStyle := [csInheritable]; if AOwner <> nil then AOwner.InsertComponent(Self); end; destructor TComponent.Destroy; begin Destroying; if FFreeNotifies <> nil then begin while Assigned(FFreeNotifies) and (FFreeNotifies.Count > 0) do TComponent(FFreeNotifies[FFreeNotifies.Count - 1]).Notification(Self, opRemove); FreeAndNil(FFreeNotifies); end; DestroyComponents; if FOwner <> nil then FOwner.RemoveComponent(Self); inherited Destroy; end; procedure TComponent.BeforeDestruction; begin if not (csDestroying in ComponentState) then Destroying; end; procedure TComponent.FreeNotification(AComponent: TComponent); begin if (Owner = nil) or (AComponent.Owner <> Owner) then begin // Never acquire a reference to a component that is being deleted. assert(not (csDestroying in (ComponentState + AComponent.ComponentState))); if not Assigned(FFreeNotifies) then FFreeNotifies := TList.Create; if FFreeNotifies.IndexOf(AComponent) < 0 then begin FFreeNotifies.Add(AComponent); AComponent.FreeNotification(Self); end; end; Include(FComponentState, csFreeNotification); end; procedure TComponent.ReadLeft(Reader: TReader); begin LongRec(FDesignInfo).Lo := Reader.ReadInteger; end; procedure TComponent.ReadTop(Reader: TReader); begin LongRec(FDesignInfo).Hi := Reader.ReadInteger; end; procedure TComponent.WriteLeft(Writer: TWriter); begin Writer.WriteInteger(LongRec(FDesignInfo).Lo); end; procedure TComponent.WriteTop(Writer: TWriter); begin Writer.WriteInteger(LongRec(FDesignInfo).Hi); end; procedure TComponent.Insert(AComponent: TComponent); begin if FComponents = nil then FComponents := TList.Create; FComponents.Add(AComponent); AComponent.FOwner := Self; end; procedure TComponent.Remove(AComponent: TComponent); begin AComponent.FOwner := nil; FComponents.Remove(AComponent); if FComponents.Count = 0 then begin FComponents.Free; FComponents := nil; end; end; procedure TComponent.InsertComponent(AComponent: TComponent); begin AComponent.ValidateContainer(Self); ValidateRename(AComponent, '', AComponent.FName); Insert(AComponent); AComponent.SetReference(True); if csDesigning in ComponentState then AComponent.SetDesigning(True); Notification(AComponent, opInsert); end; procedure TComponent.RemoveComponent(AComponent: TComponent); begin ValidateRename(AComponent, AComponent.FName, ''); Notification(AComponent, opRemove); AComponent.SetReference(False); Remove(AComponent); end; procedure TComponent.DestroyComponents; var Instance: TComponent; begin while FComponents <> nil do begin Instance := FComponents.Last; if (csFreeNotification in Instance.FComponentState) or (FComponentState * [csDesigning, csInline] = [csDesigning, csInline]) then RemoveComponent(Instance) else Remove(Instance); Instance.Destroy; end; end; procedure TComponent.Destroying; var I: Integer; begin if not (csDestroying in FComponentState) then begin Include(FComponentState, csDestroying); if FComponents <> nil then for I := 0 to FComponents.Count - 1 do TComponent(FComponents[I]).Destroying; end; end; procedure TComponent.RemoveNotification(AComponent: TComponent); begin if FFreeNotifies <> nil then begin FFreeNotifies.Remove(AComponent); if FFreeNotifies.Count = 0 then begin FFreeNotifies.Free; FFreeNotifies := nil; end; end; end; procedure TComponent.RemoveFreeNotification(AComponent: TComponent); begin RemoveNotification(AComponent); AComponent.RemoveNotification(Self); end; procedure TComponent.Notification(AComponent: TComponent; Operation: TOperation); var I: Integer; begin if (Operation = opRemove) and (AComponent <> nil) then RemoveFreeNotification(AComponent); if FComponents <> nil then begin I := FComponents.Count - 1; while I >= 0 do begin TComponent(FComponents[I]).Notification(AComponent, Operation); Dec(I); if I >= FComponents.Count then I := FComponents.Count - 1; end; end; end; procedure TComponent.DefineProperties(Filer: TFiler); var Ancestor: TComponent; Info: Longint; begin Info := 0; Ancestor := TComponent(Filer.Ancestor); if Ancestor <> nil then Info := Ancestor.FDesignInfo; Filer.DefineProperty('Left', ReadLeft, WriteLeft, LongRec(FDesignInfo).Lo <> LongRec(Info).Lo); Filer.DefineProperty('Top', ReadTop, WriteTop, LongRec(FDesignInfo).Hi <> LongRec(Info).Hi); end; function TComponent.HasParent: Boolean; begin Result := False; end; procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent); begin end; function TComponent.GetChildOwner: TComponent; begin Result := nil; end; function TComponent.GetChildParent: TComponent; begin Result := Self; end; function TComponent.GetNamePath: string; begin Result := FName; end; function TComponent.GetOwner: TPersistent; begin Result := FOwner; end; procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer); begin end; function TComponent.GetParentComponent: TComponent; begin Result := nil; end; procedure TComponent.SetParentComponent(Value: TComponent); begin end; procedure TComponent.Updating; begin Include(FComponentState, csUpdating); end; procedure TComponent.Updated; begin Exclude(FComponentState, csUpdating); end; procedure TComponent.Loaded; begin Exclude(FComponentState, csLoading); end; procedure TComponent.PaletteCreated; begin // Notification end; procedure TComponent.ReadState(Reader: TReader); begin Reader.ReadData(Self); end; procedure TComponent.WriteState(Writer: TWriter); begin Writer.WriteData(Self); end; procedure TComponent.ValidateRename(AComponent: TComponent; const CurName, NewName: string); begin if (AComponent <> nil) and not SameText(CurName, NewName) and (AComponent.Owner = Self) and (FindComponent(NewName) <> nil) then raise EComponentError.CreateResFmt(@SDuplicateName, [NewName]); if (csDesigning in ComponentState) and (Owner <> nil) then Owner.ValidateRename(AComponent, CurName, NewName); end; procedure TComponent.ValidateContainer(AComponent: TComponent); begin AComponent.ValidateInsert(Self); end; procedure TComponent.ValidateInsert(AComponent: TComponent); begin end; function TComponent.FindComponent(const AName: string): TComponent; var I: Integer; begin if (AName <> '') and (FComponents <> nil) then for I := 0 to FComponents.Count - 1 do begin Result := FComponents[I]; if SameText(Result.FName, AName) then Exit; end; Result := nil; end; procedure TComponent.SetName(const NewName: TComponentName); begin if FName <> NewName then begin if (NewName <> '') and not IsValidIdent(NewName) then raise EComponentError.CreateResFmt(@SInvalidName, [NewName]); if FOwner <> nil then FOwner.ValidateRename(Self, FName, NewName) else ValidateRename(nil, FName, NewName); SetReference(False); ChangeName(NewName); SetReference(True); end; end; procedure TComponent.ChangeName(const NewName: TComponentName); begin FName := NewName; end; function TComponent.GetComponentIndex: Integer; begin if (FOwner <> nil) and (FOwner.FComponents <> nil) then Result := FOwner.FComponents.IndexOf(Self) else Result := -1; end; function TComponent.GetComponent(AIndex: Integer): TComponent; begin if FComponents = nil then TList.Error(@SListIndexError, AIndex); Result := FComponents[AIndex]; end; function TComponent.GetComponentCount: Integer; begin if FComponents <> nil then Result := FComponents.Count else Result := 0; end; procedure TComponent.SetComponentIndex(Value: Integer); var I, Count: Integer; begin if FOwner <> nil then begin I := FOwner.FComponents.IndexOf(Self); if I >= 0 then begin Count := FOwner.FComponents.Count; if Value < 0 then Value := 0; if Value >= Count then Value := Count - 1; if Value <> I then begin FOwner.FComponents.Delete(I); FOwner.FComponents.Insert(Value, Self); end; end; end; end; procedure TComponent.SetAncestor(Value: Boolean); var I: Integer; begin if Value then Include(FComponentState, csAncestor) else Exclude(FComponentState, csAncestor); for I := 0 to ComponentCount - 1 do Components[I].SetAncestor(Value); end; procedure TComponent.SetDesigning(Value, SetChildren: Boolean); var I: Integer; begin if Value then Include(FComponentState, csDesigning) else Exclude(FComponentState, csDesigning); if SetChildren then for I := 0 to ComponentCount - 1 do Components[I].SetDesigning(Value); end; procedure TComponent.SetInline(Value: Boolean); begin if Value then Include(FComponentState, csInline) else Exclude(FComponentState, csInline); end; procedure TComponent.SetDesignInstance(Value: Boolean); begin if Value then Include(FComponentState, csDesignInstance) else Exclude(FComponentState, csDesignInstance); end; procedure TComponent.SetReference(Enable: Boolean); var Field: ^TComponent; begin if FOwner <> nil then begin Field := FOwner.FieldAddress(FName); if Field <> nil then if Enable then Field^ := Self else Field^ := nil; end; end; function TComponent.ExecuteAction(Action: TBasicAction): Boolean; begin Result := Action.HandlesTarget(Self); if Result then Action.ExecuteTarget(Self); end; function TComponent.UpdateAction(Action: TBasicAction): Boolean; begin Result := Action.HandlesTarget(Self); if Result then Action.UpdateTarget(Self); end; procedure TComponent.SetSubComponent(IsSubComponent: Boolean); begin if IsSubComponent then Include(FComponentStyle, csSubComponent) else Exclude(FComponentStyle, csSubComponent); end; function TComponent.GetComObject: IUnknown; begin if FVCLComObject = nil then begin if Assigned(CreateVCLComObjectProc) then CreateVCLComObjectProc(Self); if FVCLComObject = nil then raise EComponentError.CreateResFmt(@SNoComSupport, [ClassName]); end; IVCLComObject(FVCLComObject).QueryInterface(IUnknown, Result); end; function TComponent.SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; begin if FVCLComObject <> nil then Result := IVCLComObject(FVCLComObject).SafeCallException( ExceptObject, ExceptAddr) else Result := inherited SafeCallException(ExceptObject, ExceptAddr); {$IFDEF LINUX} if ExceptObject is Exception then begin SetSafeCallExceptionMsg(Exception(ExceptObject).Message); SetSafeCallExceptionAddr(ExceptAddr); Result := HResult($8000FFFF); end else Result := inherited SafeCallException(ExceptObject, ExceptAddr); {$ENDIF} end; procedure TComponent.FreeOnRelease; begin if FVCLComObject <> nil then IVCLComObject(FVCLComObject).FreeOnRelease; end; class procedure TComponent.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); begin end; { TComponent.IInterface } function TComponent.QueryInterface(const IID: TGUID; out Obj): HResult; begin if FVCLComObject = nil then begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE end else Result := IVCLComObject(FVCLComObject).QueryInterface(IID, Obj); end; function TComponent._AddRef: Integer; begin if FVCLComObject = nil then Result := -1 // -1 indicates no reference counting is taking place else Result := IVCLComObject(FVCLComObject)._AddRef; end; function TComponent._Release: Integer; begin if FVCLComObject = nil then Result := -1 // -1 indicates no reference counting is taking place else Result := IVCLComObject(FVCLComObject)._Release; end; { TComponent.IDispatch } function TComponent.GetTypeInfoCount(out Count: Integer): HResult; begin if FVCLComObject = nil then Result := E_NOTIMPL else Result := IVCLComObject(FVCLComObject).GetTypeInfoCount(Count); end; function TComponent.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin if FVCLComObject = nil then Result := E_NOTIMPL else Result := IVCLComObject(FVCLComObject).GetTypeInfo( Index, LocaleID, TypeInfo); end; function TComponent.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; begin if FVCLComObject = nil then Result := E_NOTIMPL else Result := IVCLComObject(FVCLComObject).GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs); end; function TComponent.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; begin if FVCLComObject = nil then Result := E_NOTIMPL else Result := IVCLComObject(FVCLComObject).Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr); end; { TComponent.IInterfaceComponentReference.GetComponent Return a reference to the component that can be queried at load time to obtain an interface. The name of the reference component will be written to the stream (same as a normal component reference) so that it can be located again at load time. In the case of aggregation, the reference component for an interface might not be the same as the class that implements the interface itself. Aggregate implementation classes should not implement IInterfaceComponentReference, but should defer requests for that interface to the controlling component. } function TComponent.IntfGetComponent: TComponent; begin Result := Self; end; function TComponent.IsImplementorOf(const I: IInterface): Boolean; var ICR: IInterfaceComponentReference; begin Result := (I <> nil) and Supports(I, IInterfaceComponentReference, ICR) and (ICR.GetComponent = Self); end; { TComponent.ReferenceInterface Establishes (opInsert) or removes (opRemove) internal links that notify us when the component that implements the given interface is destroyed. The function result indicates whether the function was able to establish/remove a notification link or not. A result of False doesn't necessarily indicate an error, but it does mean that the interface's implementor does not participate in the interfaced component reference model. This could mean that the given interface employs true reference counting, independent of component lifetimes. That doesn't affect the use of interface properties at runtime, but non-component interfaces cannot be stored by the property streaming system. When implementing components with interface-type properties, implement setter methods for the interface-type properties like this: procedure TMyComponent.SetMyIntfProp(const Value: IMyInterface); begin ReferenceInterface(FIntfField, opRemove); FIntfField := Value; ReferenceInterface(FIntfField, opInsert); end; Also override Notification to do the following for each interface property in your component: procedure TMyComponent.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if Assigned(MyIntfProp) and AComponent.IsImplementorOf(MyIntfProp) then MyIntfProp := nil; ... repeat for other interface properties ... end; Note that the Notification code assigns nil to the *property*, not to the private field, so that the property setter will call ReferenceInterface(FIntfField, opRemove to undo any links established by a previous opInsert operation. All assignments to the interface property *must* be made through the property setter. TComponent.ReferenceInterface hides the details of how links are established between the implementor and the holder of an interface. The implementation details may change in the future. Code that relies on those implementation details (instead of using ReferenceInterface) will not be supported. In particular, avoid the temptation to use IInterfaceComponentReference in your own code, as this interface may not be available in the future. } function TComponent.ReferenceInterface(const I: IInterface; Operation: TOperation): Boolean; var ICR: IInterfaceComponentReference; begin Result := (I <> nil) and Supports(I, IInterfaceComponentReference, ICR); if Result then if Operation = opInsert then ICR.GetComponent.FreeNotification(Self) else ICR.GetComponent.RemoveFreeNotification(Self); end; { TBasicActionLink } constructor TBasicActionLink.Create(AClient: TObject); begin inherited Create; AssignClient(AClient); end; procedure TBasicActionLink.AssignClient(AClient: TObject); begin end; destructor TBasicActionLink.Destroy; begin if FAction <> nil then FAction.UnRegisterChanges(Self); inherited Destroy; end; procedure TBasicActionLink.Change; begin if Assigned(OnChange) then OnChange(FAction); end; function TBasicActionLink.Execute(AComponent: TComponent): Boolean; begin if FAction.ActionComponent <> AComponent then begin if Assigned(FAction.ActionComponent) then begin FAction.ActionComponent.RemoveFreeNotification(FAction); if Assigned(AComponent) then AComponent.FreeNotification(FAction); end; FAction.ActionComponent := AComponent; end; Result := FAction.Execute; end; procedure TBasicActionLink.SetAction(Value: TBasicAction); begin if Value <> FAction then begin if FAction <> nil then FAction.UnRegisterChanges(Self); FAction := Value; if Value <> nil then Value.RegisterChanges(Self); end; end; function TBasicActionLink.IsOnExecuteLinked: Boolean; begin Result := True; end; procedure TBasicActionLink.SetOnExecute(Value: TNotifyEvent); begin end; function TBasicActionLink.Update: Boolean; begin Result := FAction.Update; end; { TBasicAction } constructor TBasicAction.Create(AOwner: TComponent); begin inherited Create(AOwner); FClients := TList.Create; end; destructor TBasicAction.Destroy; begin inherited Destroy; if Assigned(ActionComponent) then ActionComponent.RemoveFreeNotification(Self); while FClients.Count > 0 do UnRegisterChanges(TBasicActionLink(FClients.Last)); FreeAndNil(FClients); end; function TBasicAction.HandlesTarget(Target: TObject): Boolean; begin Result := False; end; procedure TBasicAction.ExecuteTarget(Target: TObject); begin end; procedure TBasicAction.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (AComponent = ActionComponent) then ActionComponent := nil; end; procedure TBasicAction.UpdateTarget(Target: TObject); begin end; function TBasicAction.Execute: Boolean; begin if Assigned(FOnExecute) then begin FOnExecute(Self); Result := True; end else Result := False; end; function TBasicAction.Update: Boolean; begin if Assigned(FOnUpdate) then begin FOnUpdate(Self); Result := True; end else Result := False; end; procedure TBasicAction.SetOnExecute(Value: TNotifyEvent); var I: Integer; begin if (TMethod(Value).Code <> TMethod(OnExecute).Code) or (TMethod(Value).Data <> TMethod(OnExecute).Data) then begin for I := 0 to FClients.Count - 1 do TBasicActionLink(FClients[I]).SetOnExecute(Value); FOnExecute := Value; Change; end; end; procedure TBasicAction.Change; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TBasicAction.RegisterChanges(Value: TBasicActionLink); begin Value.FAction := Self; FClients.Add(Value); end; procedure TBasicAction.UnRegisterChanges(Value: TBasicActionLink); var I: Integer; begin for I := 0 to FClients.Count - 1 do if FClients[I] = Value then begin Value.FAction := nil; FClients.Delete(I); Break; end; end; { TStreamAdapter } constructor TStreamAdapter.Create(Stream: TStream; Ownership: TStreamOwnership); begin inherited Create; FStream := Stream; FOwnership := Ownership; end; destructor TStreamAdapter.Destroy; begin if FOwnership = soOwned then begin FStream.Free; FStream := nil; end; inherited Destroy; end; function TStreamAdapter.Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult; var NumRead: Longint; begin try if pv = Nil then begin Result := STG_E_INVALIDPOINTER; Exit; end; NumRead := FStream.Read(pv^, cb); if pcbRead <> Nil then pcbRead^ := NumRead; Result := S_OK; except Result := S_FALSE; end; end; function TStreamAdapter.Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult; var NumWritten: Longint; begin try if pv = Nil then begin Result := STG_E_INVALIDPOINTER; Exit; end; NumWritten := FStream.Write(pv^, cb); if pcbWritten <> Nil then pcbWritten^ := NumWritten; Result := S_OK; except Result := STG_E_CANTSAVE; end; end; function TStreamAdapter.Seek(dlibMove: Largeint; dwOrigin: Longint; out libNewPosition: Largeint): HResult; var NewPos: LargeInt; begin try if (dwOrigin < STREAM_SEEK_SET) or (dwOrigin > STREAM_SEEK_END) then begin Result := STG_E_INVALIDFUNCTION; Exit; end; NewPos := FStream.Seek(dlibMove, dwOrigin); if @libNewPosition <> nil then libNewPosition := NewPos; Result := S_OK; except Result := STG_E_INVALIDPOINTER; end; end; function TStreamAdapter.SetSize(libNewSize: Largeint): HResult; begin try FStream.Size := libNewSize; if libNewSize <> FStream.Size then Result := E_FAIL else Result := S_OK; except Result := E_UNEXPECTED; end; end; function TStreamAdapter.CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; out cbWritten: Largeint): HResult; const MaxBufSize = 1024 * 1024; // 1mb var Buffer: Pointer; BufSize, N, I, R: Integer; BytesRead, BytesWritten, W: LargeInt; begin Result := S_OK; BytesRead := 0; BytesWritten := 0; try if cb > MaxBufSize then BufSize := MaxBufSize else BufSize := Integer(cb); GetMem(Buffer, BufSize); try while cb > 0 do begin if cb > MaxInt then I := MaxInt else I := cb; while I > 0 do begin if I > BufSize then N := BufSize else N := I; R := FStream.Read(Buffer^, N); if R = 0 then Exit; // The end of the stream was hit. Inc(BytesRead, R); W := 0; Result := stm.Write(Buffer, R, @W); Inc(BytesWritten, W); if (Result = S_OK) and (Integer(W) <> R) then Result := E_FAIL; if Result <> S_OK then Exit; Dec(I, R); Dec(cb, R); end; end; finally FreeMem(Buffer); if (@cbWritten <> nil) then cbWritten := BytesWritten; if (@cbRead <> nil) then cbRead := BytesRead; end; except Result := E_UNEXPECTED; end; end; function TStreamAdapter.Commit(grfCommitFlags: Longint): HResult; begin Result := S_OK; end; function TStreamAdapter.Revert: HResult; begin Result := STG_E_REVERTED; end; function TStreamAdapter.LockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; begin Result := STG_E_INVALIDFUNCTION; end; function TStreamAdapter.UnlockRegion(libOffset: Largeint; cb: Largeint; dwLockType: Longint): HResult; begin Result := STG_E_INVALIDFUNCTION; end; function TStreamAdapter.Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult; begin Result := S_OK; try if (@statstg <> nil) then with statstg do begin dwType := STGTY_STREAM; cbSize := FStream.Size; mTime.dwLowDateTime := 0; mTime.dwHighDateTime := 0; cTime.dwLowDateTime := 0; cTime.dwHighDateTime := 0; aTime.dwLowDateTime := 0; aTime.dwHighDateTime := 0; grfLocksSupported := LOCK_WRITE; end; except Result := E_UNEXPECTED; end; end; function TStreamAdapter.Clone(out stm: IStream): HResult; begin Result := E_NOTIMPL; end; procedure FreeIntConstList; var I: Integer; begin with IntConstList.LockList do try for I := 0 to Count - 1 do TIntConst(Items[I]).Free; finally IntConstList.UnlockList; end; IntConstList.Free; end; procedure ModuleUnload(Instance: Longint); begin UnregisterModuleClasses(HMODULE(Instance)); end; { TDataModule } constructor TDataModule.Create(AOwner: TComponent); begin GlobalNameSpace.BeginWrite; try CreateNew(AOwner); if (ClassType <> TDataModule) and not (csDesigning in ComponentState) then begin if not InitInheritedComponent(Self, TDataModule) then raise EResNotFound.CreateFmt(SResNotFound, [ClassName]); if OldCreateOrder then DoCreate; end; finally GlobalNameSpace.EndWrite; end; end; procedure TDataModule.AfterConstruction; begin if not OldCreateOrder then DoCreate; end; constructor TDataModule.CreateNew(AOwner: TComponent; Dummy: Integer); begin inherited Create(AOwner); if Assigned(AddDataModule) and (Dummy >= 0) then AddDataModule(Self); end; procedure TDataModule.BeforeDestruction; begin GlobalNameSpace.BeginWrite; Destroying; RemoveFixupReferences(Self, ''); if not OldCreateOrder then DoDestroy; end; destructor TDataModule.Destroy; begin if not (csDestroying in ComponentState) then GlobalNameSpace.BeginWrite; try if OldCreateOrder then DoDestroy; if Assigned(RemoveDataModule) then RemoveDataModule(Self); inherited Destroy; finally GlobalNameSpace.EndWrite; end; end; procedure TDataModule.DoCreate; begin if Assigned(FOnCreate) then try FOnCreate(Self); except if not HandleCreateException then raise; end; end; procedure TDataModule.DoDestroy; begin if Assigned(FOnDestroy) then try FOnDestroy(Self); except if Assigned(ApplicationHandleException) then ApplicationHandleException(Self); end; end; procedure TDataModule.DefineProperties(Filer: TFiler); var Ancestor: TDataModule; function DoWriteWidth: Boolean; begin Result := True; if Ancestor <> nil then Result := FDesignSize.X <> Ancestor.FDesignSize.X; end; function DoWriteHorizontalOffset: Boolean; begin if Ancestor <> nil then Result := FDesignOffset.X <> Ancestor.FDesignOffset.X else Result := FDesignOffset.X <> 0; end; function DoWriteVerticalOffset: Boolean; begin if Ancestor <> nil then Result := FDesignOffset.Y <> Ancestor.FDesignOffset.Y else Result := FDesignOffset.Y <> 0; end; function DoWriteHeight: Boolean; begin Result := True; if Ancestor <> nil then Result := FDesignSize.Y <> Ancestor.FDesignSize.Y; end; begin inherited DefineProperties(Filer); Ancestor := TDataModule(Filer.Ancestor); Filer.DefineProperty('Height', ReadHeight, WriteHeight, DoWriteHeight); Filer.DefineProperty('HorizontalOffset', ReadHorizontalOffset, WriteHorizontalOffset, DoWriteHorizontalOffset); Filer.DefineProperty('VerticalOffset', ReadVerticalOffset, WriteVerticalOffset, DoWriteVerticalOffset); Filer.DefineProperty('Width', ReadWidth, WriteWidth, DoWriteWidth); end; procedure TDataModule.GetChildren(Proc: TGetChildProc; Root: TComponent); var I: Integer; OwnedComponent: TComponent; begin inherited GetChildren(Proc, Root); if Root = Self then for I := 0 to ComponentCount - 1 do begin OwnedComponent := Components[I]; if not OwnedComponent.HasParent then Proc(OwnedComponent); end; end; function TDataModule.HandleCreateException: Boolean; begin if Assigned(ApplicationHandleException) then begin ApplicationHandleException(Self); Result := True; end else Result := False; end; procedure TDataModule.ReadState(Reader: TReader); begin FOldCreateOrder := not ModuleIsCPP; inherited ReadState(Reader); end; procedure TDataModule.ReadWidth(Reader: TReader); begin FDesignSize.X := Reader.ReadInteger; end; procedure TDataModule.ReadHorizontalOffset(Reader: TReader); begin FDesignOffset.X := Reader.ReadInteger; end; procedure TDataModule.ReadVerticalOffset(Reader: TReader); begin FDesignOffset.Y := Reader.ReadInteger; end; procedure TDataModule.ReadHeight(Reader: TReader); begin FDesignSize.Y := Reader.ReadInteger; end; procedure TDataModule.WriteWidth(Writer: TWriter); begin Writer.WriteInteger(FDesignSize.X); end; procedure TDataModule.WriteHorizontalOffset(Writer: TWriter); begin Writer.WriteInteger(FDesignOffset.X); end; procedure TDataModule.WriteVerticalOffset(Writer: TWriter); begin Writer.WriteInteger(FDesignOffset.Y); end; procedure TDataModule.WriteHeight(Writer: TWriter); begin Writer.WriteInteger(FDesignSize.Y); end; {$IFDEF MSWINDOWS} const InstanceCount = 313; { Object instance management } type PObjectInstance = ^TObjectInstance; TObjectInstance = packed record Code: Byte; Offset: Integer; case Integer of 0: (Next: PObjectInstance); 1: (Method: TWndMethod); end; type PInstanceBlock = ^TInstanceBlock; TInstanceBlock = packed record Next: PInstanceBlock; Code: array[1..2] of Byte; WndProcPtr: Pointer; Instances: array[0..InstanceCount] of TObjectInstance; end; var InstBlockList: PInstanceBlock; InstFreeList: PObjectInstance; { Standard window procedure } { In ECX = Address of method pointer } { Out EAX = Result } function StdWndProc(Window: HWND; Message, WParam: Longint; LParam: Longint): Longint; stdcall; assembler; asm XOR EAX,EAX PUSH EAX PUSH LParam PUSH WParam PUSH Message MOV EDX,ESP MOV EAX,[ECX].Longint[4] CALL [ECX].Pointer ADD ESP,12 POP EAX end; { Allocate an object instance } function CalcJmpOffset(Src, Dest: Pointer): Longint; begin Result := Longint(Dest) - (Longint(Src) + 5); end; function MakeObjectInstance(Method: TWndMethod): Pointer; const BlockCode: array[1..2] of Byte = ( $59, { POP ECX } $E9); { JMP StdWndProc } PageSize = 4096; var Block: PInstanceBlock; Instance: PObjectInstance; begin if InstFreeList = nil then begin Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE); Block^.Next := InstBlockList; Move(BlockCode, Block^.Code, SizeOf(BlockCode)); Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc)); Instance := @Block^.Instances; repeat Instance^.Code := $E8; { CALL NEAR PTR Offset } Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code); Instance^.Next := InstFreeList; InstFreeList := Instance; Inc(Longint(Instance), SizeOf(TObjectInstance)); until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock); InstBlockList := Block; end; Result := InstFreeList; Instance := InstFreeList; InstFreeList := Instance^.Next; Instance^.Method := Method; end; { Free an object instance } procedure FreeObjectInstance(ObjectInstance: Pointer); begin if ObjectInstance <> nil then begin PObjectInstance(ObjectInstance)^.Next := InstFreeList; InstFreeList := ObjectInstance; end; end; var UtilWindowClass: TWndClass = ( style: 0; lpfnWndProc: @DefWindowProc; cbClsExtra: 0; cbWndExtra: 0; hInstance: 0; hIcon: 0; hCursor: 0; hbrBackground: 0; lpszMenuName: nil; lpszClassName: 'TPUtilWindow'); function AllocateHWnd(Method: TWndMethod): HWND; var TempClass: TWndClass; ClassRegistered: Boolean; begin UtilWindowClass.hInstance := HInstance; {$IFDEF PIC} UtilWindowClass.lpfnWndProc := @DefWindowProc; {$ENDIF} ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName, TempClass); if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then begin if ClassRegistered then Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance); Windows.RegisterClass(UtilWindowClass); end; Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName, '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil); if Assigned(Method) then SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method))); end; procedure DeallocateHWnd(Wnd: HWND); var Instance: Pointer; begin Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC)); DestroyWindow(Wnd); if Instance <> @DefWindowProc then FreeObjectInstance(Instance); end; {$ENDIF} initialization InitializeCriticalSection(ThreadLock); AddModuleUnloadProc(ModuleUnload); GlobalNameSpace := TMultiReadExclusiveWriteSynchronizer.Create; RegGroups := TRegGroups.Create; IntConstList := TThreadList.Create; GlobalFixupList := TThreadList.Create; finalization UnRegisterModuleClasses(HInstance); GlobalNameSpace.BeginWrite; FreeIntConstList; RemoveFixupReferences(nil, ''); FreeAndNil(GlobalFixupList); FreeAndNil(GlobalLists); FreeAndNil(RegGroups); FreeAndNil(GlobalNameSpace); RemoveModuleUnloadProc(ModuleUnload); FreeAndNil(SyncList); DeleteCriticalSection(ThreadLock); FreeAndNil(FindGlobalComponentProcs); end.