base_sys.pas

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

    property Items: TList read fItems;
  end;

const
  _SizeVariant = SizeOf(Variant);

var
  OP_SEPARATOR,
  OP_NOP,
  OP_SKIP,
  OP_HALT,
  OP_HALT_GLOBAL,
  OP_HALT_OR_NOP,
  OP_PRINT,
  OP_PRINT_HTML,
  OP_GO,
  OP_GO_FALSE,
  OP_GO_FALSE_EX,
  OP_GO_TRUE,
  OP_GO_TRUE_EX,
  OP_SET_LABEL,

  OP_BEGIN_METHOD,
  OP_CREATE_ARRAY,
  OP_CREATE_DYNAMIC_ARRAY_TYPE,
  OP_GET_FIELD,

  OP_CREATE_SHORT_STRING,

  OP_DO_NOT_DESTROY,

  OP_CREATE_OBJECT,
  OP_CREATE_RESULT,
  OP_CHECK_CLASS,
  OP_SET_TYPE,
  OP_DESTROY_HOST,
  OP_DESTROY_OBJECT,
  OP_DESTROY_LOCAL_VAR,
  OP_DESTROY_INTF,
  OP_RELEASE,
  OP_CREATE_REF,
  OP_USE_NAMESPACE,
  OP_END_OF_NAMESPACE,
  OP_BEGIN_WITH,
  OP_END_WITH,
  OP_EVAL_WITH,
  OP_IN,
  OP_IN_SET,
  OP_INSTANCEOF,
  OP_TYPEOF,
  OP_GET_NEXT_PROP,
  OP_SAVE_RESULT,
  OP_GET_ANCESTOR_NAME,

  OP_ON_USES,

  OP_PUSH,
  OP_PUT_PROPERTY,
  OP_CALL,
  OP_CALL_CONSTRUCTOR,
  OP_TYPE_CAST,
  OP_RET,
  OP_EXIT0,
  OP_EXIT,
  OP_RETURN,
  OP_GET_PARAM_COUNT,
  OP_GET_PARAM,
  OP_GET_PUBLISHED_PROPERTY,
  OP_PUT_PUBLISHED_PROPERTY,
  OP_RET_OPERATOR,

  OP_GET_ITEM,
  OP_PUT_ITEM,
  OP_GET_ITEM_EX,
  OP_PUT_ITEM_EX,

  OP_GET_STRING_ELEMENT,
  OP_PUT_STRING_ELEMENT,

  OP_FINALLY,
  OP_CATCH,
  OP_TRY_ON,
  OP_TRY_OFF,
  OP_THROW,
  OP_DISCARD_ERROR,
  OP_EXIT_ON_ERROR,

  OP_ASSIGN,
  OP_ASSIGN_SIMPLE,
  OP_ASSIGN_ADDRESS,
  OP_GET_TERMINAL,
  OP_ASSIGN_RESULT,

  OP_AND,
  OP_OR,
  OP_XOR,
  OP_NOT,

  OP_LEFT_SHIFT, OP_LEFT_SHIFT_EX,
  OP_RIGHT_SHIFT, OP_RIGHT_SHIFT_EX,

  OP_UNSIGNED_RIGHT_SHIFT, OP_UNSIGNED_RIGHT_SHIFT_EX,

  OP_PLUS, OP_PLUS_EX,
  OP_MINUS, OP_MINUS_EX,
  OP_UNARY_PLUS,
  OP_UNARY_MINUS, OP_UNARY_MINUS_EX,
  OP_MULT, OP_MULT_EX,
  OP_DIV, OP_DIV_EX,
  OP_INT_DIV,
  OP_MOD, OP_MOD_EX,
  OP_POWER,

  OP_LT, OP_LT_EX,
  OP_GT, OP_GT_EX,
  OP_GE, OP_GE_EX,
  OP_LE, OP_LE_EX,

  OP_EQ, OP_EQ_EX,
  OP_NE, OP_NE_EX,

  OP_ID, OP_ID_EX,
  OP_NI, OP_NI_EX,

  OP_IS,
  OP_AS,

  OP_TO_INTEGER,
  OP_TO_STRING,
  OP_TO_BOOLEAN,

  OP_DEFINE,

  OP_DECLARE_ON,
  OP_DECLARE_OFF,

  OP_UPCASE_ON,
  OP_UPCASE_OFF,

  OP_OPTIMIZATION_ON,
  OP_OPTIMIZATION_OFF,

  OP_JS_OPERS_ON,
  OP_JS_OPERS_OFF,

  OP_ZERO_BASED_STRINGS_ON,
  OP_ZERO_BASED_STRINGS_OFF,

  OP_VBARRAYS_ON,
  OP_VBARRAYS_OFF,

  OP_USE_LANGUAGE_NAMESPACE,

