dxjs_object.pas

Well known and usefull component for delphi 7

        pti := PropInfo.PropType^;
        ptd := GetTypeData(pti);
        S := DXJS_CONV.ToString(Value);
        with ptd^ do
          for I:= MinValue to MaxValue do
          begin
            EnumName := GetEnumName(pti, I);
            if StrEql(S, EnumName) then
            begin
              SetOrdProp(Instance, PropInfo, I);
              Break;
            end;
          end;
      end;
      tkSet:
      begin
        EnumInfo := GetTypeData(PropInfo^.PropType^)^.CompType^;
        Data := 0;
        SA := VariantToScriptObject(Value);
        L := ToInteger(SA.GetProperty('length'));
        for I:=0 to L - 1 do
        begin
          EnumName := DXJS_CONV.ToString(SA.GetProperty(IntegerToString(I)));
          EnumValue := GetEnumValue(EnumInfo, EnumName);
          if EnumValue < 0 then
            raise TScriptFailure.Create(reIncompatibleTypes);
          Include(TIntegerSet(Data), EnumValue);
        end;
        SetOrdProp(Instance, PropInfo, Data);
      end;
      tkFloat:
        SetFloatProp(Instance, PropInfo, Value);
      tkString, tkLString, tkWString:
        SetStrProp(Instance, PropInfo, ToStr(Value));
      tkVariant:
        SetVariantProp(Instance, PropInfo, Value);
      tkMethod:
      begin
        SO := TFunctionObject(VariantToScriptObject(Value));
        EventHandler := TEventHandler.Create(PScript, PropInfo.PropType^, SO.SubID);
        M.Code := @TEventHandler.HandleEvent;
        M.Data := Pointer(EventHandler);
        TJScript(PScript).EventHandlerList.Add(Pointer(EventHandler));
        SetMethodProp(Instance, PropInfo, M);

        EventHandler.DelphiInstance := Instance;
        EventHandler.PropInfo := PropInfo;
      end;
    end
  else
  begin
    with TJScript(PScript) do
    for I:=0 to PropDefList.Count - 1 do
    if StrEql(PropDefList[I], PropertyName) then
    begin
      PropDef := TPropDef(PropDefList.Objects[I]);
      if PropDef.WriteAddr <> nil then
        if Instance.InheritsFrom(PropDef.AClass) then
        begin
          TDelphiMethod(PropDef.WriteAddr)(Instance, [Value]);
          Exit;
        end;
    end;
    inherited;
  end;
end;

// March 2004
constructor TEnumeratorObject.Create(const AValue: TVariant; AScript: Pointer);
Var
   SO:TScriptObject;

begin
   inherited Create('Enumerator', AScript);
   Prototype := TJScript(AScript).GlobalObject.EnumeratorPrototype;
   DefaultValue := aValue;
   Put('prototype', ScriptObjectToVariant(Prototype), [DontEnum, DontDelete]);
   ValueProp := AValue;
   CallAddr := @__EnumeratorObject;
   If VarType(ValueProp)=varScriptObject then Begin
      SO := VariantToScriptObject(ValueProp);
      If StrEql (SO.ClassProp,'ActiveX') then Begin
         ItemCount:=TActiveXObject(SO).GetProperty('Count');
      End
      Else If StrEql (SO.ClassProp,'DelphiObject') then Begin
         ItemCount:=TDelphiObject(SO).GetProperty('Count');
      End
      Else If StrEql (SO.ClassProp,'Array') then Begin
        ItemCount:=TArrayObject(SO).GetProperty('length');
      End;
   End
   Else Begin
      ItemCount:=0;
   End;
   ItemIndex:=0;
   Put('length', ItemCount, [DontEnum]);
end;

procedure TEnumeratorObject.MoveFirst;
begin
   ItemIndex := 0;
end;

procedure TEnumeratorObject.MoveNext;
begin
   Inc(ItemIndex);
end;

function TEnumeratorObject.Item: TVariant;
Var
   SO:TScriptObject;

begin
   If VarType(ValueProp)=varScriptObject then Begin
      SO := VariantToScriptObject(ValueProp);
      If StrEql (SO.ClassProp,'ActiveX') then Begin
         Result:=TActiveXObject(SO).GetArrayProperty('Item',ItemIndex);
      End
      Else If StrEql (SO.ClassProp,'DelphiObject') then Begin
//         ItemCount:=TDelphiObject(SO).GetProperty('Count');
      End
      Else If StrEql (SO.ClassProp,'Array') then Begin
        Result:=TArrayObject(SO).GetProperty(IntegerToString(ItemIndex));
      End;
   End
   Else Begin
      Result:=Undefined;
   End;
end;

function TEnumeratorObject.AtEnd: Boolean;
begin
   Result:=ItemIndex>=ItemCount;
end;

constructor TEventHandler.Create(PScript: Pointer; pti: PTypeInfo; SubID: Integer);
type
  TParamData = record
    Flags: TParamFlags;
    ParamName, TypeName: ShortString;
  end;
  PParamData = ^TParamData;

