mirror of
https://gitlab.com/freepascal.org/fpc/pas2js.git
synced 2025-08-12 05:45:51 +02:00
* Additions from Mattias for interface support
This commit is contained in:
michael
parent
27e3e726ea
commit
a75ff377bd
@ -53,7 +53,7 @@
|
||||
</SearchPaths>
|
||||
<Other>
|
||||
<ExecuteBefore>
|
||||
<Command Value="$MakeExe(pas2js) -Tbrowser -Jirtl.js -Jc $Name($(ProjFile))"/>
|
||||
<Command Value="$MakeExe(pas2js) -Tbrowser -Jirtl.js -Jc -O- $Name($(ProjFile))"/>
|
||||
<ScanForFPCMsgs Value="True"/>
|
||||
</ExecuteBefore>
|
||||
</Other>
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
program demoxhr;
|
||||
|
||||
uses SysUtils, JS, Web, DB, JSonDataset, ExtJSDataset, DBConst;
|
||||
uses SysUtils, JS, Web, DB, JSonDataset, ExtJSDataset, strutils, DBConst;
|
||||
|
||||
Type
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user