RealICQClient/Log/JSExtented.pas

(*
 *                               NeuglsWorkStudio
 *                     HTML Interface Javascript Extendtion
 *  This unit implmented TNCJsExtented which used for extend the capablity of
 *  javascript.
 *
 *  Author     : Neugls
 *  Create time: 4/27/2011
 *
 *  Thanks for : Henri Gourvest
 *
 *
 *
 *
 *
 *)
unit JSExtented;

interface

uses
  SysUtils, Classes, ceflib, Rtti, cefvcl;

const
  csErrorParameters            ='Error Parameters';
  csHaveNoThisMember           ='Have no member';
  csChromiumCouldNotBeNil      ='Chromium could not be nil, please first set the Chromium property';

type

TVCLJsExtended=class(TComponent)
type
TANameType=(ntMethod,ntField,ntProperty);
{Inner class}
TNCJSHandle=class(TCefv8HandlerOwn)
private
FContainer:TVCLJsExtended;
protected
function Execute(const name: ustring; const obj: ICefv8Value;
const arguments: TCefv8ValueArray; var retval: ICefv8Value;
var exception: ustring): Boolean; override;

procedure JsCallMethod(Method:TRttiMethod;out ReturnVal:ICefv8Value; const Param:TCefv8ValueArray);overload;
procedure JsCallMethod(Method:TRttiMethod;out ReturnVal:ICefv8Value);overload;
function MethodParamLength(Mn:string):Integer;
public
constructor Create(Container:TVCLJsExtended);
end;

private
FProcessObject:TObject;
FJsHandle:TNCJSHandle;
FTypeInfo:Pointer;
FCustomChromium:TChromium;
FFrame:ICefFrame;
public
Frame:ICefFrame{ read FFrame write FFrame};
property ProcessObject:TObject read FProcessObject;
property ATypeInfo:Pointer read FTypeInfo;
procedure SetProcessObject(value:TObject;ATypeInfo:Pointer);
Procedure ExecuteJavaScript(const jsCode, scriptUrl: string; startLine: Integer);overload;
Procedure ExecuteJavaScript(const jsCode:string);overload;
constructor create(AOwner:TComponent);override;

property Chromium:TChromium read FCustomChromium write FCustomChromium;
end;

TVCLNcJsExtended = class(TVCLJsExtended)
published
property Chromium;
end;
TNCWebBrowser=class(TChromium)
end;


procedure Register;

implementation
uses TypInfo;
procedure Register;
begin
RegisterComponents('NwControls', [TVCLNcJsExtended]);
RegisterComponents('NwControls', [TChromium]);
end;

{ TVCLJsExtended }

constructor TVCLJsExtended.create(AOwner:TComponent);
begin
inherited create(AOwner);
FProcessObject:=nil;
FJsHandle:=TNCJSHandle.Create(Self);
end;

procedure TVCLJsExtended.ExecuteJavaScript(const jsCode, scriptUrl: string;
  startLine: Integer);
begin
if not Assigned(FCustomChromium) then
begin
raise Exception.Create(csChromiumCouldNotBeNil);
Exit;
end;
FCustomChromium.Browser.MainFrame.ExecuteJavaScript(jsCode,scriptUrl,startLine);
end;

procedure TVCLJsExtended.ExecuteJavaScript(const jsCode:string);
begin
ExecuteJavaScript(jsCode,'',0);
end;

procedure TVCLJsExtended.SetProcessObject(value: TObject;ATypeInfo:Pointer);
var
RttiContext:TRttiContext;
RttiType:TRttiType;
RM:TRttiMethod;
RP:TRttiProperty;
RF:TRttiField;
JsStr,name:String;
I:Integer;
begin
{
根据object所提供的方法属性生成js字符串，希望注册.
}
FProcessObject:=value;
FTypeInfo:=ATypeInfo;
RttiType:=RttiContext.GetType(FTypeInfo);

name:=RttiType.Name;
JsStr:=Format('var %s;',[name]);
JsStr:=Format('%s if(!%s) %s={};',[JsStr,name,name]);

{Process method}
for RM in RttiType.GetMethods  do
begin
JsStr:=JsStr+Format(#$A#$D' native function %s(',[RM.Name]);
if Length(RM.GetParameters)=0 then
JsStr:=Format('%s);',[JsStr])
else
begin
for I := 0 to Length(RM.GetParameters)-2 do
JsStr:=Format('%s %s,',[JsStr,chr(ord('A')+I)]);
I:=Length(RM.GetParameters)-1;
JsStr:=Format('%s %s);',[JsStr,chr(ord('A')+I)]);
end;
end;
{Process Field}
for RF in RttiType.GetFields do
begin
JsStr:=Format('%s'#$A#$D' var %s;',[JsStr,RF.Name]);
case RF.FieldType.TypeKind of
tkUnknown: ;
tkInteger: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsInteger]);
tkChar: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]);
tkEnumeration: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsInteger]);
tkFloat: JsStr:=Format('%s'#$A#$D' %s=%f;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsExtended]);
tkString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]);
tkSet: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsInteger]);
tkClass:{support later} JsStr:=Format('%s'#$A#$D' %s={};',[JsStr,RF.Name]);
tkMethod: ;
tkWChar: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]);
tkLString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]);
tkWString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]);
tkVariant: ;
tkArray: ;
tkRecord: ;
tkInterface: ;
tkInt64: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsInteger]);
tkDynArray: ;
tkUString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]);
tkClassRef: ;
tkPointer: ;
tkProcedure: ;
end;
end;

