dxjs_extern.pas

Well known and usefull component for delphi 7

////////////////////////////////////////////////////////////////////////////
//    Component: DXJS_EXTERN
//       Author: Alexander Baranovsky ([e-mail])
//               G.E. Ozz Nixon Jr. ([e-mail])
// ========================================================================
// Source Owner: DX, Inc. 2002, 2004
//    Copyright: All code is the property of DX, Inc. Licensed for
//               resell by Brain Patchwork DX (tm) and part of the
//               DX (r) product lines, which are (c) 1999-2002
//               DX, Inc. Source may not be distributed without
//               written permission from both Brain Patchwork DX,
//               and DX, Inc.
//      License: (Reminder), None of this code can be added to other
//               developer products without permission. This includes
//               but not limited to DCU's, DCP's, DLL's, OCX's, or
//               any other form of merging our technologies. All of
//               your products released to a public consumer be it
//               shareware, freeware, commercial, etc. must contain a
//               license notification somewhere visible in the
//               application.
// Code Version: (3rd Generation)
// ========================================================================
//  Description: This unit is used to invoke the actual methods for the
//  supported objects. e.g. DateObject.getDate()
// ========================================================================
////////////////////////////////////////////////////////////////////////////

unit DXJS_EXTERN;
interface
{$I DXJavaScript.def}

uses
{$IFDEF VARIANTS}
   Variants,
{$ENDIF}
{$IFDEF WIN32}
   ActiveX,
   AxCtrls,
   ComObj,
{$ENDIF}
   Classes,
   Math,
   DXJS_SHARE;

var
   IsCOM:boolean=false;

type
   TDefinition=class
      Address:Pointer;
      ClassID:Integer;
      Len:Integer;
      KindProc:TKindProc;
      AClass:TClass;
   end;

   TDefinitionList=class (TStringList)
      constructor Create;
      destructor Destroy;override;
      function RegisterRoutine (const Name:string;Len:Integer;
         Address:pointer;ClassID:Integer=-1;
         KindProc:TKindProc=KindJavaScript) :TDefinition;
      procedure AddStandardRoutines;
      procedure Print (const Name:string) ;
   end;

   TPropDef=class
      ReadAddr,WriteAddr:Pointer;
      ClassID:Integer;
      AClass:TClass;
   end;

   TPropDefList=class (TStringList)
      constructor Create;
      destructor Destroy;override;
      procedure RegisterProperty (AClass:TClass;const Name:string;ReadAddr,WriteAddr:Pointer) ;
      procedure Print (const Name:string) ;
   end;

   THostVariableList=class (TStringList)
      constructor Create;
      procedure Print (const Name:string) ;
   end;

   TConstantList=class (TStringList)
      constructor Create;
      destructor Destroy;override;
      procedure AddConstant (const Name:string;const Value:Variant) ;
      procedure Print (const Name:string) ;
   end;

procedure Invoke (PScript:Pointer;
   Address:Pointer;
   var This:Variant;
   ParamCount:Integer;
   KindProc:TKindProc) ;

function InvokeDisp (ScriptObject:Pointer;const MethodName:string;ParamCount:Integer) :TVariant;

function __Boolean (var This:Variant;const Parameters:array of Variant) :Variant;
function __Date (var This:Variant;const Parameters:array of Variant) :Variant;
function __Math (var This:Variant;const Parameters:array of Variant) :Variant;
function __Number (var This:Variant;const Parameters:array of Variant) :Variant;
function __String (var This:Variant;const Parameters:array of Variant) :Variant;
function __Array (var This:Variant;const Parameters:array of Variant) :Variant;
function __RegExp (var This:Variant;const Parameters:array of Variant) :Variant;
function __Function (var This:Variant;const Parameters:array of Variant) :Variant;
function __Error (var This:Variant;const Parameters:array of Variant) :Variant;
function __DelphiObject (var This:Variant;const Parameters:array of Variant) :Variant;
function __ActiveXObject (var This:Variant;const Parameters:array of Variant) :Variant;
function __DetectActiveXControl (var This:Variant;const Parameters:array of Variant) :Variant;
function __EnumeratorObject (var This:Variant;const Parameters:array of Variant) :Variant;

implementation

uses
   SysUtils,
   DXString,// from DXFreeware
{$IFDEF LINUX}
   QForms,
{$ELSE}
   Forms,// uses TFORM
{$ENDIF}
   DXJS_MAIN,
   DXJS_OBJECT,
   DXJS_CONV,
   DXJS_DISP;

function __toString (var This:Variant;const Parameters:array of Variant) :
   Variant; forward; //715 for parseInt()

constructor TPropDefList.Create;
begin
   inherited;
   Sorted:=true;
   Duplicates:=dupAccept;
end;

destructor TPropDefList.Destroy;
var
   I:Integer;
begin
   for I:=0 to Count-1 do Objects[I].Free;
   inherited;// OZZ
end;

procedure TPropDefList.RegisterProperty (AClass:TClass;const Name:string;ReadAddr,WriteAddr:Pointer) ;
var
   D:TPropDef;
   I,J,ClassID:Integer;
