base_extern.pas

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

                     FieldType: String;
                     Address: Pointer);
    function FindRecord(const ObjectName: String;
                        ObjectType: String;
                        FieldName: String): TPAXFieldRec;
    procedure Clear;
    property Records[Index: Integer]: TPAXFieldRec read GetRecord;
  end;

  TPAXArray = class(TPersistent)
  private
    N: Integer;
    P: Pointer;
    L: Integer;
    fBounds: array of Integer;
    fIndexes: TPaxIds;
    fOwner: Variant;

    fLastIndex: Integer;
    fInputString: String;
    fIndex: Integer;
    function AddressOfElement: Pointer;
    function GetLength: Integer;
    procedure PutLength(Value: Integer);
  public
    Scripter: Pointer;
    TypeID: Integer;
    _ElSize: Integer;
    constructor Create(Bounds: array of Integer; typeID: Integer = typeVARIANT);
    destructor Destroy; override;
    procedure ReDim(Bounds: array of Integer);
    procedure _ReDim;
    procedure ClearIndexes;
    function AddIndex(I: Integer): Integer;
    procedure InsertIndex(I: Integer);
    function _GetPtr: PVariant;
    function _GetPtrEx: PVariant;
    function _Get: Variant;
    function _GetEx: Variant;
    procedure _Put(const Value: Variant);
    procedure _PutEx(const Value: Variant);
    function Get(const Indexes: array of Integer): Variant;
    procedure Put(const Indexes: array of Integer; const Value: Variant);
    function GetPtr(const Indexes: array of Integer): PVariant;
    function GetEx(const Indexes: array of Integer): Variant;
    procedure PutEx(const Indexes: array of Integer; const Value: Variant);
    function CheckIndexes(const Indexes: array of Integer): Boolean;
    function _CheckIndexes: Boolean;
    function Duplicate: Variant;
    function ToString: String;
    function HighBound(Dim: Integer): Integer;
    function Typed: Boolean;
    property Buffer: Pointer read P;
  published
    property Owner: Variant read fOwner write fOwner;
    property DimCount: Integer read L write L;
    property Length: Integer read GetLength write PutLength;

    property Index: Integer read fIndex write fIndex;
    property LastIndex: Integer read fLastIndex write fLastIndex;
    property InputString: String read fInputString write fInputString;
  end;

function PaxArrayToDynamicArray(const V: Variant; ElTypeID: Integer): Pointer;
function PaxArrayToByteSet(const V: Variant): TByteSet;
function ByteSetToPaxArray(const S: TByteSet; Scripter: Pointer): Variant;
function StringToByteSet(pti: PTypeInfo; const V: String): TByteSet;
function ComparePaxArrays(A1, A2: TPaxArray): Boolean;
function UnaryPlus(const V: Variant): Variant;

function AddSets(const S1, S2: Variant): Variant;
function SubSets(const S1, S2: Variant): Variant;
function IntersectSets(const S1, S2: Variant): Variant;
function InSet(const Value, ASet: Variant): Boolean;
function IsSubSet(const S1, S2: Variant): Boolean;
function IsStrictSubSet(const S1, S2: Variant): Boolean;
function AreEqualSets(const S1, S2: Variant): Boolean;
function EqualVariants(Scripter: Pointer; const V1, V2: Variant;
                       T1: Integer = -1;
                       T2: Integer = -1): TBoolean;

procedure Initialization_BASE_EXTERN;
procedure Finalization_BASE_EXTERN;

procedure AddTypeAlias(const T1, T2: String);
function FindTypeAlias(const TypeName: String; UpCase: Boolean): String;

var
  DefinitionList: TPAXDefinitionList;
  ArrayParamMethods: TStringList;
  TypeAliases: TStringList;
  UnresolvedTypes: TStringList;

  DefListInitialCount: Integer = 0;

  CheckDup: Boolean = false;

implementation

uses
  BASE_CLASS, BASE_SCRIPTER, PASCAL_PARSER, BASE_REGEXP, BASE_SYMBOL, PAX_RTTI;

function StringToByteSet(pti: PTypeInfo; const V: String): TByteSet;
var
  ptd: PTypeData;
  I: Byte;
  S: String;
begin
  result := [];
  if pti = nil then Exit;
  ptd := GetTypeData(pti);
  if ptd = nil then Exit;


  {$ifdef fp}
  pti := ptd^.CompType;
  {$else}
  pti := ptd^.CompType^;
  {$endif}
  if pti = nil then Exit;

  ptd := GetTypeData(pti);
  if ptd = nil then Exit;

  for I:= ptd.MinValue to ptd.MaxValue do
  begin
    S :=GetEnumName(pti, I);
    if Pos(S, V) > 0 then
      result := result + [TByteInt(I)];
  end;
end;

function PaxArrayToByteSet(const V: Variant): TByteSet;
var
  SO: TPAXScriptObject;
  PaxArray: TPAXArray;
  I, L: Integer;
  Val: Byte;
