dxjs_object.pas

Well known and usefull component for delphi 7

  end
  else Begin
  end;
  result := inherited GetDefaultValue;
end;

constructor TMathObject.Create(AScript: Pointer);
begin
  inherited Create('Math', AScript);
//715  Prototype := TJScript(AScript).GlobalObject.ObjectPrototype;
  Prototype := TScriptObject.Create('Object', AScript); //715
  Put('prototype', ScriptObjectToVariant(Prototype));
  Put('E', 2.7182818284590452354, [DontEnum, DontDelete, ReadOnly]);
  Put('LN10', 2.302585092994046, [DontEnum, DontDelete, ReadOnly]);
  Put('LN2', 0.6931471805599453, [DontEnum, DontDelete, ReadOnly]);
  Put('LOG2E', 1.4426950408889634, [DontEnum, DontDelete, ReadOnly]);
  Put('LOG10E', 0.4342944819032518, [DontEnum, DontDelete, ReadOnly]);
  Put('PI', 3.1415926535897932, [DontEnum, DontDelete, ReadOnly]);
  Put('SQRT1_2', 0.7071067811865476, [DontEnum, DontDelete, ReadOnly]);
  Put('SQRT2', 1.4142135623730951, [DontEnum, DontDelete, ReadOnly]);
  CallAddr := @__Math;
end;

constructor TNumberObject.Create(const AValue: TVariant; Ascript: Pointer);
begin
  inherited Create('Number', AScript);
  Prototype := TJScript(AScript).GlobalObject.NumberPrototype;
  DefaultValue := ToNumber(AValue);
  Put('prototype', ScriptObjectToVariant(Prototype));
  Put('MAX_VALUE', MAX_VALUE, [DontEnum, DontDelete, ReadOnly]);
  Put('MIN_VALUE', MIN_VALUE, [DontEnum, DontDelete, ReadOnly]);
  Put('NEGATIVE_INFINITY', NEGATIVE_INFINITY, [DontEnum, DontDelete, ReadOnly]);
  Put('POSITIVE_INFINITY', POSITIVE_INFINITY, [DontEnum, DontDelete, ReadOnly]);
  Put('NaN', NaN, [DontEnum, DontDelete, ReadOnly]);
  CallAddr := @__Number;
end;

constructor TFunctionObject.Create(const AValue: TVariant;
                                   SubID: Integer; Address: Pointer; Len: Integer;
                                   AScript: Pointer);
begin
  inherited Create('Function', AScript);
  Prototype := TJScript(AScript).GlobalObject.FunctionPrototype;
  DefaultValue := AValue;
  Self.SubID := SubID;
  CallAddr := Address;
  Put('arguments', ScriptObjectToVariant(TArgumentsObject.Create(AScript)), [DontEnum]);
  Put('length', Len, [DontEnum]);
end;

constructor TStringObject.Create(const AValue: Variant; AScript: Pointer);
var
  S: String;
begin
  inherited Create('String', AScript);
  Prototype := TJScript(AScript).GlobalObject.StringPrototype;
  S := DXJS_CONV.ToString(AValue);
  DefaultValue := S;
  Put('length', Length(S), [DontEnum, DontDelete]);
  Put('prototype', ScriptObjectToVariant(Prototype), [DontEnum, DontDelete]);
  CallAddr := @__String;
end;

function TStringObject.GetProperty(const PropertyName: String): TVariant;
var
  I, Code: Integer;
  S: String;
begin
  Val(PropertyName, I, Code);
  if Assigned(PScript) then
    if TJScript(PScript).ZeroBasedStringIndex then Inc(I);
  if Code = 0 then begin
    S := DefaultValue;
    if (I > 0) and (I <= Length(S)) then begin
      result := S[I];
      Exit;
    end;
  end;
  result := inherited GetProperty(PropertyName);
end;

procedure TStringObject.PutProperty(const PropertyName: String; const Value: TVariant);
var
  I, Code: Integer;
  P: TProperty;
  S, S1: String;
begin
  inherited;
  Val(PropertyName, I, Code);
  if Code = 0 then begin
    if Assigned(PScript) then
     if TJScript(PScript).ZeroBasedStringIndex then Inc(I);
    S := DefaultValue;
    P := Get('length');
    if I > P.Value then begin
      Put('length', I);
      SetLength(S, I);
    end;
    if I > 0 then begin
      S1 := ToStr(Value);
      if Length(S1) = 1 then S[I] := S1[1]
      else raise TScriptFailure.Create(reIncompatibleTypes);
    end;
    DefaultValue := S;
  end;
