* Additions from Mattias for interface support

demo/fcldb/demodb.lpi

@@ -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>

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
 

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.

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.
 

packages/rtl/sysutils.pas

@@ -99,8 +99,8 @@ type
 
   { Run-time and I/O Errors }
   EInOutError = class(Exception)
-    public
+  public
-      ErrorCode : Integer;
+    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.
 

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
+    tkRefToProcVar, // 17
-    //tkInterface,
+    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;