{Process property}
for RP in RttiType.GetProperties do
begin
JsStr:=Format('%s'#$A#$D' var %s;',[JsStr,RP.Name]);
case RF.FieldType.TypeKind of
tkUnknown: ;
tkInteger: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsInteger]);
tkChar: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]);
tkEnumeration: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsInteger]);
tkFloat: JsStr:=Format('%s'#$A#$D' %s=%f;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsExtended]);
tkString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]);
tkSet: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsInteger]);
tkClass:{support later} JsStr:=Format('%s'#$A#$D' %s={};',[JsStr,RP.Name]);
tkMethod: ;
tkWChar: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]);
tkLString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]);
tkWString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]);
tkVariant: ;
tkArray: ;
tkRecord: ;
tkInterface: ;
tkInt64: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsInteger]);
tkDynArray: ;
tkUString: if not RP.GetValue(FProcessObject).IsObject then  JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]);
tkClassRef: ;
tkPointer: ;
tkProcedure: ;
end;
end;

if not CefRegisterExtension(RttiType.Name,JsStr,FJsHandle) then
Raise Exception.Create('Register JavaScript Extension Error');
end;

{ TVCLJsExtended.TNCJSHandle }

constructor TVCLJsExtended.TNCJSHandle.Create(
  Container: TVCLJsExtended);
begin
  inherited Create;
  FContainer:=Container;
end;

function TVCLJsExtended.TNCJSHandle.Execute(const name: ustring;
  const obj: ICefv8Value; const arguments: TCefv8ValueArray;
  var retval: ICefv8Value; var exception: ustring): Boolean;
var
   RttiContext:TRttiContext;
   rm:TRttiMember;
   M:TRttiMethod;
   F:TRttiField;
   P:TRttiProperty;
   A:TRttiArrayType;
   nameType:TANameTYpe;
   o:TObject;
   n:string;

function ObjectHaveName(const AObject:TObject; const name:String;out isMethod:TANameTYpe; out mb:TRttiMember):Boolean;
var
RttiType:TRttiType;
RM:TRttiMethod;
RP:TRttiProperty;
RF:TRttiField;
begin
Result:=false;
RttiType:=RttiContext.GetType(FContainer.FTypeInfo);
for RM in RttiType.GetMethods do
begin
if CompareText(RM.Name,name)=0 then
begin
isMethod:=ntMethod;
mb:=RM;
Exit(True);
end;
end;
for RP in RttiType.GetProperties do
begin
if CompareText(RP.Name,name)=0 then
begin
isMethod:=ntProperty;
mb:=RP;
Exit(True);
end;
end;
for RF in RttiType.GetFields do
begin
if CompareText(RF.Name,name)=0 then
begin
isMethod:=ntField;
mb:=RF;
Exit(True);
end;
end;
end;
begin
Result:=true;
O:=FContainer.ProcessObject;
n:=name;
if not ObjectHaveName(O,name,nameType,rm) then
begin
exception:=csHaveNoThisMember;
Exit(False);
end;
case nameType of
ntMethod:
begin
M:=rm as TRttiMethod;
//Assert(M.MethodKind<>mkFunction);
if Length(M.GetParameters)>0 then
begin
if (Length(arguments)>0) and (Length(arguments)=Length(M.GetParameters)) then
begin
JsCallMethod(M,retval,arguments);
end
else
begin
exception:=csErrorParameters;
Exit(False);
end;
end
else
begin
JsCallMethod(M,retval);
end;
end;
ntField:
begin
F:=rm as TRttiField;
case F.FieldType.TypeKind of
tkUnknown: ;
tkInteger: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger);
tkChar: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString);
tkEnumeration: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger);
tkFloat: retval:=TCefv8ValueRef.CreateDouble(F.GetValue(FContainer.ProcessObject).AsExtended);
tkString: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString);
tkSet: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger);
tkClass: ;//retval:=TCefv8ValueRef.CreateObject(F.GetValue(FContainer.ProcessObject).AsObject);
tkMethod: ;
tkWChar: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString);
tkLString: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString);
tkWString: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString);
tkVariant: ;
tkArray:
begin
{
                    retval:=TCefv8ValueRef.CreateArray;
                    A:=F.FieldType as TRttiArrayType;
                    //support only one demision array
                    if A.DimensionCount=1 then
                     for I := 0 to A.TotalElementCount do
                     begin
                       case A.ElementType.TypeKind of
                         tkUnknown: retval.SetValueByIndex(I,TCefv8ValueRef.create());
                         tkInteger: ;
                         tkChar: ;
                         tkEnumeration: ;
                         tkFloat: ;
                         tkString: ;
                         tkSet: ;
                         tkClass: ;
                         tkMethod: ;
                         tkWChar: ;
                         tkLString: ;
                         tkWString: ;
                         tkVariant: ;
                         tkArray: ;
                         tkRecord: ;
                         tkInterface: ;
                         tkInt64: ;
                         tkDynArray: ;
                         tkUString: ;
                         tkClassRef: ;
                         tkPointer: ;
                         tkProcedure: ;
                       end;
                       retval.SetValueByIndex(I,TCefv8ValueRef.create)
                     end;



                    retval.SetValueByIndex()
                  end;;
           tkRecord: ;
           tkInterface: ;
           tkInt64: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger);
           tkDynArray: ;
           tkUString: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString);
           tkClassRef: ;
           tkPointer: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger);
           tkProcedure: ; }
