dxjs_object.pas

Well known and usefull component for delphi 7

////////////////////////////////////////////////////////////////////////////
//    Component: DXJS_OBJECT
//       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: Objects/Definitions used by the RTTI/Intepreter.
// ========================================================================
////////////////////////////////////////////////////////////////////////////

unit DXJS_OBJECT;
interface
{$I DXJavaScript.def}

uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  Classes,
  TypInfo,
  RegExpr,
  DXJS_SHARE,
  DXJS_EXTERN,
  DXJS_DISP;

type
  TAttribute = (ReadOnly, DontEnum, DontDelete, Internal);
  TAttributeSet = set of TAttribute;

  TScriptObject = class;

  TProperty = class
    Value: TVariant;
    AttributeSet: TAttributeSet;
    constructor Create(const AValue: TVariant; AnAttributeSet: TAttributeSet);
  end;

  TPropertyList = class(TStringList)
  private
    fCaseSensitive: boolean;
  public
    constructor Create;
    function IndexOf(const S: string): Integer; override;
    destructor Destroy; override;
  end;

  TScriptObject = class
  private
    PropertyList: TPropertyList;
  public
    PScript: Pointer;
    Prototype: TScriptObject;
    ClassProp: String;
    ValueProp: TVariant;
    SubID: Integer;
    CallAddr: Pointer;
    KindProc: TKindProc;
  protected
    function GetDefaultValue: TVariant; virtual;
    procedure SetDefaultValue(const AValue: TVariant);
  public
    constructor Create(const AClassName: String; AScript: Pointer);
    destructor Destroy; override;
    function GetPropertyName(Index: Integer): String;
    function Get(const PropertyName: String): TProperty;
    procedure Put(const PropertyName: String; Value: TVariant; AttrSet: TAttributeSet = []);
    function CanPut(const PropertyName: String): boolean;
    function HasProperty(const PropertyName: String): boolean;
    function Delete(const PropertyName: String): boolean;
    property DefaultValue: TVariant read GetDefaultValue write SetDefaultValue;
    function GetProperty(const PropertyName: String): TVariant; virtual;
    procedure PutProperty(const PropertyName: String; const Value: TVariant); virtual;
    function ToString: String; virtual;
  end;

  TObjectObject = class(TScriptObject)
    constructor Create(AScript: Pointer);
  end;

  TNumberObject = class(TScriptObject)
    constructor Create(const AValue: Variant; AScript: Pointer);
  end;

  TBooleanObject = class(TScriptObject)
    constructor Create(const AValue: Variant; AScript: Pointer);
  end;

  TStringObject = class(TScriptObject)
    constructor Create(const AValue: Variant; AScript: Pointer);
    function GetProperty(const PropertyName: String): TVariant; override;
    procedure PutProperty(const PropertyName: String; const Value: TVariant); override;
    function Match(const RegExp: TVariant): TVariant;
    function Replace(const RegExp: TVariant; const ReplaceStr: String): TVariant;
  end;

  TDateObject = class(TScriptObject)
    constructor Create(const AValue: Variant; AScript: Pointer);
    function GetDefaultValue: TVariant; override;
  end;

  TMathObject = class(TScriptObject)
    constructor Create(AScript: Pointer);
  end;

  TFunctionObject = class(TScriptObject)
    constructor Create(const AValue: TVariant;
                       SubID: Integer;
                       Address: Pointer; Len: Integer; AScript: Pointer);
  end;

  TArrayObject = class(TScriptObject)
  protected
    function GetDefaultValue: TVariant; override;
  public
    constructor Create(AScript: Pointer);
    procedure PutProperty(const PropertyName: String; const Value: TVariant); override;
  end;

  TArgumentsObject = TArrayObject;

  TDelphiObject = class(TScriptObject)
    Instance: TObject;
    constructor Create(const AnInstance: TObject; AScript: Pointer);
    function GetProperty(const PropertyName: String): TVariant; override;
    procedure PutProperty(const PropertyName: String; const Value: TVariant); override;
  end;

