imp_javascript.pas

来自「Delphi脚本控件」· PAS 代码 · 共 2,672 行 · 第 1/5 页

////////////////////////////////////////////////////////////////////////////
// PAXScript Importing
// Author: Alexander Baranovsky ([e-mail])
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2003-2005. All rights reserved.
// Code Version: 3.0
// ========================================================================
// Unit: IMP_JAVASCRIPT.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////
{$I PaxScript.def}
unit IMP_JavaScript;
interface
uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  SysUtils,
  Classes,
  Math,
  RegExpr1,
  BASE_SYS,
  BASE_CLASS,
  BASE_PARSER,
  BASE_EXTERN,
  BASE_REGEXP,
  BASE_SCRIPTER,
  PAX_JAVASCRIPT,
  PaxScripter;

const
  paxJavaScriptNamespace = 'paxJavaScriptNamespace';

type
  TPAXJavaScriptArrayObject = class;

  TPAXJavaScriptObject = class(TPAXScriptObject)
  private
    fDefaultValue: Variant;
    PrototypeNameIndex: Integer;
  public
    constructor Create(ClassRec: TPAXClassRec); override;
    function SafeGet(PropertyNameIndex: Integer): TPAXProperty; override;
    function GetProperty(PropertyNameIndex: Integer): Variant; reintroduce; virtual;
    procedure SetProperty(PropertyNameIndex: Integer;
                          const Value: Variant);
    function DefaultValue: Variant; override;
    procedure SetDefaultValue(const V: Variant); override;
  end;

  TPAXJavaScriptDateObject = class(TPAXJavaScriptObject)
    function DelphiDate: TDateTime;
    function UTCDelphiDate: TDateTime;
    procedure SetDelphiDate(D: TDateTime);
  public
    function ToString: String; override;
  end;

  TPAXJavaScriptFunctionObject = class(TPAXJavaScriptObject)
  end;

  TPAXJavaScriptBooleanObject = class(TPAXJavaScriptObject)
  end;

  TPAXJavaScriptStringObject = class(TPAXJavaScriptObject)
    function Match(R: RegExp): TPaxJavaScriptArrayObject;
    function Replace(R: RegExp; const ReplaceStr: String): String;
  end;

  TPAXJavaScriptNumberObject = class(TPAXJavaScriptObject)
  end;

  TPAXJavaScriptArrayObject = class(TPAXJavaScriptObject)
  private
    PaxArray: TPaxArray;
    procedure PutItem(I: Integer; const Value: Variant);
    function GetItem(I: Integer): Variant;
    function GetLength: Integer;
    procedure SetLength(Value: Integer);
  public
    constructor Create(ClassRec: TPAXClassRec); override;
    destructor Destroy; override;
    function ToString: String; override;
    function DefaultValue: Variant; override;
    function ExtraInstance: TObject; override;
    property Items[I: Integer]: Variant read GetItem write PutItem; default;
    property Length: Integer read GetLength write SetLength;
  end;

function Eval(const SourceCode: String;
              Scripter: TPAXBaseScripter;
              Parser: TPAXParser): Variant;

implementation

constructor TPAXJavaScriptObject.Create(ClassRec: TPAXClassRec);
var
  V: Variant;
begin
  inherited;
  fDefaultValue := Undefined;
  PrototypeNameIndex := TPAXBaseScripter(ClassRec.Scripter).PrototypeNameIndex;
  V := TPAXBaseScripter(ClassRec.Scripter).SymbolTable.GetVariant(ClassRec.ClassId);
  SetProperty(TPAXBaseScripter(ClassRec.Scripter).ConstructorNameIndex, V);
  Instance := Self;
end;

function TPAXJavaScriptObject.DefaultValue: Variant;
begin
  result := fDefaultValue;
end;

procedure TPAXJavaScriptObject.SetDefaultValue(const V: Variant);
begin
  fDefaultValue := V;
end;

function TPAXJavaScriptObject.SafeGet(PropertyNameIndex: Integer): TPAXProperty;
var
  SO: TPAXScriptObject;
  V: Variant;
begin
  SO := Self;
  repeat
    result := SO.PropertyList.FindProperty(PropertyNameIndex);
    if result <> nil then
      Exit;
    result := SO.PropertyList.FindProperty(PrototypeNameIndex);
    if result = nil then
    begin
      with TPaxBaseScripter(SO.Scripter) do
      begin
        V := SymbolTable.GetVariant(SO.ClassRec.ClassID + 2);
        if IsObject(V) then
        begin
          SO := VariantToScriptObject(V);
          result := SO.PropertyList.FindProperty(PropertyNameIndex);
          if result = nil then
            Exit;
        end;
      end;

      Exit;
    end;
    V := result.Value[0];
    if not IsObject(V) then
    begin
      result := nil;
      Exit;
    end;
    SO := VariantToScriptObject(V);
  until false;
end;

function TPAXJavaScriptObject.GetProperty(PropertyNameIndex: Integer): Variant;
var
  P: TPAXProperty;
begin
  P := SafeGet(PropertyNameIndex);
  if P <> nil then
    result := P.Value[0];
