base_extern.pas

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

        Exit;
      end;
    end;
end;

function EqualVariants(Scripter: Pointer; const V1, V2: Variant;
                       T1: Integer = -1;
                       T2: Integer = -1): TBoolean;
var
  SO1, SO2: TPaxScriptObject;
  IsSet: Boolean;
begin
  IsSet := (T1 = typeSET) or (T2 = typeSET);

  T1 := VarType(V1);
  T2 := VarType(V2);
  if T1 = T2 then
  begin
    if T1 in [varEmpty, varNull] then
    begin
      result := true;
      Exit;
    end;

    if T1 = varScriptObject then
    begin
      SO1 := VariantToScriptObject(V1);
      SO2 := VariantToScriptObject(V2);
      if IsPaxArray(V1) and IsPaxArray(V2) then
      begin
        if IsSet then
          result := AreEqualSets(V1, V2)
        else
          result := ComparePaxArrays(TPaxArray(SO1.Instance),
                                     TPaxArray(SO2.Instance));
        Exit;
      end
      else
      begin
        result := SO1 = SO2;
        Exit;
      end;
    end;
    result := V1 = V2;
  end
  else
  begin
    if T1 in [varEmpty, varNull] then
      result := false
    else if T2 in [varEmpty, varNull] then
      result := false
    else
      result := V1 = V2;
  end;

{

  else if (T1 in [varByte, varInteger, varDouble, varVariant, varCurrency]) and (T2 in [varByte, varInteger, varDouble, varVariant, varCurrency]) then
    result := V1 = V2
  else if ((T1 = varString) or (T1 = varOleStr)) and ((T2 = varString) or (T2 = varOleStr)) then
    result := V1 = V2;
}
end;

function PaxArrayToDynamicArray(const V: Variant; ElTypeID: Integer): Pointer;
var
  L, I, ElSize: Integer;
  P: Pointer;
  SO: TPAXScriptObject;
  PaxArray: TPAXArray;
  Val: Variant;
begin
  if not IsObject(V) then
  begin
    result := AllocMem(2*SizeOf(Integer));
    Integer(result^) := 1;
    P := ShiftPointer(result, SizeOf(Integer));
    Integer(P^) := 0;
    P := ShiftPointer(P, SizeOf(Integer));
    result := P;
    Exit;
  end;

  SO := VariantToScriptObject(V);
  PaxArray := TPAXArray(SO.Instance);

  L := PaxArray.HighBound(1);
  ElSize := PaxTypes.GetSize(ElTypeID);
  result := AllocMem(2*SizeOf(Integer) +  L * ElSize);
  P := ShiftPointer(result, SizeOf(Integer));
  Integer(P^) := L;
  P := ShiftPointer(P, SizeOf(Integer));
  result := P;
  for I:=0 to L - 1 do
  begin
    Val := PaxArray.Get([I]);
    if IsPaxArray(Val) then
      Pointer(P^) := PaxArrayToDynamicArray(Val, ElTypeID)
    else
      PutVariantValue(SO.Scripter, P, Val, ElTypeID);
    P := ShiftPointer(P, ElSize);
  end;
end;

function ComparePaxArrays(A1, A2: TPaxArray): Boolean;
var
  I: Integer;
  P1, P2: PVariant;
  Scripter: Pointer;
begin
  result := false;

  if A1.N <> A2.N then
    Exit;

  if A1.L <> A2.L then
    Exit;

  for I:=0 to A1.L - 1 do
    if A1.fBounds[I] <> A2.fBounds[I] then
      Exit;

  Scripter := A1.Scripter;

  P1 := A1.P;
  P2 := A2.P;
  for I:=0 to A1.N - 1 do
  begin
    if not EqualVariants(Scripter, P1^, P2^) then
      Exit;
    P1 := ShiftPointer(P1, _SizeVariant);
    P2 := ShiftPointer(P2, _SizeVariant);
  end;
  result := true;
end;

function UnaryPlus(const V: Variant): Variant;
var
  SO: TPaxScriptObject;
begin
  if IsObject(V) then
  begin
    SO := VariantToScriptObject(V);
    if IsPaxArray(V) then
    begin
      result := TPaxArray(SO.Instance).Duplicate;
      Exit;
    end;
  end;
  result := V;
