From a75ff377bd62665e931a42fd8f1e1c7c9dbb5801 Mon Sep 17 00:00:00 2001 From: michael Date: Sat, 7 Apr 2018 13:02:57 +0000 Subject: [PATCH] * Additions from Mattias for interface support --- demo/fcldb/demodb.lpi | 2 +- demo/fcldb/demodb.lpr | 2 +- packages/rtl/rtlconsts.pas | 3 + packages/rtl/system.pas | 183 ++++++++++++++++++++++++++++++++++++- packages/rtl/sysutils.pas | 93 +++++++++++++++++-- packages/rtl/typinfo.pas | 98 +++++++++++++++++++- 6 files changed, 367 insertions(+), 14 deletions(-) diff --git a/demo/fcldb/demodb.lpi b/demo/fcldb/demodb.lpi index e2658c8..6feb691 100644 --- a/demo/fcldb/demodb.lpi +++ b/demo/fcldb/demodb.lpi @@ -53,7 +53,7 @@ - + diff --git a/demo/fcldb/demodb.lpr b/demo/fcldb/demodb.lpr index 9c89380..a389b2f 100644 --- a/demo/fcldb/demodb.lpr +++ b/demo/fcldb/demodb.lpr @@ -1,6 +1,6 @@ program demoxhr; -uses SysUtils, JS, Web, DB, JSonDataset, ExtJSDataset, DBConst; +uses SysUtils, JS, Web, DB, JSonDataset, ExtJSDataset, strutils, DBConst; Type diff --git a/packages/rtl/rtlconsts.pas b/packages/rtl/rtlconsts.pas index 16dba19..433266b 100644 --- a/packages/rtl/rtlconsts.pas +++ b/packages/rtl/rtlconsts.pas @@ -49,6 +49,9 @@ const SErrInvalidDayOfWeekInMonth = 'Year %d Month %d NDow %d DOW %d is not a valid date'; SInvalidJulianDate = '%f Julian cannot be represented as a DateTime'; SErrInvalidHourMinuteSecMsec = '%d:%d:%d.%d is not a valid time specification'; + + SInvalidGUID = '"%s" is not a valid GUID value'; + implementation end. diff --git a/packages/rtl/system.pas b/packages/rtl/system.pas index c918ce3..ff572da 100644 --- a/packages/rtl/system.pas +++ b/packages/rtl/system.pas @@ -32,6 +32,7 @@ const Maxint = MaxLongint; IsMultiThread = false; + {***************************************************************************** Base types *****************************************************************************} @@ -68,6 +69,7 @@ type TObject, TClass *****************************************************************************} type + TGuid = string; TClass = class of TObject; { TObject } @@ -83,7 +85,7 @@ type // Free is using compiler magic. // Reasons: - // 1. In JS calling obj.Free when obj=nil crashes. + // 1. In JS calling obj.Free when obj=nil would crash. // 2. In JS freeing memory requires to set all references to nil. // Therefore any obj.free call is replaced by the compiler with some rtl magic. procedure Free; @@ -98,11 +100,91 @@ type procedure AfterConstruction; virtual; procedure BeforeDestruction; virtual; + function GetInterface(const iidstr: String; out obj): boolean; + function GetInterfaceByStr(const iidstr: String; out obj) : boolean; + function GetInterfaceWeak(const iid: TGuid; out obj): boolean; // equal to GetInterface but the interface returned is not referenced + function Equals(Obj: TObject): boolean; virtual; function ToString: String; virtual; end; -Const +const + { IInterface } + S_OK = 0; + S_FALSE = 1; + E_NOINTERFACE = -2147467262; // FPC: longint($80004002) + E_UNEXPECTED = -2147418113; // FPC: longint($8000FFFF) + E_NOTIMPL = -2147467263; // FPC: longint($80004001) + +type + IUnknown = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const iid: TGuid; out obj): Integer; + function _AddRef: Integer; + function _Release: Integer; + end; + IInterface = IUnknown; + + {$M+} + IInvokable = interface(IInterface) + end; + {$M-} + + { Enumerator support } + IEnumerator = interface(IInterface) + function GetCurrent: TObject; + function MoveNext: Boolean; + procedure Reset; + property Current: TObject read GetCurrent; + end; + + IEnumerable = interface(IInterface) + function GetEnumerator: IEnumerator; + end; + + { TInterfacedObject } + + TInterfacedObject = class(TObject,IUnknown) + protected + fRefCount: Integer; + { implement methods of IUnknown } + function QueryInterface(const iid: TGuid; out obj): Integer; virtual; + function _AddRef: Integer; virtual; + function _Release: Integer; virtual; + public + procedure BeforeDestruction; override; + property RefCount: Integer read fRefCount; + end; + TInterfacedClass = class of TInterfacedObject; + + { TAggregatedObject - sub or satellite object using same interface as controller } + + TAggregatedObject = class(TObject) + private + fController: Pointer; + function GetController: IUnknown; + protected + { implement methods of IUnknown } + function QueryInterface(const iid: TGuid; out obj): Integer; virtual; + function _AddRef: Integer; virtual; + function _Release: Integer; virtual; + public + constructor Create(const aController: IUnknown); + property Controller: IUnknown read GetController; + end; + + { TContainedObject } + + TContainedObject = class(TAggregatedObject,IInterface) + protected + function QueryInterface(const iid: TGuid; out obj): Integer; override; + end; + +const + { for safe as operator support } + IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}'; + +const DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF; {***************************************************************************** @@ -502,6 +584,77 @@ asm return A !== B; end; +{ TContainedObject } + +function TContainedObject.QueryInterface(const iid: TGuid; out obj): Integer; +begin + if GetInterface(iid,obj) then + Result:=S_OK + else + Result:=Integer(E_NOINTERFACE); +end; + +{ TAggregatedObject } + +function TAggregatedObject.GetController: IUnknown; +begin + Result := IUnknown(fController); +end; + +function TAggregatedObject.QueryInterface(const iid: TGuid; out obj): Integer; +begin + Result := IUnknown(fController).QueryInterface(iid, obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IUnknown(fController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; +begin + Result := IUnknown(fController)._Release; +end; + +constructor TAggregatedObject.Create(const aController: IUnknown); +begin + inherited Create; + { do not keep a counted reference to the controller! } + fController := Pointer(aController); +end; + +{ TInterfacedObject } + +function TInterfacedObject.QueryInterface(const iid: TGuid; out obj): Integer; +begin + if GetInterface(iid,obj) then + Result:=S_OK + else + Result:=Integer(E_NOINTERFACE); +end; + +function TInterfacedObject._AddRef: Integer; +begin + inc(fRefCount); + Result:=fRefCount; +end; + +function TInterfacedObject._Release: Integer; +begin + dec(fRefCount); + Result:=fRefCount; + if fRefCount=0 then + Destroy; +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if fRefCount<>0 then + asm + rtl.raiseE('EHeapMemoryError'); + end; +end; + { TObject } constructor TObject.Create; @@ -544,6 +697,31 @@ begin end; +function TObject.GetInterface(const iidstr: String; out obj): boolean; +begin + Result := GetInterfaceByStr(iidstr,obj); +end; + +function TObject.GetInterfaceByStr(const iidstr: String; out obj): boolean; +begin + if (iidstr = IObjectInstance) then + begin + obj:=Self; + exit(true); + end; + asm + var i = rtl.getIntfG(this,iidstr,2); + obj.set(i); + return i!==null; + end; + Result:=false; +end; + +function TObject.GetInterfaceWeak(const iid: TGuid; out obj): boolean; +begin + Result:=GetInterfaceByStr(iid,obj); +end; + function TObject.Equals(Obj: TObject): boolean; begin Result:=Obj=Self; @@ -558,6 +736,5 @@ end; initialization ExitCode:=0; // set it here, so that WPO does not remove it - end. diff --git a/packages/rtl/sysutils.pas b/packages/rtl/sysutils.pas index c927d2f..37b9b98 100644 --- a/packages/rtl/sysutils.pas +++ b/packages/rtl/sysutils.pas @@ -99,8 +99,8 @@ type { Run-time and I/O Errors } EInOutError = class(Exception) - public - ErrorCode : Integer; + public + ErrorCode : Integer; end; EHeapMemoryError = class(Exception); @@ -160,9 +160,6 @@ type ENoConstructException = class(Exception); -var - RTLEInvalidCast: ExceptClass external name 'rtl.EInvalidCast'; - //function GetTickCount: Integer; @@ -536,8 +533,23 @@ type PathStr = String; //function ExtractFilePath(const FileName: PathStr): PathStr; +{***************************************************************************** + Interfaces +*****************************************************************************} +function Supports(const Instance: IInterface; const AClass: TClass; out Obj): Boolean; overload; +function Supports(const Instance: TObject; const IID: String; out Intf): Boolean; overload; +function Supports(const Instance: IInterface; const AClass: TClass): Boolean; overload; +function Supports(const Instance: TObject; const IID: String): Boolean; overload; + +function Supports(const AClass: TClass; const IID: String): Boolean; assembler; overload; + +function TryStringToGUID(const S: string; out Guid: TGUID): Boolean; +function StringToGUID(const S: string): TGUID; +function GUIDToString(const GUID: TGUID): string; +function IsEqualGUID(const guid1, guid2: TGUID): Boolean; +function GuidCase(const GUID: TGUID; const List: array of TGuid): Integer; implementation @@ -3304,6 +3316,76 @@ begin Result:=Value; end; +function Supports(const Instance: IInterface; const AClass: TClass; out Obj + ): Boolean; +begin + Result := (Instance<>nil) and (Instance.QueryInterface(IObjectInstance,Obj)=S_OK) + and (TObject(Obj).InheritsFrom(AClass)); +end; + +function Supports(const Instance: TObject; const IID: String; out Intf + ): Boolean; +begin + Result:=(Instance<>nil) and Instance.GetInterface(IID,Intf); +end; + +function Supports(const Instance: IInterface; const AClass: TClass): Boolean; +var + Temp: TObject; +begin + Result:=Supports(Instance,AClass,Temp); +end; + +function Supports(const Instance: TObject; const IID: String): Boolean; +var + Temp: TObject; +begin + Result:=Supports(Instance,IID,Temp); +end; + +function Supports(const AClass: TClass; const IID: String): Boolean; assembler; +asm + if (!AClass) return false; + var maps = AClass.$intfmaps; + if (!maps) return false; + if (maps[IID]) return true; + return false; +end; + +function TryStringToGUID(const S: string; out Guid: TGUID): Boolean; +var + re: TJSRegexp; +begin + if Length(S)<>38 then Exit(False); + re:=TJSRegexp.new('^\{[0-9a-fA-F]{8}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{4}-[0-9a-fA-F]{12}\}$'); + Result:=re.test(S); + Guid:=S; +end; + +function StringToGUID(const S: string): TGUID; +begin + if not TryStringToGUID(S, Result) then + raise EConvertError.CreateFmt(SInvalidGUID, [S]); +end; + +function GUIDToString(const GUID: TGUID): string; +begin + Result:=GUID; +end; + +function IsEqualGUID(const guid1, guid2: TGUID): Boolean; +begin + Result:=SameText(guid1,guid2); +end; + +function GuidCase(const GUID: TGUID; const List: array of TGuid): Integer; +begin + for Result := High(List) downto 0 do + if IsEqualGUID(GUID, List[Result]) then + Exit; + Result := -1; +end; + { --------------------------------------------------------------------- Integer/Ordinal related ---------------------------------------------------------------------} @@ -3665,7 +3747,6 @@ end; initialization FormatSettings := TFormatSettings.Create; - RTLEInvalidCast:=EInvalidCast; end. diff --git a/packages/rtl/typinfo.pas b/packages/rtl/typinfo.pas index 96753d2..3eeaa84 100644 --- a/packages/rtl/typinfo.pas +++ b/packages/rtl/typinfo.pas @@ -26,7 +26,7 @@ type TTypeKind = ( tkUnknown, // 0 tkInteger, // 1 - tkChar, // 2 + tkChar, // 2 in Delphi/FPC tkWChar, tkUChar tkString, // 3 in Delphi/FPC tkSString, tkWString or tkUString tkEnumeration, // 4 tkSet, // 5 @@ -41,8 +41,8 @@ type tkClassRef, // 14 tkPointer, // 15 tkJSValue, // 16 - tkRefToProcVar // 17 - //tkInterface, + tkRefToProcVar, // 17 + tkInterface // 18 //tkObject, //tkSString,tkLString,tkAString,tkWString, //tkVariant, @@ -327,6 +327,14 @@ type RefType: TTypeInfo external name 'reftype'; // can be null end; + { TTypeInfoInterface - Kind = tkInterface } + + TTypeInfoInterface = class external name 'rtl.tTypeInfoInterface'(TTypeInfoStruct) + public + InterfaceType: TJSObject external name 'interface'; + Ancestor: TTypeInfoInterface external name 'ancestor'; + end; + EPropertyError = class(Exception); function GetClassMembers(aTIClass: TTypeInfoClass): TTypeMemberDynArray; @@ -335,6 +343,10 @@ function GetInstanceMethod(Instance: TObject; const aName: String): Pointer; function GetClassMethods(aTIClass: TTypeInfoClass): TTypeMemberMethodDynArray; function CreateMethod(Instance: TObject; FuncName: String): Pointer; external name 'rtl.createCallback'; +function GetInterfaceMembers(aTIInterface: TTypeInfoInterface): TTypeMemberDynArray; +function GetInterfaceMember(aTIInterface: TTypeInfoInterface; const aName: String): TTypeMember; +function GetInterfaceMethods(aTIInterface: TTypeInfoInterface): TTypeMemberMethodDynArray; + function GetPropInfos(aTIClass: TTypeInfoClass): TTypeMemberPropertyDynArray; function GetPropInfo(TI: TTypeInfoClass; const PropName: String): TTypeMemberProperty; function GetPropInfo(TI: TTypeInfoClass; const PropName: String; const Kinds: TTypeKinds): TTypeMemberProperty; @@ -479,6 +491,86 @@ begin end; end; +function GetInterfaceMembers(aTIInterface: TTypeInfoInterface + ): TTypeMemberDynArray; +var + Intf: TTypeInfoInterface; + i, Cnt, j: Integer; +begin + Cnt:=0; + Intf:=aTIInterface; + while Intf<>nil do + begin + inc(Cnt,length(Intf.Names)); + Intf:=Intf.Ancestor; + end; + SetLength(Result,Cnt); + Intf:=aTIInterface; + i:=0; + while Intf<>nil do + begin + for j:=0 to length(Intf.Names)-1 do + begin + Result[i]:=Intf.Members[Intf.Names[j]]; + inc(i); + end; + Intf:=Intf.Ancestor; + end; +end; + +function GetInterfaceMember(aTIInterface: TTypeInfoInterface; + const aName: String): TTypeMember; +var + Intf: TTypeInfoInterface; + i: Integer; +begin + // quick search: case sensitive + Intf:=aTIInterface; + while Intf<>nil do + begin + if TJSObject(Intf.Members).hasOwnProperty(aName) then + exit(Intf.Members[aName]); + Intf:=Intf.Ancestor; + end; + // slow search: case insensitive + Intf:=aTIInterface; + while Intf<>nil do + begin + for i:=0 to length(Intf.Names)-1 do + if CompareText(Intf.Names[i],aName)=0 then + exit(Intf.Members[Intf.Names[i]]); + Intf:=Intf.Ancestor; + end; + Result:=nil; +end; + +function GetInterfaceMethods(aTIInterface: TTypeInfoInterface + ): TTypeMemberMethodDynArray; +var + Intf: TTypeInfoInterface; + i, Cnt, j: Integer; +begin + Cnt:=0; + Intf:=aTIInterface; + while Intf<>nil do + begin + inc(Cnt,Intf.MethodCount); + Intf:=Intf.Ancestor; + end; + SetLength(Result,Cnt); + Intf:=aTIInterface; + i:=0; + while Intf<>nil do + begin + for j:=0 to Intf.MethodCount-1 do + begin + Result[i]:=TTypeMemberMethod(Intf.Members[Intf.Methods[j]]); + inc(i); + end; + Intf:=Intf.Ancestor; + end; +end; + function GetPropInfos(aTIClass: TTypeInfoClass): TTypeMemberPropertyDynArray; var C: TTypeInfoClass;