ibcarrayuni.pas

CrLab UniDAC 1.0 include sources

procedure TCustomIBCArray.SetArrayDesc(Desc: IntPtr);
var
  i: integer;
begin
  if (FArrayDesc <> nil) and FNativeDesc then begin
    Marshal.FreeHGlobal(FArrayDesc);
    FArrayDesc := nil;
    FNativeDesc := False;
  end;
  FArrayDesc := Desc;
  FDescAccessor.SetDesc(FArrayDesc);
  if FArrayDesc <> nil then begin
    FDescAccessor.Scale := ABS(FDescAccessor.Scale);
    ArrayDimensions := FDescAccessor.Dimensions;
    for i := 0 to FArrayDimensions - 1 do begin
      FArrayHighBounds[i] := FDescAccessor.GetHighBound(i);
      FArrayLowBounds[i] := FDescAccessor.GetLowBound(i);
    end;
    FInternalItemType := GetInternalItemType;
  end;
end;

function TCustomIBCArray.GetArrayIDPtr: PISC_QUAD;
begin
  Result := FArrayID;
end;

procedure TCustomIBCArray.CreateTemporaryArray;
begin
  AllocBuffer;
  SetArrayID(0);
  FDescAccessor.DescVersion := ARR_DESC_CURRENT_VERSION;
  WriteArray;
  if not FCached then
    FreeBuffer;
end;

procedure TCustomIBCArray.Check(Status: ISC_STATUS);
var
  SqlErrMsg, Msg: string;
  ErrorNumber, ErrorCode: integer;
begin
  if Status > 0 then begin
    ErrorCode := isc_sqlcode(FStatusVector);
    GetIBError(ErrorCode, ErrorNumber, FStatusVector, Msg, SqlErrMsg);
    raise EIBCError.Create(ErrorCode, ErrorNumber, Msg, SqlErrMsg);
  end;
end;

procedure TCustomIBCArray.CheckBounds(Bounds: array of integer);
var
  i: integer;
begin
  for i := 0 to ((High(Bounds) + 1) div 2) - 1 do begin
    if Bounds[i * 2] < FDescAccessor.LowBound[i] then
      raise Exception.CreateFmt(SArrayLowBoundError, [Bounds[i * 2]]);

    if Bounds[i * 2 + 1] > FDescAccessor.HighBound[i] then
      raise Exception.CreateFmt(SArrayHighBoundError,  [Bounds[i * 2 + 1]]);
  end;
end;

procedure TCustomIBCArray.CheckCachedIndices(Indices: array of integer);
var
  i: integer;
begin
  if Length(Indices) <> FDescAccessor.Dimensions then
    raise Exception.Create(SArrayDimensionError);
  for i := 0 to Length(Indices) - 1 do
    if (Indices[i] > FDescAccessor.HighBound[i]) or (Indices[i] < FDescAccessor.LowBound[i]) then
      raise Exception.CreateFmt(SArrayIndexError, [Indices[i]]);
end;

procedure TCustomIBCArray.CheckArrayIndices(Indices: array of integer);
var
  i: integer;
begin
  if Length(Indices) <> FArrayDimensions then
    raise Exception.Create(SArrayDimensionError);
  for i := 0 to Length(Indices) - 1 do
    if (Indices[i] > FArrayHighBounds[i]) or (Indices[i] < FArrayLowBounds[i]) then
      raise Exception.CreateFmt(SArrayIndexError, [Indices[i]]);
end;

procedure TCustomIBCArray.GetArrayInfo;
var
  pTableName, pColumnName: IntPtr;
  i: integer;
begin
  FDescAccessor.Clear;
  pTableName := Marshal.StringToHGlobalAnsi(FTableName);
  pColumnName := Marshal.StringToHGlobalAnsi(FColumnName);
  try
    Check(isc_array_lookup_bounds(FStatusVector, FDbHandle, FTrHandle,
      pTableName, pColumnName, FArrayDesc));
    FDescAccessor.Scale := ABS(FDescAccessor.Scale);
    ArrayDimensions := FDescAccessor.Dimensions;
    for i := 0 to FArrayDimensions - 1 do begin
      FArrayHighBounds[i] := FDescAccessor.GetHighBound(i);
      FArrayLowBounds[i] := FDescAccessor.GetLowBound(i);
    end;
    FInternalItemType := GetInternalItemType;
  finally
    Marshal.FreeCoTaskMem(pTableName);
    Marshal.FreeCoTaskMem(pColumnName);
  end;
end;

function TCustomIBCArray.GetArraySize: integer;
var
  ItemCount: integer;
  i: integer;
begin
  Result := 1;
  for i := 0 to FArrayDimensions - 1 do begin
    ItemCount := ArrayHighBound[i] - ArrayLowBound[i] + 1;
    Result := Result * ItemCount;
  end;
  Result := Result * GetItemSize;
end;

function TCustomIBCArray.GetSliceSize(Bounds: array of integer): integer;
var
  ItemCount: integer;
  i: integer;