//------------------------------------------------------------------------
  FOP_INC1,
  FOP_INC2,

  FOP_PLUS_INTEGER1,
  FOP_PLUS_INTEGER2,
  FOP_PLUS_DOUBLE1,
  FOP_PLUS_DOUBLE2,
  FOP_PLUS_STRING1,
  FOP_PLUS_STRING2,

  FOP_MINUS_INTEGER1,
  FOP_MINUS_INTEGER2,
  FOP_MINUS_DOUBLE1,
  FOP_MINUS_DOUBLE2,

  FOP_MULT_INTEGER1,
  FOP_MULT_INTEGER2,
  FOP_MULT_DOUBLE1,
  FOP_MULT_DOUBLE2,

  FOP_DIV_INTEGER1,
  FOP_DIV_INTEGER2,
  FOP_DIV_DOUBLE1,
  FOP_DIV_DOUBLE2,

  FOP_MOD1,
  FOP_MOD2,

  FOP_LT_INTEGER1,
  FOP_LT_INTEGER2,
  FOP_LT_DOUBLE1,
  FOP_LT_DOUBLE2,

  FOP_LE_INTEGER1,
  FOP_LE_INTEGER2,
  FOP_LE_DOUBLE1,
  FOP_LE_DOUBLE2,

  FOP_GT_INTEGER1,
  FOP_GT_INTEGER2,
  FOP_GT_DOUBLE1,
  FOP_GT_DOUBLE2,

  FOP_GE_INTEGER1,
  FOP_GE_INTEGER2,
  FOP_GE_DOUBLE1,
  FOP_GE_DOUBLE2,

  FOP_EQ_INTEGER1,
  FOP_EQ_INTEGER2,
  FOP_EQ_DOUBLE1,
  FOP_EQ_DOUBLE2,

  FOP_NE_INTEGER1,
  FOP_NE_INTEGER2,
  FOP_NE_DOUBLE1,
  FOP_NE_DOUBLE2,

  FOP_BITWISE_AND1,
  FOP_BITWISE_AND2,

  FOP_BITWISE_OR1,
  FOP_BITWISE_OR2,

  FOP_BITWISE_XOR1,
  FOP_BITWISE_XOR2,

  FOP_LOGICAL_AND1,
  FOP_LOGICAL_AND2,

  FOP_LOGICAL_OR1,
  FOP_LOGICAL_OR2,

  FOP_LOGICAL_XOR1,
  FOP_LOGICAL_XOR2,

  FOP_BITWISE_NOT1,
  FOP_BITWISE_NOT2,

  FOP_LOGICAL_NOT1,
  FOP_LOGICAL_NOT2,

  FOP_UNARY_MINUS_INTEGER1,
  FOP_UNARY_MINUS_INTEGER2,

  FOP_UNARY_MINUS_DOUBLE1,
  FOP_UNARY_MINUS_DOUBLE2,

  FOP_SHL1,
  FOP_SHL2,

  FOP_SHR1,
  FOP_SHR2,

  FOP_USHR1,
  FOP_USHR2,

  FOP_ASSIGN,
  FOP_GO_FALSE1,
  FOP_GO_FALSE2,
  FOP_GO_TRUE1,
  FOP_GO_TRUE2,

//=========================================

  FOP_PUSH,
  FOP_CALL,

  FOP_PLUS1,
  FOP_PLUS2,

  FOP_MINUS1,
  FOP_MINUS2,

  FOP_MULT1,
  FOP_MULT2,

  FOP_DIV1,
  FOP_DIV2,

  FOP_LT1,
  FOP_LT2,

  FOP_LE1,
  FOP_LE2,

  FOP_GT1,
  FOP_GT2,

  FOP_GE1,
  FOP_GE2,

  FOP_EQ1,
  FOP_EQ2,

  FOP_NE1,
  FOP_NE2,

  OP_DECLARE

  : Integer;

  Undefined: Variant;

  NameIndex_Create: Integer;
  NameIndex_New: Integer;

  OPResultTypes: array[1..40, 1..40] of Integer;
  AssResultTypes: array[1..40, 1..40] of Boolean;
  PAXKinds: TPAXKinds;
  PAXTypes: TPAXTypes;
  PAXOperators: TPAXOperators;
  SupportedPaxTypes: TIntegerSet;
  OverloadableOperators: TOperatorList;
  RelationalOperators: TOperatorList;