begin
   ClassID:=Integer (AClass.ClassInfo) ;

   I:=IndexOf (Name) ;
   if I<>-1 then begin
      for J:=I to Count-1 do begin
         if Strings[J]<>Name then
            Break;
         D:=TPropDef (Objects[J]) ;
         if D.ClassID=ClassID then begin
            D.ClassID:=ClassID;
            D.ReadAddr:=ReadAddr;
            D.WriteAddr:=WriteAddr;
            D.AClass:=AClass;
            Exit;
         end;
      end;
   end;

   D:=TPropDef.Create;
   D.ClassID:=ClassID;
   D.ReadAddr:=ReadAddr;
   D.WriteAddr:=WriteAddr;
   D.AClass:=AClass;
   AddObject (Name,D) ;
end;

procedure TPropDefList.Print (const Name:string) ;
var
   T:TextFile;
   I:Integer;
   D:TPropDef;
begin
   AssignFile (T,Name) ;
   Rewrite (T) ;
   try
      for I:=0 to Count-1 do begin
         D:=TPropDef (Objects[I]) ;
         writeln (T,I:5,' ',Norm (Strings[I],20) ,' ',D.ClassID) ;
      end;
   finally
      Close (T) ;
   end;
end;

constructor TDefinitionList.Create;
begin
   inherited;
   Sorted:=true;
   Duplicates:=dupAccept;
end;

function TDefinitionList.RegisterRoutine (const Name:string;
   Len:Integer;
   Address:pointer;
   ClassID:Integer=-1;
   KindProc:TKindProc=KindJavaScript) :TDefinition;
var
   I,J:Integer;
begin
   I:=IndexOf (Name) ;
   if I<>-1 then begin
      for J:=I to Count-1 do begin
         if Strings[J]<>Name then
            Break;
         result:=TDefinition (Objects[J]) ;
         if result.ClassID=ClassID then begin
            result.Address:=Address;
            result.ClassID:=ClassID;
            result.Len:=Len;
            result.KindProc:=KindProc;
            Exit;
         end;
      end;
   end;

   result:=TDefinition.Create;
   result.Address:=Address;
   result.ClassID:=ClassID;
   result.Len:=Len;
   result.KindProc:=KindProc;
   result.AClass:=nil;

   AddObject (Name,result) ;
end;

procedure TDefinitionList.Print (const Name:string) ;
var
   T:TextFile;
   I:Integer;
   D:TDefinition;
begin
   AssignFile (T,Name) ;
   Rewrite (T) ;
   try
      for I:=0 to Count-1 do begin
         D:=TDefinition (Objects[I]) ;
         writeln (T,I:5,' ',Norm (Strings[I],20) ,' ',D.ClassID) ;
      end;
   finally
      Close (T) ;
   end;
end;

destructor TDefinitionList.Destroy;
var
   I:Integer;
begin
   for I:=0 to Count-1 do TDefinition (Objects[I]) .Free;
   inherited;
end;

(*
procedure Invoke (PScript:Pointer;
   Address:Pointer;
   var This:Variant;
   ParamCount:Integer;
   KindProc:TKindProc) ;

var
   J:Integer;
   Parameters:array of Variant;
   result:Variant;
begin
   with TJScript (PScript) do begin
      SetLength (Parameters,ParamCount) ;
      for J:=0 to ParamCount-1 do
         Parameters[ParamCount-J-1]:=TJScript (PScript) .Postfix.PopVariant;

      TJScript (PScript) .Postfix.PopPopID;// sub then label

      case KindProc of
         KindJavaScript:result:=TScriptProc (Address) (This,Parameters) ;
         KindDelphiRoutine:result:=TDelphiRoutine (Address) (Parameters) ;
         KindDelphiMethod:result:=TDelphiMethod (Address) (ToDelphiObject (This) ,Parameters) ;
      end;

      if VarType (result) =varDelphiObject then begin
         TVarData (result) .VType:=varInteger;
         J:=result;
         if J=0 then
            result:=Undefined
         else
            result:=ScriptObjectToVariant (TDelphiObject.Create (TObject (J) ,PScript) ) ;
      end;

      TJScript (PScript) .Postfix.RetVariant (result) ;
   end;
end; *)

procedure Invoke (PScript:Pointer;
   Address:Pointer;
   var This:Variant;
   ParamCount:Integer;
   KindProc:TKindProc) ;

var
   J:Integer;
   Parameters:array of Variant;
   result:Variant;
begin
   with TJScript (PScript) do begin
      SetLength (Parameters,ParamCount) ;
      for J:=0 to ParamCount-1 do
         Parameters[ParamCount-J-1]:=TJScript (PScript) .Postfix.PopVariant;

      TJScript (PScript) .Postfix.PopPopID;// sub then label

      case KindProc of
         KindJavaScript:result:=TScriptProc (Address) (This,Parameters) ;
         KindDelphiRoutine:result:=TDelphiRoutine (Address) (Parameters) ;
         KindDelphiMethod:result:=TDelphiMethod (Address) (ToDelphiObject (This) ,Parameters) ;
      end;