end;

procedure TPAXJavaScriptObject.SetProperty(PropertyNameIndex: Integer;
                                           const Value: Variant);
var
  P: TPAXProperty;
begin

  P := SafeGet(PropertyNameIndex);
  if P = nil then
  begin
    P := TPAXProperty.Create(Self, @Value, nil);
    PropertyList.AddObject(PropertyNameIndex, P);
  end
  else
    P.Value[0] := Value;
end;

/////////////// GLOBAL //////////////////////////////////


function Eval(const SourceCode: String;
              Scripter: TPAXBaseScripter;
              Parser: TPAXParser): Variant;

procedure CopyLevelStack;
var
  I, ID, L: Integer;
begin
  Parser.LevelStack.Clear;
  Parser.LevelStack.Push(0);

  with Scripter do
  for I:= 1 to Code.LevelStack.Card do
  begin
    ID := Code.LevelStack[I];
    if ID > 0 then
    begin
      L := SymbolTable.Level[ID];
      if SymbolTable.Kind[L] = KindTYPE then
        Parser.LevelStack.Push(L);
      Parser.LevelStack.Push(ID);
    end;
  end;

  if Parser.LevelStack.Card = 1 then
    Parser.LevelStack.Push(Scripter.SymbolTable.RootNamespaceID);
end;

var
  StartPos, TempCodeCard, TempSymbolCard, TempClassCount: Integer;
  Success: Boolean;
begin
  with Scripter do
  begin
    TempCodeCard := Code.Card;
    TempSymbolCard := SymbolTable.Card;
    TempClassCount := ClassList.Count;

    Code.SaveState;

    Inc(EvalCount);
    StartPos := Code.Card;

    Success := true;
    Parser.Scanner.SourceCode := SourceCode + ';';

    CopyLevelStack;

    Parser.UsingList.CopyFrom(Code.UsingList);
    Parser.WithStack.CopyFrom(Code.WithStack);
    try
      with TPaxJavaScriptParser(Parser) do
      begin
        Call_SCANNER;
        Gen(OP_DECLARE_OFF, 0, 0, 0);
        Parse_SourceElements;
        Gen(OP_DECLARE_ON, 0, 0, 0);
        Gen(OP_HALT, 0, 0, 0);
      end;
    except
      Success := false;
    end;

    if Success then
    begin
      Code.LinkGoTo(TempCodeCard + 1, Code.Card);
      ClassList.CreateClassObjects(TempClassCount);
      ClassList.InitStaticFields(TempClassCount);
      SymbolTable.SetupSubs(TempSymbolCard + 1);

      Code.N := StartPos;
      Code.Terminated := false;
      Code.Run;

      result := Code.ResultValue;
    end;

    Dec(EvalCount);

    Code.RestoreState;
  end;
end;

var zz: Pointer;

procedure _eval(MethodBody: TPAXMethodBody);
var
  V: Variant;
  P: TPAXParser;
begin
  with MethodBody do
  begin
    zz := PSelf;

    V := Params[0].AsVariant;

    if VarType(V) <> varString then
    begin
      result.AsVariant := V;
      Exit;
    end;

    P := TPAXBaseScripter(Scripter).ParserList.FindParser('paxJavaScript');

    if P = nil then
      Exit;

    V := Eval(V, Scripter, P);

    result.AsVariant := V;
  end;
end;

procedure _parseInt(MethodBody: TPAXMethodBody);
var
  S:string;
 vErrPos: integer;
 vFloat: double;
begin
  with MethodBody do
    if ParamCount > 0 then
    begin
      S := ToString(Params[0].AsVariant);
      if S = 'NaN' then
        result.AsVariant := NaN
      else
       begin                           // s may be 123, 1.23, 1.2MB, or junk
        val(S, vFloat, vErrPos);       // try to convert the string to a number
        if vErrPos = 1 then            // bad from the start
          result.AsVariant := NaN      // set result to Not a Number
        else                           // some numbers at front of string
         begin
          if vErrPos > 1 then          // if we have at least one good number
           begin
            S := copy(S, 1, vErrPos-1); // copy the first numbers
            val(S, vFloat, vErrPos);   // convert the good part to a number
           end;
          S := FloatToStr(int(vFloat)); // convert integer part to a string
          result.AsVariant := StrToInt(S); // set result
         end;
       end;
    end;
end;

procedure _isNan(MethodBody: TPaxMethodBody);
var
 vPrm: double;
begin
 with MethodBody do
  begin
   if ParamCount > 0 then
    begin
     vPrm := ToNumber(Params[0].AsVariant);
      if vPrm = NaN then
        result.AsVariant := true
      else
        result.AsVariant := false;
    end;
  end;
end;

procedure _parseFloat(MethodBody: TPAXMethodBody);
var
  S:string;
begin
  with MethodBody do
    if ParamCount > 0 then
    begin
      S := ToString(Params[0].AsVariant);
      if S = 'NaN' then
        result.AsVariant := NaN
      else
        result.AsVariant := StrToFloat(S);
   end;
