dxjs_share.pas

Well known and usefull component for delphi 7

function IsNaN (const V:Variant) :boolean;
function AddSets (const V1,V2:TVariant;PScript:Pointer) :TVariant;
function SubSets (const V1,V2:TVariant;PScript:Pointer) :TVariant;

procedure SaveInteger (Value:Integer;S:TStream) ;
function LoadInteger (S:TStream) :Integer;
procedure SaveString (const Value:string;S:TStream) ;
function LoadString (S:TStream) :string;
procedure SaveValue (const Value:Variant;S:TStream) ;
function LoadValue (S:TStream;PScript:Pointer) :TVariant;
function _Shr (X,Y:Integer) :Variant;
function HashNumber (const S:string) :Integer;
function IncDate(D: Double; I: Integer): TDateTime;

procedure Initialization_Share;
procedure Finalization_Share;

implementation

uses
   DXString,// with DXFreeware
   DXJS_CONV,
   DXJS_OBJECT;

const
   strOpers:array[0..74] of string=
  {5}('PRINT','PAUSE','CREATE_OBJECT','CREATE_REFERENCE','GET_NEXT_PROP',
  {14}'SWAP','GO','GO_FALSE','NOP','EOF','EOS','HALT','START','SAVE_CALL',
  {21}'CALL','PASS_BY_VAL','RET','EXIT','COND_EXIT','FINALLY','CATCH',
  {27}'TRY_ON','TRY_OFF','RAISE','CLEAR_ERROR','THROW','BEGIN_WITH',
  {37}'END_WITH','EVAL_IDENTIFIER','POP_RET','+','-','*','/','%','&&','||',
  {48}'&','|','<<','>>','>>>','^','~','++','--','+(unary)','-(unary)',
  {58}'delete','void','typeof','<','>','<=','>=','==','!=','INSTANCEOF',
  {71}'IN','===','!==','!','?','=','+=','-=','*=','/=','%=','&=','|=',
  {75}'<<=','>>=','>>>=','^=') ;

procedure SaveInteger (Value:Integer;S:TStream) ;
begin
   S.WriteBuffer (Value,SizeOf (Integer) ) ;
end;

function LoadInteger (S:TStream) :Integer;
begin
   S.ReadBuffer (result,SizeOf (Integer) ) ;
end;

procedure SaveString (const Value:string;S:TStream) ;
var
   Size:Integer;
   P:PChar;
begin
   Size:=Length (Value) ;
   P:=Pointer (Value) ;
   SaveInteger (Size,S) ;
   if Size>0 then
      S.WriteBuffer (P^,Size) ;
end;

function LoadString (S:TStream) :string;
var
   Size:Integer;
   P:PChar;