function StrEql(Const S1, S2: String): Boolean;
function ShiftPointer(P: Pointer; D: Integer): Pointer;
function Norm(const S: String; L: Integer): String;
function GetOperName(OP: Integer): String;
function IsString(const V: Variant): boolean;
function IsBoolean(const V: Variant): boolean;
function IsObject(const V: Variant): boolean;
function IsVBArray(const V: Variant): boolean;
function IsUndefined(const V: Variant): boolean;
function ArrayCreate(const P: array of Integer): Variant;
procedure ArrayPut(V: PVariant; const Indexes: array of Integer; const Val: Variant);
function ArrayGet(V: PVariant; const Indexes: array of Integer): PVariant;
procedure ErrMessageBox(const S:  String);
function IsDelphiClass(Address: Pointer): Boolean;
function IsDelphiObject(Address: Pointer): Boolean;
procedure BackUpTextFile(const FileName: String);
function IsNumber(const V: Variant): boolean;
function _Shr(X, Y: Integer): Variant;
function StringToBinary(const S: String): Integer;
function StringToOctal(const S: String): Integer;
function ChPos(ch: Char; const S: String): Integer;
function SetToVariantArray(Val: Integer; pti: PTypeInfo): Variant;
function HashNumber(const S: String): Integer;

procedure SetBit(var Value: Integer; const Bit: Integer);
function TestBit(const Value: Integer; const Bit: Integer): Boolean;
procedure ClearBit(var Value: Integer; const Bit: Integer);

procedure SaveInteger(Value: Integer; S: TStream);
function LoadInteger(S: TStream): Integer;
procedure SaveString(const Value: String; S: TStream);
function LoadString(S: TStream): String;

procedure SaveVariant(const Value: Variant; S: TStream);
function LoadVariant(S: TStream): Variant;
function GetGMTDifference: Double;
procedure AdjustEnum(var Val: Integer);

type
  TCompareItems = function (P1, P2: Pointer): Integer;
function CompareIntegers(P1, P2: Pointer): Integer;
procedure SortList(L: TList; CompareItems: TCompareItems; I1, I2: Integer);
function GetPAXType(const V: Variant): Integer;
function IsDigits(const S: String): Boolean;
function IsNumericString(const S: String): Boolean;
function DelphiDateTimeToEcmaTime(const AValue: TDateTime): Int64;
function EcmaTimeToDelphiDateTime(const AValue: Variant): TDateTime;
procedure GetMethodList(FromClass: TClass; MethodList: TStrings);
procedure GetPublishedProperties(AClass: TClass; result: TStrings);
procedure GetPublishedPropertiesEx2(AClass: TClass; result: TStrings);
procedure GetPublishedEvents(AClass: TClass; result: TStrings);
procedure GetPublishedPropertiesEx(AClass: TClass; result: TStrings); // including type name
function HasPublishedProperty(C: TClass; const PropName: String; Scripter: Pointer; NeedCheckForForbidden: Boolean = true): boolean;
function HasPublishedPropertyEx(C: TClass; const PropName: String; var ClassType: String; Scripter: Pointer): boolean;
function GetRefCountPtr(const S: String): Pointer;
function GetRefCount(const S: String): Integer;
function GetSizePtr(const S: String): Pointer;

function GetTerminal(P: PVariant): PVariant;
function CreateAlias(P: PVariant): Variant;
function IsAlias(P: PVariant): Boolean;

procedure Initialization_BASE_SYS;
procedure Finalization_BASE_SYS;

procedure SaveStringToTextFile(const S, FileName: String);
procedure ClearVar(V: PVariant);

function IsEqualBytes(P1, P2: Pointer; L: Integer): Boolean;
function IsZeroBytes(P: Pointer; L: Integer): Boolean;
function IntfRefCount(const I: IUnknown): Integer;

function IsEqualGUID(const guid1, guid2: TGUID): Boolean;
function GetImplementorOfInterface(const I: IUnknown): TObject;
function PosCh(ch: Char; const S: String): Integer;

implementation

uses
  BASE_SCRIPTER;


constructor TPaxObjectList.Create;
begin
  fItems := TList.Create;
end;


procedure TPaxObjectList.Add(X: TObject);
begin
  fItems.Add(X);
end;

procedure TPaxObjectList.Clear;
var
  I: Integer;
begin
  for I:=0 to Count - 1 do
    TObject(fItems[I]).Free;
  fItems.Clear;
end;

destructor TPaxObjectList.Destroy;
begin
  Clear;
  fItems.Free;
  inherited;
end;

procedure TPaxObjectList.Delete(I: Integer);
begin
  TObject(fItems[I]).Free;
  fItems.Delete(I);