end;

function TStringObject.Match(const RegExp: TVariant): TVariant;
var
  SO: TRegExpObject;
  g: Boolean;
  Arr: TVariant;
  ArrObject, TempObject: TArrayObject;
  L: Integer;

begin
  SO := TRegExpObject(VariantToScriptObject(ToObject(RegExp, PScript)));
  if SO.ClassProp <> 'RegExp' then
    SO := TRegExpObject.Create(DXJS_CONV.ToString(RegExp), '', PScript);
  g := ToBoolean(SO.GetProperty('global'));
  if g then begin
    SO.PutProperty('global', false);
    ArrObject := TArrayObject.Create(PScript);
    L := 0;
    Arr := SO.Exec(DefaultValue);
    if VarType(Arr) = varNull then begin
      result := Null;
      Exit;
    end;
    TempObject := TArrayObject(VariantToScriptObject(Arr));
    ArrObject.PutProperty(IntegerToString(L), TempObject.GetProperty('0'));
    Inc(L);
    while VarType(Arr) <> varNull do begin
      Arr := SO.Exec(DefaultValue);
      if VarType(Arr) <> varNull then begin
        TempObject := TArrayObject(VariantToScriptObject(Arr));
        ArrObject.PutProperty(IntegerToString(L), TempObject.GetProperty('0'));
        Inc(L);
      end;
    end;
    ArrObject.PutProperty('length', L);
  end
  else begin
    Arr := SO.Exec(DefaultValue);
    if VarType(Arr) = varNull then begin
      result := Null;
      Exit;
    end;
    ArrObject := TArrayObject(VariantToScriptObject(Arr));
  end;
  ArrObject.PutProperty('input', TJScript(PScript).GlobalObject.RegExpObject.GetProperty('input'));
  ArrObject.PutProperty('index', TJScript(PScript).GlobalObject.RegExpObject.GetProperty('index'));
  ArrObject.PutProperty('lastIndex', TJScript(PScript).GlobalObject.RegExpObject.GetProperty('lastIndex'));
  result := ScriptObjectToVariant(ArrObject);
end;

function TStringObject.Replace(const RegExp: TVariant; const ReplaceStr: String): TVariant;
var
  SO: TRegExpObject;
  R: TRegExpr;

begin
  SO := TRegExpObject(VariantToScriptObject(ToObject(RegExp, PScript)));
  R := TRegExpr.Create;
  R.ModifierG := ToBoolean(SO.GetProperty('global'));
  R.ModifierI := ToBoolean(SO.GetProperty('ignoreCase'));
  R.ModifierM := ToBoolean(SO.GetProperty('multiline'));
  R.Expression := SO.DefaultValue;
  result := R.Replace(DefaultValue, ReplaceStr);
end;

constructor TArrayObject.Create(AScript: Pointer);
begin
  inherited Create('Array', AScript);
  Prototype := TJScript(AScript).GlobalObject.ArrayPrototype;
  Put('length', 0, [DontEnum, DontDelete]);
  Put('prototype', ScriptObjectToVariant(Prototype), [DontEnum, DontDelete]);
  CallAddr := @__Array;
end;

procedure TArrayObject.PutProperty(const PropertyName: String; const Value: TVariant);
var
  I, Code: Integer;
  P: TProperty;
begin
  inherited;
  Val(PropertyName, I, Code);
  if Code = 0 then begin
    P := Get('length');
    Inc(I);
    if I > P.Value then Put('length', I);
  end;
end;

function TArrayObject.GetDefaultValue: TVariant;
var
  Loop, L: Integer;
  P: TProperty;
  S: String;

begin
  result := '';
  P := Get('length');
  L := P.Value;
  for Loop:=0 to L - 1 do begin
    P := Get(IntegerToString(Loop));
    if P = nil then S := ''
    else begin
      if VarType(P.Value) = varScriptObject then begin
        S := VariantToScriptObject(P.Value).ToString;
      end
      else S := DXJS_CONV.ToString(P.Value);
    end;
    result := result + S;
    if Loop < L - 1 then result := result + ',';
  end;
  result := '[' + result + ']';
