imp_basic.pas

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

      begin
        V1 := Params[0].AsVariant;
        if VarType(V1) = varString then
        begin
          start := 1;
          V1 := Params[0].AsVariant;
          V2 := Params[1].AsVariant;
        end
        else
        begin
          start := Params[0].AsInteger;
          V1 := Params[1].AsVariant;
          V2 := Params[2].AsVariant;
        end;
      end;
      4:
      begin
        start := Params[0].AsInteger;
        V1 := Params[1].AsVariant;
        V2 := Params[2].AsVariant;
      end;
    end;

    if IsUndefined(V1) or IsUndefined(V2) then
    begin
      result.AsVariant := Undefined;
      Exit;
    end;
    S1 := ToString(V1);
    S2 := ToString(V2);

    if Length(S1) = 0 then
      result.AsInteger := 0
    else if Length(S2) = 0 then
      result.AsInteger := start
    else if start > Length(S1) then
      result.AsInteger := 0
    else
      result.AsInteger := Pos(S2, Copy(S1, start, Length(S1)));
  end;
end;

procedure _InStrRev(MethodBody: TPAXMethodBody);
var
  V1, V2: Variant;
  S1, S2: String;
  start, I: Integer;
begin
  start := 0;
  with MethodBody do
  begin
    case ParamCount of
      2:
      begin
        start := 0;
        V1 := Params[0].AsVariant;
        V2 := Params[1].AsVariant;
      end;
      3:
      begin
        V1 := Params[0].AsVariant;
        V2 := Params[1].AsVariant;
        start := Params[2].AsInteger;
      end;
      4:
      begin
        V1 := Params[0].AsVariant;
        V2 := Params[1].AsVariant;
        start := Params[2].AsInteger;
      end;
    end;

    if IsUndefined(V1) or IsUndefined(V2) then
    begin
      result.AsVariant := Undefined;
      Exit;
    end;

    S1 := ToString(V1);
    S2 := ToString(V2);

    if Length(S1) = 0 then
      result.AsInteger := 0
    else if Length(S2) = 0 then
      result.AsInteger := start
    else if start > Length(S1) then
      result.AsInteger := 0
    else if Length(S2) > Length(S1) then
      result.AsInteger := 0
    else if Length(S2) = Length(S1) then
    begin
      if S1 = S2 then
        result.AsInteger := 1
      else
        result.AsInteger := 0;
    end
    else
    begin
      if Start > 0 then
        S1 := Copy(S1, 1, Start);
      for I:= Length(S1) - Length(S2) + 1 downto 1 do
        if S2 = Copy(S1, I, Length(S2)) then
        begin
          result.AsInteger := I;
          Exit;
        end;
      result.AsInteger := 0;
    end;
  end;
end;

function vbInt(D: Double): Integer;
begin
  if D >= 0 then
    result := Trunc(D)
  else
  begin
    if Frac(D) <> 0.0 then
      result := Trunc(D) - 1
    else
      result := Trunc(D);
  end;
end;

procedure _Int(MethodBody: TPAXMethodBody);
var
  D: Double;
begin
  with MethodBody do
  begin
    D := ToNumber(Params[0].AsVariant);
    result.AsInteger := vbInt(D);
  end;
end;

procedure _Fix(MethodBody: TPAXMethodBody);
var
  D: Double;
begin
  with MethodBody do
  begin
    D := ToNumber(Params[0].AsVariant);
    if D >= 0 then
      result.AsInteger := vbInt(D)
    else
      result.AsInteger := -1 * vbInt(Abs(D));
  end;
end;

procedure _MsgBox(MethodBody: TPAXMethodBody);
var
  S: String;
begin
  with MethodBody do
  begin
    S := Params[0].AsString;
  end;

{$IFDEF CONSOLE}
  writeln(S);
  Exit;
{$ENDIF}

{$IFDEF WIN32}
  MessageBox(GetActiveWindow(), PChar(S), PChar('paxScript'), MB_OK);
{$ENDIF}

{$IFDEF LINUX}
  Application.MessageBox(PChar(S), 'paxScript', [smbOK]);
{$ENDIF}
end;