end;
end;
end;
ntProperty:
begin
P:=rm as TRttiProperty;
case P.PropertyType.TypeKind of
tkUnknown: ;
tkInteger: retval:=TCefv8ValueRef.CreateInt(p.GetValue(FContainer.ProcessObject).AsInteger);
tkChar: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString);
tkEnumeration: retval:=TCefv8ValueRef.CreateInt(p.GetValue(FContainer.ProcessObject).AsInteger);
tkFloat: retval:=TCefv8ValueRef.CreateDouble(p.GetValue(FContainer.ProcessObject).AsExtended);
tkString: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString);
tkSet: retval:=TCefv8ValueRef.CreateInt(p.GetValue(FContainer.ProcessObject).AsInteger);
tkClass: ;//retval:=TCefv8ValueRef.CreateObject(p.GetValue(FContainer.ProcessObject).AsObject);
tkMethod: ;
tkWChar: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString);
tkLString: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString);
tkWString: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString);
tkVariant: ;
tkArray:;
end;
end;
end;
end;

procedure TVCLJsExtended.TNCJSHandle.JsCallMethod(Method: TRttiMethod;
out ReturnVal: ICefv8Value; const Param: TCefv8ValueArray);
var
VA:array of TValue;
I:Integer;
rva:TValue;
AInstance:TObject;
begin
if Param<>nil then
begin
SetLength(VA,Length(Param));
for I := 0 to Length(Method.GetParameters)-1 do
begin
if Param[I].IsBool then
VA[I]:=TValue.From<Boolean>(Param[I].GetBoolValue);
if Param[I].IsInt then
begin
VA[I]:=TValue.From<Integer>(Param[I].GetIntValue);
Continue;
end;
if Param[I].IsDouble then
begin
VA[I]:=TValue.From<Double>(Param[I].GetDoubleValue);
Continue;
end;
if Param[I].IsString then
VA[I]:=TValue.From<String>(Param[I].GetStringValue);
if Param[I].IsObject then
{VA[I].AsObject:=Param[I].get};
      //if Param[I].is then

end;
end
else
      ;//VA:=nil;
AInstance:=FContainer.ProcessObject;
Rva:=Method.Invoke(AInstance,VA);
case rva.Kind of
tkUnknown: ;
tkInteger: ReturnVal:=TCefv8ValueRef.CreateInt(rva.AsInteger);
tkChar: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString);
tkEnumeration: ReturnVal:=TCefv8ValueRef.CreateInt(rva.AsOrdinal);
tkFloat: ReturnVal:=TCefv8ValueRef.CreateDouble(rva.AsExtended);
tkString: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString);
tkSet: ReturnVal:=TCefv8ValueRef.CreateInt(rva.AsInteger);
tkClass: ;//ReturnVal:=TCefv8ValueRef.CreateObject(rva.AsObject);
tkMethod: ;
tkWChar: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString);
tkLString: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString);
tkWString: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString);
tkVariant: ;
tkArray:;
tkRecord: ;
tkInterface: ;
tkInt64: ReturnVal:=TCefv8ValueRef.CreateInt(rva.AsInteger);
tkDynArray: ;
tkUString: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString);
tkClassRef: ;
tkPointer: ;
tkProcedure: ;
end;
end;

procedure TVCLJsExtended.TNCJSHandle.JsCallMethod(Method: TRttiMethod;
out ReturnVal: ICefv8Value);
begin
JsCallMethod(Method,ReturnVal,nil);
end;

function TVCLJsExtended.TNCJSHandle.MethodParamLength(Mn: string): Integer;
var
Rtx:TRttiContext;
M:TRttiMethod;
RT:TRttiType;
begin
RT:=Rtx.GetType(FContainer.FTypeInfo);
M:=Rt.GetMethod(Mn);
Result:=Length(M.GetParameters);
end;
{$M-}
end.