end;

function TPaxObjectList.Count: Integer;
begin
  result := fItems.Count;
end;

type
  IntegerArray  = array[0..$effffff] of Integer;
  PIntegerArray = ^IntegerArray;

function IsEqualGUID(const guid1, guid2: TGUID): Boolean;
var
  a, b: PIntegerArray;
begin
  a := PIntegerArray(@guid1);
  b := PIntegerArray(@guid2);
  Result := (a^[0] = b^[0]) and (a^[1] = b^[1]) and (a^[2] = b^[2]) and (a^[3] = b^[3]);
end;


function IntfRefCount(const I: IUnknown): Integer;
begin
  result := I._AddRef - 1;
  I._Release;
end;

function IsEqualBytes(P1, P2: Pointer; L: Integer): Boolean;
var
  I: Integer;
begin
  result := true;
  for I := 0 to L - 1 do
    if Byte(ShiftPointer(P1, I)^) <> Byte(ShiftPointer(P2, I)^) then
    begin
      result := false;
      Exit;
    end;
end;

function IsZeroBytes(P: Pointer; L: Integer): Boolean;
var
  I: Integer;
begin
  result := true;
  for I := 0 to L - 1 do
    if Byte(ShiftPointer(P, I)^) <> 0 then
    begin
      result := false;
      Exit;
    end;
end;

procedure ClearVar(V: PVariant);
begin
  if TVarData(V^).VType = varString then
    VarClear(V^)
  else if (TVarData(V^).VType and varArray) <> 0 then
    VarClear(V^)
  else
    FillChar(V^, SizeOf(TVarData), 0);
  TVarData(V^).VType := varEmpty;
end;

procedure SaveStringToTextFile(const S, FileName: String);
var
  T: TextFile;
begin
  AssignFile(T, FileName);
  Rewrite(T);
  writeln(T, S);
  CloseFile(T);
end;

constructor TOperatorList.Create;
begin
  inherited;
  fItems := TStringList.Create;
end;

destructor TOperatorList.Destroy;
begin
  fItems.Free;
  inherited;
end;

procedure TOperatorList.Add(const Name: String; Op: Integer);
begin
  fItems.AddObject(Name, TObject(Op));
end;

function TOperatorList.GetName(Op: Integer): String;
var
  I: Integer;
begin
  for I:=0 to fItems.Count - 1 do
    if Integer(fItems.Objects[I]) = Op then
    begin
      result := fItems[I];
      Exit;
    end;
  result := '';
end;

function TOperatorList.IndexOf(const Name: String): Integer;
begin
  result := fItems.IndexOf(Name);
end;

constructor TPaxAssociativeList.Create(DupYes: Boolean);
begin
  L1 := TPaxIds.Create(DupYes);
  L2 := TPaxIds.Create(DupYes);
end;

destructor TPaxAssociativeList.Destroy;
begin
  L1.Free;
  L2.Free;
  inherited;
end;

procedure TPaxAssociativeList.Clear;
begin
  L1.Clear;
  L2.Clear;
end;

function TPaxAssociativeList.Convert(ID: Integer): Integer;
var
  I: Integer;
begin
  result := ID;
  for I:=0 to Count - 1 do
    if L1[I] = ID then
      result := L2[I];
end;

function TPaxAssociativeList.Count: Integer;
begin
  result := L1.Count;
end;

function TPaxAssociativeList.Add(I1, I2: Integer): Integer;
begin
  result := L1.Add(I1);
  L2.Add(I2);
end;

function TPaxAssociativeList.GetFirst(I: Integer): Integer;
begin
  result := L1[I];
end;

function TPaxAssociativeList.GetSecond(I: Integer): Integer;
begin
  result := L2[I];
end;

constructor TPaxCallRec.Create;
begin
  CallN := 0;
  CallP := 0;
  ArgsN := TPaxIds.Create(false);
  ArgsP := TPaxIds.Create(false);
end;

destructor TPaxCallRec.Destroy;
begin
  ArgsN.Free;
  ArgsP.Free;
  inherited;
end;

function TPaxCallRecList.GetRecord(I: Integer): TPaxCallRec;
begin
  result := TPaxCallRec(Objects[I]);
end;

procedure TPaxCallRecList.AddObject(N: Integer; X: TPaxCallRec);
var
  I: Integer;
begin
  I := IndexOf(N);
  if I = -1 then
    inherited AddObject(N, X)
  else
    X.Free;
end;

function TPaxCallRecList.Top: TPaxCallRec;
begin
  result := TPaxCallRec(Objects[Count - 1]);
end;