var
  ptd: PTypeData;
  PParam: PParamData;
  PTypeString: ^ShortString;
  Loop: Integer;

begin
  inherited Create;
  Self.SubID := SubID;
  Self.PScript := PScript;
  ptd := GetTypeData(pti);
  ParamCount := ptd^.ParamCount;
  SetLength(Parameters, ParamCount);
  ParamTypes := TStringList.Create;
  PParam := PParamData(@(ptd^.ParamList));
  for Loop:=0 to ParamCount - 1 do begin
    PTypeString := ShiftPointer(PParam, SizeOf(TParamFlags) + Length(PParam^.ParamName) + 1);
    ParamTypes.Add(PTypeString^);
    PParam := ShiftPointer(PTypeString, Length(PTypeString^) + 1);
  end;
end;

destructor TEventHandler.Destroy;
begin
  SetLength(Parameters, 0);
  ParamTypes.Free;
  inherited Destroy;
end;

function SetToStringList(Val: Integer; pti: PTypeInfo): TStringList;
var
  S: TIntegerSet;
  TypeInfo: PTypeInfo;
  Loop: Integer;

begin
  result := TStringList.Create;
  Integer(S) := Val;
  TypeInfo := GetTypeData(pti)^.CompType^;
  for Loop := 0 to SizeOf(Integer) * 8 - 1 do
    if Loop in S then result.Add(GetEnumName(TypeInfo, Loop));
end;

procedure TEventHandler.Invoke;

procedure Adjust(var Val: Integer);
type
  T = array[1..4] of Byte;
begin
  T(Val)[2] := 0;
  T(Val)[3] := 0;
  T(Val)[4] := 0;
end;

var
  I, J, Index: Integer;
  S: String;
  R: Variant;
  pti: PTypeInfo;
  ptd: PTypeData;
  SZ: Integer;
  L: TStringList;
  SO: TArrayObject;
begin
  SZ := 4;
  J := _EDX;
  
  RetSize := 0;
  if ParamCount > 2 then
  case ParamCount - 2 of
    1: RetSize := 4;
    2: RetSize := 8;
    3: RetSize := 12;
  end;

  _P := ShiftPointer(_P, SZ*(ParamCount - 2));
  for I:=0 to ParamCount - 1 do
  begin
    case I of
      0: J := _EDX;
      1: J := _ECX;
    else
      begin
        J := Integer(_P^);
        _P := ShiftPointer(_P, -SZ);
        SZ := 4;
      end;
    end;

    S := ParamTypes[I];
    Index := RTTITypeList.IndexOf(S);
    if Index <> -1 then
    begin
      pti := PTypeInfo(RTTITypeList.Objects[Index]);
      case pti^.Kind of
        tkClass:
          Parameters[I] := ScriptObjectToVariant(TDelphiObject.Create(TObject(J), PScript));
        tkEnumeration:
          begin
            Adjust(J);
            ptd := GetTypeData(pti);
            if ptd^.BaseType^ = TypeInfo(Boolean) then
            begin
              if J = 0 then
                Parameters[I] := false
              else
                Parameters[I] := true;
            end
            else
              Parameters[I] := GetEnumName(pti, J);
          end;
        tkSet:
          begin
            Adjust(J);
            L := SetToStringList(J, pti);
            SO:= TArrayObject.Create(PScript);
            for J:=0 to L.Count - 1 do
              SO.PutProperty(IntegerToString(J), L[J]);
            SO.PutProperty('length', L.Count);
            Parameters[I] := ScriptObjectToVariant(SO);
            L.Free;
            SZ := 4;
          end;
        else // case
          Parameters[I] := J;
      end; // case
    end
      else
      begin
        if StrEql(ParamTypes[I], 'String') then
        begin
          Parameters[I] := String(PChar(J));
        end
        else
          Parameters[I] := J;
      end;
  end;

  R := TJScript(PScript).CallFunction(SubID, Parameters);
end;

procedure TEventHandler.HandleEvent;
const
  LocalFrameSize = 16;
asm
  mov dword ptr Self._EDX, edx
  mov dword ptr Self._ECX, ecx
  mov dword ptr Self._P, esp
  push ebp
  mov ebp, esp
  sub esp, LocalFrameSize
  mov [ebp-12], ecx
  mov [ebp- 8], edx
  mov [ebp- 4], eax
  push eax
  call Invoke
  pop eax
  mov ecx, Self.RetSize
  mov esp, ebp
  pop ebp
  cmp ecx, 0
  jnz @@Ret4
  ret
@@Ret4:
  cmp ecx, 4
  jnz @@Ret8
  ret 4
@@Ret8:
  cmp ecx, 8
  jnz @@Ret12
  ret 8
@@Ret12:
  ret $0c
end;

destructor TEventHandlerList.Destroy;
begin
  ClearHandlers;
  inherited;
end;

procedure TEventHandlerList.ClearHandlers;
var
  Loop: Integer;
  M: TMethod;
  H: TEventHandler;