begin
   Size:=LoadInteger (S) ;
   if Size>0 then begin
      P:=StrAlloc (Size+1) ;
      FillChar2 (P^,Size+1,#0) ;
      S.ReadBuffer (P^,Size) ;
      result:=string (P) ;
      StrDispose (P) ;
   end;
end;

procedure SaveValue (const Value:Variant;S:TStream) ;
var
   VType,Len:Integer;
   SO:TFunctionObject;
begin
   VType:=VarType (Value) ;
   SaveInteger (VType,S) ;
   case VType of
      varString:
         SaveString (Value,S) ;
      varScriptObject:begin
            SO:=TFunctionObject (VariantToScriptObject (Value) ) ;
            Len:=ToInteger (SO.GetProperty ('length') ) ;
            SaveString (SO.DefaultValue,S) ;
            SaveInteger (SO.SubID,S) ;
            SaveInteger (Len,S) ;
         end;
   else
      S.WriteBuffer (Value,SizeOf (Variant) ) ;
   end;
end;

function LoadValue (S:TStream;PScript:Pointer) :TVariant;
var
   VType,SubID,Len:Integer;
   Decl:string;
   SO:TFunctionObject;
begin
   VType:=LoadInteger (S) ;
   case VType of
      varString:
         result:=LoadString (S) ;
      varScriptObject:begin
            Decl:=LoadString (S) ;
            SubID:=LoadInteger (S) ;
            Len:=LoadInteger (S) ;
            SO:=TFunctionObject.Create (Decl,SubID,nil,Len,PScript) ;
            result:=ScriptObjectToVariant (SO) ;
         end;
   else
      S.ReadBuffer (result,SizeOf (Variant) ) ;
   end;
end;

function IsArray (const V:Variant) :boolean;
begin
   result:=false;
   if VarType (V) =varScriptObject then begin
      result:=StrEql (VariantToScriptObject (V).ClassProp,'array') ;
   end;
end;

function AddSets (const V1,V2:TVariant;PScript:Pointer) :TVariant;
var
   SO,SO1,SO2:TScriptObject;
   I,J,L,L1,L2:Integer;
   PropName,Value:string;
   List:TStringList;
   Exists:boolean;
begin
   SO1:=VariantToScriptObject (V1) ;
   SO2:=VariantToScriptObject (V2) ;
   List:=TStringList.Create;
   L1:=ToInteger (SO1.GetProperty ('length') ) ;
   SO:=TArrayObject.Create (PScript) ;
   for I:=0 to L1-1 do begin
      PropName:=IntegerToString (I) ;
      Value:=ToString (SO1.GetProperty (PropName) ) ;
      SO.PutProperty (PropName,Value) ;
      List.Add (Value) ;
   end;

   L:=L1;

   L2:=ToInteger (SO2.GetProperty ('length') ) ;
   for I:=0 to L2-1 do begin
      Value:=ToString (SO2.GetProperty (IntegerToString (I) ) ) ;
      Exists:=false;
      for J:=0 to List.Count-1 do
         if StrEql (Value,List[J]) then begin
            Exists:=true;
            Break;
         end;
      if not Exists then begin
         SO.PutProperty (IntegerToString (L) ,Value) ;
         List.Add (Value) ;
         Inc (L) ;
      end;
   end;

   SO.PutProperty ('length',L) ;
   List.Free;
   result:=ScriptObjectToVariant (SO) ;
end;

function SubSets (const V1,V2:TVariant;PScript:Pointer) :TVariant;
var
   SO,SO1,SO2:TScriptObject;
   I,J,L1,L2:Integer;
   Value:string;
   List:TStringList;
begin
   SO1:=VariantToScriptObject (V1) ;
   SO2:=VariantToScriptObject (V2) ;
   List:=TStringList.Create;
   L1:=ToInteger (SO1.GetProperty ('length') ) ;
   for I:=0 to L1-1 do
      List.Add (ToString (SO1.GetProperty (IntegerToString (I) ) ) ) ;
   L2:=ToInteger (SO2.GetProperty ('length') ) ;
   for I:=0 to L2-1 do begin
      Value:=ToString (SO2.GetProperty (IntegerToString (I) ) ) ;
      for J:=0 to List.Count-1 do
         if StrEql (Value,List[J]) then begin
            List.Delete (J) ;
            Break;
         end;
   end;
   SO:=TArrayObject.Create (PScript) ;
   for I:=0 to List.Count-1 do
      SO.PutProperty (IntegerToString (I) ,List[I]) ;
   SO.PutProperty ('length',List.Count) ;
   List.Free;
   result:=ScriptObjectToVariant (SO) ;
end;

function IsNumber (const V:Variant) :boolean;
begin
   case VarType(V) of
   varDouble,varInteger, {original 2 types}
   {varSmallInt,}varSingle,varCurrency,{varShortInt}$0010,{varWord}$0012,{varLongWord}$0013,{varInt64}$0014,varDate:
      Result:=True
   Else Result:=False;
   end;
end;

function IsString (const V:Variant) :boolean;
var
   T:Integer;
begin
   T:=VarType (V) ;
   result:= (T=varString) or (T=varOleStr) ;
end;

function IsBoolean (const V:Variant) :boolean;
begin
   result:=VarType (V) =varBoolean;
end;

function IsObject (const V:Variant) :boolean;
begin
   result:=VarType (V) =varScriptObject;
end;

function IsUndefined (const V:Variant) :boolean;
begin
   result:=VarType (V) =varEmpty;
end;

function IsNull (const V:Variant) :boolean;
begin
   result:=VarType (V) =varNull;
end;

function IsNaN (const V:Variant) :boolean;
var
   D:Double;
begin
   D:=ToNumber (V) ;
   result:= (D=NEGATIVE_INFINITY) or
      (D=POSITIVE_INFINITY) or
      (D=NaN) ;
end;

{$IFDEF ECMA_COMPARE}
function RelationalComparison (const V1,V2:TVariant) :TVariant;
                              //performs x < y comparison
var
   I,L:Integer;
   S1,S2:string;
   P1,P2,N1,N2:Variant;
begin
   P1:=ToPrimitive (V1) ;
   P2:=ToPrimitive (V2) ;
   if IsString (P1) and IsString (P2) then begin
      S1:=P1;
      S2:=P2;
      If (S1='') then begin //813
         result:=S1<S2;
         exit;
      end
      else if (S2='') then begin //813
         result:=S1<S2;
         exit;
      end;
      L:=Length (S1) ;
      if Length (S2) <L then L:=Length (S2) ;
      for I:=1 to L do
         if S1[I]<>S2[I] then begin
            Result:=Ord (S1[I]) <Ord (S2[I]);
            Exit;
         end;
      result:=false;
   end
   else begin
      N1:=ToNumber (P1) ;
      N2:=ToNumber (P2) ;
      if (N1<>NaN) and (N2<>NaN) then result:=N1<N2
      else result:=undefined; // 813
   end;
end;
{$ELSE}
function RelationalComparison (const V1,V2:TVariant) :TVariant;
                              //performs x < y comparison
var
   S1,S2:string;
   P1,P2:Variant;
begin
   Result:=False;
   P1:=ToPrimitive (V1) ;
   P2:=ToPrimitive (V2) ;
   if DXString.isNumericString (P1) and
      DXString.isNumericString (P2) then begin
      Result:=P1<P2;
   end
   else begin
      S1:=P1;
      S2:=P2;
      Result:=S1<S2;
   end;
end;
{$ENDIF}

{$IFDEF ECMA_COMPARE}
function EqualityComparison (const V1,V2:TVariant) :TBoolean;
var
   T1,T2:Integer;
begin
   T1:=VarType (V1) ;
   T2:=VarType (V2) ;
   If ((T1>1) and (T1<7)) or ((T1>9) and (T1<15)) then T1:=5; // June 2004
   If ((T2>1) and (T2<7)) or ((T2>9) and (T2<15)) then T2:=5; // June 2004
   if T1=T2 then begin
      if (T1=varUndefined) or (T1=varNull) then begin
         result:=true;
         Exit;
      end;
      if IsNumber (V1) then begin
         if IsNaN (V1) or IsNan (V2) then begin
            result:=false;
            Exit;
         end;
         result:=V1=V2;
         Exit;
      end;
      result:=V1=V2;
   end
   else begin
{JULY 2004 - TIGHTENED
      if (T1=varNull) and (T2=varUndefined) then
         result:=true
      else if (T2=varNull) and (T1=varUndefined) then
         result:=true
      else if IsNumber (V1) and IsString (V2) then
         result:=EqualityComparison (V1,ToNumber (V2) )
      else if IsNumber (V2) and IsString (V1) then
         result:=EqualityComparison (V2,ToNumber (V1) )
      else if IsNumber (V1) and IsBoolean (V2) then
         result:=EqualityComparison (V1,ToNumber (V2) )
      else if IsNumber (V2) and IsBoolean (V1) then
         result:=EqualityComparison (V2,ToNumber (V1) )
      else if IsObject (V1) and (IsNumber (V2) or IsBoolean (V2) or IsString (V2) ) then
         result:=EqualityComparison (ToPrimitive (V1) ,V2)
      else if IsObject (V2) and (IsNumber (V1) or IsBoolean (V1) or IsString (V1) ) then
         result:=EqualityComparison (ToPrimitive (V2) ,V1)
      else
}
      if ((T1=varNull) and (T2=varUndefined)) or
         ((T2=varNull) and (T1=varUndefined)) then result:=true
      else if IsNumber (V1) and (IsString (V2) or IsBoolean(V2)) then
         result:=EqualityComparison (V1,ToNumber (V2) )
      else if IsNumber (V2) and (IsString (V1) or IsBoolean(V1)) then
         result:=EqualityComparison (V2,ToNumber (V1) )
      else if IsObject (V1) and (IsNumber (V2) or IsBoolean (V2) or IsString (V2) ) then
         result:=EqualityComparison (ToPrimitive (V1) ,V2)
      else if IsObject (V2) and (IsNumber (V1) or IsBoolean (V1) or IsString (V1) ) then
         result:=EqualityComparison (ToPrimitive (V2) ,V1)
      else
      // June 2004 = compare if undefined string is empty - force to true!
           if (T1=0) and (T2=256) then Result:=V2=''
           else if (T2=0) and (T1=256) then Result:=V1=''
      else
         result:=false;
   end;
end;
{$ELSE}
function EqualityComparison (const V1,V2:TVariant) :TBoolean;
var
   S1,S2:string;
   P1,P2,N1,N2:Variant;
begin
   Result:=False;
   P1:=ToPrimitive (V1) ;
   P2:=ToPrimitive (V2) ;
   if DXString.isNumericString (P1) and
      DXString.isNumericString (P2) then begin
      if (P1<>NaN) and (P2<>NaN) then result:=P1=P2;
   end
   else begin
      S1:=P1;
      S2:=P2;
      Result:=S1=S2;
   end;
end;
{$ENDIF}

function StrictEqualityComparison (const V1,V2:TVariant) :TBoolean;
begin
   if VarType (V1) <>VarType (V2) then result:=false
   Else result:=EqualityComparison (V1,V2) ;
end;

function StrEql (const S1,S2:string) :Boolean;
begin
   Result:=CompareText (S1,S2) =0;
end;

function GetOperName (OP:Integer) :string;
begin