end;

function GetPublishedProperties(AClass: TClass): TStringList;
var
  pti: PTypeInfo;
  ptd: PTypeData;
  Loop, nProps: Integer;
  pProps: PPropList;
  ppi: PPropInfo;
  S: String;

begin
  result := TStringList.Create;
  pti := AClass.ClassInfo;
  if pti = nil then Exit;
  ptd := GetTypeData(pti);
  nProps := ptd^.PropCount;
  if nProps > 0 then begin
    GetMem(pProps, SizeOf(PPropInfo) * nProps);
    GetPropInfos(pti, pProps);
  end
  else pProps := nil;
  for Loop:=0 to nProps - 1 do begin
    ppi := pProps[Loop];
    S := ppi^.Name;
    result.Add(DXString.UpperCase(S));
  end;
  if pProps <> nil then
    FreeMem(pProps, SizeOf(PPropInfo) * nProps);
end;

constructor TDelphiObject.Create(const AnInstance: TObject; AScript: Pointer);
var
  L: TStringList;
  I, J, SubID: Integer;
  C: TComponent;
  SO: TScriptObject;
  V: Variant;
  D: TDefinition;
  PropDef: TPropDef;
  ToBeRemoved: boolean;
  AClass: TClass;
begin
  inherited Create('DelphiObject', AScript);
  PropertyList.fCaseSensitive := false;
  Instance := AnInstance;
  CallAddr := @__DelphiObject;
  if Instance = nil then Exit;
  KindProc := KindDelphiMethod;
  with TJScript(PScript) do begin
    for I:=0 to HostDefinitionList.Count - 1 do begin
      D := TDefinition(HostDefinitionList.Objects[I]);
      if Abs(D.ClassID) > 100 then
      if Instance.InheritsFrom(D.AClass) then begin
        SubID := SymbolTable.LookUpID(HostDefinitionList[I], 0);
        if SubID > 0 then
          Put(HostDefinitionList[I], SymbolTable.GetVariant(SubID), [DontDelete]);
      end;
    end;
    for I:=0 to PropDefList.Count - 1 do begin
      PropDef := TPropDef(PropDefList.Objects[I]);
      if Instance.InheritsFrom(PropDef.AClass) then
        Put(PropDefList[I], Undefined);
    end;
  end;
  L := GetPublishedProperties(Instance.ClassType);
  for I:=0 to L.Count - 1 do begin
    ToBeRemoved := false;
    with TJScript(PScript) do
      for J:=0 to RemovePropList.Count - 1 do
      if StrEql(RemovePropList[J], L[I]) then begin
        AClass := TClass(RemovePropList.Objects[J]);
        if Instance.InheritsFrom(AClass) then
          ToBeRemoved := true;
      end;
    if not ToBeRemoved then Put(L[I], Undefined, []);
  end;
  ValueProp := Format('$%x', [Integer(Instance)]);
  if Instance.InheritsFrom(TComponent) then begin
    C := Instance as TComponent;
    for I:=0 to C.ComponentCount - 1 do begin
      SO := TDelphiObject.Create(C.Components[I], PScript);
      V := ScriptObjectToVariant(SO);
      Put(C.Components[I].Name, V, [DontDelete]);
    end;
  end;
end;

type
  TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1;

function TDelphiObject.GetProperty(const PropertyName: String): TVariant;
var
  P: TProperty;
  PropInfo: PPropInfo;
  D: Double;
  S: String;
  I: Integer;
  TypeData: PTypeData;

  PropDef: TPropDef;
  PropInstance: TObject;
  V: Variant;

  IntegerSet: TIntegerSet;
  pti: PTypeInfo;
  SO: TArrayObject;
  L: Integer;