begin
  M.Code := nil;
  M.Data := nil;
  for Loop:=0 to Count - 1 do begin
    H := TEventHandler(Items[Loop]);
    SetMethodProp(H.DelphiInstance, H.PropInfo, M);
    H.Free;
  end;
  Clear;
end;

procedure SetValueToScriptObject(const This, Value: Variant);
begin
  VariantToScriptObject(This).DefaultValue:=Value;
end;

constructor TRegExpObject.Create(const ARegExpr, Flags: String; AScript: Pointer);
begin
  inherited Create('RegExp', AScript);
  Prototype := TJScript(AScript).GlobalObject.RegExpPrototype;
  DefaultValue := ARegExpr;
  Put('prototype', ScriptObjectToVariant(Prototype), [DontEnum, DontDelete]);
  Put('source', ARegExpr, [DontEnum, ReadOnly, DontDelete]);
  Put('global', DXString.CharPos('g', Flags) > 0, [DontEnum, ReadOnly, DontDelete]);
  Put('ignoreCase', DXString.CharPos('i', Flags) > 0, [DontEnum, ReadOnly, DontDelete]);
  Put('multiline', DXString.CharPos('m', Flags) > 0, [DontEnum, ReadOnly, DontDelete]);
  Put('lastIndex', 0, [DontEnum, DontDelete]);
  CallAddr := @__RegExp;
end;

function TRegExpObject.Exec(const S: String): TVariant;
var
  R: TRegExpr;
  SO: TArrayObject;
  Loop: Integer;
  MatchPos, MatchLen: Integer;

begin
  R := TRegExpr.Create;
  R.ModifierG := ToBoolean(GetProperty('global'));
  R.ModifierI := ToBoolean(GetProperty('ignoreCase'));
  R.ModifierM := ToBoolean(GetProperty('multiline'));
  try
    R.Expression := DefaultValue;
    R.InputString := S;
    MatchPos := ToInteger(GetProperty('lastIndex'));
    if TJScript(PScript).ZeroBasedStringIndex then Inc(MatchPos);
    if MatchPos > Length(S) then begin
      PutProperty('LastIndex', 0);
      result := Null;
      Exit;
    end;
    if R.ExecPos(MatchPos) then begin
      SO := TArrayObject.Create(PScript);
      SO.PutProperty('length', R.SubExprMatchCount);
      for Loop:=0 to R.SubExprMatchCount do begin
        SO.PutProperty(IntegerToString(Loop), R.Match[Loop]);
        MatchPos := R.MatchPos[Loop];
        MatchLen := R.MatchLen[Loop];
        if Loop = 0 then begin
          if TJScript(PScript).ZeroBasedStringIndex then Dec(MatchPos);
          with TJScript(PScript).GlobalObject.RegExpObject do begin
            PutProperty('index', MatchPos);
            PutProperty('LastIndex', MatchPos + MatchLen);
            PutProperty('input', S);
          end;
          PutProperty('LastIndex', MatchPos + MatchLen);
        end;
      end;
      result := ScriptObjectToVariant(SO);
    end
    else result := Null;
  finally
    R.Free;
  end;
end;

constructor TErrorObject.Create(AScript: Pointer);
begin
  inherited Create('Error', AScript);
  Prototype := TJScript(AScript).GlobalObject.ErrorPrototype;
  Put('prototype', ScriptObjectToVariant(Prototype), [DontEnum, DontDelete]);
  Put('description', Undefined);
  CallAddr := @__Error;
end;

function TErrorObject.GetDefaultValue: TVariant;
begin
  result := GetProperty('description');
end;

destructor TGarbage.Destroy;
var
  Loop: Integer;
begin
  for Loop:=0 to Count - 1 do TScriptObject(Items[Loop]).Free;
  inherited;
end;

constructor TActiveXObject.Create(const AValue: TVariant; AScript: Pointer);
begin
  inherited Create('ActiveX', AScript);
  ValueProp := AValue;
  CallAddr := @__ActiveXObject;
end;

function TActiveXObject.GetProperty(const PropertyName: String): TVariant;
var
  V: TVariant;
begin
  V := DispCall(ValueProp, PropertyName, []);
  if VarType(V) = varDispatch then
    result := ScriptObjectToVariant(TActiveXObject.Create(V, PScript))
  else result := V;
end;

procedure TActiveXObject.PutProperty(const PropertyName: String; const Value: TVariant);
var
  V: Variant;
begin
  if VarType(Value) = varBoolean then begin
    if Value then V := Integer(1)
    else V := Integer(0);
  end
  else V := Value;
  DispPutProp(ValueProp, PropertyName, [V]);
end;

function TActiveXObject.GetArrayProperty(const PropertyName: String;
Index: Integer): TVariant;
var
  V: TVariant;
begin
  V := DispCall(ValueProp, PropertyName, [index]);
  if VarType(V) = varDispatch then
    result := ScriptObjectToVariant(TActiveXObject.Create(V, PScript))
  else result := V;
end;


function IsDate(const V: TVariant): Boolean;
begin
  if not IsObject(V) then result := VarType(V) = varDate
  Else result := StrEql(VariantToscriptObject(V).ClassProp, 'Date');
end;

end.