begin
  Result := 1;
  for i := 0 to ((High(Bounds) + 1) div 2) - 1 do begin
    ItemCount := Bounds[i * 2 + 1] - Bounds[i * 2] + 1;
    Result := Result * ItemCount;
  end;
  Result := Result * GetItemSize;
end;

function TCustomIBCArray.GetCachedSize: integer;
var
  ItemCount: integer;
  i: integer;
begin
  Result := 1;
  for i := 0 to FDescAccessor.Dimensions - 1 do begin
    ItemCount := FDescAccessor.HighBound[i] - FDescAccessor.LowBound[i] + 1;
    Result := Result * ItemCount;
  end;
  Result := Result * GetItemSize;
end;

procedure TCustomIBCArray.ReadArray;
var
  Length: IntPtr;
begin
  AllocBuffer;
  Length := Marshal.AllocHGlobal(SizeOf(integer));
  try
    Marshal.WriteInt32(Length, GetCachedSize);
    Check(isc_array_get_slice(FStatusVector, FDbHandle, FTrHandle, FArrayID,
      FArrayDesc, FArrayBuffer, Length));
  finally
    Marshal.FreeHGlobal(Length);
  end;
end;

procedure TCustomIBCArray.ReadArraySlice(Bounds: array of integer);
var
  i: integer;
begin
  CheckBounds(Bounds);
  FDescAccessor.Dimensions := (High(Bounds) + 1) div 2;
  for i := 0 to FDescAccessor.Dimensions - 1 do begin
    FDescAccessor.LowBound[i] := Bounds[i * 2];
    FDescAccessor.HighBound[i] := Bounds[i * 2 + 1];
  end;
  ReadArray;
end;

procedure TCustomIBCArray.ReadArrayItem(Indices: array of integer);
var
  Bounds: array of integer;
  i: integer;
begin
  SetLength(Bounds, Length(Indices) * 2);
  for i := 0 to Length(Indices) - 1 do begin
    Bounds[i * 2] := Indices[i];
    Bounds[i * 2 + 1] := Indices[i];
  end;
  ReadArraySlice(Bounds);
end;

procedure TCustomIBCArray.WriteArray;
begin
  PutArray(0, GetCachedSize);
end;

procedure TCustomIBCArray.WriteArraySlice(Bounds: array of integer);
var
  TempDesc: IntPtr;
  Offset, Size: integer;
  i: integer;
  ADType: TARRAYDESCType;
begin
  if FCached then begin
    CheckBounds(Bounds);

    if GDSVersion >= 7 then
      ADType := adGDS7
    else
      ADType := adGDS;
    TempDesc := Marshal.AllocHGlobal(ARRAYDESC_LENGTH(ADType));
    try
      CopyBuffer(FArrayDesc, TempDesc, ARRAYDESC_LENGTH(ADType));
      try
        FDescAccessor.Dimensions := (High(Bounds) + 1) div 2;
        for i := 0 to FDescAccessor.Dimensions - 1 do begin
          FDescAccessor.LowBound[i] := Bounds[i * 2];
          FDescAccessor.HighBound[i] := Bounds[i * 2 + 1];
        end;
        Offset := GetSliceOffset(Bounds);
        Size := GetSliceSize(Bounds);
        PutArray(Offset, Size);
      finally
        CopyBuffer(TempDesc, FArrayDesc, ARRAYDESC_LENGTH(ADType));
      end;
    finally
      Marshal.FreeHGlobal(TempDesc);
    end;
  end;  
end;

procedure TCustomIBCArray.ClearArray;
begin
  if not Cached then
    AllocBuffer
  else
    FillChar(FArrayBuffer, GetCachedSize, $00);
  if not Cached then begin
    WriteArray;
    FreeBuffer;
  end;
end;

procedure TCustomIBCArray.PutArray(Offset: integer; Size: integer);
var
  Length: IntPtr;
begin
  if FArrayBuffer <> nil then begin
    Length := Marshal.AllocHGlobal(SizeOf(integer));
    try
      if (not FFirstWrite) and FCached then
        SetArrayID(0);
      Marshal.WriteInt32(Length, Size);
      Check(isc_array_put_slice(FStatusVector, FDbHandle, FTrHandle, FArrayID,
        FArrayDesc, IntPtr(Integer(FArrayBuffer) + Offset), Length));
      FModified := False;
      FFirstWrite := False;
    finally
      Marshal.FreeHGlobal(Length);
    end;
  end;
end;

procedure TCustomIBCArray.SetArrayDimensions(Value: integer);
const
  MAX_DIMENSIONS = 16;
begin
  if (Value < 0) or (Value > MAX_DIMENSIONS) then
    raise Exception.Create(SInvalidDimension);
  FArrayDimensions := Value;
  SetLength(FArrayHighBounds, FArrayDimensions);
  SetLength(FArrayLowBounds, FArrayDimensions);
  FDescAccessor.Dimensions := FArrayDimensions;
end;