begin
  SO := VariantToScriptObject(V);
  PaxArray := TPAXArray(SO.Instance);
  L := PaxArray.HighBound(1);
  result := [];
  for I:=0 to L - 1 do
  begin
    Val := PaxArray.Get([I]);
    Include(result, TByteInt(Val));
  end;
end;

function ByteSetToPaxArray(const S: TByteSet; Scripter: Pointer): Variant;
var
  I, K, L: Integer;
  PaxArray: TPaxArray;
  SO: TPaxScriptObject;
begin
  L := 0;
  for I:=0 to 255 do
    if TByteInt(I) in S then
      Inc(L);

  PaxArray := TPaxArray.Create([L-1]);
  PaxArray.Scripter := Scripter;

  K := -1;
  for I:=0 to 255 do
    if TByteInt(I) in S then
    begin
      Inc(K);
      PaxArray.Put([K], I);
    end;

  SO := TPAXBaseScripter(Scripter).ArrayClassRec.CreateScriptObject;
  SO.RefCount := 1;
  SO.Instance := PaxArray;
  result := ScriptObjectToVariant(SO);

end;

function _IndexOf(Scripter: Pointer; L: TPaxVarList; const Value: Variant): Integer;
var
  I: Integer;
  P: PVariant;
begin
  result := -1;
  for I:=1 to L.Count do
  begin
    P := L.GetAddress(I);
    if EqualVariants(Scripter, P^, Value) then
    begin
      result := I;
      Exit;
    end;
  end;
end;

function AddSets(const S1, S2: Variant): Variant;
var
  SO, SO1, SO2: TPaxScriptObject;
  A, A1, A2: TPaxArray;
  L: TPaxVarList;
  I, Index: Integer;
  P: PVariant;
  Scripter: Pointer;
begin
  SO1 := VariantToScriptObject(S1);
  SO2 := VariantToScriptObject(S2);
  A1 := TPaxArray(SO1.Instance);
  A2 := TPaxArray(SO2.Instance);

  Scripter := SO1.Scripter;

  L := TPaxVarList.Create;

  if A1.Length > 0 then
  for I:=0 to A1.Length - 1 do
  begin
    P := A1.GetPtr([I]);
    Index := _IndexOf(Scripter, L, P^);
    if Index = -1 then
      L.Add(P^);
  end;

  if A2.Length > 0 then
  for I:=0 to A2.Length - 1 do
  begin
    P := A2.GetPtr([I]);
    Index := _IndexOf(Scripter, L, P^);
    if Index = -1 then
      L.Add(P^);
  end;

  A := TPaxArray.Create([L.Count - 1]);
  A.Scripter := Scripter;
  for I:=1 to L.Count do
    A.Put([I-1], L[I]);

  L.Free;

  SO := TPAXBaseScripter(Scripter).ArrayClassRec.CreateScriptObject;
  SO.RefCount := 1;
  SO.Instance := A;
  result := ScriptObjectToVariant(SO);
end;

function SubSets(const S1, S2: Variant): Variant;
var
  SO, SO1, SO2: TPaxScriptObject;
  A, A1, A2: TPaxArray;
  L: TPaxVarList;
  I, Index: Integer;
  P: PVariant;
  Scripter: Pointer;
begin
  SO1 := VariantToScriptObject(S1);
  SO2 := VariantToScriptObject(S2);
  A1 := TPaxArray(SO1.Instance);
  A2 := TPaxArray(SO2.Instance);

  Scripter := SO1.Scripter;

  L := TPaxVarList.Create;

  if A1.Length > 0 then
  for I:=0 to A1.Length - 1 do
  begin
    P := A1.GetPtr([I]);
    Index := _IndexOf(Scripter, L, P^);
    if Index = -1 then
      L.Add(P^);
  end;

  if A2.Length > 0 then
  for I:=0 to A2.Length - 1 do
  begin
    P := A2.GetPtr([I]);
    Index := _IndexOf(Scripter, L, P^);
    if Index <> -1 then
      L.Delete(Index);
  end;

  A := TPaxArray.Create([L.Count - 1]);
  A.Scripter := Scripter;
  for I:=1 to L.Count do
    A.Put([I-1], L[I]);

  L.Free;

  SO := TPAXBaseScripter(Scripter).ArrayClassRec.CreateScriptObject;
  SO.RefCount := 1;
  SO.Instance := A;
  result := ScriptObjectToVariant(SO);
end;

function IntersectSets(const S1, S2: Variant): Variant;
var
  SO, SO1, SO2: TPaxScriptObject;
  A, A1, A2: TPaxArray;
  L: TPaxVarList;
  I, J, Index: Integer;
  P1, P2: PVariant;
  Scripter: Pointer;