procedure _IsNull(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.AsBoolean := IsUndefined(Params[0].AsVariant);
end;

procedure _IsArray(MethodBody: TPAXMethodBody);
var
  V: Variant;
begin
  with MethodBody do
  begin
    V := Params[0].AsVariant;
    result.AsBoolean := IsVBArray(V) or IsPaxArray(V);
  end;
end;

procedure _IsObject(MethodBody: TPAXMethodBody);
var
  V: Variant;
begin
  with MethodBody do
  begin
    V := Params[0].AsVariant;
    result.AsBoolean := IsObject(V);
  end;
end;

procedure _IsDate(MethodBody: TPAXMethodBody);
var
  V: Variant;
begin
  with MethodBody do
  begin
    V := Params[0].AsVariant;
    result.AsBoolean := VarType(V) = varDouble;
  end;
end;

procedure _VarType(MethodBody: TPAXMethodBody);
var
  V: Variant;
  I: Integer;
begin
  with MethodBody do
  begin
    V := Params[0].AsVariant;
    I := 0;
    case VarType(V) of
      varEmpty: I := vbEmpty;
      varNull: I := vbNull;
      varSmallInt: I := vbInteger;
      varInteger: I := vbLong;
      varSingle: I := vbSingle;
      varDouble: I := vbDouble;
      varCurrency: I := vbCurrency;
      varDate: I := vbDate;
      varString: I := vbString;
      varScriptObject: I := vbObject;
      varError: I := vbError;
      varBoolean: I := vbBoolean;
      varVariant: I := vbVariant;
      varDispatch: I := vbObject;
      varByte: I := vbByte;
    end;

    if VarType(V) >= varArray then
      I := vbArray;

    result.AsInteger := I;
  end;
end;

procedure _TypeName(MethodBody: TPAXMethodBody);
var
  V: Variant;
  S: String;
begin
  with MethodBody do
  begin
    V := Params[0].AsVariant;
    S := '';
    case VarType(V) of
      varEmpty: S := 'Empty';
      varNull: S := 'Null';
      varSmallInt: S := 'Integer';
      varInteger: S := 'Long';
      varSingle: S := 'Single';
      varDouble: S := 'Double';
      varCurrency: S := 'Currency';
      varDate: S := 'Date';
      varString: S := 'String';
      varScriptObject: S := 'Object';
      varBoolean: S := 'Boolean';
      varVariant: S := 'Variant';
      varDispatch: S := 'Dispatch';
      varByte: S := 'Byte';
    end;

    if VarType(V) >= varArray then
      S := 'Array';

    result.AsString := S;
  end;
end;

procedure _IsNumeric(MethodBody: TPAXMethodBody);
var
  V: Variant;
  b: Boolean;
begin
  with MethodBody do
  begin
    b := false;
    V := Params[0].AsVariant;

    case VarType(V) of
      varInteger, varByte, varDouble: b := true;
      varString: b := IsNumericString(V);
    end;

    result.AsBoolean := b;
  end;
end;

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 TPaxBasicParser(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;

procedure _eval(MethodBody: TPAXMethodBody);
var
  V: Variant;
  P: TPAXParser;
begin
  with MethodBody do
  begin
    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;

var
  H: Integer;
initialization
  Randomize;

  H := RegisterNamespace('paxBasicNamespace', -1);

  RegisterConstant('vbEmpty', 0, H);
  RegisterConstant('vbNull', 1, H);
  RegisterConstant('vbInteger', 2, H);
  RegisterConstant('vbLong', 3, H);
  RegisterConstant('vbSingle', 4, H);
  RegisterConstant('vbDouble', 5, H);
  RegisterConstant('vbCurrency', 6, H);
  RegisterConstant('vbDate', 7, H);
  RegisterConstant('vbString', 8, H);
  RegisterConstant('vbObject', 9, H);
  RegisterConstant('vbError', 10, H);
  RegisterConstant('vbBoolean', 11, H);
  RegisterConstant('vbVariant', 12, H);
  RegisterConstant('vbDataObject', 13, H);
  RegisterConstant('vbByte', 17, H);
  RegisterConstant('vbArray', 8192, H);;

  RegisterStdRoutine('Abs', _Abs, 1, H);
  RegisterStdRoutine('Array', _Array, -1, H);
  RegisterStdRoutine('Asc', _Asc, 1, H);
  RegisterStdRoutine('Atn', _Atn, 1, H);

  RegisterStdRoutine('CBool', _CBool, 1, H);
  RegisterStdRoutine('CByte', _CByte, 1, H);
  RegisterStdRoutine('CCurr', _CCurr, 1, H);
  RegisterStdRoutine('CDate', _CDate, 1, H);

  RegisterStdRoutine('CDbl', _CDbl, 1, H);
  RegisterStdRoutine('Chr', _Chr, 1, H);
  RegisterStdRoutine('CInt', _CInt, 1, H);
  RegisterStdRoutine('CLng', _CLng, 1, H);

  RegisterStdRoutine('Cos', _Cos, 1, H);
  RegisterStdRoutine('CreateObject', _CreateObject, 1, H);
  RegisterStdRoutine('CLng', _CSng, 1, H);

  RegisterStdRoutine('Date', _Date, 1, H);
  RegisterStdRoutine('DateAdd', _DateAdd, 1, H); // not implemented yet
  RegisterStdRoutine('DateDiff', _DateDiff, 1, H); // not implemented yet
  RegisterStdRoutine('DatePart', _DatePart, 1, H); // not implemented yet

  RegisterStdRoutine('DateSerial', _DateSerial, 3, H);
  RegisterStdRoutine('DateValue', _DateValue, 1, H);
  RegisterStdRoutine('Day', _Day, 1, H);

  RegisterStdRoutine('Eval', _Eval, 1, H);
  RegisterStdRoutine('Exp', _Exp, 1, H);
  RegisterStdRoutine('Filter', _Filter, -1, H);
  RegisterStdRoutine('FormatCurrency', _FormatCurrency, -1, H);

  RegisterStdRoutine('FormatDateTime', _FormatDateTime, -1, H);
  RegisterStdRoutine('FormatNumber', _FormatNumber, -1, H);
  RegisterStdRoutine('FormatPercent', _FormatPercent, -1, H);
  RegisterStdRoutine('GetLocale', _GetLocale, 0, H); // not implemented yet

  RegisterStdRoutine('GetObject', _GetObject, 1, H);
  RegisterStdRoutine('GetRef', _GetRef, 1, H);
  RegisterStdRoutine('Hex', _Hex, 1, H);
  RegisterStdRoutine('Hour', _Hour, 1, H);

  RegisterStdRoutine('InputBox', _InputBox, -1, H);
  RegisterStdRoutine('InStr', _InStr, -1, H);
  RegisterStdRoutine('InStrRev', _InStrRev, -1, H);
  RegisterStdRoutine('Int', _Int, 1, H);
  RegisterStdRoutine('Fix', _Fix, 1, H);

  RegisterStdRoutine('IsArray', _IsArray, 1, H);
  RegisterStdRoutine('IsDate', _IsDate, 1, H);
  RegisterStdRoutine('IsEmpty', _IsNull, 1, H);
  RegisterStdRoutine('IsNull', _IsNull, 1, H);

  RegisterStdRoutine('IsNumeric', _IsNumeric, 1, H);
  RegisterStdRoutine('IsObject', _IsObject, 1, H);
  RegisterStdRoutine('Join', _Join, -1, H);
  RegisterStdRoutine('LBound', _LBound, -1, H);

  RegisterStdRoutine('LCase', _LCase, 1, H);
  RegisterStdRoutine('Left', _Left, 2, H);
  RegisterStdRoutine('Len', _Len, 1, H);

  RegisterStdRoutine('Log', _Log, 1, H);
  RegisterStdRoutine('LTrim', _LTrim, 1, H);
  RegisterStdRoutine('RTrim', _RTrim, 1, H);
  RegisterStdRoutine('Trim', _Trim, 1, H);

  RegisterStdRoutine('Mid', _Mid, -1, H);
  RegisterStdRoutine('Minute', _Minute, 1, H);
  RegisterStdRoutine('Month', _Month, 1, H);
  RegisterStdRoutine('MonthName', _MonthName, -1, H);

  RegisterStdRoutine('MsgBox', _MsgBox, 1, H);
  RegisterStdRoutine('Now', _Now, 0, H);
//  RegisterStdRoutine('Oct', _Oct, 1, H);
  RegisterStdRoutine('Replace', _Replace, 3, H);
  RegisterStdRoutine('RGB', _RGB, 3, H);

  RegisterStdRoutine('Right', _Right, 2, H);
  RegisterStdRoutine('Rnd', _Rnd, -1, H);
  RegisterStdRoutine('Round', _Round, -1, H);

  RegisterStdRoutine('Second', _Second, 1, H);
  RegisterStdRoutine('Sgn', _Sgn, 1, H);
  RegisterStdRoutine('Sin', _Sin, 1, H);
  RegisterStdRoutine('Space', _Space, 1, H);

  RegisterStdRoutine('Split', _Split, -1, H);
  RegisterStdRoutine('Sqr', _Sqr, 1, H);
  RegisterStdRoutine('StrComp', _StrComp, 2, H);
//  RegisterStdRoutine('String', _String, 2, H);
  RegisterStdRoutine('StrReverse', _StrReverse, 1, H);

  RegisterStdRoutine('Tan', _Tan, 1, H);
  RegisterStdRoutine('Time', _Time, 0, H);
  RegisterStdRoutine('Timer', _Timer, 0, H);
  RegisterStdRoutine('TimeSerial', _TimeSerial, 3, H);

  RegisterStdRoutine('TimeValue', _TimeValue, 1, H);
  RegisterStdRoutine('TypeName', _TypeName, 1, H);
  RegisterStdRoutine('UBound', _UBound, 2, H);
  RegisterStdRoutine('UCase', _UCase, 1, H);

  RegisterStdRoutine('VarType', _VarType, 1, H);
  RegisterStdRoutine('Weekday', _Weekday, 1, H);
  RegisterStdRoutine('Year', _Year, 1, H);

  RegisterStdRoutine('Substr', _Substr, 3, H);

end.