// March 2004
  TEnumeratorObject = class(TScriptObject)
    ItemIndex: Integer;
    ItemCount: Integer;
    constructor Create(const AValue: TVariant; AScript: Pointer);
    procedure MoveFirst;
    procedure MoveNext;
    function Item: TVariant;
    function AtEnd: Boolean;
  end;

  TRegExpObject = class(TScriptObject)
    constructor Create(const ARegExpr, Flags: String; AScript: Pointer);
    function Exec(const S: String): TVariant;
  end;

  TErrorObject = class(TScriptObject)
  protected
    function GetDefaultValue: TVariant; override;
  public
    constructor Create(AScript: Pointer);
  end;

  TActiveXObject = class(TScriptObject)
    constructor Create(const AValue:TVariant;AScript:Pointer);
    function GetProperty(const PropertyName:String): TVariant; override;
    procedure PutProperty(const PropertyName:String;const Value:TVariant); override;
    function GetArrayProperty(const PropertyName:String;Index:Integer): TVariant;
  end;

  TGlobalObject = class(TScriptObject)
    ObjectPrototype: TObjectObject;
    StringPrototype: TStringObject;
    BooleanPrototype: TBooleanObject;
    DatePrototype: TDateObject;
    NumberPrototype: TNumberObject;
    ArrayPrototype: TArrayObject;
    FunctionPrototype: TFunctionObject;
    RegExpPrototype: TRegExpObject;
    ErrorPrototype: TErrorObject;
    RegExpObject: TRegExpObject;
    DateObject: TDateObject;
    EnumeratorPrototype: TEnumeratorObject;
    constructor Create(AScript: Pointer);
    procedure CreatePrototypes;
  end;

  TGarbage = class(TList)
    destructor Destroy; override;
  end;

  TEventHandler = class
    PScript: Pointer;
    SubID: Integer;
    ParamCount: Integer;
    Parameters: array of Variant;
    ParamTypes: TStringList;
    _EDX, _ECX: Integer;
    _P: Pointer;
    RetSize: Integer;
    PropInfo: PPropInfo;
    DelphiInstance: TObject;
    constructor Create(PScript: Pointer; pti: PTypeInfo; SubID: Integer);
    destructor Destroy; override;
    procedure Invoke;
    procedure HandleEvent;
  end;

 TEventHandlerList = class(TList)
   destructor Destroy; override;
   procedure ClearHandlers;
 end;

procedure SetValueToScriptObject(const This, Value: Variant);
function GetPublishedProperties(AClass: TClass): TStringList;
function IsDate(const V: TVariant): Boolean;

implementation

uses
  DXString, // from DXFreeware
  SysUtils,
  DXJS_MAIN,
  DXJS_SYMBOL,
  DXJS_CONV;

constructor TProperty.Create(const AValue: TVariant; AnAttributeSet: TAttributeSet);
begin
  inherited Create;
  Value := AValue;
  AttributeSet := AnAttributeSet;
end;

constructor TPropertyList.Create;
begin
  inherited;
  Sorted := true;
  Duplicates := dupIgnore;
  fCaseSensitive := true;
end;

destructor TPropertyList.Destroy;
var
  P: TProperty;
  Loop: Integer;

begin
  for Loop:=0 to Count - 1 do begin
    P := TProperty(Objects[Loop]);
    P.Free;
  end;
  inherited;
end;

function TPropertyList.IndexOf(const S: string): Integer;
var
  Loop: Integer;

begin
// !! June 2004 - see if we can improve this!
  if fCaseSensitive then result := inherited IndexOf(S)
  else begin
    result := -1;
    for Loop:=0 to Count - 1 do
      if StrEql(S, Strings[Loop]) then begin
        result := Loop;
        Exit;
      end;
  end;
end;

constructor TScriptObject.Create(const AClassName: String; AScript: Pointer);
begin
  inherited Create;
  ClassProp := AClassName;
  Prototype := nil;
  PropertyList := TPropertyList.Create;
  CallAddr := nil;
  KindProc := KindJavaScript;
  PScript := AScript;
  if PScript <> nil then TJScript(PScript).Garbage.Add(Self)
end;

destructor TScriptObject.Destroy;
begin
  PropertyList.Free;
  inherited Destroy;
end;

function TScriptObject.GetPropertyName(Index: Integer): String;
var
  Loop, K: Integer;
  PropList: TPropertyList;
  P: TProperty;
  CurrObj: TScriptObject;
  Fin: Boolean; //715
begin
  Fin := false; //715
  result := '';
  K := -1;
  CurrObj := Self;
  repeat
    PropList := CurrObj.PropertyList;
    for Loop:=0 to PropList.Count - 1 do begin
      P := TProperty(PropList.Objects[Loop]);
      if not (DontEnum in P.AttributeSet) then Inc(K);
      if K = Index then begin
        result := PropList[Loop];
        Exit;
      end;
    end;
    //715 next set of code:
    if Fin then Exit;
    if Prototype <> nil then begin
      CurrObj := Prototype;
      Fin := true;
    end
    else Exit;
  until false;
end;

function TScriptObject.Get(const PropertyName: String): TProperty;
var
  I: Integer;
begin
  I := PropertyList.IndexOf(PropertyName);
  if I >= 0 then begin
    result := TProperty(PropertyList.Objects[I]);
    Exit;
  end;
  if Prototype = nil then result := nil
  else result := Prototype.Get(PropertyName);
end;

function TScriptObject.CanPut(const PropertyName: String): boolean;
var
  P: TProperty;
begin
  P := Get(PropertyName);
  if P = nil then Result:=False
  Else result := not (ReadOnly in P.AttributeSet);
end;

procedure TScriptObject.Put(const PropertyName: String; Value: TVariant;
                            AttrSet: TAttributeSet = []);