try //803
         if VarType (result) =varDispatch then begin
            result := ScriptObjectToVariant(TActiveXObject.Create(result, PScript));
         end
         Else if VarType (result) =varDelphiObject then begin
            TVarData (result) .VType:=varInteger;
            J:=result;
            if J=0 then
               result:=Undefined
            else
               result:=ScriptObjectToVariant (TDelphiObject.Create (TObject (J) ,PScript) ) ;
         end
         else if VarType(result) >= varArray then
            result := VariantArrayToJavaScriptArray(result, PScript);
except
      result:=Undefined; //803
end;

      TJScript (PScript) .Postfix.RetVariant (result) ;
   end;
end;

function InvokeDisp (ScriptObject:Pointer;const MethodName:string;ParamCount:Integer) :TVariant;
var
   Scripter:TJScript;
   SO:TScriptObject;
   Parameters:array of TVariant;
   J:Integer;
   V:TVariant;
begin
   SO:=TScriptObject (ScriptObject) ;
   Scripter:=TJScript (SO.PScript) ;
   SetLength (Parameters,ParamCount) ;
   for J:=0 to ParamCount-1 do
      Parameters[ParamCount-J-1]:=Scripter.Postfix.PopVariant;
   Scripter.Postfix.PopPopID;// sub then label
   V:=DispCall (SO.ValueProp,MethodName,Parameters) ;
   if VarType (V) =varDispatch then
      result:=ScriptObjectToVariant (TActiveXObject.Create (V,Scripter) )
   else result:=V;
   Scripter.Postfix.RetVariant (result) ;
end;

function _Object (var This:Variant;const Parameters:array of Variant) :Variant;
begin
   if Length (Parameters) >0 then begin
      This:=ToObject (Parameters[0],VariantToScriptObject (This).PScript) ;
   end;
end;

function __Boolean (var This:Variant;const Parameters:array of Variant) :Variant;
begin
   if Length (Parameters) >0 then result:=ToBoolean (Parameters[0])
   else result:=false;
   This:=ToObject (result,VariantToScriptObject (This).PScript) ;
end;

function __Date (var This:Variant;const Parameters:array of Variant) :Variant;
var
   SO:TScriptObject;
   Y,M,D,H,N,S:Word;

Procedure SetResult(TD:TDateTime);
Begin
{    Result:=FormatDateTime ('ddd mmm d h:nn:ss @ yyyy',TD) ;
    Result:=StringReplace (Result,'@',DXString.ShortTimeZone, []) ;}
    Result:=TD;
End;

begin
   if Length (Parameters) =1 then result:=Parameters[0] // does not support 1063765933 only
   else if Length (Parameters) =3 then Begin // july 29
      Y:=ToInt32(Parameters[0]);
      M:=ToInt32(Parameters[1])+1;
      D:=ToInt32(Parameters[2]);
      SetResult(EncodeDate(Y,M,D)); // sept 24
   end
   else if Length (Parameters) =6 then Begin // august 11
      Y:=ToInt32(Parameters[0]);
      M:=ToInt32(Parameters[1])+1;
      D:=ToInt32(Parameters[2]);
      H:=ToInt32(Parameters[3]);
      N:=ToInt32(Parameters[4]);
      S:=ToInt32(Parameters[5]);
      SetResult(EncodeDate(Y,M,D)+EncodeTime(H,N,S,0)); // sept 24
   end
   else SetResult(SysUtils.Now); // sept 24
   SO:=TDateObject.Create (result,VariantToScriptObject (This).PScript) ;
   This:=ScriptObjectToVariant (SO) ;
end;

function __Math (var This:Variant;const Parameters:array of Variant) :Variant;
begin
   This:=ScriptObjectToVariant (TMathObject.Create (VariantToScriptObject (This).PScript) ) ;
end;

function __Number (var This:Variant;const Parameters:array of Variant) :Variant;
begin
   if Length (Parameters) >0 then result:=ToNumber (Parameters[0])
   else result:=0;
   This:=ToObject (result,VariantToScriptObject (This).PScript) ;
end;

function __String (var This:Variant;const Parameters:array of Variant) :Variant;
begin
   if Length (Parameters) >0 then result:=ToString (Parameters[0])
   else result:='';
   This:=ToObject (result,VariantToScriptObject (This).PScript) ;
end;

function __Array (var This:Variant;const Parameters:array of Variant) :Variant;
var
   SO:TScriptObject;
   I,L:Integer;
   PScript:Pointer;
begin
   PScript:=VariantToScriptObject (This).PScript;
   SO:=TArrayObject.Create (PScript) ;
   L:=Length (Parameters) ;
   if L>0 then begin
      if L=1 then begin
         if VarType (Parameters[0]) =varDouble then SO.PutProperty ('length',Parameters[0])
         else SO.PutProperty ('0',Parameters[0]) ;
      end
      else