From 1b445274981f5ff66ce2c46a69e019be3a67552c Mon Sep 17 00:00:00 2001 From: michael Date: Sun, 7 Jul 2019 18:36:49 +0000 Subject: [PATCH] * Implement (binary) streaming --- packages/rtl/classes.pas | 3977 ++++++++++++++++++++++++++++++++++-- packages/rtl/rtlconsts.pas | 14 + 2 files changed, 3868 insertions(+), 123 deletions(-) diff --git a/packages/rtl/classes.pas b/packages/rtl/classes.pas index f0a8150..48b7e22 100644 --- a/packages/rtl/classes.pas +++ b/packages/rtl/classes.pas @@ -17,7 +17,7 @@ unit Classes; interface uses - RTLConsts, Types, SysUtils, JS; + RTLConsts, Types, SysUtils, JS, TypInfo; type TNotifyEvent = procedure(Sender: TObject) of object; @@ -50,9 +50,13 @@ type TListStaticCallback = Types.TListStaticCallback; TAlignment = (taLeftJustify, taRightJustify, taCenter); - { TFPListEnumerator } + // Forward class definitions TFPList = Class; + TReader = Class; + TWriter = Class; + TFiler = Class; + { TFPListEnumerator } TFPListEnumerator = class private FList: TFPList; @@ -191,6 +195,7 @@ type //FObservers : TFPList; procedure AssignError(Source: TPersistent); protected + procedure DefineProperties(Filer: TFiler); virtual; procedure AssignTo(Dest: TPersistent); virtual; function GetOwner: TPersistent; virtual; public @@ -548,6 +553,7 @@ type procedure Remove(AComponent: TComponent); procedure RemoveNotification(AComponent: TComponent); procedure SetComponentIndex(Value: Integer); + procedure SetReference(Enable: Boolean); protected FComponentStyle: TComponentStyle; procedure ChangeName(const NewName: TComponentName); @@ -561,6 +567,7 @@ type procedure SetReading(Value: Boolean); virtual; procedure Notification(AComponent: TComponent; Operation: TOperation); virtual; procedure PaletteCreated; virtual; + procedure ReadState(Reader: TReader); virtual; procedure SetAncestor(Value: Boolean); procedure SetDesigning(Value: Boolean; SetChildren : Boolean = True); procedure SetDesignInstance(Value: Boolean); @@ -583,6 +590,7 @@ type procedure DestroyComponents; procedure Destroying; function QueryInterface(const IID: TGUID; out Obj): integer; virtual; + procedure WriteState(Writer: TWriter); virtual; // function ExecuteAction(Action: TBasicAction): Boolean; virtual; function FindComponent(const AName: string): TComponent; procedure FreeNotification(AComponent: TComponent); @@ -604,7 +612,7 @@ type property Owner: TComponent read FOwner; published property Name: TComponentName read FName write SetName stored False; - property Tag: PtrInt read FTag write FTag {default 0}; + property Tag: PtrInt read FTag write FTag default 0; end; TComponentClass = Class of TComponent; @@ -749,7 +757,7 @@ type procedure WriteBufferData(Buffer: Double); overload; procedure WriteBufferData(Buffer: Double; Count: NativeInt); overload; function CopyFrom(Source: TStream; Count: NativeInt): NativeInt; -{ function ReadComponent(Instance: TComponent): TComponent; + function ReadComponent(Instance: TComponent): TComponent; function ReadComponentRes(Instance: TComponent): TComponent; procedure WriteComponent(Instance: TComponent); procedure WriteComponentRes(const ResName: string; Instance: TComponent); @@ -757,7 +765,7 @@ type procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent); procedure WriteResourceHeader(const ResName: string; {!!!:out} var FixupInfo: Longint); procedure FixupResourceHeader(FixupInfo: Longint); - procedure ReadResHeader; } + procedure ReadResHeader; function ReadByte : Byte; function ReadWord : Word; function ReadDWord : Cardinal; @@ -816,7 +824,7 @@ type function Write(const Buffer: TBytes; Offset, Count: LongInt): LongInt; override; end; - { TBytesStream } +{ TBytesStream } TBytesStream = class(TMemoryStream) private @@ -826,13 +834,602 @@ type property Bytes: TBytes read GetBytes; end; + TFilerFlag = (ffInherited, ffChildPos, ffInline); + TFilerFlags = set of TFilerFlag; + + TReaderProc = procedure(Reader: TReader) of object; + TWriterProc = procedure(Writer: TWriter) of object; + TStreamProc = procedure(Stream: TStream) of object; + + TFiler = class(TObject) + private + FRoot: TComponent; + FLookupRoot: TComponent; + FAncestor: TPersistent; + FIgnoreChildren: Boolean; + protected + procedure SetRoot(ARoot: TComponent); virtual; + public + 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; + TValueType = ( + vaNull, vaList, vaInt8, vaInt16, vaInt32, vaDouble, + vaString, vaIdent, vaFalse, vaTrue, vaBinary, vaSet, + vaNil, vaCollection, vaCurrency, vaDate, vaNativeInt + ); + + { TAbstractObjectReader } + + TAbstractObjectReader = class + public + Procedure FlushBuffer; virtual; + function NextValue: TValueType; virtual; abstract; + function ReadValue: TValueType; virtual; abstract; + procedure BeginRootComponent; virtual; abstract; + procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer; + var CompClassName, CompName: String); virtual; abstract; + function BeginProperty: String; virtual; abstract; + + //Please don't use read, better use ReadBinary whenever possible + procedure Read(var Buffer : TBytes; Count: Longint); virtual;abstract; + + { All ReadXXX methods are called _after_ the value type has been read! } + procedure ReadBinary(const DestData: TMemoryStream); virtual; abstract; + function ReadFloat: Extended; virtual; abstract; + function ReadCurrency: Currency; virtual; abstract; + function ReadIdent(ValueType: TValueType): String; virtual; abstract; + function ReadInt8: ShortInt; virtual; abstract; + function ReadInt16: SmallInt; virtual; abstract; + function ReadInt32: LongInt; virtual; abstract; + function ReadNativeInt: NativeInt; virtual; abstract; + function ReadSet(EnumType: TTypeInfoEnum): Integer; virtual; abstract; + procedure ReadSignature; virtual; abstract; + function ReadStr: String; virtual; abstract; + function ReadString(StringType: TValueType): String; virtual; abstract; + function ReadWideString: WideString;virtual;abstract; + function ReadUnicodeString: UnicodeString;virtual;abstract; + procedure SkipComponent(SkipComponentInfos: Boolean); virtual; abstract; + procedure SkipValue; virtual; abstract; + end; + + { TBinaryObjectReader } + + TBinaryObjectReader = class(TAbstractObjectReader) + protected + FStream: TStream; + function ReadWord : word; + function ReadDWord : longword; + procedure SkipProperty; + procedure SkipSetBody; + public + constructor Create(Stream: TStream); + function NextValue: TValueType; override; + function ReadValue: TValueType; override; + procedure BeginRootComponent; override; + procedure BeginComponent(var Flags: TFilerFlags; var AChildPos: Integer; + var CompClassName, CompName: String); override; + function BeginProperty: String; override; + //Please don't use read, better use ReadBinary whenever possible + procedure Read(var Buffer : TBytes; Count: Longint); override; + procedure ReadBinary(const DestData: TMemoryStream); override; + function ReadFloat: Extended; override; + function ReadCurrency: Currency; override; + function ReadIdent(ValueType: TValueType): String; override; + function ReadInt8: ShortInt; override; + function ReadInt16: SmallInt; override; + function ReadInt32: LongInt; override; + function ReadNativeInt: NativeInt; override; + function ReadSet(EnumType: TTypeInfoEnum): Integer; override; + procedure ReadSignature; override; + function ReadStr: String; override; + function ReadString(StringType: TValueType): String; override; + function ReadWideString: WideString;override; + function ReadUnicodeString: UnicodeString;override; + procedure SkipComponent(SkipComponentInfos: Boolean); override; + procedure SkipValue; override; + end; + + + TFindMethodEvent = procedure(Reader: TReader; const MethodName: string; var Address: CodePointer; 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; + TPropertyNotFoundEvent = procedure(Reader: TReader; Instance: TPersistent; var PropName: string; IsPath: boolean; var Handled, Skip: 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; + + TSetMethodPropertyEvent = procedure(Reader: TReader; Instance: TPersistent; PropInfo: TTypeMemberProperty; const TheMethodName: string; + var Handled: boolean) of object; + TReadWriteStringPropertyEvent = procedure(Sender:TObject; const Instance: TPersistent; PropInfo: TTypeMemberProperty; var Content:string) of object; + + + { TReader } + + TReader = class(TFiler) + private + FDriver: TAbstractObjectReader; + FOwner: TComponent; + FParent: TComponent; + FFixups: TObject; + FLoaded: TFpList; + FOnFindMethod: TFindMethodEvent; + FOnSetMethodProperty: TSetMethodPropertyEvent; + FOnSetName: TSetNameEvent; + FOnReferenceName: TReferenceNameEvent; + FOnAncestorNotFound: TAncestorNotFoundEvent; + FOnError: TReaderError; + FOnPropertyNotFound: TPropertyNotFoundEvent; + FOnFindComponentClass: TFindComponentClassEvent; + FOnCreateComponent: TCreateComponentEvent; + FPropName: string; + FCanHandleExcepts: Boolean; + FOnReadStringProperty:TReadWriteStringPropertyEvent; + procedure DoFixupReferences; + function FindComponentClass(const AClassName: string): TComponentClass; + protected + function Error(const Message: string): Boolean; virtual; + function FindMethod(ARoot: TComponent; const AMethodName: string): CodePointer; virtual; + procedure ReadProperty(AInstance: TPersistent); + procedure ReadPropValue(Instance: TPersistent; PropInfo: TTypeMemberProperty); + procedure PropertyError; + procedure ReadData(Instance: TComponent); + property PropName: string read FPropName; + property CanHandleExceptions: Boolean read FCanHandleExcepts; + function CreateDriver(Stream: TStream): TAbstractObjectReader; virtual; + public + constructor Create(Stream: TStream); + destructor Destroy; override; + Procedure FlushBuffer; override; + procedure BeginReferences; + procedure CheckValue(Value: TValueType); + procedure DefineProperty(const Name: string; + AReadData: TReaderProc; WriteData: TWriterProc; + HasData: Boolean); override; + procedure DefineBinaryProperty(const Name: string; + AReadData, WriteData: TStreamProc; + HasData: Boolean); override; + function EndOfList: Boolean; + procedure EndReferences; + procedure FixupReferences; + function NextValue: TValueType; + //Please don't use read, better use ReadBinary whenever possible + //uuups, ReadBinary is protected .. + procedure Read(var Buffer : TBytes; Count: LongInt); virtual; + + function ReadBoolean: Boolean; + function ReadChar: Char; + function ReadWideChar: WideChar; + function ReadUnicodeChar: UnicodeChar; + procedure ReadCollection(Collection: TCollection); + function ReadComponent(Component: TComponent): TComponent; + procedure ReadComponents(AOwner, AParent: TComponent; + Proc: TReadComponentsProc); + function ReadFloat: Extended; + function ReadCurrency: Currency; + function ReadIdent: string; + function ReadInteger: Longint; + function ReadNativeInt: NativeInt; + function ReadSet(EnumType: Pointer): Integer; + procedure ReadListBegin; + procedure ReadListEnd; + function ReadRootComponent(ARoot: TComponent): TComponent; + function ReadVariant: JSValue; + procedure ReadSignature; + function ReadString: string; + function ReadWideString: WideString; + function ReadUnicodeString: UnicodeString; + function ReadValue: TValueType; + procedure CopyValue(Writer: TWriter); + property Driver: TAbstractObjectReader read FDriver; + property Owner: TComponent read FOwner write FOwner; + property Parent: TComponent read FParent write FParent; + property OnError: TReaderError read FOnError write FOnError; + property OnPropertyNotFound: TPropertyNotFoundEvent read FOnPropertyNotFound write FOnPropertyNotFound; + property OnFindMethod: TFindMethodEvent read FOnFindMethod write FOnFindMethod; + property OnSetMethodProperty: TSetMethodPropertyEvent read FOnSetMethodProperty write FOnSetMethodProperty; + 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; + property OnReadStringProperty: TReadWriteStringPropertyEvent read FOnReadStringProperty write FOnReadStringProperty; + end; + + + { TAbstractObjectWriter } + + TAbstractObjectWriter = class + public + { Begin/End markers. Those ones who don't have an end indicator, use + "EndList", after the occurrence named in the comment. Note that this + only counts for "EndList" calls on the same level; each BeginXXX call + increases the current level. } + procedure BeginCollection; virtual; abstract; { Ends with the next "EndList" } + procedure BeginComponent(Component: TComponent; Flags: TFilerFlags; + ChildPos: Integer); virtual; abstract; { Ends after the second "EndList" } + procedure WriteSignature; virtual; abstract; + procedure BeginList; virtual; abstract; + procedure EndList; virtual; abstract; + procedure BeginProperty(const PropName: String); virtual; abstract; + procedure EndProperty; virtual; abstract; + //Please don't use write, better use WriteBinary whenever possible + procedure Write(const Buffer : TBytes; Count: Longint); virtual;abstract; + Procedure FlushBuffer; virtual; abstract; + + procedure WriteBinary(const Buffer : TBytes; Count: Longint); virtual; abstract; + procedure WriteBoolean(Value: Boolean); virtual; abstract; + // procedure WriteChar(Value: Char); + procedure WriteFloat(const Value: Extended); virtual; abstract; + procedure WriteCurrency(const Value: Currency); virtual; abstract; + procedure WriteIdent(const Ident: string); virtual; abstract; + procedure WriteInteger(Value: NativeInt); virtual; abstract; + procedure WriteNativeInt(Value: NativeInt); virtual; abstract; + procedure WriteVariant(const Value: JSValue); virtual; abstract; + procedure WriteMethodName(const Name: String); virtual; abstract; + procedure WriteSet(Value: LongInt; SetType: Pointer); virtual; abstract; + procedure WriteString(const Value: String); virtual; abstract; + procedure WriteWideString(const Value: WideString);virtual;abstract; + procedure WriteUnicodeString(const Value: UnicodeString);virtual;abstract; + end; + + { TBinaryObjectWriter } + + TBinaryObjectWriter = class(TAbstractObjectWriter) + protected + FStream: TStream; + FBuffer: Pointer; + FBufSize: Integer; + FBufPos: Integer; + FBufEnd: Integer; + procedure WriteWord(w : word); + procedure WriteDWord(lw : longword); + procedure WriteValue(Value: TValueType); + public + constructor Create(Stream: TStream); + procedure WriteSignature; override; + procedure BeginCollection; override; + procedure BeginComponent(Component: TComponent; Flags: TFilerFlags; + ChildPos: Integer); override; + procedure BeginList; override; + procedure EndList; override; + procedure BeginProperty(const PropName: String); override; + procedure EndProperty; override; + Procedure FlushBuffer; override; + + //Please don't use write, better use WriteBinary whenever possible + procedure Write(const Buffer : TBytes; Count: Longint); override; + procedure WriteBinary(const Buffer : TBytes; Count: LongInt); override; + procedure WriteBoolean(Value: Boolean); override; + procedure WriteFloat(const Value: Extended); override; + procedure WriteCurrency(const Value: Currency); override; + procedure WriteIdent(const Ident: string); override; + procedure WriteInteger(Value: NativeInt); override; + procedure WriteNativeInt(Value: NativeInt); override; + procedure WriteMethodName(const Name: String); override; + procedure WriteSet(Value: LongInt; SetType: Pointer); override; + procedure WriteStr(const Value: String); + procedure WriteString(const Value: String); override; + procedure WriteWideString(const Value: WideString); override; + procedure WriteUnicodeString(const Value: UnicodeString); override; + procedure WriteVariant(const VarValue: JSValue);override; + end; + + TFindAncestorEvent = procedure (Writer: TWriter; Component: TComponent; + const Name: string; var Ancestor, RootAncestor: TComponent) of object; + TWriteMethodPropertyEvent = procedure (Writer: TWriter; Instance: TPersistent; + PropInfo: TTypeMemberProperty; + const MethodValue, DefMethodValue: TMethod; + var Handled: boolean) of object; + + { TWriter } + + TWriter = class(TFiler) + private + FDriver: TAbstractObjectWriter; + FDestroyDriver: Boolean; + FRootAncestor: TComponent; + FPropPath: String; + FAncestors: TStringList; + FAncestorPos: Integer; + FCurrentPos: Integer; + FOnFindAncestor: TFindAncestorEvent; + FOnWriteMethodProperty: TWriteMethodPropertyEvent; + FOnWriteStringProperty:TReadWriteStringPropertyEvent; + procedure AddToAncestorList(Component: TComponent); + procedure WriteComponentData(Instance: TComponent); + Procedure DetermineAncestor(Component: TComponent); + procedure DoFindAncestor(Component : TComponent); + protected + procedure SetRoot(ARoot: TComponent); override; + procedure WriteBinary(AWriteData: TStreamProc); + procedure WriteProperty(Instance: TPersistent; PropInfo: TTypeMemberProperty); + procedure WriteProperties(Instance: TPersistent); + procedure WriteChildren(Component: TComponent); + function CreateDriver(Stream: TStream): TAbstractObjectWriter; virtual; + public + constructor Create(ADriver: TAbstractObjectWriter); + constructor Create(Stream: TStream); + destructor Destroy; override; + procedure DefineProperty(const Name: string; + ReadData: TReaderProc; AWriteData: TWriterProc; + HasData: Boolean); override; + procedure DefineBinaryProperty(const Name: string; + ReadData, AWriteData: TStreamProc; + HasData: Boolean); override; + Procedure FlushBuffer; override; + procedure Write(const Buffer : TBytes; Count: Longint); virtual; + procedure WriteBoolean(Value: Boolean); + procedure WriteCollection(Value: TCollection); + procedure WriteComponent(Component: TComponent); + procedure WriteChar(Value: Char); + procedure WriteWideChar(Value: WideChar); + procedure WriteDescendent(ARoot: TComponent; AAncestor: TComponent); + procedure WriteFloat(const Value: Extended); + procedure WriteCurrency(const Value: Currency); + procedure WriteIdent(const Ident: string); + procedure WriteInteger(Value: Longint); overload; + procedure WriteInteger(Value: NativeInt); overload; + procedure WriteSet(Value: LongInt; SetType: Pointer); + procedure WriteListBegin; + procedure WriteListEnd; + Procedure WriteSignature; + procedure WriteRootComponent(ARoot: TComponent); + procedure WriteString(const Value: string); + procedure WriteWideString(const Value: WideString); + procedure WriteUnicodeString(const Value: UnicodeString); + procedure WriteVariant(const VarValue: JSValue); + property RootAncestor: TComponent read FRootAncestor write FRootAncestor; + property OnFindAncestor: TFindAncestorEvent read FOnFindAncestor write FOnFindAncestor; + property OnWriteMethodProperty: TWriteMethodPropertyEvent read FOnWriteMethodProperty write FOnWriteMethodProperty; + property OnWriteStringProperty: TReadWriteStringPropertyEvent read FOnWriteStringProperty write FOnWriteStringProperty; + + property Driver: TAbstractObjectWriter read FDriver; + property PropertyPath: string read FPropPath; + end; + +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; + TInitComponentHandler = function(Instance: TComponent; RootAncestor : TClass): boolean; + +procedure RegisterInitComponentHandler(ComponentClass: TComponentClass; Handler: TInitComponentHandler); Procedure RegisterClass(AClass : TPersistentClass); Function GetClass(AClassName : string) : TPersistentClass; +procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); +procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); +function FindGlobalComponent(const Name: string): TComponent; +Function FindNestedComponent(Root : TComponent; APath : String; CStyle : Boolean = True) : TComponent; +procedure RedirectFixupReferences(Root: TComponent; const OldRootName, NewRootName: string); +procedure RemoveFixupReferences(Root: TComponent; const RootName: string); +procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt; IntToIdentFn: TIntToIdent); +function IdentToInt(const Ident: string; out 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 FindClass(const AClassName: string): TPersistentClass; +function CollectionsEqual(C1, C2: TCollection): Boolean; +function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean; +procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings); +procedure GetFixupInstanceNames(Root: TComponent; const ReferenceRootName: string; Names: TStrings); + +Const + vaSingle = vaDouble; + vaExtended = vaDouble; + vaLString = vaString; + vaUTF8String = vaString; + vaUString = vaString; + vaWString = vaString; + vaQWord = vaNativeInt; + vaInt64 = vaNativeInt; implementation +uses simplelinkedlist; + +var + GlobalLoaded, + IntConstList: TFPList; + +type + TIntConst = class + Private + IntegerType: PTypeInfo; // The integer type RTTI pointer + IdentToIntFn: TIdentToInt; // Identifier to Integer conversion + IntToIdentFn: TIntToIdent; // Integer to Identifier conversion + Public + constructor Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt; + AIntToIdent: TIntToIdent); + end; + +constructor TIntConst.Create(AIntegerType: PTypeInfo; AIdentToInt: TIdentToInt; + AIntToIdent: TIntToIdent); +begin + IntegerType := AIntegerType; + IdentToIntFn := AIdentToInt; + IntToIdentFn := AIntToIdent; +end; + +procedure RegisterIntegerConsts(IntegerType: Pointer; IdentToIntFn: TIdentToInt; + IntToIdentFn: TIntToIdent); +begin + if Not Assigned(IntConstList) then + IntConstList:=TFPList.Create; + IntConstList.Add(TIntConst.Create(IntegerType, IdentToIntFn, IntToIdentFn)); +end; + +function FindIntToIdent(AIntegerType: Pointer): TIntToIdent; + +var + i: Integer; + +begin + Result := nil; + if Not Assigned(IntConstList) then + exit; + with IntConstList do + for i := 0 to Count - 1 do + if TIntConst(Items[i]).IntegerType = AIntegerType then + exit(TIntConst(Items[i]).IntToIdentFn); +end; + +function FindIdentToInt(AIntegerType: Pointer): TIdentToInt; +var + i: Integer; +begin + Result := nil; + if Not Assigned(IntConstList) then + exit; + with IntConstList do + for i := 0 to Count - 1 do + with TIntConst(Items[I]) do + if TIntConst(Items[I]).IntegerType = AIntegerType then + exit(IdentToIntFn); +end; + +function IdentToInt(const Ident: String; out Int: LongInt; + const Map: array of TIdentMapEntry): Boolean; +var + i: Integer; +begin + for i := Low(Map) to High(Map) do + if CompareText(Map[i].Name, Ident) = 0 then + begin + Int := Map[i].Value; + exit(True); + 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 + Ident := Map[i].Name; + exit(True); + end; + Result := False; +end; + +function GlobalIdentToInt(const Ident: String; var Int: LongInt):boolean; +var + i : Integer; +begin + Result := false; + if Not Assigned(IntConstList) then + exit; + with IntConstList do + for i := 0 to Count - 1 do + if TIntConst(Items[I]).IdentToIntFn(Ident, Int) then + Exit(True); +end; + +function FindClass(const AClassName: string): TPersistentClass; + +begin + Result := GetClass(AClassName); + if not Assigned(Result) then + raise EClassNotFound.CreateFmt(SClassNotFound, [AClassName]); +end; + + +function CollectionsEqual(C1, C2: TCollection): Boolean; + +Var + Comp1,Comp2 : TComponent; + +begin + Comp2:=Nil; + Comp1:=TComponent.Create; + try + Result:=CollectionsEqual(C1,C2,Comp1,Comp2); + finally + Comp1.Free; + Comp2.Free; + end; +end; + +function CollectionsEqual(C1, C2: TCollection; Owner1, Owner2: TComponent): Boolean; + + procedure stream_collection(s : tstream;c : tcollection;o : tcomponent); + var + w : twriter; + begin + w:=twriter.create(s); + try + w.root:=o; + w.flookuproot:=o; + w.writecollection(c); + finally + w.free; + end; + end; + + var + s1,s2 : tbytesstream; + b1,b2 : TBytes; + I,Len : Integer; + begin + result:=false; + if (c1.classtype<>c2.classtype) or + (c1.count<>c2.count) then + exit; + if c1.count = 0 then + begin + result:= true; + exit; + end; + s2:=Nil; + s1:=tbytesstream.create; + try + s2:=tbytesstream.create; + stream_collection(s1,c1,owner1); + stream_collection(s2,c2,owner2); + result:=(s1.size=s2.size); + if Result then + begin + b1:=S1.Bytes; + b2:=S2.Bytes; + I:=0; + Len:=S1.Size; // Not length of B + While Result and (Inil then @@ -3524,7 +4127,7 @@ begin end; -Procedure TComponent.SetComponentIndex(Value: Integer); +procedure TComponent.SetComponentIndex(Value: Integer); Var Temp,Count : longint; @@ -3543,14 +4146,14 @@ begin end; -Procedure TComponent.ChangeName(const NewName: TComponentName); +procedure TComponent.ChangeName(const NewName: TComponentName); begin FName:=NewName; end; -Procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent); +procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent); begin // Does nothing. @@ -3559,41 +4162,41 @@ begin end; -Function TComponent.GetChildOwner: TComponent; +function TComponent.GetChildOwner: TComponent; begin Result:=Nil; end; -Function TComponent.GetChildParent: TComponent; +function TComponent.GetChildParent: TComponent; begin Result:=Self; end; -Function TComponent.GetNamePath: string; +function TComponent.GetNamePath: string; begin Result:=FName; end; -Function TComponent.GetOwner: TPersistent; +function TComponent.GetOwner: TPersistent; begin Result:=FOwner; end; -Procedure TComponent.Loaded; +procedure TComponent.Loaded; begin Exclude(FComponentState,csLoading); end; -Procedure TComponent.Loading; +procedure TComponent.Loading; begin Include(FComponentState,csLoading); @@ -3616,8 +4219,7 @@ begin end; -Procedure TComponent.Notification(AComponent: TComponent; - Operation: TOperation); +procedure TComponent.Notification(AComponent: TComponent; Operation: TOperation); Var C : Longint; @@ -3642,9 +4244,14 @@ procedure TComponent.PaletteCreated; begin end; +procedure TComponent.ReadState(Reader: TReader); + +begin + Reader.ReadData(Self); +end; -Procedure TComponent.SetAncestor(Value: Boolean); +procedure TComponent.SetAncestor(Value: Boolean); Var Runner : Longint; @@ -3659,7 +4266,7 @@ begin end; -Procedure TComponent.SetDesigning(Value: Boolean; SetChildren : Boolean = True); +procedure TComponent.SetDesigning(Value: Boolean; SetChildren: Boolean); Var Runner : Longint; @@ -3673,7 +4280,7 @@ begin TComponent(FComponents.items[Runner]).SetDesigning(Value); end; -Procedure TComponent.SetDesignInstance(Value: Boolean); +procedure TComponent.SetDesignInstance(Value: Boolean); begin If Value then @@ -3682,7 +4289,7 @@ begin Exclude(FComponentState,csDesignInstance); end; -Procedure TComponent.SetInline(Value: Boolean); +procedure TComponent.SetInline(Value: Boolean); begin If Value then @@ -3692,7 +4299,7 @@ begin end; -Procedure TComponent.SetName(const NewName: TComponentName); +procedure TComponent.SetName(const NewName: TComponentName); begin If FName=NewName then exit; @@ -3702,11 +4309,13 @@ begin FOwner.ValidateRename(Self,FName,NewName) else ValidateRename(Nil,FName,NewName); + SetReference(False); ChangeName(NewName); + SetReference(True); end; -Procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer); +procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer); begin // does nothing @@ -3715,7 +4324,7 @@ begin end; -Procedure TComponent.SetParentComponent(Value: TComponent); +procedure TComponent.SetParentComponent(Value: TComponent); begin // Does nothing @@ -3723,22 +4332,21 @@ begin end; -Procedure TComponent.Updating; +procedure TComponent.Updating; begin Include (FComponentState,csUpdating); end; -Procedure TComponent.Updated; +procedure TComponent.Updated; begin Exclude(FComponentState,csUpdating); end; -Procedure TComponent.ValidateRename(AComponent: TComponent; - const CurName, NewName: string); +procedure TComponent.ValidateRename(AComponent: TComponent; const CurName, NewName: string); begin //!! This contradicts the Delphi manual. @@ -3749,15 +4357,40 @@ begin FOwner.ValidateRename(AComponent,Curname,Newname); end; +Procedure TComponent.SetReference(Enable: Boolean); -Procedure TComponent.ValidateContainer(AComponent: TComponent); +var + aField, aValue, aOwner : Pointer; + +begin + if Name='' then + exit; + if Assigned(Owner) then + begin + aOwner:=Owner; // so as not to depend on low-level names + aField := Owner.FieldAddress(Name); + if Assigned(aField) then + begin + if Enable then + aValue:= Self + else + aValue := nil; + asm + aOwner[aField.name]=aValue; + end; + end; + end; +end; + + +procedure TComponent.ValidateContainer(AComponent: TComponent); begin AComponent.ValidateInsert(Self); end; -Procedure TComponent.ValidateInsert(AComponent: TComponent); +procedure TComponent.ValidateInsert(AComponent: TComponent); begin // Does nothing. @@ -3775,7 +4408,7 @@ begin end; -Constructor TComponent.Create(AOwner: TComponent); +constructor TComponent.Create(AOwner: TComponent); begin FComponentStyle:=[csInheritable]; @@ -3783,7 +4416,7 @@ begin end; -Destructor TComponent.Destroy; +destructor TComponent.Destroy; Var I : Integer; @@ -3814,14 +4447,14 @@ begin end; -Procedure TComponent.BeforeDestruction; +procedure TComponent.BeforeDestruction; begin if not(csDestroying in FComponentstate) then Destroying; end; -Procedure TComponent.DestroyComponents; +procedure TComponent.DestroyComponents; Var acomponent: TComponent; @@ -3835,7 +4468,7 @@ begin end; -Procedure TComponent.Destroying; +procedure TComponent.Destroying; Var Runner : longint; @@ -3856,8 +4489,13 @@ begin end; +procedure TComponent.WriteState(Writer: TWriter); +begin + Writer.WriteComponentData(Self); +end; -Function TComponent.FindComponent(const AName: string): TComponent; + +function TComponent.FindComponent(const AName: string): TComponent; Var I : longint; @@ -3873,7 +4511,7 @@ begin end; -Procedure TComponent.FreeNotification(AComponent: TComponent); +procedure TComponent.FreeNotification(AComponent: TComponent); begin If (Owner<>Nil) and (AComponent=Owner) then exit; @@ -3894,21 +4532,21 @@ begin end; -Function TComponent.GetParentComponent: TComponent; +function TComponent.GetParentComponent: TComponent; begin Result:=Nil; end; -Function TComponent.HasParent: Boolean; +function TComponent.HasParent: Boolean; begin Result:=False; end; -Procedure TComponent.InsertComponent(AComponent: TComponent); +procedure TComponent.InsertComponent(AComponent: TComponent); begin AComponent.ValidateContainer(Self); @@ -3920,7 +4558,7 @@ begin end; -Procedure TComponent.RemoveComponent(AComponent: TComponent); +procedure TComponent.RemoveComponent(AComponent: TComponent); begin Notification(AComponent,opRemove); @@ -4833,100 +5471,94 @@ begin 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; +var + Reader: TReader; +begin + Reader := TReader.Create(Self); + try + Result := Reader.ReadRootComponent(Instance); + finally + Reader.Free; end; +end; function TStream.ReadComponentRes(Instance: TComponent): TComponent; - begin - - ReadResHeader; - Result := ReadComponent(Instance); - - end; +begin + ReadResHeader; + Result := ReadComponent(Instance); +end; procedure TStream.WriteComponent(Instance: TComponent); - begin - - WriteDescendent(Instance, nil); - - end; +begin + WriteDescendent(Instance, nil); +end; procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent); - begin - - WriteDescendentRes(ResName, Instance, nil); - - end; +begin + WriteDescendentRes(ResName, Instance, nil); +end; procedure TStream.WriteDescendent(Instance, Ancestor: TComponent); - var - Driver : TAbstractObjectWriter; - Writer : TWriter; - - begin - - Driver := TBinaryObjectWriter.Create(Self, 4096); - Try - Writer := TWriter.Create(Driver); - Try - Writer.WriteDescendent(Instance, Ancestor); - Finally - Writer.Destroy; - end; - Finally - Driver.Free; - end; +var + Driver : TAbstractObjectWriter; + Writer : TWriter; +begin + Driver := TBinaryObjectWriter.Create(Self); + Try + Writer := TWriter.Create(Driver); + Try + Writer.WriteDescendent(Instance, Ancestor); + Finally + Writer.Destroy; + end; + Finally + Driver.Free; end; +end; procedure TStream.WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent); - var - FixupInfo: Longint; +var + FixupInfo: Longint; - begin - - { Write a resource header } - WriteResourceHeader(ResName, FixupInfo); - { Write the instance itself } - WriteDescendent(Instance, Ancestor); - { Insert the correct resource size into the resource header } - FixupResourceHeader(FixupInfo); - - end; +begin + { Write a resource header } + WriteResourceHeader(ResName, FixupInfo); + { Write the instance itself } + WriteDescendent(Instance, Ancestor); + { Insert the correct resource size into the resource header } + FixupResourceHeader(FixupInfo); +end; procedure TStream.WriteResourceHeader(const ResName: string; {!!!: out} var FixupInfo: Longint); var ResType, Flags : word; + B : Byte; + I : Integer; + begin - ResType:=NtoLE(word($000A)); - Flags:=NtoLE(word($1030)); + ResType:=Word($000A); + Flags:=Word($1030); { Note: This is a Windows 16 bit resource } { Numeric resource type } WriteByte($ff); { Application defined data } WriteWord(ResType); { write the name as asciiz } - WriteBuffer(ResName[1],length(ResName)); + For I:=1 to Length(ResName) do + begin + B:=Ord(ResName[i]); + WriteByte(B); + end; WriteByte(0); { Movable, Pure and Discardable } WriteWord(Flags); @@ -4939,22 +5571,22 @@ procedure TStream.WriteResourceHeader(const ResName: string; {!!!: out} var Fixu procedure TStream.FixupResourceHeader(FixupInfo: Longint); - var - ResSize,TmpResSize : Longint; +var + ResSize,TmpResSize : Longint; - begin +begin - ResSize := Position - FixupInfo; - TmpResSize := NtoLE(longword(ResSize)); + ResSize := Position - FixupInfo; + TmpResSize := longword(ResSize); - { Insert the correct resource size into the placeholder written by - WriteResourceHeader } - Position := FixupInfo - 4; - WriteDWord(TmpResSize); - { Seek back to the end of the resource } - Position := FixupInfo + ResSize; + { Insert the correct resource size into the placeholder written by + WriteResourceHeader } + Position := FixupInfo - 4; + WriteDWord(TmpResSize); + { Seek back to the end of the resource } + Position := FixupInfo + ResSize; - end; +end; procedure TStream.ReadResHeader; var @@ -4965,14 +5597,14 @@ procedure TStream.ReadResHeader; { application specific resource ? } if ReadByte<>$ff then raise EInvalidImage.Create(SInvalidImage); - ResType:=LEtoN(ReadWord); + ResType:=ReadWord; if ResType<>$000a then raise EInvalidImage.Create(SInvalidImage); { read name } while ReadByte<>0 do ; { check the access specifier } - Flags:=LEtoN(ReadWord); + Flags:=ReadWord; if Flags<>$1030 then raise EInvalidImage.Create(SInvalidImage); { ignore the size } @@ -4984,7 +5616,7 @@ procedure TStream.ReadResHeader; raise EInvalidImage.create(SInvalidImage); end; end; -*) + function TStream.ReadByte : Byte; @@ -5277,6 +5909,2984 @@ begin Result:=TMemoryStream.MemoryToBytes(Memory); end; +{ ********************************************************************* + * TFiler * + *********************************************************************} + +procedure TFiler.SetRoot(ARoot: TComponent); +begin + FRoot := ARoot; +end; + + +{ + This file is part of the Free Component Library (FCL) + Copyright (c) 1999-2000 by the Free Pascal development team + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + +{****************************************************************************} +{* TBinaryObjectReader *} +{****************************************************************************} + + +function TBinaryObjectReader.ReadWord : word; +begin + FStream.ReadBufferData(Result); +end; + +function TBinaryObjectReader.ReadDWord : longword; +begin + FStream.ReadBufferData(Result); +end; + + +constructor TBinaryObjectReader.Create(Stream: TStream); +begin + inherited Create; + If (Stream=Nil) then + Raise EReadError.Create(SEmptyStreamIllegalReader); + FStream := Stream; +end; + +function TBinaryObjectReader.ReadValue: TValueType; +var + b: byte; +begin + FStream.ReadBufferData(b); + Result := TValueType(b); +end; + +function TBinaryObjectReader.NextValue: TValueType; +begin + Result := ReadValue; + { We only 'peek' at the next value, so seek back to unget the read value: } + FStream.Seek(-1,soCurrent); +end; + +procedure TBinaryObjectReader.BeginRootComponent; +begin + { Read filer signature } + ReadSignature; +end; + +procedure TBinaryObjectReader.BeginComponent(var Flags: TFilerFlags; + var AChildPos: Integer; var CompClassName, CompName: String); +var + Prefix: Byte; + ValueType: TValueType; +begin + { Every component can start with a special prefix: } + Flags := []; + if (Byte(NextValue) and $f0) = $f0 then + begin + Prefix := Byte(ReadValue); + Flags:=[]; + if (Prefix and $01)<>0 then + Include(Flags,ffInherited); + if (Prefix and $02)<>0 then + Include(Flags,ffChildPos); + if (Prefix and $04)<>0 then + Include(Flags,ffInline); + if ffChildPos in Flags then + begin + ValueType := ReadValue; + case ValueType of + vaInt8: + AChildPos := ReadInt8; + vaInt16: + AChildPos := ReadInt16; + vaInt32: + AChildPos := ReadInt32; + vaNativeInt: + AChildPos := ReadNativeInt; + else + raise EReadError.Create(SInvalidPropertyValue); + end; + end; + end; + + CompClassName := ReadStr; + CompName := ReadStr; +end; + +function TBinaryObjectReader.BeginProperty: String; +begin + Result := ReadStr; +end; + +procedure TBinaryObjectReader.Read(var Buffer: TBytes; Count: Longint); +begin + FStream.Read(Buffer,Count); +end; + +procedure TBinaryObjectReader.ReadBinary(const DestData: TMemoryStream); +var + BinSize: LongInt; +begin + BinSize:=LongInt(ReadDWord); + DestData.Size := BinSize; + DestData.CopyFrom(FStream,BinSize); +end; + +function TBinaryObjectReader.ReadFloat: Extended; +begin + FStream.ReadBufferData(Result); +end; + +function TBinaryObjectReader.ReadCurrency: Currency; + +begin + Result:=ReadFloat; +end; + +function TBinaryObjectReader.ReadIdent(ValueType: TValueType): String; +var + i: Byte; + c : Char; +begin + case ValueType of + vaIdent: + begin + FStream.ReadBufferData(i); + SetLength(Result,i); + For I:=1 to Length(Result) do + begin + FStream.ReadBufferData(C); + Result[I]:=C; + end; + end; + vaNil: + Result := 'nil'; + vaFalse: + Result := 'False'; + vaTrue: + Result := 'True'; + vaNull: + Result := 'Null'; + end; +end; + +function TBinaryObjectReader.ReadInt8: ShortInt; +begin + FStream.ReadBufferData(Result); +end; + +function TBinaryObjectReader.ReadInt16: SmallInt; +begin + FStream.ReadBufferData(Result); +end; + +function TBinaryObjectReader.ReadInt32: LongInt; +begin + FStream.ReadBufferData(Result); +end; + +function TBinaryObjectReader.ReadNativeInt : NativeInt; +begin + FStream.ReadBufferData(Result); +end; + + +function TBinaryObjectReader.ReadSet(EnumType: TTypeInfoEnum): Integer; + +var + Name: String; + Value: Integer; + +begin + try + Result := 0; + while True do + begin + Name := ReadStr; + if Length(Name) = 0 then + break; + Value:=EnumType.EnumType.NameToInt[Name]; + if Value=-1 then + raise EReadError.Create(SInvalidPropertyValue); + Result:=Result or (1 shl Value); + end; + except + SkipSetBody; + raise; + end; +end; + + +Const + // Integer version of 4 chars 'TPF0' + FilerSignatureInt = 809914452; + +procedure TBinaryObjectReader.ReadSignature; + +var + Signature: LongInt; + +begin + FStream.ReadBufferData(Signature); + if Signature <> FilerSignatureInt then + raise EReadError.Create(SInvalidImage); +end; + +function TBinaryObjectReader.ReadStr: String; +var + l,i: Byte; + c : Char; +begin + FStream.ReadBufferData(L); + SetLength(Result,L); + For I:=1 to L do + begin + FStream.ReadBufferData(C); + Result[i]:=C; + end; +end; + +function TBinaryObjectReader.ReadString(StringType: TValueType): String; +var + i: Integer; + C : Char; + +begin + Result:=''; + if StringType<>vaString then + Raise EFilerError.Create('Invalid string type passed to ReadString'); + i:=ReadDWord; + SetLength(Result, i); + for I:=1 to Length(Result) do + begin + FStream.ReadbufferData(C); + Result[i]:=C; + end; +end; + + +function TBinaryObjectReader.ReadWideString: WideString; +begin + Result:=ReadString(vaWString); +end; + +function TBinaryObjectReader.ReadUnicodeString: UnicodeString; + +begin + Result:=ReadString(vaWString); +end; + +procedure TBinaryObjectReader.SkipComponent(SkipComponentInfos: Boolean); +var + Flags: TFilerFlags; + Dummy: Integer; + CompClassName, CompName: String; +begin + if SkipComponentInfos then + { Skip prefix, component class name and component object name } + BeginComponent(Flags, Dummy, CompClassName, CompName); + + { Skip properties } + while NextValue <> vaNull do + SkipProperty; + ReadValue; + + { Skip children } + while NextValue <> vaNull do + SkipComponent(True); + ReadValue; +end; + +procedure TBinaryObjectReader.SkipValue; + + procedure SkipBytes(Count: LongInt); + var + Dummy: TBytes; + SkipNow: Integer; + begin + while Count > 0 do + begin + if Count > 1024 then + SkipNow := 1024 + else + SkipNow := Count; + SetLength(Dummy,SkipNow); + Read(Dummy, SkipNow); + Dec(Count, SkipNow); + end; + end; + +var + Count: LongInt; +begin + case ReadValue of + vaNull, vaFalse, vaTrue, vaNil: ; + vaList: + begin + while NextValue <> vaNull do + SkipValue; + ReadValue; + end; + vaInt8: + SkipBytes(1); + vaInt16: + SkipBytes(2); + vaInt32: + SkipBytes(4); + vaInt64, + vaDouble: + SkipBytes(8); + vaString, vaIdent: + ReadStr; + vaBinary: + begin + Count:=LongInt(ReadDWord); + SkipBytes(Count); + end; + vaSet: + SkipSetBody; + vaCollection: + begin + while NextValue <> vaNull do + begin + { Skip the order value if present } + if NextValue in [vaInt8, vaInt16, vaInt32] then + SkipValue; + SkipBytes(1); + while NextValue <> vaNull do + SkipProperty; + ReadValue; + end; + ReadValue; + end; + end; +end; + +{ private methods } + + +procedure TBinaryObjectReader.SkipProperty; +begin + { Skip property name, then the property value } + ReadStr; + SkipValue; +end; + +procedure TBinaryObjectReader.SkipSetBody; +begin + while Length(ReadStr) > 0 do; +end; + + + // Quadruple representing an unresolved component property. +Type + { TUnresolvedReference } + + TUnresolvedReference = class(TlinkedListItem) + Private + FRoot: TComponent; // Root component when streaming + FPropInfo: TTypeMemberProperty; // Property to set. + FGlobal, // Global component. + FRelative : string; // Path relative to global component. + Function Resolve(Instance : TPersistent) : Boolean; // Resolve this reference + Function RootMatches(ARoot : TComponent) : Boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} // True if Froot matches or ARoot is nil. + Function NextRef : TUnresolvedReference; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} + end; + + TLocalUnResolvedReference = class(TUnresolvedReference) + Finstance : TPersistent; + end; + + // Linked list of TPersistent items that have unresolved properties. + + { TUnResolvedInstance } + + TUnResolvedInstance = Class(TLinkedListItem) + Public + Instance : TPersistent; // Instance we're handling unresolveds for + FUnresolved : TLinkedList; // The list + Destructor Destroy; override; + Function AddReference(ARoot : TComponent; APropInfo : TTypeMemberProperty; AGlobal,ARelative : String) : TUnresolvedReference; + Function RootUnresolved : TUnresolvedReference; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} // Return root element in list. + Function ResolveReferences : Boolean; // Return true if all unresolveds were resolved. + end; + + // Builds a list of TUnResolvedInstances, removes them from global list on free. + TBuildListVisitor = Class(TLinkedListVisitor) + Private + List : TFPList; + Public + Procedure Add(Item : TlinkedListItem); // Add TUnResolvedInstance item to list. Create list if needed + Destructor Destroy; override; // All elements in list (if any) are removed from the global list. + end; + + // Visitor used to try and resolve instances in the global list + TResolveReferenceVisitor = Class(TBuildListVisitor) + Function Visit(Item : TLinkedListItem) : Boolean; override; + end; + + // Visitor used to remove all references to a certain component. + TRemoveReferenceVisitor = Class(TBuildListVisitor) + Private + FRef : String; + FRoot : TComponent; + Public + Constructor Create(ARoot : TComponent;Const ARef : String); + Function Visit(Item : TLinkedListItem) : Boolean; override; + end; + + // Visitor used to collect reference names. + TReferenceNamesVisitor = Class(TLinkedListVisitor) + Private + FList : TStrings; + FRoot : TComponent; + Public + Function Visit(Item : TLinkedListItem) : Boolean; override; + Constructor Create(ARoot : TComponent;AList : TStrings); + end; + + // Visitor used to collect instance names. + TReferenceInstancesVisitor = Class(TLinkedListVisitor) + Private + FList : TStrings; + FRef : String; + FRoot : TComponent; + Public + Function Visit(Item : TLinkedListItem) : Boolean; override; + Constructor Create(ARoot : TComponent;Const ARef : String; AList : TStrings); + end; + + // Visitor used to redirect links to another root component. + TRedirectReferenceVisitor = Class(TLinkedListVisitor) + Private + FOld, + FNew : String; + FRoot : TComponent; + Public + Function Visit(Item : TLinkedListItem) : Boolean; override; + Constructor Create(ARoot : TComponent;Const AOld,ANew : String); + end; + +var + NeedResolving : TLinkedList; + +// Add an instance to the global list of instances which need resolving. +Function FindUnresolvedInstance(AInstance: TPersistent) : TUnResolvedInstance; + +begin + Result:=Nil; +{$ifdef FPC_HAS_FEATURE_THREADING} + EnterCriticalSection(ResolveSection); + Try +{$endif} + If Assigned(NeedResolving) then + begin + Result:=TUnResolvedInstance(NeedResolving.Root); + While (Result<>Nil) and (Result.Instance<>AInstance) do + Result:=TUnResolvedInstance(Result.Next); + end; +{$ifdef FPC_HAS_FEATURE_THREADING} + finally + LeaveCriticalSection(ResolveSection); + end; +{$endif} +end; + +Function AddtoResolveList(AInstance: TPersistent) : TUnResolvedInstance; + +begin + Result:=FindUnresolvedInstance(AInstance); + If (Result=Nil) then + begin +{$ifdef FPC_HAS_FEATURE_THREADING} + EnterCriticalSection(ResolveSection); + Try +{$endif} + If not Assigned(NeedResolving) then + NeedResolving:=TLinkedList.Create(TUnResolvedInstance); + Result:=NeedResolving.Add as TUnResolvedInstance; + Result.Instance:=AInstance; +{$ifdef FPC_HAS_FEATURE_THREADING} + finally + LeaveCriticalSection(ResolveSection); + end; +{$endif} + end; +end; + +// Walk through the global list of instances to be resolved. + +Procedure VisitResolveList(V : TLinkedListVisitor); + +begin +{$ifdef FPC_HAS_FEATURE_THREADING} + EnterCriticalSection(ResolveSection); + Try +{$endif} + try + NeedResolving.Foreach(V); + Finally + FreeAndNil(V); + end; +{$ifdef FPC_HAS_FEATURE_THREADING} + Finally + LeaveCriticalSection(ResolveSection); + end; +{$endif} +end; + +procedure GlobalFixupReferences; + +begin + If (NeedResolving=Nil) then + Exit; +{$ifdef FPC_HAS_FEATURE_THREADING} + GlobalNameSpace.BeginWrite; + try +{$endif} + VisitResolveList(TResolveReferenceVisitor.Create); +{$ifdef FPC_HAS_FEATURE_THREADING} + finally + GlobalNameSpace.EndWrite; + end; +{$endif} +end; + + +procedure GetFixupReferenceNames(Root: TComponent; Names: TStrings); + +begin + If (NeedResolving=Nil) then + Exit; + VisitResolveList(TReferenceNamesVisitor.Create(Root,Names)); +end; + +procedure GetFixupInstanceNames(Root: TComponent; const ReferenceRootName: string; Names: TStrings); + +begin + If (NeedResolving=Nil) then + Exit; + VisitResolveList(TReferenceInstancesVisitor.Create(Root,ReferenceRootName,Names)); +end; + +procedure RedirectFixupReferences(Root: TComponent; const OldRootName, NewRootName: string); + +begin + If (NeedResolving=Nil) then + Exit; + VisitResolveList(TRedirectReferenceVisitor.Create(Root,OldRootName,NewRootName)); +end; + +procedure RemoveFixupReferences(Root: TComponent; const RootName: string); + +begin + If (NeedResolving=Nil) then + Exit; + VisitResolveList(TRemoveReferenceVisitor.Create(Root,RootName)); +end; + + +{ TUnresolvedReference } + +Function TUnresolvedReference.Resolve(Instance : TPersistent) : Boolean; + +Var + C : TComponent; + +begin + C:=FindGlobalComponent(FGlobal); + Result:=(C<>Nil); + If Result then + begin + C:=FindNestedComponent(C,FRelative); + Result:=C<>Nil; + If Result then + SetObjectProp(Instance, FPropInfo,C); + end; +end; + +Function TUnresolvedReference.RootMatches(ARoot : TComponent) : Boolean; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} + +begin + Result:=(ARoot=Nil) or (ARoot=FRoot); +end; + +Function TUnResolvedReference.NextRef : TUnresolvedReference; + +begin + Result:=TUnresolvedReference(Next); +end; + +{ TUnResolvedInstance } + +destructor TUnResolvedInstance.Destroy; +begin + FUnresolved.Free; + inherited Destroy; +end; + +function TUnResolvedInstance.AddReference(ARoot: TComponent; APropInfo : TTypeMemberProperty; AGlobal, ARelative: String): TUnresolvedReference; +begin + If (FUnResolved=Nil) then + FUnResolved:=TLinkedList.Create(TUnresolvedReference); + Result:=FUnResolved.Add as TUnresolvedReference; + Result.FGlobal:=AGLobal; + Result.FRelative:=ARelative; + Result.FPropInfo:=APropInfo; + Result.FRoot:=ARoot; +end; + +Function TUnResolvedInstance.RootUnresolved : TUnresolvedReference; + +begin + Result:=Nil; + If Assigned(FUnResolved) then + Result:=TUnresolvedReference(FUnResolved.Root); +end; + +Function TUnResolvedInstance.ResolveReferences:Boolean; + +Var + R,RN : TUnresolvedReference; + +begin + R:=RootUnResolved; + While (R<>Nil) do + begin + RN:=R.NextRef; + If R.Resolve(Self.Instance) then + FUnresolved.RemoveItem(R,True); + R:=RN; + end; + Result:=RootUnResolved=Nil; +end; + +{ TReferenceNamesVisitor } + +Constructor TReferenceNamesVisitor.Create(ARoot : TComponent;AList : TStrings); + +begin + FRoot:=ARoot; + FList:=AList; +end; + +Function TReferenceNamesVisitor.Visit(Item : TLinkedListItem) : Boolean; + +Var + R : TUnresolvedReference; + +begin + R:=TUnResolvedInstance(Item).RootUnresolved; + While (R<>Nil) do + begin + If R.RootMatches(FRoot) then + If (FList.IndexOf(R.FGlobal)=-1) then + FList.Add(R.FGlobal); + R:=R.NextRef; + end; + Result:=True; +end; + +{ TReferenceInstancesVisitor } + +Constructor TReferenceInstancesVisitor.Create(ARoot : TComponent; Const ARef : String;AList : TStrings); + +begin + FRoot:=ARoot; + FRef:=UpperCase(ARef); + FList:=AList; +end; + +Function TReferenceInstancesVisitor.Visit(Item : TLinkedListItem) : Boolean; + +Var + R : TUnresolvedReference; + +begin + R:=TUnResolvedInstance(Item).RootUnresolved; + While (R<>Nil) do + begin + If (FRoot=R.FRoot) and (FRef=UpperCase(R.FGLobal)) Then + If Flist.IndexOf(R.FRelative)=-1 then + Flist.Add(R.FRelative); + R:=R.NextRef; + end; + Result:=True; +end; + +{ TRedirectReferenceVisitor } + +Constructor TRedirectReferenceVisitor.Create(ARoot : TComponent; Const AOld,ANew : String); + +begin + FRoot:=ARoot; + FOld:=UpperCase(AOld); + FNew:=ANew; +end; + +Function TRedirectReferenceVisitor.Visit(Item : TLinkedListItem) : Boolean; + +Var + R : TUnresolvedReference; + +begin + R:=TUnResolvedInstance(Item).RootUnresolved; + While (R<>Nil) do + begin + If R.RootMatches(FRoot) and (FOld=UpperCase(R.FGLobal)) Then + R.FGlobal:=FNew; + R:=R.NextRef; + end; + Result:=True; +end; + +{ TRemoveReferenceVisitor } + +Constructor TRemoveReferenceVisitor.Create(ARoot : TComponent; Const ARef : String); + +begin + FRoot:=ARoot; + FRef:=UpperCase(ARef); +end; + +Function TRemoveReferenceVisitor.Visit(Item : TLinkedListItem) : Boolean; + +Var + I : Integer; + UI : TUnResolvedInstance; + R : TUnresolvedReference; + L : TFPList; + +begin + UI:=TUnResolvedInstance(Item); + R:=UI.RootUnresolved; + L:=Nil; + Try + // Collect all matches. + While (R<>Nil) do + begin + If R.RootMatches(FRoot) and ((FRef = '') or (FRef=UpperCase(R.FGLobal))) Then + begin + If Not Assigned(L) then + L:=TFPList.Create; + L.Add(R); + end; + R:=R.NextRef; + end; + // Remove all matches. + IF Assigned(L) then + begin + For I:=0 to L.Count-1 do + UI.FUnresolved.RemoveItem(TLinkedListitem(L[i]),True); + end; + // If any references are left, leave them. + If UI.FUnResolved.Root=Nil then + begin + If List=Nil then + List:=TFPList.Create; + List.Add(UI); + end; + Finally + L.Free; + end; + Result:=True; +end; + +{ TBuildListVisitor } + +Procedure TBuildListVisitor.Add(Item : TlinkedListItem); + +begin + If (List=Nil) then + List:=TFPList.Create; + List.Add(Item); +end; + +Destructor TBuildListVisitor.Destroy; + +Var + I : Integer; + +begin + If Assigned(List) then + For I:=0 to List.Count-1 do + NeedResolving.RemoveItem(TLinkedListItem(List[I]),True); + FreeAndNil(List); + Inherited; +end; + +{ TResolveReferenceVisitor } + +Function TResolveReferenceVisitor.Visit(Item : TLinkedListItem) : Boolean; + +begin + If TUnResolvedInstance(Item).ResolveReferences then + Add(Item); + Result:=True; +end; + + + +{****************************************************************************} +{* TREADER *} +{****************************************************************************} + + +constructor TReader.Create(Stream: TStream); +begin + inherited Create; + If (Stream=Nil) then + Raise EReadError.Create(SEmptyStreamIllegalReader); + FDriver := CreateDriver(Stream); +end; + +destructor TReader.Destroy; +begin + FDriver.Free; + inherited Destroy; +end; + + +procedure TReader.FlushBuffer; +begin + Driver.FlushBuffer; +end; + +function TReader.CreateDriver(Stream: TStream): TAbstractObjectReader; +begin + Result := TBinaryObjectReader.Create(Stream); +end; + +procedure TReader.BeginReferences; +begin + FLoaded := TFpList.Create; +end; + +procedure TReader.CheckValue(Value: TValueType); +begin + if FDriver.NextValue <> Value then + raise EReadError.Create(SInvalidPropertyValue) + else + FDriver.ReadValue; +end; + +procedure TReader.DefineProperty(const Name: String; AReadData: TReaderProc; + WriteData: TWriterProc; HasData: Boolean); +begin + if Assigned(AReadData) and (UpperCase(Name) = UpperCase(FPropName)) then + begin + AReadData(Self); + SetLength(FPropName, 0); + end; +end; + +procedure TReader.DefineBinaryProperty(const Name: String; + AReadData, WriteData: TStreamProc; HasData: Boolean); +var + MemBuffer: TMemoryStream; +begin + if Assigned(AReadData) and (UpperCase(Name) = UpperCase(FPropName)) then + begin + { Check if the next property really is a binary property} + if FDriver.NextValue <> vaBinary then + begin + FDriver.SkipValue; + FCanHandleExcepts := True; + raise EReadError.Create(SInvalidPropertyValue); + end else + FDriver.ReadValue; + + MemBuffer := TMemoryStream.Create; + try + FDriver.ReadBinary(MemBuffer); + FCanHandleExcepts := True; + AReadData(MemBuffer); + finally + MemBuffer.Free; + end; + SetLength(FPropName, 0); + end; +end; + +function TReader.EndOfList: Boolean; +begin + Result := FDriver.NextValue = vaNull; +end; + +procedure TReader.EndReferences; +begin + 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(ARoot: TComponent; const AMethodName: String): CodePointer; +var + ErrorResult: Boolean; +begin + Result:=nil; + if (ARoot=Nil) or (aMethodName='') then + exit; + Result := ARoot.MethodAddress(AMethodName); + ErrorResult := Result = nil; + + { always give the OnFindMethod callback a chance to locate the method } + if Assigned(FOnFindMethod) then + FOnFindMethod(Self, AMethodName, Result, ErrorResult); + + if ErrorResult then + raise EReadError.Create(SInvalidPropertyValue); +end; + +procedure TReader.DoFixupReferences; + +Var + R,RN : TLocalUnresolvedReference; + G : TUnresolvedInstance; + Ref : String; + C : TComponent; + P : integer; + L : TLinkedList; + +begin + If Assigned(FFixups) then + begin + L:=TLinkedList(FFixups); + R:=TLocalUnresolvedReference(L.Root); + While (R<>Nil) do + begin + RN:=TLocalUnresolvedReference(R.Next); + Ref:=R.FRelative; + If Assigned(FOnReferenceName) then + FOnReferenceName(Self,Ref); + C:=FindNestedComponent(R.FRoot,Ref); + If Assigned(C) then + if R.FPropInfo.TypeInfo.Kind = tkInterface then + SetInterfaceProp(R.FInstance,R.FPropInfo,C) + else + SetObjectProp(R.FInstance,R.FPropInfo,C) + else + begin + P:=Pos('.',R.FRelative); + If (P<>0) then + begin + G:=AddToResolveList(R.FInstance); + G.Addreference(R.FRoot,R.FPropInfo,Copy(R.FRelative,1,P-1),Copy(R.FRelative,P+1,Length(R.FRelative)-P)); + end; + end; + L.RemoveItem(R,True); + R:=RN; + end; + FreeAndNil(FFixups); + end; +end; + +procedure TReader.FixupReferences; +var + i: Integer; +begin + DoFixupReferences; + GlobalFixupReferences; + for i := 0 to FLoaded.Count - 1 do + TComponent(FLoaded[I]).Loaded; +end; + + +function TReader.NextValue: TValueType; +begin + Result := FDriver.NextValue; +end; + +procedure TReader.Read(var Buffer : TBytes; Count: LongInt); +begin + //This should give an exception if read is not implemented (i.e. TTextObjectReader) + //but should work with TBinaryObjectReader. + Driver.Read(Buffer, Count); +end; + +procedure TReader.PropertyError; +begin + FDriver.SkipValue; + raise EReadError.CreateFmt(SUnknownProperty,[FPropName]); +end; + +function TReader.ReadBoolean: Boolean; +var + ValueType: TValueType; +begin + ValueType := FDriver.ReadValue; + if ValueType = vaTrue then + Result := True + else if ValueType = vaFalse then + Result := False + else + raise EReadError.Create(SInvalidPropertyValue); +end; + +function TReader.ReadChar: Char; +var + s: String; +begin + s := ReadString; + if Length(s) = 1 then + Result := s[1] + else + raise EReadError.Create(SInvalidPropertyValue); +end; + +function TReader.ReadWideChar: WideChar; + +var + W: WideString; + +begin + W := ReadWideString; + if Length(W) = 1 then + Result := W[1] + else + raise EReadError.Create(SInvalidPropertyValue); +end; + +function TReader.ReadUnicodeChar: UnicodeChar; + +var + U: UnicodeString; + +begin + U := ReadUnicodeString; + if Length(U) = 1 then + Result := U[1] + else + raise EReadError.Create(SInvalidPropertyValue); +end; + +procedure TReader.ReadCollection(Collection: TCollection); +var + Item: TCollectionItem; +begin + Collection.BeginUpdate; + if not EndOfList then + Collection.Clear; + while not EndOfList do begin + ReadListBegin; + Item := Collection.Add; + while NextValue<>vaNull do + ReadProperty(Item); + ReadListEnd; + end; + Collection.EndUpdate; + ReadListEnd; +end; + +function TReader.ReadComponent(Component: TComponent): TComponent; +var + Flags: TFilerFlags; + + function Recover(E : Exception; var aComponent: TComponent): Boolean; + begin + Result := False; + if not ((ffInherited in Flags) or Assigned(Component)) then + aComponent.Free; + aComponent := nil; + FDriver.SkipComponent(False); + Result := Error(E.Message); + end; + +var + CompClassName, Name: String; + n, ChildPos: Integer; + SavedParent, SavedLookupRoot: TComponent; + ComponentClass: TComponentClass; + C, NewComponent: TComponent; + SubComponents: TList; +begin + FDriver.BeginComponent(Flags, ChildPos, CompClassName, Name); + SavedParent := Parent; + SavedLookupRoot := FLookupRoot; + SubComponents := nil; + try + Result := Component; + if not Assigned(Result) then + try + if ffInherited in Flags then + begin + { Try to locate the existing ancestor component } + + if Assigned(FLookupRoot) then + Result := FLookupRoot.FindComponent(Name) + else + Result := nil; + + if not Assigned(Result) then + begin + if Assigned(FOnAncestorNotFound) then + FOnAncestorNotFound(Self, Name, + FindComponentClass(CompClassName), Result); + if not Assigned(Result) then + raise EReadError.CreateFmt(SAncestorNotFound, [Name]); + end; + + Parent := Result.GetParentComponent; + if not Assigned(Parent) then + Parent := Root; + end else + begin + Result := nil; + ComponentClass := FindComponentClass(CompClassName); + if Assigned(FOnCreateComponent) then + FOnCreateComponent(Self, ComponentClass, Result); + if not Assigned(Result) then + begin + asm + NewComponent = Object.create(ComponentClass); + NewComponent.$init(); + end; + if ffInline in Flags then + NewComponent.FComponentState := + NewComponent.FComponentState + [csLoading, csInline]; + NewComponent.Create(Owner); + NewComponent.AfterConstruction; + + { Don't set Result earlier because else we would come in trouble + with the exception recover mechanism! (Result should be NIL if + an error occurred) } + Result := NewComponent; + end; + Include(Result.FComponentState, csLoading); + end; + except + On E: Exception do + if not Recover(E,Result) then + raise; + end; + + if Assigned(Result) then + try + Include(Result.FComponentState, csLoading); + + { create list of subcomponents and set loading} + SubComponents := TList.Create; + for n := 0 to Result.ComponentCount - 1 do + begin + C := Result.Components[n]; + if csSubcomponent in C.ComponentStyle + then begin + SubComponents.Add(C); + Include(C.FComponentState, csLoading); + end; + end; + + if not (ffInherited in Flags) then + try + Result.SetParentComponent(Parent); + if Assigned(FOnSetName) then + FOnSetName(Self, Result, Name); + Result.Name := Name; + if FindGlobalComponent(Name) = Result then + Include(Result.FComponentState, csInline); + except + On E : Exception do + if not Recover(E,Result) then + raise; + end; + if not Assigned(Result) then + exit; + if csInline in Result.ComponentState then + FLookupRoot := Result; + + { Read the component state } + Include(Result.FComponentState, csReading); + for n := 0 to Subcomponents.Count - 1 do + Include(TComponent(Subcomponents[n]).FComponentState, csReading); + + Result.ReadState(Self); + + Exclude(Result.FComponentState, csReading); + for n := 0 to Subcomponents.Count - 1 do + Exclude(TComponent(Subcomponents[n]).FComponentState, csReading); + + if ffChildPos in Flags then + Parent.SetChildOrder(Result, ChildPos); + + { Add component to list of loaded components, if necessary } + if (not ((ffInherited in Flags) or (csInline in Result.ComponentState))) or + (FLoaded.IndexOf(Result) < 0) + then begin + for n := 0 to Subcomponents.Count - 1 do + FLoaded.Add(Subcomponents[n]); + FLoaded.Add(Result); + end; + except + if ((ffInherited in Flags) or Assigned(Component)) then + Result.Free; + raise; + end; + finally + Parent := SavedParent; + FLookupRoot := SavedLookupRoot; + Subcomponents.Free; + end; +end; + +procedure TReader.ReadData(Instance: TComponent); +var + SavedOwner, SavedParent: TComponent; + +begin + { Read properties } + while not EndOfList do + ReadProperty(Instance); + ReadListEnd; + + { Read children } + SavedOwner := Owner; + SavedParent := Parent; + try + Owner := Instance.GetChildOwner; + if not Assigned(Owner) then + Owner := Root; + Parent := Instance.GetChildParent; + + while not EndOfList do + ReadComponent(nil); + ReadListEnd; + finally + Owner := SavedOwner; + Parent := SavedParent; + end; + + { Fixup references if necessary (normally only if this is the root) } + If (Instance=FRoot) then + DoFixupReferences; +end; + +function TReader.ReadFloat: Extended; +begin + if FDriver.NextValue = vaExtended then + begin + ReadValue; + Result := FDriver.ReadFloat + end else + Result := ReadNativeInt; +end; + +procedure TReader.ReadSignature; +begin + FDriver.ReadSignature; +end; + + +function TReader.ReadCurrency: Currency; +begin + if FDriver.NextValue = vaCurrency then + begin + FDriver.ReadValue; + Result := FDriver.ReadCurrency; + end else + Result := ReadInteger; +end; + + +function TReader.ReadIdent: String; +var + ValueType: TValueType; +begin + ValueType := FDriver.ReadValue; + if ValueType in [vaIdent, vaNil, vaFalse, vaTrue, vaNull] then + Result := FDriver.ReadIdent(ValueType) + else + raise EReadError.Create(SInvalidPropertyValue); +end; + + +function TReader.ReadInteger: LongInt; +begin + case FDriver.ReadValue of + vaInt8: + Result := FDriver.ReadInt8; + vaInt16: + Result := FDriver.ReadInt16; + vaInt32: + Result := FDriver.ReadInt32; + else + raise EReadError.Create(SInvalidPropertyValue); + end; +end; + +function TReader.ReadNativeInt: NativeInt; +begin + if FDriver.NextValue = vaInt64 then + begin + FDriver.ReadValue; + Result := FDriver.ReadNativeInt; + end else + Result := ReadInteger; +end; + +function TReader.ReadSet(EnumType: Pointer): Integer; +begin + if FDriver.NextValue = vaSet then + begin + FDriver.ReadValue; + Result := FDriver.ReadSet(enumtype); + end + else + Result := ReadInteger; +end; + +procedure TReader.ReadListBegin; +begin + CheckValue(vaList); +end; + +procedure TReader.ReadListEnd; +begin + CheckValue(vaNull); +end; + +function TReader.ReadVariant: JSValue; +var + nv: TValueType; +begin + nv:=NextValue; + case nv of + vaNil: + begin + Result:=Undefined; + readvalue; + end; + vaNull: + begin + Result:=Nil; + readvalue; + end; + { all integer sizes must be split for big endian systems } + vaInt8,vaInt16,vaInt32: + begin + Result:=ReadInteger; + end; + vaInt64: + begin + Result:=ReadNativeInt; + end; +{ + vaQWord: + begin + Result:=QWord(ReadInt64); + end; +} vaFalse,vaTrue: + begin + Result:=(nv<>vaFalse); + readValue; + end; + vaCurrency: + begin + Result:=ReadCurrency; + end; + vaDouble: + begin + Result:=ReadFloat; + end; + vaString: + begin + Result:=ReadString; + end; + else + raise EReadError.CreateFmt(SUnsupportedPropertyVariantType, [Ord(nv)]); + end; +end; + +procedure TReader.ReadProperty(AInstance: TPersistent); +var + Path: String; + Instance: TPersistent; + PropInfo: TTypeMemberProperty; + Obj: TObject; + Name: String; + Skip: Boolean; + Handled: Boolean; + OldPropName: String; + DotPos : String; + NextPos: Integer; + + function HandleMissingProperty(IsPath: Boolean): boolean; + begin + Result:=true; + if Assigned(OnPropertyNotFound) then begin + // user defined property error handling + OldPropName:=FPropName; + Handled:=false; + Skip:=false; + OnPropertyNotFound(Self,Instance,FPropName,IsPath,Handled,Skip); + if Handled and (not Skip) and (OldPropName<>FPropName) then + // try alias property + PropInfo := GetPropInfo(Instance.ClassType, FPropName); + if Skip then begin + FDriver.SkipValue; + Result:=false; + exit; + end; + end; + end; + +begin + try + Path := FDriver.BeginProperty; + try + Instance := AInstance; + FCanHandleExcepts := True; + DotPos := Path; + while True do + begin + NextPos := Pos('.',DotPos); + if NextPos>0 then + FPropName := Copy(DotPos, 1, NextPos-1) + else + begin + FPropName := DotPos; + break; + end; + Delete(DotPos,1,NextPos); + + PropInfo := GetPropInfo(Instance.ClassType, FPropName); + if not Assigned(PropInfo) then begin + if not HandleMissingProperty(true) then exit; + if not Assigned(PropInfo) then + PropertyError; + end; + + if PropInfo.TypeInfo.Kind = tkClass then + Obj := TObject(GetObjectProp(Instance, PropInfo)) + //else if PropInfo^.PropType^.Kind = tkInterface then + // Obj := TObject(GetInterfaceProp(Instance, PropInfo)) + else + Obj := nil; + + if not (Obj is TPersistent) then + begin + { All path elements must be persistent objects! } + FDriver.SkipValue; + raise EReadError.Create(SInvalidPropertyPath); + end; + Instance := TPersistent(Obj); + end; + + PropInfo := GetPropInfo(Instance.ClassType, FPropName); + if Assigned(PropInfo) then + ReadPropValue(Instance, PropInfo) + else + begin + FCanHandleExcepts := False; + Instance.DefineProperties(Self); + FCanHandleExcepts := True; + if Length(FPropName) > 0 then begin + if not HandleMissingProperty(false) then exit; + if not Assigned(PropInfo) then + PropertyError; + end; + end; + except + on e: Exception do + begin + SetLength(Name, 0); + if AInstance.InheritsFrom(TComponent) then + Name := TComponent(AInstance).Name; + if Length(Name) = 0 then + Name := AInstance.ClassName; + raise EReadError.CreateFmt(SPropertyException, [Name, '.', Path, e.Message]); + end; + end; + except + on e: Exception do + if not FCanHandleExcepts or not Error(E.Message) then + raise; + end; +end; + +procedure TReader.ReadPropValue(Instance: TPersistent; PropInfo: TTypeMemberProperty); +const + NullMethod: TMethod = (Code: nil; Data: nil); +var + PropType: TTypeInfo; + Value: LongInt; +{ IdentToIntFn: TIdentToInt; } + Ident: String; + Method: TMethod; + Handled: Boolean; + TmpStr: String; +begin + if (PropInfo.Setter='') then + raise EReadError.Create(SReadOnlyProperty); + + PropType := PropInfo.TypeInfo; + case PropType.Kind of + tkInteger: + case FDriver.NextValue of + vaIdent : + begin + Ident := ReadIdent; + if GlobalIdentToInt(Ident,Value) then + SetOrdProp(Instance, PropInfo, Value) + else + raise EReadError.Create(SInvalidPropertyValue); + end; + vaNativeInt : + SetOrdProp(Instance, PropInfo, ReadNativeInt); + vaCurrency: + SetFloatProp(Instance, PropInfo, ReadCurrency); + else + SetOrdProp(Instance, PropInfo, ReadInteger); + end; + tkBool: + SetOrdProp(Instance, PropInfo, Ord(ReadBoolean)); + tkChar: + SetOrdProp(Instance, PropInfo, Ord(ReadChar)); + tkEnumeration: + begin + Value := GetEnumValue(TTypeInfoEnum(PropType), ReadIdent); + if Value = -1 then + raise EReadError.Create(SInvalidPropertyValue); + SetOrdProp(Instance, PropInfo, Value); + end; +{$ifndef FPUNONE} + tkFloat: + SetFloatProp(Instance, PropInfo, ReadFloat); +{$endif} + tkSet: + begin + CheckValue(vaSet); + if TTypeInfoSet(PropType).CompType.Kind=tkEnumeration then + SetOrdProp(Instance, PropInfo, FDriver.ReadSet(TTypeInfoEnum(TTypeInfoSet(PropType).CompType))); + end; + tkMethod: + if FDriver.NextValue = vaNil then + begin + FDriver.ReadValue; + SetMethodProp(Instance, PropInfo, NullMethod); + end else + begin + Handled:=false; + Ident:=ReadIdent; + if Assigned(OnSetMethodProperty) then + OnSetMethodProperty(Self,Instance,PropInfo,Ident,Handled); + if not Handled then begin + Method.Code := FindMethod(Root, Ident); + Method.Data := Root; + if Assigned(Method.Code) then + SetMethodProp(Instance, PropInfo, Method); + end; + end; + tkString: + begin + TmpStr:=ReadString; + if Assigned(FOnReadStringProperty) then + FOnReadStringProperty(Self,Instance,PropInfo,TmpStr); + SetStrProp(Instance, PropInfo, TmpStr); + end; + tkJSValue: + begin + SetJSValueProp(Instance,PropInfo,ReadVariant); + end; + tkClass, tkInterface: + case FDriver.NextValue of + vaNil: + begin + FDriver.ReadValue; + SetOrdProp(Instance, PropInfo, 0) + end; + vaCollection: + begin + FDriver.ReadValue; + ReadCollection(TCollection(GetObjectProp(Instance, PropInfo))); + end + else + begin + If Not Assigned(FFixups) then + FFixups:=TLinkedList.Create(TLocalUnresolvedReference); + With TLocalUnresolvedReference(TLinkedList(FFixups).Add) do + begin + FInstance:=Instance; + FRoot:=Root; + FPropInfo:=PropInfo; + FRelative:=ReadIdent; + end; + end; + end; + {tkint64: + SetInt64Prop(Instance, PropInfo, ReadInt64);} + else + raise EReadError.CreateFmt(SUnknownPropertyType, [Ord(PropType.Kind)]); + end; +end; + +function TReader.ReadRootComponent(ARoot: TComponent): TComponent; +var + Dummy, i: Integer; + Flags: TFilerFlags; + CompClassName, CompName, ResultName: String; +begin + FDriver.BeginRootComponent; + Result := nil; + {!!!: GlobalNameSpace.BeginWrite; // Loading from stream adds to name space + try} + try + FDriver.BeginComponent(Flags, Dummy, CompClassName, CompName); + if not Assigned(ARoot) then + begin + { Read the class name and the object name and create a new object: } + Result := TComponentClass(FindClass(CompClassName)).Create(nil); + Result.Name := CompName; + end else + begin + Result := ARoot; + + if not (csDesigning in Result.ComponentState) then + begin + Result.FComponentState := + Result.FComponentState + [csLoading, csReading]; + + { We need an unique name } + i := 0; + { Don't use Result.Name directly, as this would influence + FindGlobalComponent in successive loop runs } + ResultName := CompName; + while Assigned(FindGlobalComponent(ResultName)) do + begin + Inc(i); + ResultName := CompName + '_' + IntToStr(i); + end; + Result.Name := ResultName; + end; + end; + + FRoot := Result; + FLookupRoot := Result; + if Assigned(GlobalLoaded) then + FLoaded := GlobalLoaded + else + FLoaded := TFpList.Create; + + try + if FLoaded.IndexOf(FRoot) < 0 then + FLoaded.Add(FRoot); + FOwner := FRoot; + FRoot.FComponentState := FRoot.FComponentState + [csLoading, csReading]; + FRoot.ReadState(Self); + Exclude(FRoot.FComponentState, csReading); + + if not Assigned(GlobalLoaded) then + for i := 0 to FLoaded.Count - 1 do + TComponent(FLoaded[i]).Loaded; + + finally + if not Assigned(GlobalLoaded) then + FLoaded.Free; + FLoaded := nil; + end; + GlobalFixupReferences; + except + RemoveFixupReferences(ARoot, ''); + if not Assigned(ARoot) then + Result.Free; + raise; + end; + {finally + GlobalNameSpace.EndWrite; + end;} +end; + +procedure TReader.ReadComponents(AOwner, AParent: TComponent; + Proc: TReadComponentsProc); +var + Component: TComponent; +begin + Root := AOwner; + Owner := AOwner; + Parent := AParent; + BeginReferences; + try + while not EndOfList do + begin + FDriver.BeginRootComponent; + Component := ReadComponent(nil); + if Assigned(Proc) then + Proc(Component); + end; + ReadListEnd; + FixupReferences; + finally + EndReferences; + end; +end; + + +function TReader.ReadString: String; +var + StringType: TValueType; +begin + StringType := FDriver.ReadValue; + if StringType=vaString then + Result := FDriver.ReadString(StringType) + else + raise EReadError.Create(SInvalidPropertyValue); +end; + + +function TReader.ReadWideString: WideString; + +begin + Result:=ReadString; +end; + +function TReader.ReadUnicodeString: UnicodeString; + +begin + Result:=ReadString; +end; + +function TReader.ReadValue: TValueType; +begin + Result := FDriver.ReadValue; +end; + +procedure TReader.CopyValue(Writer: TWriter); + +(* +procedure CopyBytes(Count: Integer); +{ var + Buffer: array[0..1023] of Byte; } + begin +{!!!: while Count > 1024 do + begin + FDriver.Read(Buffer, 1024); + Writer.Driver.Write(Buffer, 1024); + Dec(Count, 1024); + end; + if Count > 0 then + begin + FDriver.Read(Buffer, Count); + Writer.Driver.Write(Buffer, Count); + end;} + end; +*) + +{var + s: String; + Count: LongInt; } +begin + case FDriver.NextValue of + vaNull: + Writer.WriteIdent('NULL'); + vaFalse: + Writer.WriteIdent('FALSE'); + vaTrue: + Writer.WriteIdent('TRUE'); + vaNil: + Writer.WriteIdent('NIL'); + {!!!: vaList, vaCollection: + begin + Writer.WriteValue(FDriver.ReadValue); + while not EndOfList do + CopyValue(Writer); + ReadListEnd; + Writer.WriteListEnd; + end;} + vaInt8, vaInt16, vaInt32: + Writer.WriteInteger(ReadInteger); +{$ifndef FPUNONE} + vaExtended: + Writer.WriteFloat(ReadFloat); +{$endif} + vaString: + Writer.WriteString(ReadString); + vaIdent: + Writer.WriteIdent(ReadIdent); + {!!!: vaBinary, vaLString, vaWString: + begin + Writer.WriteValue(FDriver.ReadValue); + FDriver.Read(Count, SizeOf(Count)); + Writer.Driver.Write(Count, SizeOf(Count)); + CopyBytes(Count); + end;} + {!!!: vaSet: + Writer.WriteSet(ReadSet);} + {!!!: vaCurrency: + Writer.WriteCurrency(ReadCurrency);} + vaInt64: + Writer.WriteInteger(ReadNativeInt); + end; +end; + +function TReader.FindComponentClass(const AClassName: String): TComponentClass; + +var + PersistentClass: TPersistentClass; + + function FindClassInFieldTable(Instance: TComponent): TComponentClass; + var + aClass: TClass; + i: longint; + ClassTI, MemberClassTI: TTypeInfoClass; + MemberTI: TTypeInfo; + begin + aClass:=Instance.ClassType; + while aClass<>nil do + begin + ClassTI:=typeinfo(aClass); + for i:=0 to ClassTI.FieldCount-1 do + begin + MemberTI:=ClassTI.GetField(i).TypeInfo; + if MemberTI.Kind=tkClass then + begin + MemberClassTI:=TTypeInfoClass(MemberTI); + if SameText(MemberClassTI.Name,aClassName) + and (MemberClassTI.ClassType is TComponent) then + exit(TComponentClass(MemberClassTI.ClassType)); + end; + end; + aClass:=aClass.ClassParent; + end; + end; + +begin + Result := nil; + Result:=FindClassInFieldTable(Root); + + if (Result=nil) and assigned(LookupRoot) and (LookupRoot<>Root) then + Result:=FindClassInFieldTable(LookupRoot); + + if (Result=nil) then begin + PersistentClass := GetClass(AClassName); + if PersistentClass.InheritsFrom(TComponent) then + Result := TComponentClass(PersistentClass); + end; + + if (Result=nil) and assigned(OnFindComponentClass) then + OnFindComponentClass(Self, AClassName, Result); + + if (Result=nil) or (not Result.InheritsFrom(TComponent)) then + raise EClassNotFound.CreateFmt(SClassNotFound, [AClassName]); +end; + + +{ TAbstractObjectReader } + +procedure TAbstractObjectReader.FlushBuffer; +begin + // Do nothing +end; + + +{ + This file is part of the Free Component Library (FCL) + Copyright (c) 1999-2000 by the Free Pascal development team + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + + +{****************************************************************************} +{* TBinaryObjectWriter *} +{****************************************************************************} + + +procedure TBinaryObjectWriter.WriteWord(w : word); +begin + FStream.WriteBufferData(w); +end; + +procedure TBinaryObjectWriter.WriteDWord(lw : longword); +begin + FStream.WriteBufferData(lw); +end; + +constructor TBinaryObjectWriter.Create(Stream: TStream); +begin + inherited Create; + If (Stream=Nil) then + Raise EWriteError.Create(SEmptyStreamIllegalWriter); + FStream := Stream; +end; + +procedure TBinaryObjectWriter.BeginCollection; +begin + WriteValue(vaCollection); +end; + +procedure TBinaryObjectWriter.WriteSignature; + +begin + FStream.WriteBufferData(FilerSignatureInt); +end; + +procedure TBinaryObjectWriter.BeginComponent(Component: TComponent; + Flags: TFilerFlags; ChildPos: Integer); +var + Prefix: Byte; +begin + + { Only write the flags if they are needed! } + if Flags <> [] then + begin + Prefix:=0; + if ffInherited in Flags then + Prefix:=Prefix or $01; + if ffChildPos in Flags then + Prefix:=Prefix or $02; + if ffInline in Flags then + Prefix:=Prefix or $04; + Prefix := Prefix or $f0; + FStream.WriteBufferData(Prefix); + if ffChildPos in Flags then + WriteInteger(ChildPos); + end; + + WriteStr(Component.ClassName); + WriteStr(Component.Name); +end; + +procedure TBinaryObjectWriter.BeginList; +begin + WriteValue(vaList); +end; + +procedure TBinaryObjectWriter.EndList; +begin + WriteValue(vaNull); +end; + +procedure TBinaryObjectWriter.BeginProperty(const PropName: String); +begin + WriteStr(PropName); +end; + +procedure TBinaryObjectWriter.EndProperty; +begin +end; + +procedure TBinaryObjectWriter.FlushBuffer; +begin + // Do nothing; +end; + +procedure TBinaryObjectWriter.WriteBinary(const Buffer : TBytes; Count: LongInt); +begin + WriteValue(vaBinary); + WriteDWord(longword(Count)); + FStream.Write(Buffer, Count); +end; + +procedure TBinaryObjectWriter.WriteBoolean(Value: Boolean); +begin + if Value then + WriteValue(vaTrue) + else + WriteValue(vaFalse); +end; + +procedure TBinaryObjectWriter.WriteFloat(const Value: Extended); +begin + WriteValue(vaDouble); + FStream.WriteBufferData(Value); +end; + + +procedure TBinaryObjectWriter.WriteCurrency(const Value: Currency); + +Var + F : Double; +begin + WriteValue(vaCurrency); + F:=Value; + FStream.WriteBufferData(F); +end; + +procedure TBinaryObjectWriter.WriteIdent(const Ident: string); +begin + { Check if Ident is a special identifier before trying to just write + Ident directly } + if UpperCase(Ident) = 'NIL' then + WriteValue(vaNil) + else if UpperCase(Ident) = 'FALSE' then + WriteValue(vaFalse) + else if UpperCase(Ident) = 'TRUE' then + WriteValue(vaTrue) + else if UpperCase(Ident) = 'NULL' then + WriteValue(vaNull) else + begin + WriteValue(vaIdent); + WriteStr(Ident); + end; +end; + +procedure TBinaryObjectWriter.WriteInteger(Value: NativeInt); +var + s: ShortInt; + i: SmallInt; + l: Longint; +begin + { Use the smallest possible integer type for the given value: } + if (Value >= -128) and (Value <= 127) then + begin + WriteValue(vaInt8); + s := Value; + FStream.WriteBufferData(s); + end else if (Value >= -32768) and (Value <= 32767) then + begin + WriteValue(vaInt16); + i := Value; + WriteWord(word(i)); + end else if (Value >= -$80000000) and (Value <= $7fffffff) then + begin + WriteValue(vaInt32); + l := Value; + WriteDWord(longword(l)); + end else + begin + WriteValue(vaInt64); + FStream.WriteBufferData(Value); + end; +end; + +procedure TBinaryObjectWriter.WriteNativeInt(Value: NativeInt); +var + s: Int8; + i: Int16; + l: Int32; +begin + { Use the smallest possible integer type for the given value: } + if (Value <= 127) then + begin + WriteValue(vaInt8); + s := Value; + FStream.WriteBufferData(s); + end else if (Value <= 32767) then + begin + WriteValue(vaInt16); + i := Value; + WriteWord(word(i)); + end else if (Value <= $7fffffff) then + begin + WriteValue(vaInt32); + l := Value; + WriteDWord(longword(l)); + end else + begin + WriteValue(vaQWord); + FStream.WriteBufferData(Value); + end; +end; + + +procedure TBinaryObjectWriter.WriteMethodName(const Name: String); +begin + if Length(Name) > 0 then + begin + WriteValue(vaIdent); + WriteStr(Name); + end else + WriteValue(vaNil); +end; + +procedure TBinaryObjectWriter.WriteSet(Value: LongInt; SetType: Pointer); +var + i: Integer; + b : Integer; +begin + WriteValue(vaSet); + B:=1; + for i:=0 to 31 do + begin + if (Value and b) <>0 then + begin + WriteStr(GetEnumName(PTypeInfo(SetType), i)); + end; + b:=b shl 1; + end; + WriteStr(''); +end; + +procedure TBinaryObjectWriter.WriteString(const Value: String); + +var + i, len: Integer; +begin + len := Length(Value); + WriteValue(vaString); + WriteDWord(len); + For I:=1 to len do + FStream.WriteBufferData(Value[i]); +end; + +procedure TBinaryObjectWriter.WriteWideString(const Value: WideString); + +begin + WriteString(Value); +end; + +procedure TBinaryObjectWriter.WriteUnicodeString(const Value: UnicodeString); + +begin + WriteString(Value); +end; + +procedure TBinaryObjectWriter.WriteVariant(const VarValue: JSValue); +begin + if isUndefined(varValue) then + WriteValue(vaNil) + else if IsNull(VarValue) then + WriteValue(vaNull) + else if IsNumber(VarValue) then + begin + if Frac(Double(varValue))=0 then + WriteInteger(NativeInt(VarValue)) + else + WriteFloat(Double(varValue)) + end + else if isBoolean(varValue) then + WriteBoolean(Boolean(VarValue)) + else if isString(varValue) then + WriteString(String(VarValue)) + else + raise EWriteError.Create(SUnsupportedPropertyVariantType); +end; + + +procedure TBinaryObjectWriter.Write(const Buffer : TBytes; Count: LongInt); + +begin + FStream.Write(Buffer,Count); +end; + +procedure TBinaryObjectWriter.WriteValue(Value: TValueType); +var + b: uint8; +begin + b := uint8(Value); + FStream.WriteBufferData(b); +end; + +procedure TBinaryObjectWriter.WriteStr(const Value: String); +var + len,i: integer; + b: uint8; +begin + len:= Length(Value); + if len > 255 then + len := 255; + b := len; + FStream.WriteBufferData(b); + For I:=1 to len do + FStream.WriteBufferData(Value[i]); +end; + + + +{****************************************************************************} +{* TWriter *} +{****************************************************************************} + + +constructor TWriter.Create(ADriver: TAbstractObjectWriter); +begin + inherited Create; + FDriver := ADriver; +end; + +constructor TWriter.Create(Stream: TStream); +begin + inherited Create; + If (Stream=Nil) then + Raise EWriteError.Create(SEmptyStreamIllegalWriter); + FDriver := CreateDriver(Stream); + FDestroyDriver := True; +end; + +destructor TWriter.Destroy; +begin + if FDestroyDriver then + FDriver.Free; + inherited Destroy; +end; + +function TWriter.CreateDriver(Stream: TStream): TAbstractObjectWriter; +begin + Result := TBinaryObjectWriter.Create(Stream); +end; + +Type + TPosComponent = Class(TObject) + Private + FPos : Integer; + FComponent : TComponent; + Public + Constructor Create(APos : Integer; AComponent : TComponent); + end; + +Constructor TPosComponent.Create(APos : Integer; AComponent : TComponent); + +begin + FPos:=APos; + FComponent:=AComponent; +end; + +// Used as argument for calls to TComponent.GetChildren: +procedure TWriter.AddToAncestorList(Component: TComponent); +begin + FAncestors.AddObject(Component.Name,TPosComponent.Create(FAncestors.Count,Component)); +end; + +procedure TWriter.DefineProperty(const Name: String; + ReadData: TReaderProc; AWriteData: TWriterProc; HasData: Boolean); +begin + if HasData and Assigned(AWriteData) then + begin + // Write the property name and then the data itself + Driver.BeginProperty(FPropPath + Name); + AWriteData(Self); + Driver.EndProperty; + end; +end; + +procedure TWriter.DefineBinaryProperty(const Name: String; + ReadData, AWriteData: TStreamProc; HasData: Boolean); +begin + if HasData and Assigned(AWriteData) then + begin + // Write the property name and then the data itself + Driver.BeginProperty(FPropPath + Name); + WriteBinary(AWriteData); + Driver.EndProperty; + end; +end; + +procedure TWriter.FlushBuffer; +begin + Driver.FlushBuffer; +end; + +procedure TWriter.Write(const Buffer : TBytes; Count: Longint); +begin + //This should give an exception if write is not implemented (i.e. TTextObjectWriter) + //but should work with TBinaryObjectWriter. + Driver.Write(Buffer, Count); +end; + +procedure TWriter.SetRoot(ARoot: TComponent); +begin + inherited SetRoot(ARoot); + // Use the new root as lookup root too + FLookupRoot := ARoot; +end; + +procedure TWriter.WriteSignature; + +begin + FDriver.WriteSignature; +end; + +procedure TWriter.WriteBinary(AWriteData: TStreamProc); +var + MemBuffer: TBytesStream; +begin + { First write the binary data into a memory stream, then copy this buffered + stream into the writing destination. This is necessary as we have to know + the size of the binary data in advance (we're assuming that seeking within + the writer stream is not possible) } + MemBuffer := TBytesStream.Create; + try + AWriteData(MemBuffer); + Driver.WriteBinary(MemBuffer.Bytes, MemBuffer.Size); + finally + MemBuffer.Free; + end; +end; + +procedure TWriter.WriteBoolean(Value: Boolean); +begin + Driver.WriteBoolean(Value); +end; + +procedure TWriter.WriteChar(Value: Char); +begin + WriteString(Value); +end; + +procedure TWriter.WriteWideChar(Value: WideChar); +begin + WriteWideString(Value); +end; + +procedure TWriter.WriteCollection(Value: TCollection); +var + i: Integer; +begin + Driver.BeginCollection; + if Assigned(Value) then + for i := 0 to Value.Count - 1 do + begin + { Each collection item needs its own ListBegin/ListEnd tag, or else the + reader wouldn't be able to know where an item ends and where the next + one starts } + WriteListBegin; + WriteProperties(Value.Items[i]); + WriteListEnd; + end; + WriteListEnd; +end; + +procedure TWriter.DetermineAncestor(Component : TComponent); + +Var + I : Integer; + +begin + // Should be set only when we write an inherited with children. + if Not Assigned(FAncestors) then + exit; + I:=FAncestors.IndexOf(Component.Name); + If (I=-1) then + begin + FAncestor:=Nil; + FAncestorPos:=-1; + end + else + With TPosComponent(FAncestors.Objects[i]) do + begin + FAncestor:=FComponent; + FAncestorPos:=FPos; + end; +end; + +procedure TWriter.DoFindAncestor(Component : TComponent); + +Var + C : TComponent; + +begin + if Assigned(FOnFindAncestor) then + if (Ancestor=Nil) or (Ancestor is TComponent) then + begin + C:=TComponent(Ancestor); + FOnFindAncestor(Self,Component,Component.Name,C,FRootAncestor); + Ancestor:=C; + end; +end; + +procedure TWriter.WriteComponent(Component: TComponent); + +var + SA : TPersistent; + SR, SRA : TComponent; +begin + SR:=FRoot; + SA:=FAncestor; + SRA:=FRootAncestor; + Try + Component.FComponentState:=Component.FComponentState+[csWriting]; + Try + // Possibly set ancestor. + DetermineAncestor(Component); + DoFindAncestor(Component); // Mainly for IDE when a parent form had an ancestor renamed... + // Will call WriteComponentData. + Component.WriteState(Self); + FDriver.EndList; + Finally + Component.FComponentState:=Component.FComponentState-[csWriting]; + end; + Finally + FAncestor:=SA; + FRoot:=SR; + FRootAncestor:=SRA; + end; +end; + +procedure TWriter.WriteChildren(Component : TComponent); + +Var + SRoot, SRootA : TComponent; + SList : TStringList; + SPos, I , SAncestorPos: Integer; + O : TObject; + +begin + // Write children list. + // While writing children, the ancestor environment must be saved + // This is recursive... + SRoot:=FRoot; + SRootA:=FRootAncestor; + SList:=FAncestors; + SPos:=FCurrentPos; + SAncestorPos:=FAncestorPos; + try + FAncestors:=Nil; + FCurrentPos:=0; + FAncestorPos:=-1; + if csInline in Component.ComponentState then + FRoot:=Component; + if (FAncestor is TComponent) then + begin + FAncestors:=TStringList.Create; + if csInline in TComponent(FAncestor).ComponentState then + FRootAncestor := TComponent(FAncestor); + TComponent(FAncestor).GetChildren(@AddToAncestorList,FRootAncestor); + FAncestors.Sorted:=True; + end; + try + Component.GetChildren(@WriteComponent, FRoot); + Finally + If Assigned(Fancestors) then + For I:=0 to FAncestors.Count-1 do + begin + O:=FAncestors.Objects[i]; + FAncestors.Objects[i]:=Nil; + O.Free; + end; + FreeAndNil(FAncestors); + end; + finally + FAncestors:=Slist; + FRoot:=SRoot; + FRootAncestor:=SRootA; + FCurrentPos:=SPos; + FAncestorPos:=SAncestorPos; + end; +end; + +procedure TWriter.WriteComponentData(Instance: TComponent); +var + Flags: TFilerFlags; +begin + Flags := []; + If (Assigned(FAncestor)) and //has ancestor + (not (csInline in Instance.ComponentState) or // no inline component + // .. or the inline component is inherited + (csAncestor in Instance.Componentstate) and (FAncestors <> nil)) then + Flags:=[ffInherited] + else If csInline in Instance.ComponentState then + Flags:=[ffInline]; + If (FAncestors<>Nil) and ((FCurrentPos<>FAncestorPos) or (FAncestor=Nil)) then + Include(Flags,ffChildPos); + FDriver.BeginComponent(Instance,Flags,FCurrentPos); + If (FAncestors<>Nil) then + Inc(FCurrentPos); + WriteProperties(Instance); + WriteListEnd; + // Needs special handling of ancestor. + If not IgnoreChildren then + WriteChildren(Instance); +end; + +procedure TWriter.WriteDescendent(ARoot: TComponent; AAncestor: TComponent); +begin + FRoot := ARoot; + FAncestor := AAncestor; + FRootAncestor := AAncestor; + FLookupRoot := ARoot; + WriteSignature; + WriteComponent(ARoot); +end; + +procedure TWriter.WriteFloat(const Value: Extended); +begin + Driver.WriteFloat(Value); +end; + + +procedure TWriter.WriteCurrency(const Value: Currency); +begin + Driver.WriteCurrency(Value); +end; + + +procedure TWriter.WriteIdent(const Ident: string); +begin + Driver.WriteIdent(Ident); +end; + +procedure TWriter.WriteInteger(Value: LongInt); +begin + Driver.WriteInteger(Value); +end; + +procedure TWriter.WriteInteger(Value: NativeInt); +begin + Driver.WriteInteger(Value); +end; + +procedure TWriter.WriteSet(Value: LongInt; SetType: Pointer); + +begin + Driver.WriteSet(Value,SetType); +end; + +procedure TWriter.WriteVariant(const VarValue: JSValue); +begin + Driver.WriteVariant(VarValue); +end; + +procedure TWriter.WriteListBegin; +begin + Driver.BeginList; +end; + +procedure TWriter.WriteListEnd; +begin + Driver.EndList; +end; + +procedure TWriter.WriteProperties(Instance: TPersistent); + +var + PropCount,i : integer; + PropList : TTypeMemberPropertyDynArray; + +begin + PropList:=GetPropList(Instance); + PropCount:=Length(PropList); + if PropCount>0 then + for i := 0 to PropCount-1 do + if IsStoredProp(Instance,PropList[i]) then + WriteProperty(Instance,PropList[i]); + Instance.DefineProperties(Self); +end; + + +procedure TWriter.WriteProperty(Instance: TPersistent; PropInfo: TTypeMemberProperty); +var + HasAncestor: Boolean; + PropType: TTypeInfo; + N,Value, DefValue: LongInt; + Ident: String; + IntToIdentFn: TIntToIdent; +{$ifndef FPUNONE} + FloatValue, DefFloatValue: Extended; +{$endif} + MethodValue: TMethod; + DefMethodValue: TMethod; + StrValue, DefStrValue: String; + AncestorObj: TObject; + C,Component: TComponent; + ObjValue: TObject; + SavedAncestor: TPersistent; + Key, SavedPropPath, Name, lMethodName: String; + VarValue, DefVarValue : JSValue; + BoolValue, DefBoolValue: boolean; + Handled: Boolean; + O : TJSObject; + intfValue : IInterface; + +begin + // do not stream properties without getter + if PropInfo.Getter='' then + exit; + // properties without setter are only allowed, if they are subcomponents + PropType := PropInfo.TypeInfo; + if (PropInfo.Setter='') then + begin + if PropType.Kind<>tkClass then + exit; + ObjValue := TObject(GetObjectProp(Instance, PropInfo)); + if not ObjValue.InheritsFrom(TComponent) or + not (csSubComponent in TComponent(ObjValue).ComponentStyle) then + exit; + end; + + { Check if the ancestor can be used } + HasAncestor := Assigned(Ancestor) and ((Instance = Root) or + (Instance.ClassType = Ancestor.ClassType)); + //writeln('TWriter.WriteProperty Name=',PropType^.Name,' Kind=',GetEnumName(TypeInfo(TTypeKind),ord(PropType^.Kind)),' HasAncestor=',HasAncestor); + + case PropType.Kind of + tkInteger, tkChar, tkEnumeration, tkSet: + begin + Value := GetOrdProp(Instance, PropInfo); + if HasAncestor then + DefValue := GetOrdProp(Ancestor, PropInfo) + else + begin + if PropType.Kind<>tkSet then + DefValue := Longint(PropInfo.Default) + else + begin + o:=TJSObject(PropInfo.Default); + DefValue:=0; + for Key in o do + begin + n:=parseInt(Key,10); + if n<32 then + DefValue:=DefValue+(1 shl n); + end; + end; + end; + // writeln(PPropInfo(PropInfo)^.Name, ', HasAncestor=', ord(HasAncestor), ', Value=', Value, ', Default=', DefValue); + if (Value <> DefValue) or (DefValue=longint($80000000)) then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + case PropType.Kind of + tkInteger: + begin + // Check if this integer has a string identifier + IntToIdentFn := FindIntToIdent(PropInfo.TypeInfo); + if Assigned(IntToIdentFn) and IntToIdentFn(Value, Ident) then + // Integer can be written a human-readable identifier + WriteIdent(Ident) + else + // Integer has to be written just as number + WriteInteger(Value); + end; + tkChar: + WriteChar(Chr(Value)); + tkSet: + begin + Driver.WriteSet(Value, TTypeInfoSet(PropType).CompType); + end; + tkEnumeration: + WriteIdent(GetEnumName(TTypeInfoEnum(PropType), Value)); + end; + Driver.EndProperty; + end; + end; +{$ifndef FPUNONE} + tkFloat: + begin + FloatValue := GetFloatProp(Instance, PropInfo); + if HasAncestor then + DefFloatValue := GetFloatProp(Ancestor, PropInfo) + else + begin + // This is really ugly.. + DefFloatValue:=Double(PropInfo.Default); + end; + if (FloatValue<>DefFloatValue) or (not HasAncestor and (int(DefFloatValue)=longint($80000000))) then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + WriteFloat(FloatValue); + Driver.EndProperty; + end; + end; +{$endif} + tkMethod: + begin + MethodValue := GetMethodProp(Instance, PropInfo); + if HasAncestor then + DefMethodValue := GetMethodProp(Ancestor, PropInfo) + else begin + DefMethodValue.Data := nil; + DefMethodValue.Code := nil; + end; + + Handled:=false; + if Assigned(OnWriteMethodProperty) then + OnWriteMethodProperty(Self,Instance,PropInfo,MethodValue, + DefMethodValue,Handled); + if isString(MethodValue.Code) then + lMethodName:=String(MethodValue.Code) + else + lMethodName:=FLookupRoot.MethodName(MethodValue.Code); + //Writeln('Writeln A: ',lMethodName); + if (not Handled) and + (MethodValue.Code <> DefMethodValue.Code) and + ((not Assigned(MethodValue.Code)) or + ((Length(lMethodName) > 0))) then + begin + //Writeln('Writeln B',FPropPath + PropInfo.Name); + Driver.BeginProperty(FPropPath + PropInfo.Name); + if Assigned(MethodValue.Code) then + Driver.WriteMethodName(lMethodName) + else + Driver.WriteMethodName(''); + Driver.EndProperty; + end; + end; + tkString: // tkSString, tkLString, tkAString are not supported + begin + StrValue := GetStrProp(Instance, PropInfo); + if HasAncestor then + DefStrValue := GetStrProp(Ancestor, PropInfo) + else + begin + DefValue :=Longint(PropInfo.Default); + SetLength(DefStrValue, 0); + end; + + if (StrValue<>DefStrValue) or (not HasAncestor and (DefValue=longint($80000000))) then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + if Assigned(FOnWriteStringProperty) then + FOnWriteStringProperty(Self,Instance,PropInfo,StrValue); + WriteString(StrValue); + Driver.EndProperty; + end; + end; + tkJSValue: + begin + { Ensure that a Variant manager is installed } + VarValue := GetJSValueProp(Instance, PropInfo); + if HasAncestor then + DefVarValue := GetJSValueProp(Ancestor, PropInfo) + else + DefVarValue:=null; + + if (VarValue<>DefVarValue) then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + { can't use variant() typecast, pulls in variants unit } + WriteVariant(VarValue); + Driver.EndProperty; + end; + end; + tkClass: + begin + ObjValue := TObject(GetObjectProp(Instance, PropInfo)); + if HasAncestor then + begin + AncestorObj := TObject(GetObjectProp(Ancestor, PropInfo)); + if (AncestorObj is TComponent) and + (ObjValue is TComponent) then + begin + //writeln('TWriter.WriteProperty AncestorObj=',TComponent(AncestorObj).Name,' OwnerFit=',TComponent(AncestorObj).Owner = FRootAncestor,' ',TComponent(ObjValue).Name,' OwnerFit=',TComponent(ObjValue).Owner = Root); + if (AncestorObj<> ObjValue) and + (TComponent(AncestorObj).Owner = FRootAncestor) and + (TComponent(ObjValue).Owner = Root) and + (UpperCase(TComponent(AncestorObj).Name) = UpperCase(TComponent(ObjValue).Name)) then + begin + // different components, but with the same name + // treat it like an override + AncestorObj := ObjValue; + end; + end; + end else + AncestorObj := nil; + + if not Assigned(ObjValue) then + begin + if ObjValue <> AncestorObj then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + Driver.WriteIdent('NIL'); + Driver.EndProperty; + end + end + else if ObjValue.InheritsFrom(TPersistent) then + begin + { Subcomponents are streamed the same way as persistents } + if ObjValue.InheritsFrom(TComponent) + and ((not (csSubComponent in TComponent(ObjValue).ComponentStyle)) + or ((TComponent(ObjValue).Owner<>Instance) and (TComponent(ObjValue).Owner<>Nil))) then + begin + Component := TComponent(ObjValue); + if (ObjValue <> AncestorObj) + and not (csTransient in Component.ComponentStyle) then + begin + Name:= ''; + C:= Component; + While (C<>Nil) and (C.Name<>'') do + begin + If (Name<>'') Then + Name:='.'+Name; + if C.Owner = LookupRoot then + begin + Name := C.Name+Name; + break; + end + else if C = LookupRoot then + begin + Name := 'Owner' + Name; + break; + end; + Name:=C.Name + Name; + C:= C.Owner; + end; + if (C=nil) and (Component.Owner=nil) then + if (Name<>'') then //foreign root + Name:=Name+'.Owner'; + if Length(Name) > 0 then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + WriteIdent(Name); + Driver.EndProperty; + end; // length Name>0 + end; //(ObjValue <> AncestorObj) + end // ObjValue.InheritsFrom(TComponent) + else + begin + SavedAncestor := Ancestor; + SavedPropPath := FPropPath; + try + FPropPath := FPropPath + PropInfo.Name + '.'; + if HasAncestor then + Ancestor := TPersistent(GetObjectProp(Ancestor, PropInfo)); + WriteProperties(TPersistent(ObjValue)); + finally + Ancestor := SavedAncestor; + FPropPath := SavedPropPath; + end; + if ObjValue.InheritsFrom(TCollection) then + begin + if (not HasAncestor) or (not CollectionsEqual(TCollection(ObjValue), + TCollection(GetObjectProp(Ancestor, PropInfo)),root,rootancestor)) then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + SavedPropPath := FPropPath; + try + SetLength(FPropPath, 0); + WriteCollection(TCollection(ObjValue)); + finally + FPropPath := SavedPropPath; + Driver.EndProperty; + end; + end; + end // Tcollection + end; + end; // Inheritsfrom(TPersistent) + end; +{ tkInt64, tkQWord: + begin + Int64Value := GetInt64Prop(Instance, PropInfo); + if HasAncestor then + DefInt64Value := GetInt64Prop(Ancestor, PropInfo) + else + DefInt64Value := 0; + if Int64Value <> DefInt64Value then + begin + Driver.BeginProperty(FPropPath + PPropInfo(PropInfo)^.Name); + WriteInteger(Int64Value); + Driver.EndProperty; + end; + end;} + tkBool: + begin + BoolValue := GetOrdProp(Instance, PropInfo)<>0; + if HasAncestor then + DefBoolValue := GetOrdProp(Ancestor, PropInfo)<>0 + else + begin + DefBoolValue := PropInfo.Default<>0; + DefValue:=Longint(PropInfo.Default); + end; + // writeln(PropInfo.Name, ', HasAncestor=', ord(HasAncestor), ', Value=', Value, ', Default=', DefBoolValue); + if (BoolValue<>DefBoolValue) or (DefValue=longint($80000000)) then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + WriteBoolean(BoolValue); + Driver.EndProperty; + end; + end; + tkInterface: + begin + IntfValue := GetInterfaceProp(Instance, PropInfo); +{ + if Assigned(IntfValue) and Supports(IntfValue, IInterfaceComponentReference, CompRef) then + begin + Component := CompRef.GetComponent; + if HasAncestor then + begin + AncestorObj := TObject(GetObjectProp(Ancestor, PropInfo)); + if (AncestorObj is TComponent) then + begin + //writeln('TWriter.WriteProperty AncestorObj=',TComponent(AncestorObj).Name,' OwnerFit=',TComponent(AncestorObj).Owner = FRootAncestor,' ',TComponent(ObjValue).Name,' OwnerFit=',TComponent(ObjValue).Owner = Root); + if (AncestorObj<> Component) and + (TComponent(AncestorObj).Owner = FRootAncestor) and + (Component.Owner = Root) and + (UpperCase(TComponent(AncestorObj).Name) = UpperCase(Component.Name)) then + begin + // different components, but with the same name + // treat it like an override + AncestorObj := Component; + end; + end; + end else + AncestorObj := nil; + + if not Assigned(Component) then + begin + if Component <> AncestorObj then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + Driver.WriteIdent('NIL'); + Driver.EndProperty; + end + end + else if ((not (csSubComponent in Component.ComponentStyle)) + or ((Component.Owner<>Instance) and (Component.Owner<>Nil))) then + begin + if (Component <> AncestorObj) + and not (csTransient in Component.ComponentStyle) then + begin + Name:= ''; + C:= Component; + While (C<>Nil) and (C.Name<>'') do + begin + If (Name<>'') Then + Name:='.'+Name; + if C.Owner = LookupRoot then + begin + Name := C.Name+Name; + break; + end + else if C = LookupRoot then + begin + Name := 'Owner' + Name; + break; + end; + Name:=C.Name + Name; + C:= C.Owner; + end; + if (C=nil) and (Component.Owner=nil) then + if (Name<>'') then //foreign root + Name:=Name+'.Owner'; + if Length(Name) > 0 then + begin + Driver.BeginProperty(FPropPath + PropInfo.Name); + WriteIdent(Name); + Driver.EndProperty; + end; // length Name>0 + end; //(Component <> AncestorObj) + end; + end; //Assigned(IntfValue) and Supports(IntfValue,.. + //else write NIL ? +} end; + end; +end; + +procedure TWriter.WriteRootComponent(ARoot: TComponent); +begin + WriteDescendent(ARoot, nil); +end; + +procedure TWriter.WriteString(const Value: String); +begin + Driver.WriteString(Value); +end; + +procedure TWriter.WriteWideString(const Value: WideString); +begin + Driver.WriteWideString(Value); +end; + +procedure TWriter.WriteUnicodeString(const Value: UnicodeString); +begin + Driver.WriteUnicodeString(Value); +end; + +{ TAbstractObjectWriter } { --------------------------------------------------------------------- @@ -5285,7 +8895,9 @@ end; var ClassList : TJSObject; - + InitHandlerList : TList; + FindGlobalComponentList : TFPList; + Procedure RegisterClass(AClass : TPersistentClass); begin @@ -5301,6 +8913,125 @@ begin Result:=TPersistentClass(ClassList[AClassName]); end; + +procedure RegisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); + begin + if not(assigned(FindGlobalComponentList)) then + FindGlobalComponentList:=TFPList.Create; + if FindGlobalComponentList.IndexOf(CodePointer(AFindGlobalComponent))<0 then + FindGlobalComponentList.Add(CodePointer(AFindGlobalComponent)); + end; + + +procedure UnregisterFindGlobalComponentProc(AFindGlobalComponent: TFindGlobalComponent); + begin + if assigned(FindGlobalComponentList) then + FindGlobalComponentList.Remove(CodePointer(AFindGlobalComponent)); + end; + + +function FindGlobalComponent(const Name: string): TComponent; + +var + i : sizeint; +begin + Result:=nil; + if assigned(FindGlobalComponentList) then + begin + for i:=FindGlobalComponentList.Count-1 downto 0 do + begin + FindGlobalComponent:=TFindGlobalComponent(FindGlobalComponentList[i])(name); + if assigned(Result) then + break; + end; + end; +end; + +Function FindNestedComponent(Root : TComponent; APath : String; CStyle : Boolean = True) : TComponent; + + Function GetNextName : String; {$ifdef CLASSESINLINE} inline; {$endif CLASSESINLINE} + + Var + P : Integer; + CM : Boolean; + + begin + P:=Pos('.',APath); + CM:=False; + If (P=0) then + begin + If CStyle then + begin + P:=Pos('->',APath); + CM:=P<>0; + end; + If (P=0) Then + P:=Length(APath)+1; + end; + Result:=Copy(APath,1,P-1); + Delete(APath,1,P+Ord(CM)); + end; + +Var + C : TComponent; + S : String; +begin + If (APath='') then + Result:=Nil + else + begin + Result:=Root; + While (APath<>'') And (Result<>Nil) do + begin + C:=Result; + S:=Uppercase(GetNextName); + Result:=C.FindComponent(S); + If (Result=Nil) And (S='OWNER') then + Result:=C; + end; + end; +end; + +Type + TInitHandler = Class(TObject) + AHandler : TInitComponentHandler; + AClass : TComponentClass; + end; + + +procedure RegisterInitComponentHandler(ComponentClass: TComponentClass; Handler: TInitComponentHandler); + +Var + I : Integer; + H: TInitHandler; +begin + If (InitHandlerList=Nil) then + InitHandlerList:=TList.Create; + H:=TInitHandler.Create; + H.Aclass:=ComponentClass; + H.AHandler:=Handler; + try + With InitHandlerList do + begin + I:=0; + While (I