function TCustomIBCArray.GetArrayHighBound(Dimension: integer): integer;
begin
  if FArrayDimensions <> Length(FArrayHighBounds) then
    raise Exception.Create(SInvalidDimension);
  if (Dimension < 0) or (Dimension >= FArrayDimensions) then
    raise Exception.Create(SInvalidDimension);
  Result := FArrayHighBounds[Dimension];
end;

procedure TCustomIBCArray.SetArrayHighBound(Dimension: integer; Value: integer);
begin
  if FArrayDimensions <> Length(FArrayHighBounds) then
    raise Exception.Create(SInvalidDimension);
  if (Dimension < 0) or (Dimension >= FArrayDimensions) then
    raise Exception.Create(SInvalidDimension);
  FArrayHighBounds[Dimension] := Value;
  FDescAccessor.HighBound[Dimension] := Value;
end;

function TCustomIBCArray.GetArrayLowBound(Dimension: integer): integer;
begin
  if FArrayDimensions <> Length(FArrayLowBounds) then
    raise Exception.Create(SInvalidDimension);
  if (Dimension < 0) or (Dimension >= FArrayDimensions) then
    raise Exception.Create(SInvalidDimension);
  Result := FArrayLowBounds[Dimension];
end;

procedure TCustomIBCArray.SetArrayLowBound(Dimension: integer; Value: integer);
begin
  if FArrayDimensions <> Length(FArrayLowBounds) then
    raise Exception.Create(SInvalidDimension);
  if (Dimension < 0) or (Dimension >= FArrayDimensions) then
    raise Exception.Create(SInvalidDimension);
  FArrayLowBounds[Dimension] := Value;
  FDescAccessor.LowBound[Dimension] := Value;
end;

function TCustomIBCArray.GetCachedDimensions: integer;
begin
  Result := FDescAccessor.Dimensions;
end;

function TCustomIBCArray.GetCachedHighBound(Dimension: integer): integer;
begin
  Result := FDescAccessor.HighBound[Dimension];
end;

function TCustomIBCArray.GetCachedLowBound(Dimension: integer): integer;
begin
  Result := FDescAccessor.LowBound[Dimension];
end;

function TCustomIBCArray.GetInternalItemType: Word;
begin
  case FDescAccessor.DataType of
    blr_double, blr_float, blr_d_float, blr_int64:
      Result := dtFloat;
    blr_long:
      Result := dtInteger;
    blr_short:
      Result := dtSmallInt;
    blr_boolean_dtype:
      Result := dtBoolean;
    blr_sql_date:
      Result := dtDate;
    blr_sql_time:
      Result := dtTime;
    blr_timestamp:
      Result := dtDateTime;
    blr_cstring, blr_cstring2,
    blr_text, blr_text2,
    blr_Varying, blr_varying2:
      Result := dtString;
    else
      Result := dtUnknown;
  end;
end;

function TCustomIBCArray.GetItemScale: integer;
begin
  Result := FDescAccessor.Scale;
end;

procedure TCustomIBCArray.SetItemScale(Value: integer);
begin
  FDescAccessor.Scale := Value;
end;

function TCustomIBCArray.GetItems: Variant;
var
  Bounds: array of integer;
  i: integer;
begin
  if (not FCached) or (FArrayBuffer = nil) then
    ReadArray;
  SetLength(Bounds, FDescAccessor.Dimensions * 2);
  for i := 0 to FDescAccessor.Dimensions - 1 do begin
    Bounds[i * 2] := FDescAccessor.LowBound[i];
    Bounds[i * 2 + 1] := FDescAccessor.HighBound[i];
  end;
  Result := BufToVarArray(Bounds);
  if not FCached then
    FreeBuffer
end;

function TCustomIBCArray.GetItemsSlice(Bounds: array of integer): Variant;
begin
  if (not FCached) or (FArrayBuffer = nil) then
    ReadArraySlice(Bounds);
  Result := BufToVarArray(Bounds);
  if not FCached then
    FreeBuffer;
end;

procedure TCustomIBCArray.SetItemsSlice(const Values: variant);
var
  Bounds: array of integer;
  i: integer;
begin
  if VarIsEmpty(Values) or VarIsNull(Values) then
    ClearArray
  else
  if VarIsArray(Values) then begin
    if not FCached then
      AllocBuffer;
    SetLength(Bounds, VarArrayDimCount(Values) * 2);
    for i := 0 to ((High(Bounds) + 1) div 2) - 1 do begin
      Bounds[i * 2] := VarArrayLowBound(Values, i + 1);
      Bounds[i * 2 + 1] := VarArrayHighBound(Values, i + 1);
    end;
    CheckBounds(Bounds);
    VarArrayToBuf(Values);
    if not FCached then begin
      WriteArraySlice(Bounds);
      FreeBuffer;
    end
    else
      FModified := True;
  end
  else
    raise Exception.Create(SVarIsNotArray);
end;

procedure TCustomIBCArray.SetItems(const Values: Variant);
var