From 30fed3660553f4ba7d5c3d64cf6c68d8894a567c Mon Sep 17 00:00:00 2001
From: mattias <mattias@idefix.freepascal.org>
Date: Sat, 21 Apr 2018 06:14:52 +0000
Subject: [PATCH] rtl: added rtti.pas with TVirtualInterface

---
 packages/rtl/pas2js_rtl.lpk |   6 +-
 packages/rtl/rtti.pas       | 107 ++++++++++++++++++++++++++++++++++++
 2 files changed, 112 insertions(+), 1 deletion(-)
 create mode 100644 packages/rtl/rtti.pas

diff --git a/packages/rtl/pas2js_rtl.lpk b/packages/rtl/pas2js_rtl.lpk
index 8a009be..8468001 100644
--- a/packages/rtl/pas2js_rtl.lpk
+++ b/packages/rtl/pas2js_rtl.lpk
@@ -32,7 +32,7 @@
     <Description Value="pas2js RTL - Run Time Library"/>
     <License Value="Modified LGPL2 as the FPC packages."/>
     <Version Major="1"/>
-    <Files Count="19">
+    <Files Count="20">
       <Item1>
         <HasRegisterProc Value="True"/>
       </Item1>
@@ -109,6 +109,10 @@
         <Filename Value="webrouter.pp"/>
         <UnitName Value="webrouter"/>
       </Item19>
+      <Item20>
+        <Filename Value="rtti.pas"/>
+        <UnitName Value="RTTI"/>
+      </Item20>
     </Files>
     <UsageOptions>
       <CustomOptions Value="-dPas2js"/>
diff --git a/packages/rtl/rtti.pas b/packages/rtl/rtti.pas
new file mode 100644
index 0000000..fcc2cb6
--- /dev/null
+++ b/packages/rtl/rtti.pas
@@ -0,0 +1,107 @@
+{
+    This file is part of the Pas2JS run time library.
+    Copyright (c) 2018 by Mattias Gaertner
+
+    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.
+
+ **********************************************************************}
+unit RTTI;
+
+{$mode objfpc}
+
+interface
+
+uses
+  SysUtils, Types, TypInfo;
+
+type
+  TVirtualInterfaceInvokeEvent = function(const aMethodName: string;
+    const Args: TJSValueDynArray): JSValue of object;
+
+  { TVirtualInterface: A class that can implement any IInterface. Any method
+    call is handled by the OnInvoke event. }
+  TVirtualInterface = class(TInterfacedObject, IInterface)
+  private
+    FOnInvoke: TVirtualInterfaceInvokeEvent;
+  public
+    constructor Create(InterfaceTypeInfo: Pointer); overload; assembler;
+    constructor Create(InterfaceTypeInfo: Pointer;
+      const InvokeEvent: TVirtualInterfaceInvokeEvent); overload;
+    property OnInvoke: TVirtualInterfaceInvokeEvent read FOnInvoke write FOnInvoke;
+  end;
+
+procedure CreateVirtualCorbaInterface(InterfaceTypeInfo: Pointer;
+  const MethodImplementation: TVirtualInterfaceInvokeEvent; out IntfVar); assembler;
+
+implementation
+
+procedure CreateVirtualCorbaInterface(InterfaceTypeInfo: Pointer;
+  const MethodImplementation: TVirtualInterfaceInvokeEvent; out IntfVar); assembler;
+asm
+  var IntfType = InterfaceTypeInfo.interface;
+  var i = Object.create(IntfType);
+  var o = { $name: "virtual", $fullname: "virtual" };
+  i.$o = o;
+  do {
+    var names = IntfType.$names;
+    if (!names) break;
+    for (var j=0; j<names.length; j++){
+      let fnname = names[j];
+      i[fnname] = function(){ return MethodImplementation(fnname,arguments); };
+    }
+    IntfType = Object.getPrototypeOf(IntfType);
+  } while(IntfType!=null);
+  IntfVar.set(i);
+end;
+
+{ TVirtualInterface }
+
+constructor TVirtualInterface.Create(InterfaceTypeInfo: Pointer); assembler;
+asm
+  var IntfType = InterfaceTypeInfo.interface;
+  if (IntfType.$kind !== 'com') rtl.raiseE('EInvalidCast');
+  var guid = IntfType.$guid;
+  var i = Object.create(IntfType); // needed by IntfVar is IntfType
+  i.$o = this;
+  // copy IInterface methods: _AddRef, _Release, QueryInterface
+  var iinterfaceguid = '{00000000-0000-0000-C000-000000000046}';
+  var map = this.$intfmaps[iinterfaceguid];
+  for (var key in map){
+    var v = map[key];
+    if (typeof(v)!=='function') continue;
+    i[key] = map[key];
+  }
+  // all other methods call OnInvoke
+  do {
+    var names = IntfType.$names;
+    if (!names) break;
+    for (var j=0; j<names.length; j++){
+      let fnname = names[j];
+      if (i[fnname]) continue;
+      i[fnname] = function(){ return this.$o.FOnInvoke(fnname,arguments); };
+    }
+    IntfType = Object.getPrototypeOf(IntfType);
+  } while(IntfType!=null);
+  // create a new list of interface map, supporting IInterface and IntfType
+  this.$intfmaps = {};
+  this.$intfmaps[iinterfaceguid] = map;
+  this.$intfmaps[guid] = {};
+  // store the implementation of IntfType (used by the as-operator)
+  this.$interfaces = {};
+  this.$interfaces[guid] = i;
+end;
+
+constructor TVirtualInterface.Create(InterfaceTypeInfo: Pointer;
+  const InvokeEvent: TVirtualInterfaceInvokeEvent);
+begin
+  Create(InterfaceTypeInfo);
+  OnInvoke:=InvokeEvent;
+end;
+
+end.
+