end;

constructor TPAXArray.Create(Bounds: array of Integer; typeID: Integer = typeVARIANT);
var
  I: Integer;
begin
  if typeID = 0 then
    typeID := typeVARIANT;
  if TypeID > PaxTypes.Count then
    typeID := typeVARIANT;

  Self.TypeID := typeID;
  _ElSize := _SizeVariant;

  if TypeID < PaxTypes.Count then
    if TypeID <> typeVARIANT then
      _ElSize := PaxTypes.GetSize(typeID);

  L := System.Length(Bounds);
  SetLength(Self.fBounds, L);
  N := 1;
  for I:=0 to L - 1 do
  begin
    Self.fBounds[I] := Bounds[I] + 1;
    N := N * Self.fBounds[I];
  end;
  P := AllocMem(N * _ElSize);

  fIndexes := TPAXIds.Create(true);

  Scripter := nil;
end;

function TPAXArray.Typed: Boolean;
begin
  result := typeID <> typeVARIANT;
end;

function TPAXArray.Duplicate: Variant;
var
  I: Integer;
  Q, R: PVariant;
  PaxArray: TPaxArray;
  SO: TPaxScriptObject;
  B: array of Integer;
  Q1, R1: Pointer;
begin
  SetLength(B, L);
  for I:=0 to L - 1 do
    B[I] := fBounds[I] - 1;

  PaxArray := TPaxArray.Create(B);
  PaxArray.Scripter := Scripter;

  if _ElSize = _SizeVariant then
  begin
    Q := P;
    R := PaxArray.P;
    for I:=0 to N - 1 do
    begin
      if IsPaxArray(Q^) then
      begin
        SO := VariantToScriptObject(Q^);
        R^ := TPaxArray(SO.Instance).Duplicate;
      end
      else
        R^ := Q^;
      Q := ShiftPointer(Q, _ElSize);
      R := ShiftPointer(R, _ElSize);
    end;
  end
  else
  begin
    Q1 := P;
    R1 := PaxArray.P;
    for I:=0 to N - 1 do
    begin
      if typeID = typeSTRING then
        String(R1^) := String(Q1^)
      else
        Move(Q1^, R1^, _ElSize);
      Q1 := ShiftPointer(Q1, _ElSize);
      R1 := ShiftPointer(R1, _ElSize);
    end;
  end;

  result := ScriptObjectToVariant(DelphiInstanceToScriptObject(PaxArray, Scripter));
end;

procedure TPAXArray.ReDim(Bounds: array of Integer);
var
  I, OldN, MinN: Integer;
  Q: Pointer;
begin
  OldN := N;

  L := System.Length(Bounds);
  SetLength(Self.fBounds, L);
  N := 1;
  for I:=0 to L - 1 do
  begin
    Self.fBounds[I] := Bounds[I] + 1;
    N := N * Self.fBounds[I];
  end;
  Q := AllocMem(N * _ElSize);

  MinN := OldN;
  if N < OldN then
    MinN := N;
  Move(P^, Q^, MinN * _ElSize);

  FreeMem(P, OldN);
  P := Q;
end;

function TPAXArray.GetLength: Integer;
begin
  result := fBounds[0];
end;

procedure TPAXArray.PutLength(Value: Integer);
begin
  if GetLength <> Value then
  begin
    fBounds[0] := Value - 1;
    ReDim(fBounds);
  end;
end;

procedure TPAXArray._ReDim;
var
  I, OldN, MinN: Integer;
  Q: Pointer;
begin
  OldN := N;

  L := fIndexes.Count;
  SetLength(Self.fBounds, L);
  N := 1;
  for I:=0 to L - 1 do
  begin
    Self.fBounds[I] := fIndexes[I] + 1;
    N := N * Self.fBounds[I];
  end;
  Q := AllocMem(N * _ElSize);

  MinN := OldN;
  if N < OldN then
    MinN := N;
  Move(P^, Q^, MinN * _ElSize);

  FreeMem(P, OldN);
  P := Q;
end;

destructor TPAXArray.Destroy;
var
  I, VT: Integer;
  Ptr: Pointer;
  SO: TPaxScriptObject;
