* Patch from mattias to handle GUID as record

packages/rtl/system.pas

@@ -1,6 +1,6 @@
 {
     This file is part of the Pas2JS run time library.
-    Copyright (c) 2017 by Mattias Gaertner
+    Copyright (c) 2018 by Mattias Gaertner
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -66,10 +66,17 @@ type
   TTextLineBreakStyle = (tlbsLF,tlbsCRLF,tlbsCR);
 
 {*****************************************************************************
-                            TObject, TClass
+            TObject, TClass, IUnknown, IInterface, TInterfacedObject
 *****************************************************************************}
 type
-  TGuid = string;
+  TGuid = record
+    D1: DWord;
+    D2: word;
+    D3: word;
+    D4: array[0..7] of byte;
+  end;
+  TGUIDString = string; // ToDo: use type string when supported by compiler
+
   TClass = class of TObject;
 
   { TObject }
@@ -100,8 +107,9 @@ type
     procedure AfterConstruction; virtual;
     procedure BeforeDestruction; virtual;
 
-    function GetInterface(const iidstr: String; out obj): boolean;
-    function GetInterfaceByStr(const iidstr: String; out obj) : boolean;
+    function GetInterface(const iid: TGuid; out obj): boolean;
+    function GetInterface(const iidstr: String; out obj): boolean; inline;
+    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;
@@ -184,8 +192,7 @@ const
   { for safe as operator support }
   IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}';
 
-const
-  DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
+function GUIDToString(const GUID: TGUID): string; overload;
 
 {*****************************************************************************
                             Init / Exit / ExitProc
@@ -238,6 +245,9 @@ function Trunc(const A: Double): NativeInt;
 {*****************************************************************************
                           String functions
 *****************************************************************************}
+const
+  DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
+
 function Int(const A: Double): double;
 function Copy(const S: string; Index, Size: Integer): String; assembler; overload;
 function Copy(const S: string; Index: Integer): String; assembler; overload;
@@ -282,6 +292,11 @@ asm
   return s1.toLowerCase() == s2.toLowerCase();
 end;
 
+function GUIDToString(const GUID: TGUID): string; assembler;
+asm
+  return rtl.guidrToStr(GUID);
+end;
+
 function ParamCount: Longint;
 begin
   if Assigned(OnParamCount) then
@@ -706,6 +721,21 @@ begin
 
 end;
 
+function TObject.GetInterface(const iid: TGuid; out obj): boolean;
+begin
+  asm
+    var i = iid.$intf;
+    if (i){
+      i = rtl.getIntfG(this,i.$guid,2);
+      if (i){
+        obj.set(i);
+        return true;
+      }
+    }
+  end;
+  Result := GetInterfaceByStr(GUIDToString(iid),obj);
+end;
+
 function TObject.GetInterface(const iidstr: String; out obj): boolean;
 begin
   Result := GetInterfaceByStr(iidstr,obj);
@@ -728,7 +758,15 @@ end;
 
 function TObject.GetInterfaceWeak(const iid: TGuid; out obj): boolean;
 begin
-  Result:=GetInterfaceByStr(iid,obj);
+  Result:=GetInterface(iid,obj);
+  asm
+    if (Result){
+      var o = obj.get();
+      if (o.$kind==='com'){
+        o._Release();
+      }
+    }
+  end;
 end;
 
 function TObject.Equals(Obj: TObject): boolean;

packages/rtl/sysutils.pas

@@ -537,19 +537,27 @@ type
                                Interfaces
 *****************************************************************************}
 
+const
+  GUID_NULL: TGuid = '{00000000-0000-0000-0000-000000000000}';
+
 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 IID: TGuid; out Intf): Boolean; overload;
+function Supports(const Instance: TObject; const IID: TGuid; out Intf): Boolean; overload;
+function Supports(const Instance: TObject; const IID: TGuidString; 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 Instance: IInterface; const IID: TGuid): Boolean; overload;
+function Supports(const Instance: TObject; const IID: TGuid): Boolean; overload;
+function Supports(const Instance: TObject; const IID: TGuidString): Boolean; overload;
 
-function Supports(const AClass: TClass; const IID: String): Boolean; assembler; overload;
+function Supports(const AClass: TClass; const IID: TGuid): Boolean; overload;
+function Supports(const AClass: TClass; const IID: TGuidString): Boolean; 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;
+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
 
@@ -3316,6 +3324,9 @@ begin
   Result:=Value;
 end;
 
+{ ---------------------------------------------------------------------
+  Interface related
+  ---------------------------------------------------------------------}
 function Supports(const Instance: IInterface; const AClass: TClass; out Obj
   ): Boolean;
 begin
@@ -3323,12 +3334,24 @@ begin
      and (TObject(Obj).InheritsFrom(AClass));
 end;
 