var
  P: TProperty;
  I: Integer;
begin
  I := PropertyList.IndexOf(PropertyName);
  if I >= 0 then begin
    P := TProperty(PropertyList.Objects[I]);
    if not (ReadOnly in P.AttributeSet) then P.Value := Value;
    Exit;
  end;
  P := TProperty.Create(Value, AttrSet);
  PropertyList.AddObject(PropertyName, P);
end;

function TScriptObject.GetDefaultValue: TVariant;
begin
  result := ValueProp;
end;

procedure TScriptObject.SetDefaultValue(const AValue: TVariant);
begin
  ValueProp := AValue;
end;

function TScriptObject.HasProperty(const PropertyName: String): boolean;
begin
  result := PropertyList.IndexOf(PropertyName) <> -1;
  if result or (Prototype = nil) then Exit;
  result := Prototype.HasProperty(PropertyName);
end;

function TScriptObject.Delete(const PropertyName: String): boolean;
var
  I: Integer;
  P: TProperty;

begin
  result := true;
  I := PropertyList.IndexOf(PropertyName);
  if I >= 0 then begin
    P := TProperty(PropertyList.Objects[I]);
    if DontDelete in P.AttributeSet then begin
      result := false;
      Exit;
    end;
    P.Free;
    PropertyList.Delete(I);
    Exit;
  end;
  if Prototype <> nil then result := Prototype.Delete(PropertyName);
end;

function TScriptObject.GetProperty(const PropertyName: String): TVariant;
begin
  if not HasProperty(PropertyName) then Result := Undefined
  Else Result:=Get(PropertyName).Value;
end;

procedure TScriptObject.PutProperty(const PropertyName: String; const Value: TVariant);
begin
  Put(PropertyName, Value);
end;

function TScriptObject.ToString: String;
begin
  result := VariantToString(DefaultValue);
end;

constructor TGlobalObject.Create(AScript: Pointer);
begin
  inherited Create('Global', AScript);
  Prototype := nil;
end;

procedure TGlobalObject.CreatePrototypes;
Var
   Ws:String;

begin
   Ws:=FormatDateTime ('ddd mmm d h:nn:ss @ yyyy',SysUtils.Now) ;
   Ws:=StringReplace (Ws,'@',DXString.ShortTimeZone, []) ;
  ObjectPrototype := TObjectObject.Create(PScript);
  StringPrototype := TStringObject.Create('', PScript);
  BooleanPrototype := TBooleanObject.Create(false, PScript);
  DatePrototype := TDateObject.Create(Ws,PScript);
//  DatePrototype := TDateObject.Create(SysUtils.Now, PScript); Sept 24
  NumberPrototype := TNumberObject.Create(Integer(0), PScript);
  ArrayPrototype := TArrayObject.Create(PScript);
  FunctionPrototype := TFunctionObject.Create(Undefined, 0, nil, 0, PScript);
  RegExpPrototype := TRegExpObject.Create('', '', PScript);
  ErrorPrototype := TErrorObject.Create(PScript);
  RegExpObject := TRegExpObject.Create('', '', PScript);
  DateObject := TDateObject.Create(Ws,PScript);
//  DateObject := TDateObject.Create(Now, PScript); Sept 24
  EnumeratorPrototype := TEnumeratorObject.Create(Undefined, PScript);
end;

constructor TObjectObject.Create(AScript: Pointer);
begin
  inherited Create('Object', AScript);
  Prototype := TJScript(AScript).GlobalObject.ObjectPrototype;
  // 713 added:
  Put('prototype', ScriptObjectToVariant(Prototype), [DontEnum, DontDelete]);
end;

constructor TBooleanObject.Create(const AValue: TVariant; AScript: Pointer);
begin
  inherited Create('Boolean', AScript);
  Prototype := TJScript(AScript).GlobalObject.BooleanPrototype;
  DefaultValue := ToBoolean(AValue);
  Put('prototype', ScriptObjectToVariant(Prototype), [DontEnum, DontDelete]);
  CallAddr := @__Boolean;
end;

constructor TDateObject.Create(const AValue: TVariant; AScript: Pointer);
begin
  inherited Create('Date', AScript);
  Prototype := TJScript(AScript).GlobalObject.DatePrototype;
  DefaultValue := AValue;
  Put('prototype', ScriptObjectToVariant(Prototype), [DontEnum, DontDelete]);
  CallAddr := @__Date;
end;

function TDateObject.GetDefaultValue: TVariant;
{Var
   Ws:String;}

begin
  if Self = TJScript(PScript).GlobalObject.DateObject then Begin
     Self.ValueProp:=FormatDateTime ('ddd mmm d h:nn:ss @ yyyy',SysUtils.Now) ;
     Self.ValueProp:=StringReplace (Self.ValueProp,'@',DXString.ShortTimeZone, []) ;