From eb74dbf3b0a8001541f9cd8373ef0d7d8d308967 Mon Sep 17 00:00:00 2001 From: mattias Date: Wed, 13 Jul 2022 15:27:24 +0200 Subject: [PATCH] wasmjob: merged job_wasm into job_js, moved job_shared and job_browser to packages/job --- demo/wasienv/button/BrowserButton1.lpi | 11 +- demo/wasienv/button/BrowserButton1.lpr | 2 +- demo/wasienv/button/WasiButton1.lpi | 12 +- demo/wasienv/button/WasiButton1.lpr | 4 +- demo/wasienv/dom/BrowserDomTest1.lpi | 8 +- demo/wasienv/dom/BrowserDomTest1.lpr | 2 +- demo/wasienv/dom/WasiDomTest1.lpi | 11 +- demo/wasienv/dom/WasiDomTest1.lpr | 6 +- demo/wasienv/dom/job_js.pas | 1943 +++++++++++++++- demo/wasienv/dom/job_wasm.pas | 1955 ----------------- .../dom => packages/job}/job_browser.pp | 0 .../dom => packages/job}/job_shared.pp | 0 12 files changed, 1973 insertions(+), 1981 deletions(-) delete mode 100644 demo/wasienv/dom/job_wasm.pas rename {demo/wasienv/dom => packages/job}/job_browser.pp (100%) rename {demo/wasienv/dom => packages/job}/job_shared.pp (100%) diff --git a/demo/wasienv/button/BrowserButton1.lpi b/demo/wasienv/button/BrowserButton1.lpi index 09049c7..143fffd 100644 --- a/demo/wasienv/button/BrowserButton1.lpi +++ b/demo/wasienv/button/BrowserButton1.lpi @@ -36,17 +36,22 @@ - + - + + + + + + @@ -56,7 +61,7 @@ - + diff --git a/demo/wasienv/button/BrowserButton1.lpr b/demo/wasienv/button/BrowserButton1.lpr index 8f652d0..b58f64b 100644 --- a/demo/wasienv/button/BrowserButton1.lpr +++ b/demo/wasienv/button/BrowserButton1.lpr @@ -4,7 +4,7 @@ program BrowserButton1; uses BrowserConsole, BrowserApp, JS, Classes, SysUtils, Web, WebAssembly, Types, - WasiEnv, JOB_Browser, JOB_Shared; + WasiEnv, JOB_Shared, JOB_Browser; Type diff --git a/demo/wasienv/button/WasiButton1.lpi b/demo/wasienv/button/WasiButton1.lpi index 20d2c28..c5d728c 100644 --- a/demo/wasienv/button/WasiButton1.lpi +++ b/demo/wasienv/button/WasiButton1.lpi @@ -28,11 +28,6 @@ - - - - - @@ -43,6 +38,11 @@ + + + + + @@ -52,7 +52,7 @@ - + diff --git a/demo/wasienv/button/WasiButton1.lpr b/demo/wasienv/button/WasiButton1.lpr index 27b5dd8..b546d15 100644 --- a/demo/wasienv/button/WasiButton1.lpr +++ b/demo/wasienv/button/WasiButton1.lpr @@ -5,7 +5,7 @@ library WasiButton1; {$codepage UTF8} uses - SysUtils, JOB_WAsm, JOB_Shared, JOB_Web, JOB_JS; + SysUtils, JOB_Shared, JOB_Web, JOB_JS; type @@ -58,7 +58,7 @@ end; // workaround: fpc wasm does not yet support exporting functions from units function JOBCallback(const Func: TJOBCallback; Data, Code: Pointer; Args: PByte): PByte; begin - Result:=JOB_WAsm.JOBCallback(Func,Data,Code,Args); + Result:=JOB_JS.JOBCallback(Func,Data,Code,Args); end; exports diff --git a/demo/wasienv/dom/BrowserDomTest1.lpi b/demo/wasienv/dom/BrowserDomTest1.lpi index b658695..9854195 100644 --- a/demo/wasienv/dom/BrowserDomTest1.lpi +++ b/demo/wasienv/dom/BrowserDomTest1.lpi @@ -42,10 +42,15 @@ - + + + + + + @@ -55,6 +60,7 @@ + diff --git a/demo/wasienv/dom/BrowserDomTest1.lpr b/demo/wasienv/dom/BrowserDomTest1.lpr index 9e29faa..f2a6911 100644 --- a/demo/wasienv/dom/BrowserDomTest1.lpr +++ b/demo/wasienv/dom/BrowserDomTest1.lpr @@ -4,7 +4,7 @@ program BrowserDomTest1; uses BrowserConsole, BrowserApp, JS, Classes, SysUtils, Web, WebAssembly, Types, - wasienv, job_browser, job_shared; + wasienv, job_shared, JOB_Browser; Type diff --git a/demo/wasienv/dom/WasiDomTest1.lpi b/demo/wasienv/dom/WasiDomTest1.lpi index 7479092..c9b436c 100644 --- a/demo/wasienv/dom/WasiDomTest1.lpi +++ b/demo/wasienv/dom/WasiDomTest1.lpi @@ -28,11 +28,6 @@ - - - - - @@ -43,6 +38,11 @@ + + + + + @@ -52,6 +52,7 @@ + diff --git a/demo/wasienv/dom/WasiDomTest1.lpr b/demo/wasienv/dom/WasiDomTest1.lpr index 584110c..4c169d2 100644 --- a/demo/wasienv/dom/WasiDomTest1.lpr +++ b/demo/wasienv/dom/WasiDomTest1.lpr @@ -5,7 +5,7 @@ library WasiDomTest1; {$codepage UTF8} uses - SysUtils, JOB_WAsm, JOB_Shared, JOB_Web, JOB_JS; + SysUtils, JOB_Shared, JOB_Web, JOB_JS; type @@ -66,7 +66,7 @@ begin exit; - obj:=TJSObject.CreateFromID(JObjIdBird); + obj:=TJSObject.JOBCreateFromID(JObjIdBird); obj.WriteJSPropertyUnicodeString('Caption','Root'); writeln('AAA1 '); //u:='äbc'; @@ -141,7 +141,7 @@ end; // workaround: fpc wasm does not yet support exporting functions from units function JOBCallback(const Func: TJOBCallback; Data, Code: Pointer; Args: PByte): PByte; begin - Result:=JOB_WAsm.JOBCallback(Func,Data,Code,Args); + Result:=JOB_JS.JOBCallback(Func,Data,Code,Args); end; exports diff --git a/demo/wasienv/dom/job_js.pas b/demo/wasienv/dom/job_js.pas index e5872b5..402867b 100644 --- a/demo/wasienv/dom/job_js.pas +++ b/demo/wasienv/dom/job_js.pas @@ -1,13 +1,344 @@ +{ + JOB - JS Object Bridge for Webassembly + + Webassembly unit giving access to the browser DOM. + + see https://wiki.freepascal.org/WebAssembly/DOM +} unit JOB_JS; {$mode ObjFPC}{$H+} +{$ModeSwitch advancedrecords} + +{$define VerboseJOB} interface - uses - JOB_Shared, JOB_WAsm; + SysUtils, Types, Math, Classes, JOB_Shared; + +const + MinSafeIntDouble = -$1fffffffffffff; // -9007199254740991 54 bits (52 plus signed bit plus implicit highest bit) + MaxSafeIntDouble = $1fffffffffffff; // 9007199254740991 + +Type + PJOBObjectID = ^TJOBObjectID; + + EJSObject = class(Exception); + EJSInvoke = class(EJSObject) + public + ObjectID: TJOBObjectID; + FuncName: string; + end; + EJSArgParse = class(EJSObject); + + TJOB_JSValueKind = ( + jjvkUndefined, + jjvkBoolean, + jjvkDouble, + jjvkString, + jjvkObject, + jjvkMethod, + jjvkDictionary, + jjvkArrayOfJSValue, + jjvkArrayOfDouble + ); + TJOB_JSValueKinds = set of TJOB_JSValueKind; + +const + JOB_JSValueKindNames: array[TJOB_JSValueKind] of string = ( + 'Undefined', + 'Boolean', + 'Double', + 'String', + 'Object', + 'Method', + 'Dictionary', + 'ArrayOfJSValue', + 'ArrayOfDouble' + ); + + JOB_Undefined = Pointer(1); type + TUnicodeStringDynArray = array of UnicodeString; + + { TJOB_JSValue } + + TJOB_JSValue = class + public + Kind: TJOB_JSValueKind; + constructor Create(aKind: TJOB_JSValueKind); + function AsString: string; virtual; + end; + TJOB_JSValueClass = class of TJOB_JSValue; + TJOB_JSValueArray = array of TJOB_JSValue; + + { TJOB_Boolean } + + TJOB_Boolean = class(TJOB_JSValue) + public + Value: Boolean; + constructor Create(aValue: Boolean); + function AsString: string; override; + end; + + { TJOB_Double } + + TJOB_Double = class(TJOB_JSValue) + public + Value: Double; + constructor Create(const aValue: Double); + function AsString: string; override; + end; + + { TJOB_String } + + TJOB_String = class(TJOB_JSValue) + public + Value: UnicodeString; + constructor Create(const aValue: UnicodeString); + function AsString: string; override; + end; + + IJSObject = interface; + + { TJOB_Object } + + TJOB_Object = class(TJOB_JSValue) + public + Value: IJSObject; + constructor Create(aValue: IJSObject); + function AsString: string; override; + end; + + TJOBInvokeType = ( + jiCall, // call function + jiGet, // read property + jiGetTypeOf, // read property and do typeof + jiSet, // write property + jiNew // new operator + ); + TJOBInvokeTypes = set of TJOBInvokeType; + + TJSObject = class; + TJSObjectClass = class of TJSObject; + + { TJOBCallbackHelper - parse callback arguments and create result } + + TJOBCallbackHelper = record + p: PByte; + Index: integer; + Count: integer; + procedure Init(Args: PByte); + function GetType: byte; // see JOBArg* constants, keeps p + procedure Skip; + function GetBoolean: boolean; + function GetDouble: double; + function GetString: UnicodeString; + function GetObject(aResultClass: TJSObjectClass): TJSObject; + function GetValue: TJOB_JSValue; + function GetLongInt: longint; + function GetMaxInt: int64; + + function AllocUndefined: PByte; + function AllocBool(b: boolean): PByte; + function AllocLongint(i: longint): PByte; + function AllocDouble(const d: double): PByte; + function AllocString(const s: UnicodeString): PByte; + function AllocNil: PByte; + function AllocIntf(Intf: IJSObject): PByte; + function AllocObject(Obj: TJSObject): PByte; + function AllocObjId(ObjId: TJOBObjectID): PByte; + end; + + TJOBCallback = function(const aMethod: TMethod; var H: TJOBCallbackHelper): PByte; + + { TJOB_Method } + + TJOB_Method = class(TJOB_JSValue) + public + Value: TMethod; + Invoke: TJOBCallback; + constructor Create(const aMethod: TMethod; const AnInvoke: TJOBCallback); + function AsString: string; override; + end; + + TJOB_Pair = record + Name: UnicodeString; + Value: TJOB_JSValue; + end; + TJOB_PairArray = array of TJOB_Pair; + + { TJOB_Dictionary } + + TJOB_Dictionary = class(TJOB_JSValue) + public + Values: TJOB_PairArray; + procedure Add(const aName: UnicodeString; const aValue: TJOB_JSValue); + constructor Create(const Pairs: array of const); + destructor Destroy; override; + procedure Clear; + end; + + TJOB_ArrayBase = class(TJOB_JSValue) + end; + + { TJOB_ArrayOfJSValue } + + TJOB_ArrayOfJSValue = class(TJOB_ArrayBase) + public + Values: TJOB_JSValueArray; + procedure Add(const aValue: TJOB_JSValue); + constructor Create(const TheValues: array of const); + destructor Destroy; override; + procedure Clear; + end; + + { TJOB_ArrayOfDouble } + + TJOB_ArrayOfDouble = class(TJOB_ArrayBase) + public + Values: TDoubleDynArray; + constructor Create(const TheValues: TDoubleDynArray); + end; + + { IJSObject } + + IJSObject = interface + ['{BE5CDE03-D471-4AB3-8F27-A5EA637416F7}'] + function GetJSObjectID: TJOBObjectID; + function GetJSObjectCastSrc: IJSObject; + function GetPascalClassName: string; + function GetProperties(const PropName: String): TJOB_JSValue; virtual; + procedure SetProperties(const PropName: String; const AValue: TJOB_JSValue); virtual; + // call a function + procedure InvokeJSNoResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall); virtual; + function InvokeJSBooleanResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): Boolean; virtual; + function InvokeJSDoubleResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): Double; virtual; + function InvokeJSUnicodeStringResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): UnicodeString; virtual; + function InvokeJSObjectResult(const aName: string; Const Args: Array of const; aResultClass: TJSObjectClass; Invoke: TJOBInvokeType = jiCall): TJSObject; virtual; + function InvokeJSValueResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): TJOB_JSValue; virtual; + function InvokeJSUtf8StringResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): String; virtual; + function InvokeJSLongIntResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): LongInt; virtual; + function InvokeJSTypeOf(const aName: string; Const Args: Array of const): TJOBResult; virtual; + function InvokeJSUnicodeStringArrayResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): TUnicodeStringDynArray; virtual; + // read a property + function ReadJSPropertyBoolean(const aName: string): boolean; virtual; + function ReadJSPropertyDouble(const aName: string): double; virtual; + function ReadJSPropertyUnicodeString(const aName: string): UnicodeString; virtual; + function ReadJSPropertyObject(const aName: string; aResultClass: TJSObjectClass): TJSObject; virtual; + function ReadJSPropertyUtf8String(const aName: string): string; virtual; + function ReadJSPropertyLongInt(const aName: string): LongInt; virtual; + function ReadJSPropertyValue(const aName: string): TJOB_JSValue; virtual; + // write a property + procedure WriteJSPropertyBoolean(const aName: string; Value: Boolean); virtual; + procedure WriteJSPropertyDouble(const aName: string; Value: Double); virtual; + procedure WriteJSPropertyUnicodeString(const aName: string; const Value: UnicodeString); virtual; + procedure WriteJSPropertyUtf8String(const aName: string; const Value: String); virtual; + procedure WriteJSPropertyObject(const aName: string; Value: IJSObject); virtual; + procedure WriteJSPropertyLongInt(const aName: string; Value: LongInt); virtual; + // create a new object using the new-operator + function NewJSObject(Const Args: Array of const; aResultClass: TJSObjectClass): TJSObject; virtual; + // JS members + function getOwnPropertyNames(const Obj: IJSObject): TUnicodeStringDynArray; + function getPrototypeOf(const Obj: IJSObject): IJSObject; + function hasOwnProperty(const PropName: String): boolean; virtual; + function isPrototypeOf(const Obj: IJSObject): boolean; virtual; + function propertyIsEnumerable(const PropName: String): boolean; virtual; + function toLocaleString: UnicodeString; virtual; overload; + function toString: String; override; overload; + function toUString: UnicodeString; virtual; overload; + function valueOf: TJOB_JSValue; virtual; overload; + property Properties[const PropName: String]: TJOB_JSValue read GetProperties write SetProperties; default; + end; + + { TJSObject } + + TJSObject = class(TInterfacedObject,IJSObject) + private + FJOBObjectID: TJOBObjectID; + FJOBCastSrc: IJSObject; + protected + type + TJOBInvokeNoResultFunc = function( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte + ): TJOBResult; + TJOBInvokeOneResultFunc = function( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte; + ResultP: PByte + ): TJOBResult; + function GetJSObjectID: TJOBObjectID; + function GetJSObjectCastSrc: IJSObject; + function GetPascalClassName: string; + function GetProperties(const PropName: String): TJOB_JSValue; virtual; + procedure SetProperties(const PropName: String; const AValue: TJOB_JSValue); virtual; + function FetchString(Len: NativeInt): UnicodeString; + function InvokeJSNoResultFunc(const aName: string; Const Args: Array of const; + const InvokeFunc: TJOBInvokeNoResultFunc; Invoke: TJOBInvokeType): TJOBResult; + function InvokeJSOneResult(const aName: string; Const Args: Array of const; + const InvokeFunc: TJOBInvokeOneResultFunc; ResultP: PByte; Invoke: TJOBInvokeType): TJOBResult; + procedure InvokeJS_Raise(const aName, Msg: string); virtual; + procedure InvokeJS_RaiseResultMismatch(const aName: string; Expected, Actual: TJOBResult); virtual; + procedure InvokeJS_RaiseResultMismatchStr(const aName: string; const Expected, Actual: string); virtual; + function CreateInvokeJSArgs(const Args: array of const): PByte; virtual; + public + constructor JOBCast(Intf: IJSObject); overload; + constructor JOBCreateFromID(aID: TJOBObjectID); virtual; // use this only for the owner (it will release it on free) + class function Cast(Intf: IJSObject): IJSObject; overload; + destructor Destroy; override; + property JOBObjectID: TJOBObjectID read FJOBObjectID; + property JOBCastSrc: IJSObject read FJOBCastSrc; // nil means it is the owner, otherwise it is a typecast + // call a function + procedure InvokeJSNoResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall); virtual; + function InvokeJSBooleanResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): Boolean; virtual; + function InvokeJSDoubleResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): Double; virtual; + function InvokeJSUnicodeStringResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): UnicodeString; virtual; + function InvokeJSObjectResult(const aName: string; Const Args: Array of const; aResultClass: TJSObjectClass; Invoke: TJOBInvokeType = jiCall): TJSObject; virtual; + function InvokeJSValueResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): TJOB_JSValue; virtual; + function InvokeJSUtf8StringResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): String; virtual; + function InvokeJSLongIntResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): LongInt; virtual; + function InvokeJSMaxIntResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): int64; virtual; + function InvokeJSTypeOf(const aName: string; Const Args: Array of const): TJOBResult; virtual; + function InvokeJSUnicodeStringArrayResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): TUnicodeStringDynArray; virtual; + // read a property + function ReadJSPropertyBoolean(const aName: string): boolean; virtual; + function ReadJSPropertyDouble(const aName: string): double; virtual; + function ReadJSPropertyUnicodeString(const aName: string): UnicodeString; virtual; + function ReadJSPropertyObject(const aName: string; aResultClass: TJSObjectClass): TJSObject; virtual; + function ReadJSPropertyUtf8String(const aName: string): string; virtual; + function ReadJSPropertyLongInt(const aName: string): LongInt; virtual; + function ReadJSPropertyInt64(const aName: string): Int64; virtual; + function ReadJSPropertyValue(const aName: string): TJOB_JSValue; virtual; + // write a property + procedure WriteJSPropertyBoolean(const aName: string; Value: Boolean); virtual; + procedure WriteJSPropertyDouble(const aName: string; Value: Double); virtual; + procedure WriteJSPropertyUnicodeString(const aName: string; const Value: UnicodeString); virtual; + procedure WriteJSPropertyUtf8String(const aName: string; const Value: String); virtual; + procedure WriteJSPropertyObject(const aName: string; Value: IJSObject); virtual; + procedure WriteJSPropertyLongInt(const aName: string; Value: LongInt); virtual; + procedure WriteJSPropertyValue(const aName: string; Value: TJOB_JSValue); virtual; + // create a new object using the new-operator + function NewJSObject(Const Args: Array of const; aResultClass: TJSObjectClass): TJSObject; virtual; + // JS members + function getOwnPropertyNames(const Obj: IJSObject): TUnicodeStringDynArray; + function getPrototypeOf(const Obj: IJSObject): IJSObject; + function hasOwnProperty(const PropName: String): boolean; virtual; + function isPrototypeOf(const Obj: IJSObject): boolean; virtual; + function propertyIsEnumerable(const PropName: String): boolean; virtual; + function toLocaleString: UnicodeString; virtual; overload; + function toString: String; override; overload; + function toUString: UnicodeString; virtual; overload; + function valueOf: TJOB_JSValue; virtual; overload; + property Properties[const PropName: String]: TJOB_JSValue read GetProperties write SetProperties; default; + end; { IJSDate } @@ -31,10 +362,1613 @@ type end; var - JSDate: TJSDate; + JSObject: IJSObject; // singleton of JS 'Object' + JSDate: IJSDate; // singleton of JS 'Date' + +// imported functions from browser +function __job_invoke_noresult( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte +): TJOBResult; external JOBExportName name JOBFn_InvokeNoResult; + +function __job_invoke_boolresult( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte; + ResultByteBoolP: PByte +): TJOBResult; external JOBExportName name JOBFn_InvokeBooleanResult; + +function __job_invoke_doubleresult( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte; + ResultDoubleP: PByte +): TJOBResult; external JOBExportName name JOBFn_InvokeDoubleResult; + +function __job_invoke_stringresult( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte; + ResultLenP: PByte // nativeint +): TJOBResult; external JOBExportName name JOBFn_InvokeStringResult; + +function __job_getstringresult( + ResultP: PByte +): TJOBResult; external JOBExportName name JOBFn_GetStringResult; + +function __job_releasestringresult( +): TJOBResult; external JOBExportName name JOBFn_ReleaseStringResult; + +function __job_invoke_objectresult( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte; + ResultObjIDP: PByte // nativeint +): TJOBResult; external JOBExportName name JOBFn_InvokeObjectResult; + +function __job_release_object( + ObjID: TJOBObjectID +): TJOBResult; external JOBExportName name JOBFn_ReleaseObject; + +function __job_invoke_jsvalueresult( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte; + ResultP: PByte // various +): TJOBResult; external JOBExportName name JOBFn_InvokeJSValueResult; + +function __job_invoke_arraystringresult( + ObjID: TJOBObjectID; + NameP: PChar; + NameLen: longint; + Invoke: longint; + ArgP: PByte; + ResultLenP: PByte // nativeint +): TJOBResult; external JOBExportName name JOBFn_InvokeArrayStringResult; + +function JOBCallback(const Func: TJOBCallback; Data, Code: Pointer; Args: PByte): PByte; +function VarRecToJSValue(const V: TVarRec): TJOB_JSValue; implementation +const + InvokeGetToInt: array[TJOBInvokeType] of integer = ( + JOBInvokeCall, + JOBInvokeGet, + JOBInvokeGetTypeOf, + JOBInvokeSet, + JOBInvokeNew + ); + +{$IFDEF VerboseJOB} +function GetVarRecName(vt: word): string; +begin + case vt of + vtInteger: Result:='vtInteger'; + vtBoolean: Result:='vtBoolean'; + vtChar: Result:='vtChar'; + {$ifndef FPUNONE} + vtExtended: Result:='vtExtended'; + {$endif} + vtString: Result:='vtString'; + vtPointer: Result:='vtPointer'; + vtPChar: Result:='vtPChar'; + vtObject: Result:='vtObject'; + vtClass: Result:='vtClass'; + vtWideChar: Result:='vtWideChar'; + vtPWideChar: Result:='vtPWideChar'; + vtAnsiString: Result:='vtAnsiString'; + vtCurrency: Result:='vtCurrency'; + vtVariant: Result:='vtVariant'; + vtInterface: Result:='vtInterface'; + vtWideString: Result:='vtWideString'; + vtInt64: Result:='vtInt64'; + vtQWord: Result:='vtQWord'; + vtUnicodeString: Result:='vtUnicodeString'; + else + Result:='vt?'; + end; +end; +{$ENDIF} + +function __job_callback(w: NativeInt): boolean; +begin + writeln('__job_callback w=',w); + Result:=true; +end; + +function JOBCallback(const Func: TJOBCallback; Data, Code: Pointer; Args: PByte + ): PByte; +var + m: TMethod; + h: TJOBCallbackHelper; +begin + Result:=nil; + try + //writeln('JOBCallback'); + m.Data:=Data; + m.Code:=Code; + h.Init(Args); + Result:=Func(m,h); + finally + if Args<>nil then + FreeMem(Args); + end; +end; + +function VarRecToJSValue(const V: TVarRec): TJOB_JSValue; +var + p: Pointer; + CurLen: SizeInt; + S: String; + Obj: TObject; + Intf: IJSObject; +begin + case V.VType of + vtInteger: + Result:=TJOB_Double.Create(V.VInteger); + vtBoolean: + Result:=TJOB_Boolean.Create(V.VBoolean); + vtChar: + Result:=TJOB_String.Create(UnicodeString(V.VChar)); + {$ifndef FPUNONE} + vtExtended: + Result:=TJOB_Double.Create(V.VExtended^); + {$endif} + vtString: + Result:=TJOB_String.Create(UnicodeString(V.VString^)); + vtPointer: + begin + p:=V.VPointer; + if p=nil then + Result:=TJOB_Object.Create(nil) + else if p=JOB_Undefined then + Result:=TJOB_JSValue.Create(jjvkUndefined) + else + raise EJSArgParse.Create('VarRecToJSValue pointer not supported'); + end; + vtPChar: + begin + CurLen:=strlen(V.VPChar); + SetString(S,V.VPChar,CurLen); + Result:=TJOB_String.Create(UnicodeString(S)); + end; + vtObject: + begin + Obj:=V.VObject; + if Obj=nil then + Result:=TJOB_Object.Create(nil) + else if Obj is TJOB_JSValue then + Result:=TJOB_JSValue(Obj) + else if Obj is TJSObject then + Result:=TJOB_Object.Create(TJSObject(Obj) as IJSObject) + else + raise EJSArgParse.Create('VarRecToJSValue object '+Obj.ClassName+' not supported'); + end; + vtClass: + raise EJSArgParse.Create('VarRecToJSValue class not supported'); + vtWideChar: + Result:=TJOB_String.Create(V.VWideChar); + vtPWideChar: + raise EJSArgParse.Create('VarRecToJSValue vtPWideChar not supported'); + vtAnsiString: + Result:=TJOB_String.Create(UnicodeString(PAnsiString(V.VAnsiString)^)); + vtCurrency: + Result:=TJOB_Double.Create(V.VCurrency^); + vtVariant: + raise EJSArgParse.Create('VarRecToJSValue vtVariant not supported'); + vtInterface: + begin + Intf:=IJSObject(V.VInterface); + Result:=TJOB_Object.Create(Intf); + end; + vtWideString: + raise EJSArgParse.Create('VarRecToJSValue vtWideString not supported'); + vtInt64: + Result:=TJOB_Double.Create(V.VInt64^); + vtQWord: + Result:=TJOB_Double.Create(V.VQWord^); + vtUnicodeString: + Result:=TJOB_String.Create(PUnicodeString(V.VUnicodeString)^); + else + raise EJSArgParse.Create('VarRecToJSValue unsupported VType '+IntToStr(V.VType)); + end; +end; + +{ TJOBCallbackHelper } + +procedure TJOBCallbackHelper.Init(Args: PByte); +begin + p:=Args; + Index:=0; + if p<>nil then + begin + Count:=p^; + inc(p); + end else + Count:=0; +end; + +function TJOBCallbackHelper.GetType: byte; +begin + if Index=Count then + Result:=JOBArgUndefined + else + Result:=p^; +end; + +procedure TJOBCallbackHelper.Skip; +var + Len: LongWord; +begin + if Index=Count then exit; + case p^ of + JOBArgUndefined, + JOBArgTrue, + JOBArgFalse, + JOBArgNil: inc(p); + JOBArgDouble: inc(p,9); + JOBArgUnicodeString: + begin + inc(p); + Len:=PLongWord(p)^; + inc(p,4+2*Len); + end + else + raise EJSArgParse.Create(JOBArgNames[p^]); + end; + inc(Index); +end; + +function TJOBCallbackHelper.GetBoolean: boolean; +begin + Result:=false; + if Index=Count then + exit; + case p^ of + JOBArgUndefined: ; + JOBArgTrue: Result:=true; + JOBArgFalse: ; + else + raise EJSArgParse.Create(JOBArgNames[p^]); + end; + inc(p); + inc(Index); +end; + +function TJOBCallbackHelper.GetDouble: double; +begin + Result:=NaN; + if Index=Count then + exit; + case p^ of + JOBArgUndefined: + inc(p); + JOBArgDouble: + begin + inc(p); + Result:=PDouble(p)^; + inc(p,8); + end + else + raise EJSArgParse.Create(JOBArgNames[p^]); + end; + inc(Index); +end; + +function TJOBCallbackHelper.GetString: UnicodeString; +var + Len: LongWord; +begin + Result:=''; + if Index=Count then + exit; + case p^ of + JOBArgUndefined: + inc(p); + JOBArgUnicodeString: + begin + inc(p); + Len:=PLongWord(p)^; + inc(p,4); + if Len>0 then + begin + SetLength(Result,Len); + Move(p^,Result[1],2*Len); + inc(p,2*Len); + end; + end + else + raise EJSArgParse.Create(JOBArgNames[p^]); + end; + inc(Index); +end; + +function TJOBCallbackHelper.GetObject(aResultClass: TJSObjectClass): TJSObject; +var + ObjId: LongWord; +begin + //writeln('TJOBCallbackHelper.GetObject ',Index,' Count=',Count); + Result:=nil; + if Index=Count then + exit; + //writeln('TJOBCallbackHelper.GetObject type=',p^); + case p^ of + JOBArgUndefined, + JOBArgNil: + inc(p); + JOBArgObject: + begin + inc(p); + ObjId:=PLongWord(p)^; + inc(p,4); + Result:=aResultClass.JOBCreateFromID(ObjId); + end + else + raise EJSArgParse.Create(JOBArgNames[p^]); + end; + inc(Index); +end; + +function TJOBCallbackHelper.GetValue: TJOB_JSValue; +var + ObjId, Len: LongWord; + Obj: TJSObject; + S: UnicodeString; +begin + Result:=nil; + if (Index=Count) or (p^=JOBArgUndefined) then + begin + Result:=TJOB_JSValue.Create(jjvkUndefined); + exit; + end; + case p^ of + JOBArgTrue: + begin + Result:=TJOB_Boolean.Create(true); + inc(p); + end; + JOBArgFalse: + begin + Result:=TJOB_Boolean.Create(false); + inc(p); + end; + JOBArgDouble: + begin + inc(p); + Result:=TJOB_Double.Create(PDouble(p)^); + inc(p,8); + end; + JOBArgUnicodeString: + begin + inc(p); + Len:=PLongWord(p)^; + inc(p,4); + S:=''; + if Len>0 then + begin + SetLength(S,Len); + Move(p^,S[1],2*Len); + inc(p,2*Len); + end; + Result:=TJOB_String.Create(S); + end; + JOBArgNil: + begin + Result:=TJOB_Object.Create(nil); + inc(p); + end; + JOBArgObject: + begin + inc(p); + ObjId:=PLongWord(p)^; + inc(p,4); + Obj:=TJSObject.JOBCreateFromID(ObjId); + Result:=TJOB_Object.Create(Obj); + end; + else + raise EJSArgParse.Create(JOBArgNames[p^]); + end; + inc(Index); +end; + +function TJOBCallbackHelper.GetLongInt: longint; +var + d: Double; +begin + d:=GetDouble; + if (Frac(d)<>0) or (dhigh(longint)) then + raise EJSArgParse.Create('expected longint, but got double') + else + Result:=Trunc(d); +end; + +function TJOBCallbackHelper.GetMaxInt: int64; +var + d: Double; +begin + d:=GetDouble; + if (Frac(d)<>0) or (dhigh(int64)) then + raise EJSArgParse.Create('expected int64, but got double') + else + Result:=Trunc(d); +end; + +function TJOBCallbackHelper.AllocUndefined: PByte; +begin + GetMem(Result,1); + Result^:=JOBArgUndefined; +end; + +function TJOBCallbackHelper.AllocBool(b: boolean): PByte; +begin + GetMem(Result,1); + if b then + Result^:=JOBArgTrue + else + Result^:=JOBArgFalse; +end; + +function TJOBCallbackHelper.AllocLongint(i: longint): PByte; +begin + GetMem(Result,5); + Result^:=JOBArgLongint; + PLongint(Result+1)^:=i; +end; + +function TJOBCallbackHelper.AllocDouble(const d: double): PByte; +begin + GetMem(Result,9); + Result^:=JOBArgDouble; + PDouble(Result+1)^:=d; +end; + +function TJOBCallbackHelper.AllocString(const s: UnicodeString): PByte; +var + l: SizeInt; +begin + l:=length(s); + GetMem(Result,5+l); + Result^:=JOBArgUnicodeString; + PLongWord(Result+1)^:=l; + if l>0 then + Move(s[1],Result[5],l); +end; + +function TJOBCallbackHelper.AllocNil: PByte; +begin + GetMem(Result,1); + Result^:=JOBArgNil; +end; + +function TJOBCallbackHelper.AllocIntf(Intf: IJSObject): PByte; +begin + if Intf=nil then + Result:=AllocNil + else + Result:=AllocObjId(Intf.GetJSObjectID); +end; + +function TJOBCallbackHelper.AllocObject(Obj: TJSObject): PByte; +begin + if Obj=nil then + Result:=AllocNil + else + Result:=AllocObjId(Obj.JOBObjectID); +end; + +function TJOBCallbackHelper.AllocObjId(ObjId: TJOBObjectID): PByte; +begin + GetMem(Result,1+SizeOf(TJOBObjectID)); + Result^:=JOBArgObject; + PJOBObjectID(Result+1)^:=ObjId; +end; + +{ TJOB_JSValue } + +constructor TJOB_JSValue.Create(aKind: TJOB_JSValueKind); +begin + Kind:=aKind; +end; + +function TJOB_JSValue.AsString: string; +begin + if Kind=jjvkUndefined then + Result:='undefined' + else begin + Result:=''; + str(Kind,Result); + end; +end; + +{ TJOB_Boolean } + +constructor TJOB_Boolean.Create(aValue: Boolean); +begin + Kind:=jjvkBoolean; + Value:=aValue; +end; + +function TJOB_Boolean.AsString: string; +begin + str(Value,Result); +end; + +{ TJOB_Double } + +constructor TJOB_Double.Create(const aValue: Double); +begin + Kind:=jjvkDouble; + Value:=aValue; +end; + +function TJOB_Double.AsString: string; +begin + str(Value,Result); +end; + +{ TJOB_String } + +constructor TJOB_String.Create(const aValue: UnicodeString); +begin + Kind:=jjvkString; + Value:=aValue; +end; + +function TJOB_String.AsString: string; +begin + Result:=AnsiQuotedStr(String(Value),'"'); +end; + +{ TJOB_Object } + +constructor TJOB_Object.Create(aValue: IJSObject); +begin + Kind:=jjvkObject; + Value:=aValue; +end; + +function TJOB_Object.AsString: string; +begin + if Value=nil then + Result:='nil' + else + Result:='['+IntToStr(Value.GetJSObjectID)+']:'+Value.GetPascalClassName; +end; + +{ TJOB_Method } + +constructor TJOB_Method.Create(const aMethod: TMethod; + const AnInvoke: TJOBCallback); +begin + Kind:=jjvkMethod; + Value:=aMethod; + Invoke:=AnInvoke; +end; + +function TJOB_Method.AsString: string; +begin + Result:='Callback'; +end; + +{ TJOB_Dictionary } + +procedure TJOB_Dictionary.Add(const aName: UnicodeString; + const aValue: TJOB_JSValue); +var + p: TJOB_Pair; +begin + p.Name:=aName; + p.Value:=aValue; + Insert(p,Values,length(Values)); +end; + +constructor TJOB_Dictionary.Create(const Pairs: array of const); +var + i: Integer; + l, CurLen: SizeInt; + CurName: UnicodeString; +begin + inherited Create(jjvkDictionary); + l:=length(Pairs); + SetLength(Values,l div 2); + for i:=0 to length(Values)-1 do + Values[i].Value:=nil; + i:=0; + while inil then + FreeMem(InvokeArgs); + end; + end; +end; + +function TJSObject.InvokeJSOneResult(const aName: string; + const Args: array of const; const InvokeFunc: TJOBInvokeOneResultFunc; + ResultP: PByte; Invoke: TJOBInvokeType): TJOBResult; +var + InvokeArgs: PByte; +begin + if length(Args)=0 then + Result:=InvokeFunc(JOBObjectID,PChar(aName),length(aName),InvokeGetToInt[Invoke],nil,ResultP) + else begin + InvokeArgs:=CreateInvokeJSArgs(Args); + try + Result:=InvokeFunc(JOBObjectID,PChar(aName),length(aName),InvokeGetToInt[Invoke],InvokeArgs,ResultP); + finally + if InvokeArgs<>nil then + FreeMem(InvokeArgs); + end; + end; +end; + +procedure TJSObject.InvokeJS_Raise(const aName, Msg: string); +var + E: EJSInvoke; +begin + E:=EJSInvoke.Create(Msg); + E.ObjectID:=JOBObjectID; + E.FuncName:=aName; + raise E; +end; + +procedure TJSObject.InvokeJS_RaiseResultMismatch(const aName: string; + Expected, Actual: TJOBResult); +begin + case Actual of + JOBResult_UnknownObjId: InvokeJS_Raise(aName,'unknown object id '+IntToStr(JOBObjectID)); + JOBResult_NotAFunction: InvokeJS_Raise(aName,'object '+IntToStr(JOBObjectID)+' does not have a function "'+aName+'"'); + else + InvokeJS_RaiseResultMismatchStr(aName,JOBResult_Names[Expected],JOBResult_Names[Actual]); + end; +end; + +procedure TJSObject.InvokeJS_RaiseResultMismatchStr(const aName: string; + const Expected, Actual: string); +begin + InvokeJS_Raise(aName,'expected '+Expected+', but got '+Actual+' from object '+IntToStr(JOBObjectID)+' function "'+aName+'"'); +end; + +function TJSObject.CreateInvokeJSArgs(const Args: array of const): PByte; + + procedure RaiseNotSupported(const Msg: string); + begin + raise EJSInvoke.Create('Invoke js: type not supported '+Msg); + end; + + procedure RaiseRange; + begin + raise ERangeError.Create('Invoke js: number out of bounds'); + end; + +var + p: PByte; + + function SizeOfTJOB_JSValue(JSValue: TJOB_JSValue): integer; + var + Dict: TJOB_PairArray; + i: Integer; + Arr: TJOB_JSValueArray; + begin + case JSValue.Kind of + jjvkUndefined: Result:=1; + jjvkBoolean: Result:=1; + jjvkDouble: Result:=9; + jjvkString: Result:=1+SizeOf(NativeInt)+SizeOf(PByte); + jjvkObject: + if TJOB_Object(JSValue).Value=nil then + Result:=1 + else + Result:=1+SizeOf(TJOBObjectID); + jjvkMethod: Result:=1+3*SizeOf(PByte); + jjvkDictionary: + begin + Result:=1+SizeOf(NativeInt); + Dict:=TJOB_Dictionary(JSValue).Values; + for i:=0 to length(Dict)-1 do + begin + inc(Result,1+SizeOf(NativeInt)+SizeOf(PByte)); + inc(Result,SizeOfTJOB_JSValue(Dict[i].Value)); + end; + end; + jjvkArrayOfJSValue: + begin + Result:=1+SizeOf(NativeInt); + Arr:=TJOB_ArrayOfJSValue(JSValue).Values; + for i:=0 to length(Arr)-1 do + inc(Result,SizeOfTJOB_JSValue(Dict[i].Value)); + end; + jjvkArrayOfDouble: + Result:=1+SizeOf(NativeInt)+SizeOf(PByte); + else + RaiseNotSupported('20220630135718'){%H-}; + end; + end; + + procedure AddBoolean(b: boolean); + begin + if b then + p^:=JOBArgTrue + else + p^:=JOBArgFalse; + inc(p); + end; + + procedure AddLongInt(const i: LongInt); + begin + p^:=JOBArgLongint; + inc(p); + PLongint(p)^:=i; + inc(p,4); + end; + + procedure AddDouble(const d: double); + begin + p^:=JOBArgDouble; + inc(p); + PDouble(p)^:=d; + inc(p,8); + end; + + procedure AddChar(c: word); + begin + p^:=JOBArgChar; + inc(p); + PWord(p)^:=c; + inc(p,2); + end; + + procedure AddObjectID(const ObjId: TJOBObjectID); + begin + p^:=JOBArgObject; + inc(p); + PNativeInt(p)^:=ObjId; + inc(p,sizeof(NativeInt)); + end; + + procedure AddIJSObject(const Intf: IJSObject); + begin + if Intf=nil then + begin + p^:=JOBArgNil; + inc(p); + end else + AddObjectID(Intf.GetJSObjectID); + end; + + procedure AddUTF8String(s: PByte; Len: NativeInt); + begin + p^:=JOBArgUTF8String; + inc(p); + PNativeInt(p)^:=Len; + inc(p,sizeof(NativeInt)); + PPointer(p)^:=s; + inc(p,sizeof(Pointer)); + end; + + procedure AddUnicodeString(s: PByte; Len: NativeInt); overload; + begin + p^:=JOBArgUnicodeString; + inc(p); + PNativeInt(p)^:=Len; + inc(p,sizeof(NativeInt)); + PPointer(p)^:=s; + inc(p,sizeof(Pointer)); + end; + + procedure AddUnicodeString(const us: UnicodeString); overload; + begin + if us='' then + AddUnicodeString(nil,0) + else + AddUnicodeString(@us[1],length(us)); + end; + + procedure Add_TJOB_JSValue(aValue: TJOB_JSValue); + var + us: UnicodeString; + h: PByte; + aMethod: TJOB_Method; + Dict: TJOB_PairArray; + i: Integer; + Arr: TJOB_JSValueArray; + begin + case aValue.Kind of + jjvkUndefined: + begin + p^:=JOBArgUndefined; + inc(p); + end; + jjvkBoolean: + AddBoolean(TJOB_Boolean(aValue).Value); + jjvkDouble: + AddDouble(TJOB_Double(aValue).Value); + jjvkString: + begin + us:=TJOB_String(aValue).Value; + h:=PByte(PWideChar(us)); + AddUnicodeString(h,length(us)); + end; + jjvkObject: + AddIJSObject(TJOB_Object(aValue).Value); + jjvkMethod: + begin + aMethod:=TJOB_Method(aValue); + p^:=JOBArgMethod; + inc(p); + PPointer(p)^:=Pointer(aMethod.Invoke); + inc(p,sizeof(Pointer)); + PPointer(p)^:=aMethod.Value.Data; + inc(p,sizeof(Pointer)); + PPointer(p)^:=aMethod.Value.Code; + inc(p,sizeof(Pointer)); + end; + jjvkDictionary: + begin + Dict:=TJOB_Dictionary(aValue).Values; + p^:=JOBArgDictionary; + inc(p); + PNativeInt(p)^:=length(Dict); + inc(p,SizeOf(NativeInt)); + for i:=0 to length(Dict)-1 do + begin + AddUnicodeString(Dict[i].Name); + Add_TJOB_JSValue(Dict[i].Value); + end; + end; + jjvkArrayOfJSValue: + begin + Arr:=TJOB_ArrayOfJSValue(aValue).Values; + p^:=JOBArgArrayOfJSValue; + inc(p); + PNativeInt(p)^:=length(Arr); + inc(p,SizeOf(NativeInt)); + for i:=0 to length(Arr)-1 do + Add_TJOB_JSValue(Arr[i]); + end; + jjvkArrayOfDouble: + begin + p^:=JOBArgArrayOfDouble; + inc(p); + i:=length(TJOB_ArrayOfDouble(aValue).Values); + PNativeInt(p)^:=i; + inc(p,SizeOf(NativeInt)); + if i=0 then + PPointer(p)^:=nil + else + PPointer(p)^:=@TJOB_ArrayOfDouble(aValue).Values[0]; + inc(p,sizeof(Pointer)); + end; + end; + end; + +var + i, Len: Integer; + qw: QWord; + i64: Int64; + h: PByte; + s: String; + ws: WideString; + us: UnicodeString; + d: Double; + Obj: TObject; + JSValue: TJOB_JSValue; +begin + Result:=nil; + if length(Args)>255 then + raise EJSInvoke.Create('Invoke js: too many args'); + + Len:=1; + for i:=0 to high(Args) do + begin + {$IFDEF VerboseInvokeJSArgs} + writeln('TJSObject.CreateInvokeJSArgs ',i,' VType=',Args[i].VType); + {$ENDIF} + case Args[i].VType of + vtInteger : inc(Len,5); + vtBoolean : inc(Len); + vtChar, + vtWideChar : inc(Len,3); + {$ifndef FPUNONE} + vtExtended: + begin + d:=double(Args[i].VExtended^); + if d=0 then ; + inc(Len,9); + end; + {$endif} + vtString : inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); + vtPointer: + begin + p:=Args[i].VPointer; + if p=JOB_Undefined then + inc(Len) + else + inc(Len,1+SizeOf(PByte)); + end; + vtPChar: + begin + // check length + strlen(Args[i].VPChar); + inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); + end; + vtObject: + begin + Obj:=Args[i].VObject; + if Obj=nil then + inc(Len,1) + else if Obj is TJSObject then + inc(Len,1+sizeof(TJOBObjectID)) + else if Obj is TJOB_JSValue then + begin + JSValue:=TJOB_JSValue(Obj); + inc(Len,SizeOfTJOB_JSValue(JSValue)); + end else + RaiseNotSupported('object'); + end; + vtClass : RaiseNotSupported('class'); + vtPWideChar: + begin + // check length + strlen(Args[i].VPWideChar); + inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); + end; + vtAnsiString: + inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); + vtCurrency : RaiseNotSupported('currency'); + {$ifdef FPC_HAS_FEATURE_VARIANTS} + vtVariant : RaiseNotSupported('variant'); + {$endif FPC_HAS_FEATURE_VARIANTS} + vtInterface: + begin + p:=Args[i].VInterface; + if p=nil then + inc(Len,1) + else if IInterface(p) is IJSObject then + inc(Len,1+sizeof(TJOBObjectID)) + else + RaiseNotSupported('interface'); + end; + vtWideString: + inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); + vtInt64: + begin + i64:=Args[i].VInt64^; + if (i64MaxSafeIntDouble) then + RaiseRange; + if (i64>=low(longint)) and (i64<=high(longint)) then + inc(Len,5) + else + inc(Len,9); + end; + vtUnicodeString: + inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); + vtQWord: + begin + qw:=Args[i].VQWord^; + if (qw>MaxSafeIntDouble) then + RaiseRange; + if (qw<=high(longint)) then + inc(Len,5) + else + inc(Len,9); + end; + else + RaiseNotSupported(IntToStr(Args[i].VType)); + end; + end; + + Result:=GetMem(Len); + p:=Result; + p^:=length(Args); + inc(p); + for i:=0 to high(Args) do + begin + case Args[i].VType of + vtInteger: + AddLongInt(Args[i].VInteger); + vtBoolean: + AddBoolean(Args[i].VBoolean); + {$ifndef FPUNONE} + vtExtended: + AddDouble(double(Args[i].VExtended^)); + {$endif} + vtChar: + AddChar(ord(Args[i].VChar)); + vtWideChar: + AddChar(ord(Args[i].VWideChar)); + vtString: + begin + // shortstring + h:=PByte(Args[i].VString); + AddUTF8String(h+1,h^); + end; + vtPointer: + begin + h:=Args[i].VPointer; + if h=nil then + begin + p^:=JOBArgNil; + inc(p); + end else if h=JOB_Undefined then + begin + p^:=JOBArgUndefined; + inc(p); + end + else begin + p^:=JOBArgPointer; + inc(p); + PPointer(p)^:=h; + inc(p,sizeof(Pointer)); + end; + end; + vtPChar: + begin + h:=PByte(Args[i].VPChar); + AddUTF8String(h,strlen(PChar(h))); + end; + vtObject: + begin + Obj:=Args[i].VObject; + if Obj=nil then + begin + p^:=JOBArgNil; + inc(p); + end else if Obj is TJSObject then + AddObjectID(TJSObject(Obj).JOBObjectID) + else if Obj is TJOB_JSValue then + begin + JSValue:=TJOB_JSValue(Obj); + Add_TJOB_JSValue(JSValue); + end else + RaiseNotSupported(Obj.ClassName); + end; + vtClass: ; + vtPWideChar: + begin + h:=PByte(Args[i].VPWideChar); + AddUnicodeString(h,strlen(PWideChar(h))); + end; + vtAnsiString: + begin + h:=Args[i].VAnsiString; + s:=AnsiString(h); + AddUTF8String(h,length(s)); + end; + vtCurrency : ; + {$ifdef FPC_HAS_FEATURE_VARIANTS} + vtVariant : ; + {$endif FPC_HAS_FEATURE_VARIANTS} + vtInterface: + begin + h:=Args[i].VInterface; + AddIJSObject(IJSObject(h)); + end; + vtWideString: + begin + h:=Args[i].VWideString; + ws:=WideString(h); + AddUnicodeString(h,length(ws)); + end; + vtInt64: + begin + i64:=Args[i].VInt64^; + if (i64>=low(longint)) and (i64<=high(longint)) then + AddLongInt(i64) + else + AddDouble(i64); + end; + vtUnicodeString: + begin + h:=Args[i].VUnicodeString; + us:=UnicodeString(h); + AddUnicodeString(h,length(us)); + end; + vtQWord: + begin + qw:=Args[i].VQWord^; + if (qw<=high(longint)) then + AddLongInt(qw) + else + AddDouble(qw); + end; + end; + end; + + {$IFDEF VerboseInvokeJSArgs} + s:='TJSObject.CreateInvokeJSArgs ArgCnt='+IntToStr(length(Args)); + for i:=0 to high(Args) do + s:=s+' '+GetVarRecName(Args[i].VType); + s:=s+' Len='+IntToStr(Len); + s:=s+' Bytes='; + for i:=0 to Len-1 do + s:=s+HexStr(Result[i],2); + writeln(s); + {$ENDIF} +end; + +constructor TJSObject.JOBCast(Intf: IJSObject); +begin + FJOBObjectID:=Intf.GetJSObjectID; + FJOBCastSrc:=Intf.GetJSObjectCastSrc; + if FJOBCastSrc=nil then + FJOBCastSrc:=Intf; +end; + +constructor TJSObject.JOBCreateFromID(aID: TJOBObjectID); +begin + FJOBObjectID:=aID; +end; + +class function TJSObject.Cast(Intf: IJSObject): IJSObject; +begin + Result:=JOBCast(Intf); +end; + +destructor TJSObject.Destroy; +begin + if FJOBCastSrc<>nil then + FJOBCastSrc:=nil + else if JOBObjectID>=0 then + __job_release_object(JOBObjectID); + FJOBObjectID:=0; + inherited Destroy; +end; + +procedure TJSObject.InvokeJSNoResult(const aName: string; + const Args: array of const; Invoke: TJOBInvokeType); +var + aError: TJOBResult; +begin + aError:=InvokeJSNoResultFunc(aName,Args,@__job_invoke_noresult,Invoke); + if aError<>JOBResult_Success then + InvokeJS_RaiseResultMismatch(aName,JOBResult_Success,aError); +end; + +function TJSObject.InvokeJSBooleanResult(const aName: string; + const Args: array of const; Invoke: TJOBInvokeType): Boolean; +var + aError: TJOBResult; + b: bytebool; +begin + b:=false; + aError:=InvokeJSOneResult(aName,Args,@__job_invoke_boolresult,@b,Invoke); + if aError=JOBResult_Boolean then + else if aError=JOBResult_Undefined then + b:=false + else + InvokeJS_RaiseResultMismatch(aName,JOBResult_Boolean,aError); + Result:=b; +end; + +function TJSObject.InvokeJSDoubleResult(const aName: string; + const Args: array of const; Invoke: TJOBInvokeType): Double; +var + aError: TJOBResult; +begin + Result:=NaN; + aError:=InvokeJSOneResult(aName,Args,@__job_invoke_doubleresult,@Result,Invoke); + if aError=JOBResult_Double then + else if aError=JOBResult_Undefined then + Result:=NaN + else + InvokeJS_RaiseResultMismatch(aName,JOBResult_Double,aError); +end; + +function TJSObject.InvokeJSUnicodeStringResult(const aName: string; + const Args: array of const; Invoke: TJOBInvokeType): UnicodeString; +var + ResultLen: NativeInt; + aError: TJOBResult; +begin + ResultLen:=0; + aError:=InvokeJSOneResult(aName,Args,@__job_invoke_stringresult,@ResultLen,Invoke); + if aError=JOBResult_String then + Result:=FetchString(ResultLen) + else begin + Result:=''; + if aError<>JOBResult_Undefined then + InvokeJS_RaiseResultMismatch(aName,JOBResult_String,aError); + end; + //writeln('TJSObject.InvokeJSUnicodeStringResult Result="',Result,'"'); +end; + +function TJSObject.InvokeJSObjectResult(const aName: string; + const Args: array of const; aResultClass: TJSObjectClass; + Invoke: TJOBInvokeType): TJSObject; +var + aError: TJOBResult; + NewObjId: TJOBObjectID; +begin + Result:=nil; + NewObjId:=-1; + aError:=InvokeJSOneResult(aName,Args,@__job_invoke_objectresult,@NewObjId,Invoke); + if (aError=JOBResult_Null) or (aError=JOBResult_Undefined) then + exit; + if aError<>JOBResult_Object then + InvokeJS_RaiseResultMismatch(aName,JOBResult_Object,aError); + + Result:=aResultClass.JOBCreateFromID(NewObjId); +end; + +function TJSObject.InvokeJSValueResult(const aName: string; + const Args: array of const; Invoke: TJOBInvokeType): TJOB_JSValue; +var + Buf: array[0..7] of byte; + p: PByte; + aError: TJOBResult; + Obj: TJSObject; +begin + Result:=nil; + FillByte(Buf[0],length(Buf),0); + p:=@Buf[0]; + aError:=InvokeJSOneResult(aName,Args,@__job_invoke_jsvalueresult,p,Invoke); + case aError of + JOBResult_Undefined: + Result:=TJOB_JSValue.Create(jjvkUndefined); + JOBResult_Null: + Result:=TJOB_Object.Create(nil); + JOBResult_Boolean: + Result:=TJOB_Boolean.Create(p^<>0); + JOBResult_Double: + Result:=TJOB_Double.Create(PDouble(p)^); + JOBResult_String: + Result:=TJOB_String.Create(FetchString(PNativeInt(p)^)); + JOBResult_Function, + JOBResult_Object: + begin + Obj:=TJSObject.JOBCreateFromID(PJOBObjectID(p)^); + Result:=TJOB_Object.Create(Obj); + end; + else + InvokeJS_RaiseResultMismatchStr(aName,'jsvalue',JOBResult_Names[aError]); + end; +end; + +function TJSObject.InvokeJSUtf8StringResult(const aName: string; + const args: array of const; Invoke: TJOBInvokeType): String; +begin + Result:=String(InvokeJSUnicodeStringResult(aName,Args,Invoke)); +end; + +function TJSObject.InvokeJSLongIntResult(const aName: string; + const args: array of const; Invoke: TJOBInvokeType): LongInt; +var + d: Double; +begin + d:=InvokeJSDoubleResult(aName,Args,Invoke); + if (Frac(d)<>0) or (dhigh(longint)) then + InvokeJS_RaiseResultMismatchStr(aName,'longint','double') + else + Result:=Trunc(d); +end; + +function TJSObject.InvokeJSMaxIntResult(const aName: string; + const args: array of const; Invoke: TJOBInvokeType): int64; +var + d: Double; +begin + d:=InvokeJSDoubleResult(aName,Args,Invoke); + if (Frac(d)<>0) or (dhigh(int64)) then + InvokeJS_RaiseResultMismatchStr(aName,'int64','double') + else + Result:=Trunc(d); +end; + +function TJSObject.InvokeJSTypeOf(const aName: string; + const Args: array of const): TJOBResult; +begin + Result:=InvokeJSNoResultFunc(aName,Args,@__job_invoke_noresult,jiGetTypeOf); +end; + +function TJSObject.InvokeJSUnicodeStringArrayResult(const aName: string; + const Args: array of const; Invoke: TJOBInvokeType): TUnicodeStringDynArray; +var + ResultP: NativeInt; + aError: TJOBResult; +begin + ResultP:=0; + aError:=InvokeJSOneResult(aName,Args,@__job_invoke_arraystringresult,@ResultP,Invoke); + if aError=JOBResult_ArrayOfString then + Result:=TUnicodeStringDynArray(ResultP) + else begin + Result:=[]; + if aError<>JOBResult_Undefined then + InvokeJS_RaiseResultMismatch(aName,JOBResult_ArrayOfString,aError); + end; +end; + +function TJSObject.ReadJSPropertyBoolean(const aName: string): boolean; +begin + Result:=InvokeJSBooleanResult(aName,[],jiGet); +end; + +function TJSObject.ReadJSPropertyDouble(const aName: string): double; +begin + Result:=InvokeJSDoubleResult(aName,[],jiGet); +end; + +function TJSObject.ReadJSPropertyUnicodeString(const aName: string + ): UnicodeString; +begin + Result:=InvokeJSUnicodeStringResult(aName,[],jiGet); +end; + +function TJSObject.ReadJSPropertyObject(const aName: string; + aResultClass: TJSObjectClass): TJSObject; +begin + Result:=InvokeJSObjectResult(aName,[],aResultClass,jiGet); +end; + +function TJSObject.ReadJSPropertyUtf8String(const aName: string): string; +begin + Result:=InvokeJSUtf8StringResult(aName,[],jiGet); +end; + +function TJSObject.ReadJSPropertyLongInt(const aName: string): LongInt; +begin + Result:=InvokeJSLongIntResult(aName,[],jiGet); +end; + +function TJSObject.ReadJSPropertyInt64(const aName: string): Int64; +begin + Result:=Trunc(InvokeJSDoubleResult(aName,[],jiGet)); +end; + +function TJSObject.ReadJSPropertyValue(const aName: string): TJOB_JSValue; +begin + Result:=InvokeJSValueResult(aName,[],jiGet); +end; + +procedure TJSObject.WriteJSPropertyBoolean(const aName: string; Value: Boolean); +begin + InvokeJSNoResult(aName,[Value],jiSet); +end; + +procedure TJSObject.WriteJSPropertyDouble(const aName: string; Value: Double); +begin + InvokeJSNoResult(aName,[Value],jiSet); +end; + +procedure TJSObject.WriteJSPropertyUnicodeString(const aName: string; + const Value: UnicodeString); +begin + InvokeJSNoResult(aName,[Value],jiSet); +end; + +procedure TJSObject.WriteJSPropertyUtf8String(const aName: string; + const Value: String); +begin + InvokeJSNoResult(aName,[Value],jiSet); +end; + +procedure TJSObject.WriteJSPropertyObject(const aName: string; Value: IJSObject + ); +begin + InvokeJSNoResult(aName,[Value],jiSet); +end; + +procedure TJSObject.WriteJSPropertyLongInt(const aName: string; Value: LongInt); +begin + InvokeJSNoResult(aName,[Value],jiSet); +end; + +procedure TJSObject.WriteJSPropertyValue(const aName: string; + Value: TJOB_JSValue); +begin + InvokeJSNoResult(aName,[Value],jiSet); +end; + +function TJSObject.NewJSObject(const Args: array of const; + aResultClass: TJSObjectClass): TJSObject; +begin + Result:=InvokeJSObjectResult('',Args,aResultClass,jiNew); +end; + +function TJSObject.getOwnPropertyNames(const Obj: IJSObject + ): TUnicodeStringDynArray; +begin + Result:=JSObject.InvokeJSUnicodeStringArrayResult('getOwnPropertyNames',[Obj]); +end; + +function TJSObject.getPrototypeOf(const Obj: IJSObject): IJSObject; +begin + Result:=JSObject.InvokeJSObjectResult('getPrototypeOf',[Obj],TJSObject) as IJSObject; +end; + +function TJSObject.hasOwnProperty(const PropName: String): boolean; +begin + Result:=InvokeJSBooleanResult('hasOwnProperty',[PropName]); +end; + +function TJSObject.isPrototypeOf(const Obj: IJSObject): boolean; +begin + Result:=InvokeJSBooleanResult('isPrototypeOf',[Obj]); +end; + +function TJSObject.propertyIsEnumerable(const PropName: String): boolean; +begin + Result:=InvokeJSBooleanResult('propertyIsEnumerable',[PropName]); +end; + +function TJSObject.toLocaleString: UnicodeString; +begin + Result:=InvokeJSUnicodeStringResult('toLocaleString',[]); +end; + +function TJSObject.toString: String; +begin + Result:=InvokeJSUtf8StringResult('toString',[]); +end; + +function TJSObject.toUString: UnicodeString; +begin + Result:=InvokeJSUnicodeStringResult('toString',[]); +end; + +function TJSObject.valueOf: TJOB_JSValue; +begin + Result:=InvokeJSValueResult('valueOf',[]); +end; + { TJSDate } class function TJSDate.Cast(Intf: IJSObject): IJSDate; @@ -55,7 +1989,8 @@ begin end; initialization - JSDate:=TJSDate.JOBCreateFromID(JOBObjIdDate); + JSObject:=TJSObject.JOBCreateFromID(JOBObjIdObject) as IJSObject; + JSDate:=TJSDate.JOBCreateFromID(JOBObjIdDate) as IJSDate; end. diff --git a/demo/wasienv/dom/job_wasm.pas b/demo/wasienv/dom/job_wasm.pas deleted file mode 100644 index 9d61aea..0000000 --- a/demo/wasienv/dom/job_wasm.pas +++ /dev/null @@ -1,1955 +0,0 @@ -{ - JOB - JS Object Bridge for Webassembly - - Webassembly unit giving access to the browser DOM. - - see https://wiki.freepascal.org/WebAssembly/DOM -} -unit JOB_WAsm; - -{$mode ObjFPC}{$H+} -{$ModeSwitch advancedrecords} - -{$define VerboseJOB} - -interface - -uses - SysUtils, Types, Math, Classes, JOB_Shared; - -const - MinSafeIntDouble = -$1fffffffffffff; // -9007199254740991 54 bits (52 plus signed bit plus implicit highest bit) - MaxSafeIntDouble = $1fffffffffffff; // 9007199254740991 - -Type - PJOBObjectID = ^TJOBObjectID; - - EJSObject = class(Exception); - EJSInvoke = class(EJSObject) - public - ObjectID: TJOBObjectID; - FuncName: string; - end; - EJSArgParse = class(EJSObject); - - TJOB_JSValueKind = ( - jjvkUndefined, - jjvkBoolean, - jjvkDouble, - jjvkString, - jjvkObject, - jjvkMethod, - jjvkDictionary, - jjvkArrayOfJSValue, - jjvkArrayOfDouble - ); - TJOB_JSValueKinds = set of TJOB_JSValueKind; - -const - JOB_JSValueKindNames: array[TJOB_JSValueKind] of string = ( - 'Undefined', - 'Boolean', - 'Double', - 'String', - 'Object', - 'Method', - 'Dictionary', - 'ArrayOfJSValue', - 'ArrayOfDouble' - ); - - JOB_Undefined = Pointer(1); - -type - TUnicodeStringDynArray = array of UnicodeString; - - { TJOB_JSValue } - - TJOB_JSValue = class - public - Kind: TJOB_JSValueKind; - constructor Create(aKind: TJOB_JSValueKind); - function AsString: string; virtual; - end; - TJOB_JSValueClass = class of TJOB_JSValue; - TJOB_JSValueArray = array of TJOB_JSValue; - - { TJOB_Boolean } - - TJOB_Boolean = class(TJOB_JSValue) - public - Value: Boolean; - constructor Create(aValue: Boolean); - function AsString: string; override; - end; - - { TJOB_Double } - - TJOB_Double = class(TJOB_JSValue) - public - Value: Double; - constructor Create(const aValue: Double); - function AsString: string; override; - end; - - { TJOB_String } - - TJOB_String = class(TJOB_JSValue) - public - Value: UnicodeString; - constructor Create(const aValue: UnicodeString); - function AsString: string; override; - end; - - IJSObject = interface; - - { TJOB_Object } - - TJOB_Object = class(TJOB_JSValue) - public - Value: IJSObject; - constructor Create(aValue: IJSObject); - function AsString: string; override; - end; - - TJOBInvokeType = ( - jiCall, // call function - jiGet, // read property - jiGetTypeOf, // read property and do typeof - jiSet, // write property - jiNew // new operator - ); - TJOBInvokeTypes = set of TJOBInvokeType; - - TJSObject = class; - TJSObjectClass = class of TJSObject; - - { TJOBCallbackHelper - parse callback arguments and create result } - - TJOBCallbackHelper = record - p: PByte; - Index: integer; - Count: integer; - procedure Init(Args: PByte); - function GetType: byte; // see JOBArg* constants, keeps p - procedure Skip; - function GetBoolean: boolean; - function GetDouble: double; - function GetString: UnicodeString; - function GetObject(aResultClass: TJSObjectClass): TJSObject; - function GetValue: TJOB_JSValue; - function GetLongInt: longint; - function GetMaxInt: int64; - - function AllocUndefined: PByte; - function AllocBool(b: boolean): PByte; - function AllocLongint(i: longint): PByte; - function AllocDouble(const d: double): PByte; - function AllocString(const s: UnicodeString): PByte; - function AllocNil: PByte; - function AllocIntf(Intf: IJSObject): PByte; - function AllocObject(Obj: TJSObject): PByte; - function AllocObjId(ObjId: TJOBObjectID): PByte; - end; - - TJOBCallback = function(const aMethod: TMethod; var H: TJOBCallbackHelper): PByte; - - { TJOB_Method } - - TJOB_Method = class(TJOB_JSValue) - public - Value: TMethod; - Invoke: TJOBCallback; - constructor Create(const aMethod: TMethod; const AnInvoke: TJOBCallback); - function AsString: string; override; - end; - - TJOB_Pair = record - Name: UnicodeString; - Value: TJOB_JSValue; - end; - TJOB_PairArray = array of TJOB_Pair; - - { TJOB_Dictionary } - - TJOB_Dictionary = class(TJOB_JSValue) - public - Values: TJOB_PairArray; - procedure Add(const aName: UnicodeString; const aValue: TJOB_JSValue); - constructor Create(const Pairs: array of const); - destructor Destroy; override; - procedure Clear; - end; - - TJOB_ArrayBase = class(TJOB_JSValue) - end; - - { TJOB_ArrayOfJSValue } - - TJOB_ArrayOfJSValue = class(TJOB_ArrayBase) - public - Values: TJOB_JSValueArray; - procedure Add(const aValue: TJOB_JSValue); - constructor Create(const TheValues: array of const); - destructor Destroy; override; - procedure Clear; - end; - - { TJOB_ArrayOfDouble } - - TJOB_ArrayOfDouble = class(TJOB_ArrayBase) - public - Values: TDoubleDynArray; - constructor Create(const TheValues: TDoubleDynArray); - end; - - { IJSObject } - - IJSObject = interface - ['{BE5CDE03-D471-4AB3-8F27-A5EA637416F7}'] - function GetJSObjectID: TJOBObjectID; - function GetJSObjectCastSrc: IJSObject; - function GetPascalClassName: string; - function GetProperties(const PropName: String): TJOB_JSValue; virtual; - procedure SetProperties(const PropName: String; const AValue: TJOB_JSValue); virtual; - // call a function - procedure InvokeJSNoResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall); virtual; - function InvokeJSBooleanResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): Boolean; virtual; - function InvokeJSDoubleResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): Double; virtual; - function InvokeJSUnicodeStringResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): UnicodeString; virtual; - function InvokeJSObjectResult(const aName: string; Const Args: Array of const; aResultClass: TJSObjectClass; Invoke: TJOBInvokeType = jiCall): TJSObject; virtual; - function InvokeJSValueResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): TJOB_JSValue; virtual; - function InvokeJSUtf8StringResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): String; virtual; - function InvokeJSLongIntResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): LongInt; virtual; - function InvokeJSTypeOf(const aName: string; Const Args: Array of const): TJOBResult; virtual; - function InvokeJSUnicodeStringArrayResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): TUnicodeStringDynArray; virtual; - // read a property - function ReadJSPropertyBoolean(const aName: string): boolean; virtual; - function ReadJSPropertyDouble(const aName: string): double; virtual; - function ReadJSPropertyUnicodeString(const aName: string): UnicodeString; virtual; - function ReadJSPropertyObject(const aName: string; aResultClass: TJSObjectClass): TJSObject; virtual; - function ReadJSPropertyUtf8String(const aName: string): string; virtual; - function ReadJSPropertyLongInt(const aName: string): LongInt; virtual; - function ReadJSPropertyValue(const aName: string): TJOB_JSValue; virtual; - // write a property - procedure WriteJSPropertyBoolean(const aName: string; Value: Boolean); virtual; - procedure WriteJSPropertyDouble(const aName: string; Value: Double); virtual; - procedure WriteJSPropertyUnicodeString(const aName: string; const Value: UnicodeString); virtual; - procedure WriteJSPropertyUtf8String(const aName: string; const Value: String); virtual; - procedure WriteJSPropertyObject(const aName: string; Value: IJSObject); virtual; - procedure WriteJSPropertyLongInt(const aName: string; Value: LongInt); virtual; - // create a new object using the new-operator - function NewJSObject(Const Args: Array of const; aResultClass: TJSObjectClass): TJSObject; virtual; - // JS members - function getOwnPropertyNames(const Obj: IJSObject): TUnicodeStringDynArray; - function getPrototypeOf(const Obj: IJSObject): IJSObject; - function hasOwnProperty(const PropName: String): boolean; virtual; - function isPrototypeOf(const Obj: IJSObject): boolean; virtual; - function propertyIsEnumerable(const PropName: String): boolean; virtual; - function toLocaleString: UnicodeString; virtual; overload; - function toString: String; override; overload; - function toUString: UnicodeString; virtual; overload; - function valueOf: TJOB_JSValue; virtual; overload; - property Properties[const PropName: String]: TJOB_JSValue read GetProperties write SetProperties; default; - end; - - { TJSObject } - - TJSObject = class(TInterfacedObject,IJSObject) - private - FJOBObjectID: TJOBObjectID; - FJOBCastSrc: IJSObject; - protected - type - TJOBInvokeNoResultFunc = function( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte - ): TJOBResult; - TJOBInvokeOneResultFunc = function( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte; - ResultP: PByte - ): TJOBResult; - function GetJSObjectID: TJOBObjectID; - function GetJSObjectCastSrc: IJSObject; - function GetPascalClassName: string; - function GetProperties(const PropName: String): TJOB_JSValue; virtual; - procedure SetProperties(const PropName: String; const AValue: TJOB_JSValue); virtual; - function FetchString(Len: NativeInt): UnicodeString; - function InvokeJSNoResultFunc(const aName: string; Const Args: Array of const; - const InvokeFunc: TJOBInvokeNoResultFunc; Invoke: TJOBInvokeType): TJOBResult; - function InvokeJSOneResult(const aName: string; Const Args: Array of const; - const InvokeFunc: TJOBInvokeOneResultFunc; ResultP: PByte; Invoke: TJOBInvokeType): TJOBResult; - procedure InvokeJS_Raise(const aName, Msg: string); virtual; - procedure InvokeJS_RaiseResultMismatch(const aName: string; Expected, Actual: TJOBResult); virtual; - procedure InvokeJS_RaiseResultMismatchStr(const aName: string; const Expected, Actual: string); virtual; - function CreateInvokeJSArgs(const Args: array of const): PByte; virtual; - public - constructor JOBCast(Intf: IJSObject); overload; - constructor JOBCreateFromID(aID: TJOBObjectID); virtual; // use this only for the owner (it will release it on free) - class function Cast(Intf: IJSObject): IJSObject; overload; - destructor Destroy; override; - property JOBObjectID: TJOBObjectID read FJOBObjectID; - property JOBCastSrc: IJSObject read FJOBCastSrc; // nil means it is the owner, otherwise it is a typecast - // call a function - procedure InvokeJSNoResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall); virtual; - function InvokeJSBooleanResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): Boolean; virtual; - function InvokeJSDoubleResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): Double; virtual; - function InvokeJSUnicodeStringResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): UnicodeString; virtual; - function InvokeJSObjectResult(const aName: string; Const Args: Array of const; aResultClass: TJSObjectClass; Invoke: TJOBInvokeType = jiCall): TJSObject; virtual; - function InvokeJSValueResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): TJOB_JSValue; virtual; - function InvokeJSUtf8StringResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): String; virtual; - function InvokeJSLongIntResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): LongInt; virtual; - function InvokeJSMaxIntResult(const aName: string; Const args: Array of const; Invoke: TJOBInvokeType = jiCall): int64; virtual; - function InvokeJSTypeOf(const aName: string; Const Args: Array of const): TJOBResult; virtual; - function InvokeJSUnicodeStringArrayResult(const aName: string; Const Args: Array of const; Invoke: TJOBInvokeType = jiCall): TUnicodeStringDynArray; virtual; - // read a property - function ReadJSPropertyBoolean(const aName: string): boolean; virtual; - function ReadJSPropertyDouble(const aName: string): double; virtual; - function ReadJSPropertyUnicodeString(const aName: string): UnicodeString; virtual; - function ReadJSPropertyObject(const aName: string; aResultClass: TJSObjectClass): TJSObject; virtual; - function ReadJSPropertyUtf8String(const aName: string): string; virtual; - function ReadJSPropertyLongInt(const aName: string): LongInt; virtual; - function ReadJSPropertyInt64(const aName: string): Int64; virtual; - function ReadJSPropertyValue(const aName: string): TJOB_JSValue; virtual; - // write a property - procedure WriteJSPropertyBoolean(const aName: string; Value: Boolean); virtual; - procedure WriteJSPropertyDouble(const aName: string; Value: Double); virtual; - procedure WriteJSPropertyUnicodeString(const aName: string; const Value: UnicodeString); virtual; - procedure WriteJSPropertyUtf8String(const aName: string; const Value: String); virtual; - procedure WriteJSPropertyObject(const aName: string; Value: IJSObject); virtual; - procedure WriteJSPropertyLongInt(const aName: string; Value: LongInt); virtual; - procedure WriteJSPropertyValue(const aName: string; Value: TJOB_JSValue); virtual; - // create a new object using the new-operator - function NewJSObject(Const Args: Array of const; aResultClass: TJSObjectClass): TJSObject; virtual; - // JS members - function getOwnPropertyNames(const Obj: IJSObject): TUnicodeStringDynArray; - function getPrototypeOf(const Obj: IJSObject): IJSObject; - function hasOwnProperty(const PropName: String): boolean; virtual; - function isPrototypeOf(const Obj: IJSObject): boolean; virtual; - function propertyIsEnumerable(const PropName: String): boolean; virtual; - function toLocaleString: UnicodeString; virtual; overload; - function toString: String; override; overload; - function toUString: UnicodeString; virtual; overload; - function valueOf: TJOB_JSValue; virtual; overload; - property Properties[const PropName: String]: TJOB_JSValue read GetProperties write SetProperties; default; - end; - -var - JSObject: IJSObject; // global singleton of JS 'Object' - -// imported functions from browser -function __job_invoke_noresult( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte -): TJOBResult; external JOBExportName name JOBFn_InvokeNoResult; - -function __job_invoke_boolresult( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte; - ResultByteBoolP: PByte -): TJOBResult; external JOBExportName name JOBFn_InvokeBooleanResult; - -function __job_invoke_doubleresult( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte; - ResultDoubleP: PByte -): TJOBResult; external JOBExportName name JOBFn_InvokeDoubleResult; - -function __job_invoke_stringresult( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte; - ResultLenP: PByte // nativeint -): TJOBResult; external JOBExportName name JOBFn_InvokeStringResult; - -function __job_getstringresult( - ResultP: PByte -): TJOBResult; external JOBExportName name JOBFn_GetStringResult; - -function __job_releasestringresult( -): TJOBResult; external JOBExportName name JOBFn_ReleaseStringResult; - -function __job_invoke_objectresult( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte; - ResultObjIDP: PByte // nativeint -): TJOBResult; external JOBExportName name JOBFn_InvokeObjectResult; - -function __job_release_object( - ObjID: TJOBObjectID -): TJOBResult; external JOBExportName name JOBFn_ReleaseObject; - -function __job_invoke_jsvalueresult( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte; - ResultP: PByte // various -): TJOBResult; external JOBExportName name JOBFn_InvokeJSValueResult; - -function __job_invoke_arraystringresult( - ObjID: TJOBObjectID; - NameP: PChar; - NameLen: longint; - Invoke: longint; - ArgP: PByte; - ResultLenP: PByte // nativeint -): TJOBResult; external JOBExportName name JOBFn_InvokeArrayStringResult; - -function JOBCallback(const Func: TJOBCallback; Data, Code: Pointer; Args: PByte): PByte; -function VarRecToJSValue(const V: TVarRec): TJOB_JSValue; - -implementation - -const - InvokeGetToInt: array[TJOBInvokeType] of integer = ( - JOBInvokeCall, - JOBInvokeGet, - JOBInvokeGetTypeOf, - JOBInvokeSet, - JOBInvokeNew - ); - -{$IFDEF VerboseJOB} -function GetVarRecName(vt: word): string; -begin - case vt of - vtInteger: Result:='vtInteger'; - vtBoolean: Result:='vtBoolean'; - vtChar: Result:='vtChar'; - {$ifndef FPUNONE} - vtExtended: Result:='vtExtended'; - {$endif} - vtString: Result:='vtString'; - vtPointer: Result:='vtPointer'; - vtPChar: Result:='vtPChar'; - vtObject: Result:='vtObject'; - vtClass: Result:='vtClass'; - vtWideChar: Result:='vtWideChar'; - vtPWideChar: Result:='vtPWideChar'; - vtAnsiString: Result:='vtAnsiString'; - vtCurrency: Result:='vtCurrency'; - vtVariant: Result:='vtVariant'; - vtInterface: Result:='vtInterface'; - vtWideString: Result:='vtWideString'; - vtInt64: Result:='vtInt64'; - vtQWord: Result:='vtQWord'; - vtUnicodeString: Result:='vtUnicodeString'; - else - Result:='vt?'; - end; -end; -{$ENDIF} - -function __job_callback(w: NativeInt): boolean; -begin - writeln('__job_callback w=',w); - Result:=true; -end; - -function JOBCallback(const Func: TJOBCallback; Data, Code: Pointer; Args: PByte - ): PByte; -var - m: TMethod; - h: TJOBCallbackHelper; -begin - Result:=nil; - try - //writeln('JOBCallback'); - m.Data:=Data; - m.Code:=Code; - h.Init(Args); - Result:=Func(m,h); - finally - if Args<>nil then - FreeMem(Args); - end; -end; - -function VarRecToJSValue(const V: TVarRec): TJOB_JSValue; -var - p: Pointer; - CurLen: SizeInt; - S: String; - Obj: TObject; - Intf: IJSObject; -begin - case V.VType of - vtInteger: - Result:=TJOB_Double.Create(V.VInteger); - vtBoolean: - Result:=TJOB_Boolean.Create(V.VBoolean); - vtChar: - Result:=TJOB_String.Create(UnicodeString(V.VChar)); - {$ifndef FPUNONE} - vtExtended: - Result:=TJOB_Double.Create(V.VExtended^); - {$endif} - vtString: - Result:=TJOB_String.Create(UnicodeString(V.VString^)); - vtPointer: - begin - p:=V.VPointer; - if p=nil then - Result:=TJOB_Object.Create(nil) - else if p=JOB_Undefined then - Result:=TJOB_JSValue.Create(jjvkUndefined) - else - raise EJSArgParse.Create('VarRecToJSValue pointer not supported'); - end; - vtPChar: - begin - CurLen:=strlen(V.VPChar); - SetString(S,V.VPChar,CurLen); - Result:=TJOB_String.Create(UnicodeString(S)); - end; - vtObject: - begin - Obj:=V.VObject; - if Obj=nil then - Result:=TJOB_Object.Create(nil) - else if Obj is TJOB_JSValue then - Result:=TJOB_JSValue(Obj) - else if Obj is TJSObject then - Result:=TJOB_Object.Create(TJSObject(Obj) as IJSObject) - else - raise EJSArgParse.Create('VarRecToJSValue object '+Obj.ClassName+' not supported'); - end; - vtClass: - raise EJSArgParse.Create('VarRecToJSValue class not supported'); - vtWideChar: - Result:=TJOB_String.Create(V.VWideChar); - vtPWideChar: - raise EJSArgParse.Create('VarRecToJSValue vtPWideChar not supported'); - vtAnsiString: - Result:=TJOB_String.Create(UnicodeString(PAnsiString(V.VAnsiString)^)); - vtCurrency: - Result:=TJOB_Double.Create(V.VCurrency^); - vtVariant: - raise EJSArgParse.Create('VarRecToJSValue vtVariant not supported'); - vtInterface: - begin - Intf:=IJSObject(V.VInterface); - Result:=TJOB_Object.Create(Intf); - end; - vtWideString: - raise EJSArgParse.Create('VarRecToJSValue vtWideString not supported'); - vtInt64: - Result:=TJOB_Double.Create(V.VInt64^); - vtQWord: - Result:=TJOB_Double.Create(V.VQWord^); - vtUnicodeString: - Result:=TJOB_String.Create(PUnicodeString(V.VUnicodeString)^); - else - raise EJSArgParse.Create('VarRecToJSValue unsupported VType '+IntToStr(V.VType)); - end; -end; - -{ TJOBCallbackHelper } - -procedure TJOBCallbackHelper.Init(Args: PByte); -begin - p:=Args; - Index:=0; - if p<>nil then - begin - Count:=p^; - inc(p); - end else - Count:=0; -end; - -function TJOBCallbackHelper.GetType: byte; -begin - if Index=Count then - Result:=JOBArgUndefined - else - Result:=p^; -end; - -procedure TJOBCallbackHelper.Skip; -var - Len: LongWord; -begin - if Index=Count then exit; - case p^ of - JOBArgUndefined, - JOBArgTrue, - JOBArgFalse, - JOBArgNil: inc(p); - JOBArgDouble: inc(p,9); - JOBArgUnicodeString: - begin - inc(p); - Len:=PLongWord(p)^; - inc(p,4+2*Len); - end - else - raise EJSArgParse.Create(JOBArgNames[p^]); - end; - inc(Index); -end; - -function TJOBCallbackHelper.GetBoolean: boolean; -begin - Result:=false; - if Index=Count then - exit; - case p^ of - JOBArgUndefined: ; - JOBArgTrue: Result:=true; - JOBArgFalse: ; - else - raise EJSArgParse.Create(JOBArgNames[p^]); - end; - inc(p); - inc(Index); -end; - -function TJOBCallbackHelper.GetDouble: double; -begin - Result:=NaN; - if Index=Count then - exit; - case p^ of - JOBArgUndefined: - inc(p); - JOBArgDouble: - begin - inc(p); - Result:=PDouble(p)^; - inc(p,8); - end - else - raise EJSArgParse.Create(JOBArgNames[p^]); - end; - inc(Index); -end; - -function TJOBCallbackHelper.GetString: UnicodeString; -var - Len: LongWord; -begin - Result:=''; - if Index=Count then - exit; - case p^ of - JOBArgUndefined: - inc(p); - JOBArgUnicodeString: - begin - inc(p); - Len:=PLongWord(p)^; - inc(p,4); - if Len>0 then - begin - SetLength(Result,Len); - Move(p^,Result[1],2*Len); - inc(p,2*Len); - end; - end - else - raise EJSArgParse.Create(JOBArgNames[p^]); - end; - inc(Index); -end; - -function TJOBCallbackHelper.GetObject(aResultClass: TJSObjectClass): TJSObject; -var - ObjId: LongWord; -begin - //writeln('TJOBCallbackHelper.GetObject ',Index,' Count=',Count); - Result:=nil; - if Index=Count then - exit; - //writeln('TJOBCallbackHelper.GetObject type=',p^); - case p^ of - JOBArgUndefined, - JOBArgNil: - inc(p); - JOBArgObject: - begin - inc(p); - ObjId:=PLongWord(p)^; - inc(p,4); - Result:=aResultClass.JOBCreateFromID(ObjId); - end - else - raise EJSArgParse.Create(JOBArgNames[p^]); - end; - inc(Index); -end; - -function TJOBCallbackHelper.GetValue: TJOB_JSValue; -var - ObjId, Len: LongWord; - Obj: TJSObject; - S: UnicodeString; -begin - Result:=nil; - if (Index=Count) or (p^=JOBArgUndefined) then - begin - Result:=TJOB_JSValue.Create(jjvkUndefined); - exit; - end; - case p^ of - JOBArgTrue: - begin - Result:=TJOB_Boolean.Create(true); - inc(p); - end; - JOBArgFalse: - begin - Result:=TJOB_Boolean.Create(false); - inc(p); - end; - JOBArgDouble: - begin - inc(p); - Result:=TJOB_Double.Create(PDouble(p)^); - inc(p,8); - end; - JOBArgUnicodeString: - begin - inc(p); - Len:=PLongWord(p)^; - inc(p,4); - S:=''; - if Len>0 then - begin - SetLength(S,Len); - Move(p^,S[1],2*Len); - inc(p,2*Len); - end; - Result:=TJOB_String.Create(S); - end; - JOBArgNil: - begin - Result:=TJOB_Object.Create(nil); - inc(p); - end; - JOBArgObject: - begin - inc(p); - ObjId:=PLongWord(p)^; - inc(p,4); - Obj:=TJSObject.JOBCreateFromID(ObjId); - Result:=TJOB_Object.Create(Obj); - end; - else - raise EJSArgParse.Create(JOBArgNames[p^]); - end; - inc(Index); -end; - -function TJOBCallbackHelper.GetLongInt: longint; -var - d: Double; -begin - d:=GetDouble; - if (Frac(d)<>0) or (dhigh(longint)) then - raise EJSArgParse.Create('expected longint, but got double') - else - Result:=Trunc(d); -end; - -function TJOBCallbackHelper.GetMaxInt: int64; -var - d: Double; -begin - d:=GetDouble; - if (Frac(d)<>0) or (dhigh(int64)) then - raise EJSArgParse.Create('expected int64, but got double') - else - Result:=Trunc(d); -end; - -function TJOBCallbackHelper.AllocUndefined: PByte; -begin - GetMem(Result,1); - Result^:=JOBArgUndefined; -end; - -function TJOBCallbackHelper.AllocBool(b: boolean): PByte; -begin - GetMem(Result,1); - if b then - Result^:=JOBArgTrue - else - Result^:=JOBArgFalse; -end; - -function TJOBCallbackHelper.AllocLongint(i: longint): PByte; -begin - GetMem(Result,5); - Result^:=JOBArgLongint; - PLongint(Result+1)^:=i; -end; - -function TJOBCallbackHelper.AllocDouble(const d: double): PByte; -begin - GetMem(Result,9); - Result^:=JOBArgDouble; - PDouble(Result+1)^:=d; -end; - -function TJOBCallbackHelper.AllocString(const s: UnicodeString): PByte; -var - l: SizeInt; -begin - l:=length(s); - GetMem(Result,5+l); - Result^:=JOBArgUnicodeString; - PLongWord(Result+1)^:=l; - if l>0 then - Move(s[1],Result[5],l); -end; - -function TJOBCallbackHelper.AllocNil: PByte; -begin - GetMem(Result,1); - Result^:=JOBArgNil; -end; - -function TJOBCallbackHelper.AllocIntf(Intf: IJSObject): PByte; -begin - if Intf=nil then - Result:=AllocNil - else - Result:=AllocObjId(Intf.GetJSObjectID); -end; - -function TJOBCallbackHelper.AllocObject(Obj: TJSObject): PByte; -begin - if Obj=nil then - Result:=AllocNil - else - Result:=AllocObjId(Obj.JOBObjectID); -end; - -function TJOBCallbackHelper.AllocObjId(ObjId: TJOBObjectID): PByte; -begin - GetMem(Result,1+SizeOf(TJOBObjectID)); - Result^:=JOBArgObject; - PJOBObjectID(Result+1)^:=ObjId; -end; - -{ TJOB_JSValue } - -constructor TJOB_JSValue.Create(aKind: TJOB_JSValueKind); -begin - Kind:=aKind; -end; - -function TJOB_JSValue.AsString: string; -begin - if Kind=jjvkUndefined then - Result:='undefined' - else begin - Result:=''; - str(Kind,Result); - end; -end; - -{ TJOB_Boolean } - -constructor TJOB_Boolean.Create(aValue: Boolean); -begin - Kind:=jjvkBoolean; - Value:=aValue; -end; - -function TJOB_Boolean.AsString: string; -begin - str(Value,Result); -end; - -{ TJOB_Double } - -constructor TJOB_Double.Create(const aValue: Double); -begin - Kind:=jjvkDouble; - Value:=aValue; -end; - -function TJOB_Double.AsString: string; -begin - str(Value,Result); -end; - -{ TJOB_String } - -constructor TJOB_String.Create(const aValue: UnicodeString); -begin - Kind:=jjvkString; - Value:=aValue; -end; - -function TJOB_String.AsString: string; -begin - Result:=AnsiQuotedStr(String(Value),'"'); -end; - -{ TJOB_Object } - -constructor TJOB_Object.Create(aValue: IJSObject); -begin - Kind:=jjvkObject; - Value:=aValue; -end; - -function TJOB_Object.AsString: string; -begin - if Value=nil then - Result:='nil' - else - Result:='['+IntToStr(Value.GetJSObjectID)+']:'+Value.GetPascalClassName; -end; - -{ TJOB_Method } - -constructor TJOB_Method.Create(const aMethod: TMethod; - const AnInvoke: TJOBCallback); -begin - Kind:=jjvkMethod; - Value:=aMethod; - Invoke:=AnInvoke; -end; - -function TJOB_Method.AsString: string; -begin - Result:='Callback'; -end; - -{ TJOB_Dictionary } - -procedure TJOB_Dictionary.Add(const aName: UnicodeString; - const aValue: TJOB_JSValue); -var - p: TJOB_Pair; -begin - p.Name:=aName; - p.Value:=aValue; - Insert(p,Values,length(Values)); -end; - -constructor TJOB_Dictionary.Create(const Pairs: array of const); -var - i: Integer; - l, CurLen: SizeInt; - CurName: UnicodeString; -begin - inherited Create(jjvkDictionary); - l:=length(Pairs); - SetLength(Values,l div 2); - for i:=0 to length(Values)-1 do - Values[i].Value:=nil; - i:=0; - while inil then - FreeMem(InvokeArgs); - end; - end; -end; - -function TJSObject.InvokeJSOneResult(const aName: string; - const Args: array of const; const InvokeFunc: TJOBInvokeOneResultFunc; - ResultP: PByte; Invoke: TJOBInvokeType): TJOBResult; -var - InvokeArgs: PByte; -begin - if length(Args)=0 then - Result:=InvokeFunc(JOBObjectID,PChar(aName),length(aName),InvokeGetToInt[Invoke],nil,ResultP) - else begin - InvokeArgs:=CreateInvokeJSArgs(Args); - try - Result:=InvokeFunc(JOBObjectID,PChar(aName),length(aName),InvokeGetToInt[Invoke],InvokeArgs,ResultP); - finally - if InvokeArgs<>nil then - FreeMem(InvokeArgs); - end; - end; -end; - -procedure TJSObject.InvokeJS_Raise(const aName, Msg: string); -var - E: EJSInvoke; -begin - E:=EJSInvoke.Create(Msg); - E.ObjectID:=JOBObjectID; - E.FuncName:=aName; - raise E; -end; - -procedure TJSObject.InvokeJS_RaiseResultMismatch(const aName: string; - Expected, Actual: TJOBResult); -begin - case Actual of - JOBResult_UnknownObjId: InvokeJS_Raise(aName,'unknown object id '+IntToStr(JOBObjectID)); - JOBResult_NotAFunction: InvokeJS_Raise(aName,'object '+IntToStr(JOBObjectID)+' does not have a function "'+aName+'"'); - else - InvokeJS_RaiseResultMismatchStr(aName,JOBResult_Names[Expected],JOBResult_Names[Actual]); - end; -end; - -procedure TJSObject.InvokeJS_RaiseResultMismatchStr(const aName: string; - const Expected, Actual: string); -begin - InvokeJS_Raise(aName,'expected '+Expected+', but got '+Actual+' from object '+IntToStr(JOBObjectID)+' function "'+aName+'"'); -end; - -function TJSObject.CreateInvokeJSArgs(const Args: array of const): PByte; - - procedure RaiseNotSupported(const Msg: string); - begin - raise EJSInvoke.Create('Invoke js: type not supported '+Msg); - end; - - procedure RaiseRange; - begin - raise ERangeError.Create('Invoke js: number out of bounds'); - end; - -var - p: PByte; - - function SizeOfTJOB_JSValue(JSValue: TJOB_JSValue): integer; - var - Dict: TJOB_PairArray; - i: Integer; - Arr: TJOB_JSValueArray; - begin - case JSValue.Kind of - jjvkUndefined: Result:=1; - jjvkBoolean: Result:=1; - jjvkDouble: Result:=9; - jjvkString: Result:=1+SizeOf(NativeInt)+SizeOf(PByte); - jjvkObject: - if TJOB_Object(JSValue).Value=nil then - Result:=1 - else - Result:=1+SizeOf(TJOBObjectID); - jjvkMethod: Result:=1+3*SizeOf(PByte); - jjvkDictionary: - begin - Result:=1+SizeOf(NativeInt); - Dict:=TJOB_Dictionary(JSValue).Values; - for i:=0 to length(Dict)-1 do - begin - inc(Result,1+SizeOf(NativeInt)+SizeOf(PByte)); - inc(Result,SizeOfTJOB_JSValue(Dict[i].Value)); - end; - end; - jjvkArrayOfJSValue: - begin - Result:=1+SizeOf(NativeInt); - Arr:=TJOB_ArrayOfJSValue(JSValue).Values; - for i:=0 to length(Arr)-1 do - inc(Result,SizeOfTJOB_JSValue(Dict[i].Value)); - end; - jjvkArrayOfDouble: - Result:=1+SizeOf(NativeInt)+SizeOf(PByte); - else - RaiseNotSupported('20220630135718'){%H-}; - end; - end; - - procedure AddBoolean(b: boolean); - begin - if b then - p^:=JOBArgTrue - else - p^:=JOBArgFalse; - inc(p); - end; - - procedure AddLongInt(const i: LongInt); - begin - p^:=JOBArgLongint; - inc(p); - PLongint(p)^:=i; - inc(p,4); - end; - - procedure AddDouble(const d: double); - begin - p^:=JOBArgDouble; - inc(p); - PDouble(p)^:=d; - inc(p,8); - end; - - procedure AddChar(c: word); - begin - p^:=JOBArgChar; - inc(p); - PWord(p)^:=c; - inc(p,2); - end; - - procedure AddObjectID(const ObjId: TJOBObjectID); - begin - p^:=JOBArgObject; - inc(p); - PNativeInt(p)^:=ObjId; - inc(p,sizeof(NativeInt)); - end; - - procedure AddIJSObject(const Intf: IJSObject); - begin - if Intf=nil then - begin - p^:=JOBArgNil; - inc(p); - end else - AddObjectID(Intf.GetJSObjectID); - end; - - procedure AddUTF8String(s: PByte; Len: NativeInt); - begin - p^:=JOBArgUTF8String; - inc(p); - PNativeInt(p)^:=Len; - inc(p,sizeof(NativeInt)); - PPointer(p)^:=s; - inc(p,sizeof(Pointer)); - end; - - procedure AddUnicodeString(s: PByte; Len: NativeInt); overload; - begin - p^:=JOBArgUnicodeString; - inc(p); - PNativeInt(p)^:=Len; - inc(p,sizeof(NativeInt)); - PPointer(p)^:=s; - inc(p,sizeof(Pointer)); - end; - - procedure AddUnicodeString(const us: UnicodeString); overload; - begin - if us='' then - AddUnicodeString(nil,0) - else - AddUnicodeString(@us[1],length(us)); - end; - - procedure Add_TJOB_JSValue(aValue: TJOB_JSValue); - var - us: UnicodeString; - h: PByte; - aMethod: TJOB_Method; - Dict: TJOB_PairArray; - i: Integer; - Arr: TJOB_JSValueArray; - begin - case aValue.Kind of - jjvkUndefined: - begin - p^:=JOBArgUndefined; - inc(p); - end; - jjvkBoolean: - AddBoolean(TJOB_Boolean(aValue).Value); - jjvkDouble: - AddDouble(TJOB_Double(aValue).Value); - jjvkString: - begin - us:=TJOB_String(aValue).Value; - h:=PByte(PWideChar(us)); - AddUnicodeString(h,length(us)); - end; - jjvkObject: - AddIJSObject(TJOB_Object(aValue).Value); - jjvkMethod: - begin - aMethod:=TJOB_Method(aValue); - p^:=JOBArgMethod; - inc(p); - PPointer(p)^:=Pointer(aMethod.Invoke); - inc(p,sizeof(Pointer)); - PPointer(p)^:=aMethod.Value.Data; - inc(p,sizeof(Pointer)); - PPointer(p)^:=aMethod.Value.Code; - inc(p,sizeof(Pointer)); - end; - jjvkDictionary: - begin - Dict:=TJOB_Dictionary(aValue).Values; - p^:=JOBArgDictionary; - inc(p); - PNativeInt(p)^:=length(Dict); - inc(p,SizeOf(NativeInt)); - for i:=0 to length(Dict)-1 do - begin - AddUnicodeString(Dict[i].Name); - Add_TJOB_JSValue(Dict[i].Value); - end; - end; - jjvkArrayOfJSValue: - begin - Arr:=TJOB_ArrayOfJSValue(aValue).Values; - p^:=JOBArgArrayOfJSValue; - inc(p); - PNativeInt(p)^:=length(Arr); - inc(p,SizeOf(NativeInt)); - for i:=0 to length(Arr)-1 do - Add_TJOB_JSValue(Arr[i]); - end; - jjvkArrayOfDouble: - begin - p^:=JOBArgArrayOfDouble; - inc(p); - i:=length(TJOB_ArrayOfDouble(aValue).Values); - PNativeInt(p)^:=i; - inc(p,SizeOf(NativeInt)); - if i=0 then - PPointer(p)^:=nil - else - PPointer(p)^:=@TJOB_ArrayOfDouble(aValue).Values[0]; - inc(p,sizeof(Pointer)); - end; - end; - end; - -var - i, Len: Integer; - qw: QWord; - i64: Int64; - h: PByte; - s: String; - ws: WideString; - us: UnicodeString; - d: Double; - Obj: TObject; - JSValue: TJOB_JSValue; -begin - Result:=nil; - if length(Args)>255 then - raise EJSInvoke.Create('Invoke js: too many args'); - - Len:=1; - for i:=0 to high(Args) do - begin - {$IFDEF VerboseInvokeJSArgs} - writeln('TJSObject.CreateInvokeJSArgs ',i,' VType=',Args[i].VType); - {$ENDIF} - case Args[i].VType of - vtInteger : inc(Len,5); - vtBoolean : inc(Len); - vtChar, - vtWideChar : inc(Len,3); - {$ifndef FPUNONE} - vtExtended: - begin - d:=double(Args[i].VExtended^); - if d=0 then ; - inc(Len,9); - end; - {$endif} - vtString : inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); - vtPointer: - begin - p:=Args[i].VPointer; - if p=JOB_Undefined then - inc(Len) - else - inc(Len,1+SizeOf(PByte)); - end; - vtPChar: - begin - // check length - strlen(Args[i].VPChar); - inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); - end; - vtObject: - begin - Obj:=Args[i].VObject; - if Obj=nil then - inc(Len,1) - else if Obj is TJSObject then - inc(Len,1+sizeof(TJOBObjectID)) - else if Obj is TJOB_JSValue then - begin - JSValue:=TJOB_JSValue(Obj); - inc(Len,SizeOfTJOB_JSValue(JSValue)); - end else - RaiseNotSupported('object'); - end; - vtClass : RaiseNotSupported('class'); - vtPWideChar: - begin - // check length - strlen(Args[i].VPWideChar); - inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); - end; - vtAnsiString: - inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); - vtCurrency : RaiseNotSupported('currency'); - {$ifdef FPC_HAS_FEATURE_VARIANTS} - vtVariant : RaiseNotSupported('variant'); - {$endif FPC_HAS_FEATURE_VARIANTS} - vtInterface: - begin - p:=Args[i].VInterface; - if p=nil then - inc(Len,1) - else if IInterface(p) is IJSObject then - inc(Len,1+sizeof(TJOBObjectID)) - else - RaiseNotSupported('interface'); - end; - vtWideString: - inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); - vtInt64: - begin - i64:=Args[i].VInt64^; - if (i64MaxSafeIntDouble) then - RaiseRange; - if (i64>=low(longint)) and (i64<=high(longint)) then - inc(Len,5) - else - inc(Len,9); - end; - vtUnicodeString: - inc(Len,1+SizeOf(NativeInt)+SizeOf(PByte)); - vtQWord: - begin - qw:=Args[i].VQWord^; - if (qw>MaxSafeIntDouble) then - RaiseRange; - if (qw<=high(longint)) then - inc(Len,5) - else - inc(Len,9); - end; - else - RaiseNotSupported(IntToStr(Args[i].VType)); - end; - end; - - Result:=GetMem(Len); - p:=Result; - p^:=length(Args); - inc(p); - for i:=0 to high(Args) do - begin - case Args[i].VType of - vtInteger: - AddLongInt(Args[i].VInteger); - vtBoolean: - AddBoolean(Args[i].VBoolean); - {$ifndef FPUNONE} - vtExtended: - AddDouble(double(Args[i].VExtended^)); - {$endif} - vtChar: - AddChar(ord(Args[i].VChar)); - vtWideChar: - AddChar(ord(Args[i].VWideChar)); - vtString: - begin - // shortstring - h:=PByte(Args[i].VString); - AddUTF8String(h+1,h^); - end; - vtPointer: - begin - h:=Args[i].VPointer; - if h=nil then - begin - p^:=JOBArgNil; - inc(p); - end else if h=JOB_Undefined then - begin - p^:=JOBArgUndefined; - inc(p); - end - else begin - p^:=JOBArgPointer; - inc(p); - PPointer(p)^:=h; - inc(p,sizeof(Pointer)); - end; - end; - vtPChar: - begin - h:=PByte(Args[i].VPChar); - AddUTF8String(h,strlen(PChar(h))); - end; - vtObject: - begin - Obj:=Args[i].VObject; - if Obj=nil then - begin - p^:=JOBArgNil; - inc(p); - end else if Obj is TJSObject then - AddObjectID(TJSObject(Obj).JOBObjectID) - else if Obj is TJOB_JSValue then - begin - JSValue:=TJOB_JSValue(Obj); - Add_TJOB_JSValue(JSValue); - end else - RaiseNotSupported(Obj.ClassName); - end; - vtClass: ; - vtPWideChar: - begin - h:=PByte(Args[i].VPWideChar); - AddUnicodeString(h,strlen(PWideChar(h))); - end; - vtAnsiString: - begin - h:=Args[i].VAnsiString; - s:=AnsiString(h); - AddUTF8String(h,length(s)); - end; - vtCurrency : ; - {$ifdef FPC_HAS_FEATURE_VARIANTS} - vtVariant : ; - {$endif FPC_HAS_FEATURE_VARIANTS} - vtInterface: - begin - h:=Args[i].VInterface; - AddIJSObject(IJSObject(h)); - end; - vtWideString: - begin - h:=Args[i].VWideString; - ws:=WideString(h); - AddUnicodeString(h,length(ws)); - end; - vtInt64: - begin - i64:=Args[i].VInt64^; - if (i64>=low(longint)) and (i64<=high(longint)) then - AddLongInt(i64) - else - AddDouble(i64); - end; - vtUnicodeString: - begin - h:=Args[i].VUnicodeString; - us:=UnicodeString(h); - AddUnicodeString(h,length(us)); - end; - vtQWord: - begin - qw:=Args[i].VQWord^; - if (qw<=high(longint)) then - AddLongInt(qw) - else - AddDouble(qw); - end; - end; - end; - - {$IFDEF VerboseInvokeJSArgs} - s:='TJSObject.CreateInvokeJSArgs ArgCnt='+IntToStr(length(Args)); - for i:=0 to high(Args) do - s:=s+' '+GetVarRecName(Args[i].VType); - s:=s+' Len='+IntToStr(Len); - s:=s+' Bytes='; - for i:=0 to Len-1 do - s:=s+HexStr(Result[i],2); - writeln(s); - {$ENDIF} -end; - -constructor TJSObject.JOBCast(Intf: IJSObject); -begin - FJOBObjectID:=Intf.GetJSObjectID; - FJOBCastSrc:=Intf.GetJSObjectCastSrc; - if FJOBCastSrc=nil then - FJOBCastSrc:=Intf; -end; - -constructor TJSObject.JOBCreateFromID(aID: TJOBObjectID); -begin - FJOBObjectID:=aID; -end; - -class function TJSObject.Cast(Intf: IJSObject): IJSObject; -begin - Result:=JOBCast(Intf); -end; - -destructor TJSObject.Destroy; -begin - if FJOBCastSrc<>nil then - FJOBCastSrc:=nil - else if JOBObjectID>=0 then - __job_release_object(JOBObjectID); - FJOBObjectID:=0; - inherited Destroy; -end; - -procedure TJSObject.InvokeJSNoResult(const aName: string; - const Args: array of const; Invoke: TJOBInvokeType); -var - aError: TJOBResult; -begin - aError:=InvokeJSNoResultFunc(aName,Args,@__job_invoke_noresult,Invoke); - if aError<>JOBResult_Success then - InvokeJS_RaiseResultMismatch(aName,JOBResult_Success,aError); -end; - -function TJSObject.InvokeJSBooleanResult(const aName: string; - const Args: array of const; Invoke: TJOBInvokeType): Boolean; -var - aError: TJOBResult; - b: bytebool; -begin - b:=false; - aError:=InvokeJSOneResult(aName,Args,@__job_invoke_boolresult,@b,Invoke); - if aError=JOBResult_Boolean then - else if aError=JOBResult_Undefined then - b:=false - else - InvokeJS_RaiseResultMismatch(aName,JOBResult_Boolean,aError); - Result:=b; -end; - -function TJSObject.InvokeJSDoubleResult(const aName: string; - const Args: array of const; Invoke: TJOBInvokeType): Double; -var - aError: TJOBResult; -begin - Result:=NaN; - aError:=InvokeJSOneResult(aName,Args,@__job_invoke_doubleresult,@Result,Invoke); - if aError=JOBResult_Double then - else if aError=JOBResult_Undefined then - Result:=NaN - else - InvokeJS_RaiseResultMismatch(aName,JOBResult_Double,aError); -end; - -function TJSObject.InvokeJSUnicodeStringResult(const aName: string; - const Args: array of const; Invoke: TJOBInvokeType): UnicodeString; -var - ResultLen: NativeInt; - aError: TJOBResult; -begin - ResultLen:=0; - aError:=InvokeJSOneResult(aName,Args,@__job_invoke_stringresult,@ResultLen,Invoke); - if aError=JOBResult_String then - Result:=FetchString(ResultLen) - else begin - Result:=''; - if aError<>JOBResult_Undefined then - InvokeJS_RaiseResultMismatch(aName,JOBResult_String,aError); - end; - //writeln('TJSObject.InvokeJSUnicodeStringResult Result="',Result,'"'); -end; - -function TJSObject.InvokeJSObjectResult(const aName: string; - const Args: array of const; aResultClass: TJSObjectClass; - Invoke: TJOBInvokeType): TJSObject; -var - aError: TJOBResult; - NewObjId: TJOBObjectID; -begin - Result:=nil; - NewObjId:=-1; - aError:=InvokeJSOneResult(aName,Args,@__job_invoke_objectresult,@NewObjId,Invoke); - if (aError=JOBResult_Null) or (aError=JOBResult_Undefined) then - exit; - if aError<>JOBResult_Object then - InvokeJS_RaiseResultMismatch(aName,JOBResult_Object,aError); - - Result:=aResultClass.JOBCreateFromID(NewObjId); -end; - -function TJSObject.InvokeJSValueResult(const aName: string; - const Args: array of const; Invoke: TJOBInvokeType): TJOB_JSValue; -var - Buf: array[0..7] of byte; - p: PByte; - aError: TJOBResult; - Obj: TJSObject; -begin - Result:=nil; - FillByte(Buf[0],length(Buf),0); - p:=@Buf[0]; - aError:=InvokeJSOneResult(aName,Args,@__job_invoke_jsvalueresult,p,Invoke); - case aError of - JOBResult_Undefined: - Result:=TJOB_JSValue.Create(jjvkUndefined); - JOBResult_Null: - Result:=TJOB_Object.Create(nil); - JOBResult_Boolean: - Result:=TJOB_Boolean.Create(p^<>0); - JOBResult_Double: - Result:=TJOB_Double.Create(PDouble(p)^); - JOBResult_String: - Result:=TJOB_String.Create(FetchString(PNativeInt(p)^)); - JOBResult_Function, - JOBResult_Object: - begin - Obj:=TJSObject.JOBCreateFromID(PJOBObjectID(p)^); - Result:=TJOB_Object.Create(Obj); - end; - else - InvokeJS_RaiseResultMismatchStr(aName,'jsvalue',JOBResult_Names[aError]); - end; -end; - -function TJSObject.InvokeJSUtf8StringResult(const aName: string; - const args: array of const; Invoke: TJOBInvokeType): String; -begin - Result:=String(InvokeJSUnicodeStringResult(aName,Args,Invoke)); -end; - -function TJSObject.InvokeJSLongIntResult(const aName: string; - const args: array of const; Invoke: TJOBInvokeType): LongInt; -var - d: Double; -begin - d:=InvokeJSDoubleResult(aName,Args,Invoke); - if (Frac(d)<>0) or (dhigh(longint)) then - InvokeJS_RaiseResultMismatchStr(aName,'longint','double') - else - Result:=Trunc(d); -end; - -function TJSObject.InvokeJSMaxIntResult(const aName: string; - const args: array of const; Invoke: TJOBInvokeType): int64; -var - d: Double; -begin - d:=InvokeJSDoubleResult(aName,Args,Invoke); - if (Frac(d)<>0) or (dhigh(int64)) then - InvokeJS_RaiseResultMismatchStr(aName,'int64','double') - else - Result:=Trunc(d); -end; - -function TJSObject.InvokeJSTypeOf(const aName: string; - const Args: array of const): TJOBResult; -begin - Result:=InvokeJSNoResultFunc(aName,Args,@__job_invoke_noresult,jiGetTypeOf); -end; - -function TJSObject.InvokeJSUnicodeStringArrayResult(const aName: string; - const Args: array of const; Invoke: TJOBInvokeType): TUnicodeStringDynArray; -var - ResultP: NativeInt; - aError: TJOBResult; -begin - ResultP:=0; - aError:=InvokeJSOneResult(aName,Args,@__job_invoke_arraystringresult,@ResultP,Invoke); - if aError=JOBResult_ArrayOfString then - Result:=TUnicodeStringDynArray(ResultP) - else begin - Result:=[]; - if aError<>JOBResult_Undefined then - InvokeJS_RaiseResultMismatch(aName,JOBResult_ArrayOfString,aError); - end; -end; - -function TJSObject.ReadJSPropertyBoolean(const aName: string): boolean; -begin - Result:=InvokeJSBooleanResult(aName,[],jiGet); -end; - -function TJSObject.ReadJSPropertyDouble(const aName: string): double; -begin - Result:=InvokeJSDoubleResult(aName,[],jiGet); -end; - -function TJSObject.ReadJSPropertyUnicodeString(const aName: string - ): UnicodeString; -begin - Result:=InvokeJSUnicodeStringResult(aName,[],jiGet); -end; - -function TJSObject.ReadJSPropertyObject(const aName: string; - aResultClass: TJSObjectClass): TJSObject; -begin - Result:=InvokeJSObjectResult(aName,[],aResultClass,jiGet); -end; - -function TJSObject.ReadJSPropertyUtf8String(const aName: string): string; -begin - Result:=InvokeJSUtf8StringResult(aName,[],jiGet); -end; - -function TJSObject.ReadJSPropertyLongInt(const aName: string): LongInt; -begin - Result:=InvokeJSLongIntResult(aName,[],jiGet); -end; - -function TJSObject.ReadJSPropertyInt64(const aName: string): Int64; -begin - Result:=Trunc(InvokeJSDoubleResult(aName,[],jiGet)); -end; - -function TJSObject.ReadJSPropertyValue(const aName: string): TJOB_JSValue; -begin - Result:=InvokeJSValueResult(aName,[],jiGet); -end; - -procedure TJSObject.WriteJSPropertyBoolean(const aName: string; Value: Boolean); -begin - InvokeJSNoResult(aName,[Value],jiSet); -end; - -procedure TJSObject.WriteJSPropertyDouble(const aName: string; Value: Double); -begin - InvokeJSNoResult(aName,[Value],jiSet); -end; - -procedure TJSObject.WriteJSPropertyUnicodeString(const aName: string; - const Value: UnicodeString); -begin - InvokeJSNoResult(aName,[Value],jiSet); -end; - -procedure TJSObject.WriteJSPropertyUtf8String(const aName: string; - const Value: String); -begin - InvokeJSNoResult(aName,[Value],jiSet); -end; - -procedure TJSObject.WriteJSPropertyObject(const aName: string; Value: IJSObject - ); -begin - InvokeJSNoResult(aName,[Value],jiSet); -end; - -procedure TJSObject.WriteJSPropertyLongInt(const aName: string; Value: LongInt); -begin - InvokeJSNoResult(aName,[Value],jiSet); -end; - -procedure TJSObject.WriteJSPropertyValue(const aName: string; - Value: TJOB_JSValue); -begin - InvokeJSNoResult(aName,[Value],jiSet); -end; - -function TJSObject.NewJSObject(const Args: array of const; - aResultClass: TJSObjectClass): TJSObject; -begin - Result:=InvokeJSObjectResult('',Args,aResultClass,jiNew); -end; - -function TJSObject.getOwnPropertyNames(const Obj: IJSObject - ): TUnicodeStringDynArray; -begin - Result:=JSObject.InvokeJSUnicodeStringArrayResult('getOwnPropertyNames',[Obj]); -end; - -function TJSObject.getPrototypeOf(const Obj: IJSObject): IJSObject; -begin - Result:=JSObject.InvokeJSObjectResult('getPrototypeOf',[Obj],TJSObject) as IJSObject; -end; - -function TJSObject.hasOwnProperty(const PropName: String): boolean; -begin - Result:=InvokeJSBooleanResult('hasOwnProperty',[PropName]); -end; - -function TJSObject.isPrototypeOf(const Obj: IJSObject): boolean; -begin - Result:=InvokeJSBooleanResult('isPrototypeOf',[Obj]); -end; - -function TJSObject.propertyIsEnumerable(const PropName: String): boolean; -begin - Result:=InvokeJSBooleanResult('propertyIsEnumerable',[PropName]); -end; - -function TJSObject.toLocaleString: UnicodeString; -begin - Result:=InvokeJSUnicodeStringResult('toLocaleString',[]); -end; - -function TJSObject.toString: String; -begin - Result:=InvokeJSUtf8StringResult('toString',[]); -end; - -function TJSObject.toUString: UnicodeString; -begin - Result:=InvokeJSUnicodeStringResult('toString',[]); -end; - -function TJSObject.valueOf: TJOB_JSValue; -begin - Result:=InvokeJSValueResult('valueOf',[]); -end; - -initialization - JSObject:=TJSObject.JOBCreateFromID(JOBObjIdObject) as IJSObject; - -end. - diff --git a/demo/wasienv/dom/job_browser.pp b/packages/job/job_browser.pp similarity index 100% rename from demo/wasienv/dom/job_browser.pp rename to packages/job/job_browser.pp diff --git a/demo/wasienv/dom/job_shared.pp b/packages/job/job_shared.pp similarity index 100% rename from demo/wasienv/dom/job_shared.pp rename to packages/job/job_shared.pp