-function Supports(const Instance: TObject; const IID: String; out Intf
+function Supports(const Instance: IInterface; const IID: TGUID; out Intf
+  ): Boolean;
+begin
+  Result:=(Instance<>nil) and (Instance.QueryInterface(IID,Intf)=S_OK);
+end;
+
+function Supports(const Instance: TObject; const IID: TGUID; out Intf
   ): Boolean;
 begin
   Result:=(Instance<>nil) and Instance.GetInterface(IID,Intf);
 end;
 
+function Supports(const Instance: TObject; const IID: TGuidString; out Intf
+  ): Boolean;
+begin
+  Result:=(Instance<>nil) and Instance.GetInterfaceByStr(IID,Intf);
+end;
+
 function Supports(const Instance: IInterface; const AClass: TClass): Boolean;
 var
   Temp: TObject;
@@ -3336,30 +3359,71 @@ begin
   Result:=Supports(Instance,AClass,Temp);
 end;
 
-function Supports(const Instance: TObject; const IID: String): Boolean;
+function Supports(const Instance: IInterface; const IID: TGUID): Boolean;
 var
-  Temp: TObject;
+  Temp: IInterface;
 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;
+function Supports(const Instance: TObject; const IID: TGUID): Boolean;
+var
+  Temp: TJSObject;
+begin
+  Result:=Supports(Instance,IID,Temp);
+  asm
+    if (Temp && Temp.$kind==='com') Temp._Release();
+  end;
 end;
 
-function TryStringToGUID(const S: string; out Guid: TGUID): Boolean;
+function Supports(const Instance: TObject; const IID: TGuidString): Boolean;
+var
+  Temp: TJSObject;
+begin
+  Result:=Supports(Instance,IID,Temp);
+  asm
+    if (Temp && Temp.$kind==='com') Temp._Release();
+  end;
+end;
+
+function Supports(const AClass: TClass; const IID: TGUID): Boolean;
+var
+  maps: JSValue;
+begin
+  if AClass=nil then exit(false);
+  maps := TJSObject(AClass)['$intfmaps'];
+  if not maps then exit(false);
+  if TJSObject(maps)[GUIDToString(IID)] then exit(true);
+  Result:=false;
+end;
+
+function Supports(const AClass: TClass; const IID: TGuidString): Boolean;
+var
+  maps: JSValue;
+begin
+  if AClass=nil then exit(false);
+  maps := TJSObject(AClass)['$intfmaps'];
+  if not maps then exit(false);
+  if TJSObject(maps)[uppercase(IID)] then exit(true);
+  Result:=false;
+end;
+
+function TryStringToGUID(const s: string; out Guid: TGUID): Boolean;
 var
   re: TJSRegexp;
 begin
-  if Length(S)<>38 then Exit(False);
+  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;
+  Result:=re.test(s);
+  if not Result then
+    begin
+    Guid.D1:=0;
+    exit;
+    end;
+  asm
+    rtl.strToGUIDR(s,Guid.get());
+  end;
+  Result:=true;
 end;
 
 function StringToGUID(const S: string): TGUID;
@@ -3368,20 +3432,25 @@ begin
     raise EConvertError.CreateFmt(SInvalidGUID, [S]);
 end;
 
-function GUIDToString(const GUID: TGUID): string;
+function GUIDToString(const guid: TGUID): string;
 begin
-  Result:=GUID;
+  Result:=System.GUIDToString(guid);
 end;
 
 function IsEqualGUID(const guid1, guid2: TGUID): Boolean;
+var
+  i: integer;
 begin
-  Result:=SameText(guid1,guid2);
+  if (guid1.D1<>guid2.D1) or (guid1.D2<>guid2.D2) or (guid1.D3<>guid2.D3) then
+    exit(false);
+  for i:=0 to 7 do if guid1.D4[i]<>guid2.D4[i] then exit(false);
+  Result:=true;
 end;
 
-function GuidCase(const GUID: TGUID; const List: array of TGuid): Integer;
+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
+    if IsEqualGUID(guid, List[Result]) then
       Exit;
   Result := -1;
 end;
@@ -3585,21 +3654,19 @@ end;
 
 
 function IntToHex(Value: NativeInt; Digits: integer): string;
-
 const
-   HexDigits = '0123456789ABCDEF';
-
+  HexDigits = '0123456789ABCDEF';
 begin
- If Digits=0 then
-   Digits:=1;
- Result:='';
- While Value>0 do
-   begin
-   result:=HexDigits[(value and 15)+1]+Result;
-   value := value shr 4;
-   end ;
- while (Length(Result)<Digits) do
-   Result:='0'+Result;
+  If Digits=0 then
+    Digits:=1;
+  Result:='';
+  While Value>0 do
+    begin
+    result:=HexDigits[(value and 15)+1]+Result;
+    value := value shr 4;
+    end ;
+  while (Length(Result)<Digits) do
+    Result:='0'+Result;
 end;
 
 { TFormatSettings }

packages/rtl/types.pas

@@ -1,6 +1,6 @@
 {
     This file is part of the Pas2JS run time library.
-    Copyright (c) 2017 by Mattias Gaertner
+    Copyright (c) 2018 by Mattias Gaertner
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.

packages/rtl/typinfo.pas

@@ -1,6 +1,6 @@
 {
     This file is part of the Pas2JS run time library.
-    Copyright (c) 2017 by Mattias Gaertner
+    Copyright (c) 2018 by Mattias Gaertner
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.