begin
  SO1 := VariantToScriptObject(S1);
  SO2 := VariantToScriptObject(S2);
  A1 := TPaxArray(SO1.Instance);
  A2 := TPaxArray(SO2.Instance);

  Scripter := SO1.Scripter;

  L := TPaxVarList.Create;

  if A1.Length > 0 then
  for I:=0 to A1.Length - 1 do
  begin
    P1 := A1.GetPtr([I]);
    Index := _IndexOf(Scripter, L, P1^);
    if Index = -1 then
    begin
      for J:=0 to A2.Length - 1 do
      begin
        P2 := A2.GetPtr([J]);
        if EqualVariants(Scripter, P1^, P2^) then
        begin
          Index := J;
          Break;
        end;
      end;
      if Index <> -1 then
        L.Add(P1^);
    end;
  end;

  A := TPaxArray.Create([L.Count - 1]);
  A.Scripter := Scripter;
  for I:=1 to L.Count do
    A.Put([I-1], L[I]);

  L.Free;

  SO := TPAXBaseScripter(Scripter).ArrayClassRec.CreateScriptObject;
  SO.RefCount := 1;
  SO.Instance := A;
  result := ScriptObjectToVariant(SO);
end;

function IsSubSet(const S1, S2: Variant): Boolean;
var
  SO1, SO2: TPaxScriptObject;
  A1, A2: TPaxArray;
  I, J: Integer;
  P1, P2: PVariant;
  Scripter: Pointer;
  Found: Boolean;
begin
  SO1 := VariantToScriptObject(S1);
  SO2 := VariantToScriptObject(S2);
  A1 := TPaxArray(SO1.Instance);
  A2 := TPaxArray(SO2.Instance);

  Scripter := SO1.Scripter;

  result := true;

  if A1.Length > 0 then
  for I:=0 to A1.Length - 1 do
  begin
    P1 := A1.GetPtr([I]);
    Found := false;
    for J:=0 to A2.Length - 1 do
    begin
      P2 := A2.GetPtr([J]);
      Found := EqualVariants(Scripter, P1^, P2^);
      if Found then
        Break;
    end;
    if not Found then
    begin
      result := false;
      Exit;
    end;
  end;
end;

function IsStrictSubSet(const S1, S2: Variant): Boolean;
var
  SO1, SO2: TPaxScriptObject;
  A1, A2: TPaxArray;
begin
  SO1 := VariantToScriptObject(S1);
  SO2 := VariantToScriptObject(S2);
  A1 := TPaxArray(SO1.Instance);
  A2 := TPaxArray(SO2.Instance);
  result := IsSubSet(S1, S2) and (A1.Length < A2.Length);
end;

function AreEqualSets(const S1, S2: Variant): Boolean;
var
  SO1, SO2: TPaxScriptObject;
  A1, A2: TPaxArray;
  I, J: Integer;
  P1, P2: PVariant;
  Found: Boolean;
  Scripter: Pointer;
begin
  SO1 := VariantToScriptObject(S1);
  SO2 := VariantToScriptObject(S2);
  A1 := TPaxArray(SO1.Instance);
  A2 := TPaxArray(SO2.Instance);

  Scripter := SO1.Scripter;

  result := true;

  if A1.Length > 0 then
  for I:=0 to A1.Length - 1 do
  begin
    P1 := A1.GetPtr([I]);
    Found := false;
    for J:=0 to A2.Length - 1 do
    begin
      P2 := A2.GetPtr([J]);
      Found := EqualVariants(Scripter, P1^, P2^);
      if Found then
        Break;
    end;
    if not Found then
    begin
      result := false;
      Exit;
    end;
  end;

  if A2.Length > 0 then
  for I:=0 to A2.Length - 1 do
  begin
    P1 := A2.GetPtr([I]);
    Found := false;
    for J:=0 to A1.Length - 1 do
    begin
      P2 := A1.GetPtr([J]);
      Found := EqualVariants(Scripter, P1^, P2^);
      if Found then
        Break;
    end;
    if not Found then
    begin
      result := false;
      Exit;
    end;
  end;

end;

function InSet(const Value, ASet: Variant): Boolean;
var
  SO: TPaxScriptObject;
  A: TPaxArray;
  I: Integer;
  P: PVariant;
  Scripter: Pointer;
begin
  SO := VariantToScriptObject(ASet);
  A := TPaxArray(SO.Instance);
  Scripter := SO.Scripter;

  result := false;

  if IsPaxArray(Value) then
  begin
    result := true;
    SO := VariantToScriptObject(Value);
    A := TPaxArray(SO.Instance);
    for I:=0 to A.Length - 1 do
    begin
      P := A.GetPtr(I);
      result := result and InSet(P^, ASet);
      if not result then
        Break;
    end;
  end
  else
    for I:=0 to A.Length - 1 do
    begin
      P := A.GetPtr(I);
      if EqualVariants(Scripter, P^, Value) then
      begin
        result := true;