paweld/pas2js
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/pas2js.git synced 2025-04-13 16:49:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

rtl: added TObject.Dispatch and DispatchStr

Browse Source
This commit is contained in:
mattias 2019-03-12 12:12:02 +00:00
parent b4fb0f45dd
commit 33328ecf5a
1 changed files with 71 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
packages/rtl/system.pas
View File

@ -99,6 +99,8 @@ type
{ TObject }
{$DispatchField Msg} // enable checking message methods for record field name "Msg"
{$DispatchStrField MsgStr}
TObject = class
private
class var FClassName: String; external name '$classname';
@ -125,6 +127,12 @@ type
procedure AfterConstruction; virtual;
procedure BeforeDestruction; virtual;
// message handling routines
procedure Dispatch(var aMessage); virtual;
procedure DispatchStr(var aMessage); virtual;
procedure DefaultHandler(var aMessage); virtual;
procedure DefaultHandlerStr(var aMessage); virtual;
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;
@ -393,7 +401,9 @@ type
var
JSArguments: TJSArguments; external name 'arguments';
// function parseInt(s: String; Radix: NativeInt): NativeInt; external name 'parseInt'; // may result NaN
function isNumber(const v: JSValue): boolean; external name 'rtl.isNumber';
function isObject(const v: JSValue): boolean; external name 'rtl.isObject'; // true if not null and a JS Object
function isString(const v: JSValue): boolean; external name 'rtl.isString';
function isNaN(i: JSValue): boolean; external name 'isNaN'; // may result NaN
// needed by ClassNameIs, the real SameText is in SysUtils
@ -824,6 +834,66 @@ begin
end;
procedure TObject.Dispatch(var aMessage);
// aMessage is a record with an integer field 'Msg'
var
aClass: TClass;
Msg: TJSObj absolute aMessage;
Id: jsvalue;
begin
if not isObject(Msg) then exit;
Id:=Msg['Msg'];
if not isNumber(Id) then exit;
aClass:=ClassType;
while aClass<>nil do
begin
asm
var Handlers = aClass.$msgint;
if (rtl.isObject(Handlers) && Handlers.hasOwnProperty(Id)){
this[Handlers[Id]](aMessage);
return;
}
end;
aClass:=aClass.ClassParent;
end;
DefaultHandler(aMessage);
end;
procedure TObject.DispatchStr(var aMessage);
// aMessage is a record with a string field 'MsgStr'
var
aClass: TClass;
Msg: TJSObj absolute aMessage;
Id: jsvalue;
begin
if not isObject(Msg) then exit;
Id:=Msg['MsgStr'];
if not isString(Id) then exit;
aClass:=ClassType;
while aClass<>nil do
begin
asm
var Handlers = aClass.$msgstr;
if (rtl.isObject(Handlers) && Handlers.hasOwnProperty(Id)){
this[Handlers[Id]](aMessage);
return;
}
end;
aClass:=aClass.ClassParent;
end;
DefaultHandlerStr(aMessage);
end;
procedure TObject.DefaultHandler(var aMessage);
begin
if jsvalue(aMessage) then ;
end;
procedure TObject.DefaultHandlerStr(var aMessage);
begin
if jsvalue(aMessage) then ;
end;
function TObject.GetInterface(const iid: TGuid; out obj): boolean;
begin
asm