begin
  P := Get(PropertyName);
  if P = nil then
  begin
    if Assigned(TJScript(PScript).fOnGetExtraProperty) then
    begin
      result := TJScript(PScript).fOnGetExtraProperty(
        TJScript(PScript).Owner, Instance, PropertyName);
      if VarType(result) = varDelphiObject then
      begin
        TVarData(result).VType := varInteger;
        I := result;
        if I = 0 then
          result := Undefined
        else
          result := ScriptObjectToVariant(TDelphiObject.Create(TObject(I), PScript));
      end;
    end;
    Exit;
  end;

  pti := PTypeInfo(Instance.ClassType.ClassInfo);
  if pti = nil then
    PropInfo := nil
  else
    PropInfo := GetPropInfo(pti, PropertyName);

  if PropInfo <> nil then
  begin
    TypeData := GetTypeData(PropInfo^.PropType^);
    // return the right type
    case PropInfo^.PropType^^.Kind of
      tkInteger
         {$IFNDEF VER100}
            ,tkInt64
         {$ENDIF}
      :begin
        D := GetOrdProp(Instance, PropInfo);
        result := D;
      end;
      tkEnumeration:
        if TypeData^.BaseType^ = TypeInfo(Boolean) then
          result := Boolean(GetOrdProp(Instance, PropInfo))
        else
        begin
          I := GetOrdProp(Instance, PropInfo);
          result := GetEnumName(PropInfo^.PropType^, I);
        end;
      {$IFNDEF VER100}
      tkSet:
      begin
        SO := TArrayObject.Create(PScript);
        L := 0;
        Integer(IntegerSet) := GetOrdProp(Instance, PropInfo);
        pti := GetTypeData(PropInfo^.PropType^)^.CompType^;
        for I := 0 to SizeOf(Integer) * 8 - 1 do
          if I in IntegerSet then
          begin
            S := GetEnumName(pti, I);
            SO.PutProperty(IntegerToString(L), S);
            Inc(L);
          end;
        SO.PutProperty('length', L);
        result := ScriptObjectToVariant(SO);
      end;
      {$ENDIF}
      tkClass:
      begin
        I := GetOrdProp(Instance, PropInfo);
        if I <> 0 then
          result := ScriptObjectToVariant(TDelphiObject.Create(TObject(I), PScript));
      end;
      tkChar:
      begin
        S := Chr(GetOrdProp(Instance, PropInfo));
        result := S;
      end;
      tkString, tkLString, tkWString:
      begin
        S := GetStrProp(Instance, PropInfo);
        result := S;
      end;
      tkVariant:
        result := GetVariantProp(Instance, PropInfo);
    end;
  end
  else
  begin

    with TJScript(PScript) do
    for I:=0 to PropDefList.Count - 1 do
    if PropDefList[I] = PropertyName then
    begin
      PropDef := TPropDef(PropDefList.Objects[I]);
      if PropDef.ReadAddr <> nil then
        if Instance.InheritsFrom(PropDef.AClass) then
        begin
          V := TDelphiMethod(PropDef.ReadAddr)(Instance, []);
          if VarType(V) = varDelphiObject then begin
            TVarData(V).VType := varInteger;
            Integer(PropInstance) := Integer(V);
            result := ScriptObjectToVariant(TDelphiObject.Create(PropInstance, PScript));
          end
          else
            result := V;
          Exit;
        end;
    end;

    result := P.Value;
  end;
end;

procedure TDelphiObject.PutProperty(const PropertyName: String; const Value: TVariant);
var
  PropInfo: PPropInfo;
  I: Integer;
  PropDef: TPropDef;
  EventHandler: TEventHandler;
  M: TMethod;
  SO: TFunctionObject;
  pti: PTypeInfo;
  ptd: PTypeData;
  EnumName, S: String;
  SA: TScriptObject;
  L, EnumValue, Data: Integer;
  EnumInfo: PTypeInfo;
  P: TProperty;
begin
  P := Get(PropertyName);
  if P = nil then
  begin
    if Assigned(TJScript(PScript).fOnPutExtraProperty) then
      TJScript(PScript).fOnPutExtraProperty(
        TJScript(PScript).Owner, Instance, PropertyName, Value);
    Exit;
  end;

  pti := PTypeInfo(Instance.ClassType.ClassInfo);

  if pti = nil then
    PropInfo := nil
  else
    PropInfo := GetPropInfo(pti, PropertyName);

  if PropInfo <> nil then
    case PropInfo.PropType^^.Kind of
      tkInteger, tkChar, tkWChar:
        SetOrdProp(Instance, PropInfo, Value);
      tkClass: begin
        SetOrdProp(Instance, PropInfo, Integer(ToDelphiObject(Value)));
      end;
      tkEnumeration:
      begin