begin
  Ptr := P;

  if typeID = typeVARIANT then
  begin
    for I:=0 to N - 1 do
    begin
      VT := VarType(Variant(Ptr^));
      if VT = varString then
         Variant(Ptr^) := ''
      else if VT = varScriptObject then
      begin
        SO := VariantToScriptObject(Variant(Ptr^));
        if TPaxBaseScripter(scripter).ScriptObjectList.HasObject(SO) then
          SO.RefCount := 1;
        VarClear(Variant(Ptr^));
      end;

      Inc(Integer(Ptr), _ElSize);
    end;
  end
  else
  begin
    for I:=0 to N - 1 do
    begin
      if typeID = typeSTRING then
         String(Ptr^) := '';
      Inc(Integer(Ptr), _ElSize);
    end;
  end;

  FreeMem(P, N * _ElSize);
  fIndexes.Free;
  inherited;
end;

function TPAXArray.HighBound(Dim: Integer): Integer;
begin
  result := fBounds[Dim - 1];
end;

function TPAXArray.ToString: String;

var
  B: array[0..100] of Integer;

function F(Q: Pointer; I: Integer; var SZ: Integer): String;
var
  K, TempSZ: Integer;
begin
  if I >= L then
  begin
    if Scripter = nil then
      result := VarToStr(GetTerminal(Q)^)
    else
      result := BASE_CLASS._ToStr(Scripter, GetTerminal(Q)^);
    SZ := _ElSize;
    Exit;
  end;

  with TPaxBaseScripter(Scripter).Visited do
  if (IndexOf(Q) = -1) then
    Add(Q)
  else
  begin
    SZ := _ElSize;
    result := '...';
    Exit;
  end;

  result := '[';

  SZ := 0;

  for K:=1 to B[I] do
  begin
    result := result + F(Q, I + 1, TempSZ);
    if K < B[I] then
      result := result + ',';
    Inc(Integer(Q), TempSZ);
    Inc(SZ, TempSZ);
  end;

  result := result + ']';
end;

var
  I, SZ: Integer;
begin
  for I:=0 to L - 1 do
    B[I] := fBounds[L - 1 - I];

  if typeID = typeVARIANT then
    result := F(P, 0, SZ)
  else
    result := 'array';
end;

function TPAXArray.AddressOfElement: Pointer;
var
  I, J, R: Integer;
begin
  if L > fIndexes.Count then
    raise TPAXScriptFailure.Create(errNotEnoughParameters)
  else if L < fIndexes.Count then
    raise TPAXScriptFailure.Create(errTooManyParameters);

  J := fIndexes[0];
  R := 1;
  for I:=1 to L - 1 do
  begin
    R := R * fBounds[I-1];
    Inc(J, R * fIndexes[I]);
  end;
  result := Pointer(Integer(P) + J * _ElSize);
end;

function TPAXArray._Get: Variant;
var
  Q: Pointer;
begin
  Q := AddressOfElement;

  if TypeID = typeVARIANT then
    result := PVariant(Q)^
  else
    result := GetVariantValue(scripter, Q, typeID);
end;

function TPAXArray._GetPtr: PVariant;
begin
  result := AddressOfElement;
end;

function TPAXArray._GetEx: Variant;
begin
  if not _CheckIndexes then
    _ReDim;
  result := _Get;
end;

function TPAXArray._GetPtrEx: PVariant;
begin
  if not _CheckIndexes then
    _ReDim;

  result := AddressOfElement;
end;

procedure TPAXArray._Put(const Value: Variant);
var
  Q: Pointer;
begin
  Q := AddressOfElement;

  if TypeID = typeVARIANT then
    PVariant(Q)^ := Value
  else
    PutVariantValue(scripter, Q, Value, typeID);
end;

procedure TPAXArray._PutEx(const Value: Variant);
begin
  if not _CheckIndexes then
    _ReDim;

  _Put(Value);
end;

procedure TPAXArray.ClearIndexes;
begin
  fIndexes.Clear;
end;

function TPAXArray.AddIndex(I: Integer): Integer;
begin
  result := fIndexes.Add(I);
end;