end;

procedure _memberCount(MethodBody: TPAXMethodBody);
var
  SO: TPaxScriptObject;
begin
  with MethodBody do
    begin
      SO := VariantToScriptObject(Params[0].AsVariant);
      result.AsVariant := SO.PropertyList.Count - 1;
   end;
end;

/////////////// OBJECT //////////////////////////////////

procedure _Object_New(MethodBody: TPAXMethodBody);
var
  SO: TPAXJavaScriptObject;
  ClassRec: TPAXClassRec;
begin
  with MethodBody do
  begin
    ClassRec := TPAXBaseScripter(Scripter).ClassList.ObjectClassRec;
    SO := TPAXJavaScriptObject.Create(ClassRec);
    Self := SO;
  end;
end;

procedure _Object_GetProperty(M: TPAXMethodBody);
var
  SO: TPAXJavaScriptObject;
  Index: Integer;
  P: TPaxProperty;
begin
  with M do
  begin
    SO := TPAXJavaScriptObject(Self);
    if SO.HasProperty(Name) then
      result.AsVariant := SO.GetProperty(CreateNameIndex(Name, SO.Scripter))
    else if IsDigits(Name) then
    begin
      Index := StrToInt(Name) + 1;
      P := SO.PropertyList.Properties[Index];
      result.AsVariant := P.Value[0];
    end
    else
      result.AsVariant := Undefined;

    PSelf := nil;
  end;
end;

procedure _Object_PutProperty(M: TPAXMethodBody);
var
  SO: TPAXJavaScriptObject;
begin
  with M do
  begin
    SO := TPAXJavaScriptObject(Self);
    SO.SetProperty(CreateNameIndex(Name, SO.Scripter), Params[0].AsVariant);
  end;
end;

procedure _Object_toString(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.AsVariant := ToString(DefaultValue);
end;

procedure _Object_valueOf(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.AsVariant := DefaultValue;
end;

/////////////// BOOLEAN //////////////////////////////////

procedure _Boolean_New(MethodBody: TPAXMethodBody);
var
  SO: TPAXJavaScriptBooleanObject;
  ClassRec: TPAXClassRec;
begin
  with MethodBody do
  begin
    ClassRec := TPAXBaseScripter(Scripter).ClassList.BooleanClassRec;
    SO := TPAXJavaScriptBooleanObject.Create(ClassRec);
    if ParamCount > 0 then
      SO.fDefaultValue := ToBoolean(Params[0].AsVariant)
    else
      SO.fDefaultValue := false;
    Self := SO;
  end;
end;

/////////////// DATE ////////////////////////////////////

function TPAXJavaScriptDateObject.DelphiDate: TDateTime;
begin
  result := EcmaTimeToDelphiDateTime(fDefaultValue);
end;

function TPAXJavaScriptDateObject.UTCDelphiDate: TDateTime;
var
  Diff: Integer;
begin
  Diff := Floor(GetGMTDifference);
  result := EcmaTimeToDelphiDateTime(fDefaultValue - MSecsPerHour * Diff);
end;

procedure TPAXJavaScriptDateObject.SetDelphiDate(D: TDateTime);
var
  Dbl: Double;
begin
  Dbl := DelphiDateTimeToEcmaTime(D);
  fDefaultValue := Dbl;
end;

function TPAXJavaScriptDateObject.ToString: String;
var
  SO: TPAXJavaScriptDateObject;
begin
  SO := TPAXJavaScriptDateObject(Self);
  result := ToStr(Scripter, SO.DelphiDate);
end;

procedure _Date_New(MethodBody: TPAXMethodBody);
var
  SO: TPAXJavaScriptDateObject;
  ClassRec: TPAXClassRec;
  Y,M,D: Word;
  R: Variant;
begin
  with MethodBody do
  begin
    ClassRec := TPAXBaseScripter(Scripter).ClassList.DateClassRec;
    SO := TPAXJavaScriptDateObject.Create(ClassRec);

    case ParamCount of
      1:
      begin
        R := EcmaTimeToDelphiDateTime(Params[0].AsVariant);
      end;
      3:
      begin
        Y := ToInt32(Params[0].AsVariant);
        M := ToInt32(Params[1].AsVariant)+1;
        D := ToInt32(Params[2].AsVariant);
        R := EncodeDate(Y,M,D);
      end
      else
        R := SysUtils.Now;
    end;

   SO.SetDelphiDate(R);
   Self := SO;

   Result.AsVariant := R;
  end;
end;

procedure _Date_toString(MethodBody: TPAXMethodBody);
var
  SO: TPAXJavaScriptDateObject;
begin
  with MethodBody do
  begin
    SO := TPAXJavaScriptDateObject(Self);
    result.AsVariant := ToString(SO.DelphiDate);
  end;
end;

procedure _Date_toGMTString(MethodBody: TPAXMethodBody);
var
  SO: TPAXJavaScriptDateObject;
begin
  with MethodBody do
  begin
    SO := TPAXJavaScriptDateObject(Self);
    result.AsVariant := ToString(SO.UTCDelphiDate);