ibcarrayuni.pas

CrLab UniDAC 1.0 include sources

  i: integer;
begin
  if VarIsEmpty(Values) or VarIsNull(Values) then
    ClearArray
  else
  if VarIsArray(Values) then begin
    if (not FCached) or (FArrayBuffer = nil) then
      AllocBuffer;
    if FDescAccessor.Dimensions <> VarArrayDimCount(Values) then
      raise Exception.Create(SArrayDimensionError);
    for i := 0 to FDescAccessor.Dimensions - 1 do begin
      if (FDescAccessor.HighBound[i] - FDescAccessor.LowBound[i] + 1) <>
        (VarArrayHighBound(Values, i + 1) - VarArrayLowBound(Values, i + 1) + 1) then
        raise Exception.Create(SInvalidDimension);
    end;
    VarArrayToBuf(Values);
    if not FCached then begin
      WriteArray;
      FreeBuffer;
    end
    else
      FModified := True;
  end
  else
    raise Exception.Create(SVarIsNotArray);
end;

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

function TCustomIBCArray.GetItemSize: integer;
begin
  Result := FDescAccessor.Length;
  case FDescAccessor.DataType of
    blr_varying, blr_varying2:
      Inc(Result, 2);
  end;
end;

procedure TCustomIBCArray.SetItemSize(Value: integer);
begin
  FDescAccessor.Length := Value;
end;

function TCustomIBCArray.GetItemVarType: integer;
begin
  case FDescAccessor.DataType of
    blr_boolean_dtype:
      Result := varBoolean;
    blr_short:
      Result := varSmallint;
    blr_long:
      Result := varInteger;
    blr_float:
      Result := varSingle;
    blr_double, blr_d_float, blr_int64:
      Result := varDouble;
    blr_date, blr_sql_date, blr_sql_time:
      Result := varDate;
    else
      Result := varVariant;
  end;
end;

function TCustomIBCArray.GetItemOffset(Indices: array of integer): integer;

  function GetItemsCount(Index, SubCount: integer): integer;
  begin
    Result := (Indices[Index] - FDescAccessor.LowBound[Index]) * SubCount;
    if Index = 0 then
      Exit;
    SubCount := SubCount * (FDescAccessor.HighBound[Index] - FDescAccessor.LowBound[Index] + 1);
    Result := Result + GetItemsCount(Index - 1, SubCount);
  end;

begin
  if Length(Indices) > 0 then
    Result := GetItemsCount(High(Indices), 1)
  else
    Result := 0;
  Result := Result * GetItemSize;
end;

function TCustomIBCArray.GetSliceOffset(Bounds: array of integer): integer;
var
  i: integer;
  SliceItemCount: integer;

begin
  Result := 0;
  i := ((High(Bounds) + 1) div 2) - 1;
  SliceItemCount := Bounds[i * 2 + 1] - Bounds[i * 2] + 1;
  for i := ((High(Bounds) + 1) div 2) - 1 downto 0 do
    Result := Result + (Bounds[i * 2] - FArrayLowBounds[i]) * SliceItemCount;
  Result := Result * GetItemSize;
end;

function TCustomIBCArray.BufItemToVariant(Offset: integer): variant;
var
  tm_date: TCTimeStructure;
begin
  case FDescAccessor.DataType of
    blr_long:
      Result := Marshal.ReadInt32(FArrayBuffer, Offset);
    blr_short:
      Result := Marshal.ReadInt16(FArrayBuffer, Offset);
    blr_float:
    {$IFDEF CLR}
      Result := BitConverter.ToSingle(BitConverter.GetBytes(Marshal.ReadInt32(FArrayBuffer, Offset)), 0);
    {$ELSE}
      Result := Single(IntPtr(Integer(FArrayBuffer) + Offset)^);
    {$ENDIF}
    blr_double:
      Result := BitConverter.Int64BitsToDouble(Marshal.ReadInt64(FArrayBuffer, Offset));
    blr_int64:
      if (FDescAccessor.Scale <> 0) then
        Result := BitConverter.Int64BitsToDouble(Marshal.ReadInt64(FArrayBuffer, Offset))
      else
      {$IFDEF VER6P}
        Result := Marshal.ReadInt64(FArrayBuffer, Offset);
      {$ELSE}
        begin
          TVarData(Result).VType := varDecimal;
          TVarDataD6(Result).VInt64 := Int64(IntPtr(Integer(FArrayBuffer) + Offset)^);
        end;
      {$ENDIF}
    blr_boolean_dtype:
      Result := Marshal.ReadInt16(FArrayBuffer, Offset) = 1;
    blr_sql_date: begin
      isc_decode_sql_date(IntPtr(Integer(FArrayBuffer) + Offset), tm_date);
      Result := EncodeDate(tm_date.tm_year + 1900, tm_date.tm_mon + 1, tm_date.tm_mday);
    end;
    blr_sql_time: begin
      isc_decode_sql_time(IntPtr(Integer(FArrayBuffer) + Offset), tm_date);
      Result := EncodeTime(tm_date.tm_hour, tm_date.tm_min, tm_date.tm_sec, 0);
    end;
    blr_timestamp: begin
      isc_decode_date(IntPtr(Integer(FArrayBuffer) + Offset), tm_date);
      Result := EncodeDate(tm_date.tm_year + 1900, tm_date.tm_mon + 1, tm_date.tm_mday);
      if Result >= 0 then
        Result := Result + EncodeTime(tm_date.tm_hour, tm_date.tm_min, tm_date.tm_sec, 0)
      else
        Result := Result - EncodeTime(tm_date.tm_hour, tm_date.tm_min, tm_date.tm_sec, 0);
    end;
    blr_text, blr_text2, blr_cstring, blr_cstring2:
      Result := Marshal.PtrToStringAnsi(IntPtr(Integer(FArrayBuffer) + Offset), FDescAccessor.Length);
    blr_varying, blr_varying2:
      Result := Marshal.PtrToStringAnsi(IntPtr(Integer(FArrayBuffer) + Offset));
    else
      Result := Unassigned;
  end;
end;

function TCustomIBCArray.BufToVarArray(Bounds: array of integer): variant;
var
  Indices: array of integer;
  Offset: integer;
  i: integer;

  procedure UpdateIndices;
  var
    i: integer;
  begin
    for i := VarArrayDimCount(Result) - 1 downto 0 do
      if Indices[i] = VarArrayHighBound(Result, i + 1) then
        Indices[i] := VarArrayLowBound(Result, i + 1)
      else begin
        Indices[i] := Indices[i] + 1;
        Break;
      end;
  end;

begin
  CheckBounds(Bounds);
  Result := VarArrayCreate(Bounds, GetItemVarType);
  SetLength(Indices, FDescAccessor.Dimensions);
  for i := 0 to FDescAccessor.Dimensions - 1 do
    Indices[i] := VarArrayLowBound(Result, i + 1);
  Offset := GetSliceOffset(Bounds);
  for i := 0 to GetItemCount(Bounds) - 1 do begin
    VarArrayPut(Result, BufItemToVariant(Offset), Indices);
    UpdateIndices;
    Inc(Offset, GetItemSize);
  end;
end;

procedure TCustomIBCArray.VariantToBufItem(const Value: variant; Offset: integer);
var
  SPtr: IntPtr;
  Len: integer;
begin
  case FDescAccessor.DataType of
    blr_long:
      if VarIsType(Value, varInteger) then
        Marshal.WriteInt32(FArrayBuffer, Offset, Value);
    blr_short:
      if VarIsType(Value, varSmallint) then
        Marshal.WriteInt16(FArrayBuffer, Offset, SmallInt(Value));
    blr_float:
      if VarIsType(Value, varSingle) then
      {$IFDEF CLR}
        Marshal.WriteInt32(FArrayBuffer, Offset, BitConverter.ToInt32(BitConverter.GetBytes(Single(Value)), 0));
      {$ELSE}
        Single(IntPtr(Integer(FArrayBuffer) + Offset)^) := Single(Value);
      {$ENDIF}
    blr_double:
      if VarIsType(Value, varDouble) then
      {$IFDEF CLR}
        Marshal.WriteInt64(FArrayBuffer, Offset, BitConverter.DoubleToInt64Bits(Value));
      {$ELSE}
        Double(IntPtr(Integer(FArrayBuffer) + Offset)^) := Double(Value);
      {$ENDIF}
    blr_int64:
      if (FDescAccessor.Scale <> 0) then
        Marshal.WriteInt64(FArrayBuffer, Offset, BitConverter.DoubleToInt64Bits(Value))
      else
        Marshal.WriteInt64(FArrayBuffer, Offset, BitConverter.DoubleToInt64Bits(Value));
    blr_boolean_dtype:
      if VarIsType(Value, varBoolean) then
        Marshal.WriteInt16(FArrayBuffer, Offset, SmallInt(WordBool(Value)));
    blr_sql_date:
      DateTimeToSQLDate(TDateTime(Value), IntPtr(Integer(FArrayBuffer) + Offset));
    blr_sql_time:
      DateTimeToSQLTime(TDateTime(Value), IntPtr(Integer(FArrayBuffer) + Offset));
    blr_timestamp:
      DateTimeToSQLTimeStamp(TDateTime(Value), IntPtr(Integer(FArrayBuffer) + Offset));
    blr_text, blr_text2, blr_cstring, blr_cstring2, blr_varying, blr_varying2:
      if Value <> '' then begin
        Len := Length(Value);
        if Len > FDescAccessor.Length then
          Len := FDescAccessor.Length;
        if Len > 0 then begin
          SPtr := Marshal.StringToHGlobalAnsi(String(Value));
          try
            FillChar(IntPtr(Integer(FArrayBuffer) + Offset), FDescAccessor.Length, $00);
            CopyBuffer(SPtr, IntPtr(Integer(FArrayBuffer) + Offset), Len);
          finally
            Marshal.FreeCoTaskMem(SPtr);
          end;
          Marshal.WriteByte(IntPtr(Integer(FArrayBuffer) + Offset), Len, $00);
        end;
      end;
    else
      raise Exception.Create(SDataTypeNotSupported);
  end;
end;

procedure TCustomIBCArray.VarArrayToBuf(const Values: Variant);
var
  i: integer;
  Value: Variant;
  ItemCount: integer;
  Indices: array of integer;
  VarDimesion: integer;

  procedure UpdateIndices;
  var
    i: integer;
  begin
    for i := VarArrayDimCount(Values) - 1 downto 0 do
      if Indices[i] = VarArrayHighBound(Values, i + 1) then
        Indices[i] := VarArrayLowBound(Values, i + 1)
      else begin
        Indices[i] := Indices[i] + 1;
        Break;
      end;
  end;

begin
  VarDimesion := VarArrayDimCount(Values);
  SetLength(Indices, VarDimesion);
  ItemCount := 1;
  for i := 0 to VarDimesion - 1 do begin
    ItemCount := ItemCount * (VarArrayHighBound(Values, i + 1) - VarArrayLowBound(Values, i + 1) + 1);
    Indices[i] := VarArrayLowBound(Values, i + 1);
  end;
  if FArrayBuffer = nil then
    AllocBuffer;
  for i := 0 to ItemCount - 1 do begin
    Value := VarArrayGet(Values, Indices);
    VariantToBufItem(Value, GetItemOffset(Indices));
    UpdateIndices;
  end;
end;

procedure TCustomIBCArray.Assign(Source: TCustomIBCArray);
begin
  FCached := Source.FCached;
  if GetCachedSize <> Source.GetCachedSize then
    FreeBuffer;
  DbHandle := Source.DbHandle;
  TrHandle := Source.TrHandle;
  FTableName := Source.FTableName;
  FColumnName := Source.FColumnName;
  ArrayID := Source.ArrayID;
  SetArrayDesc(Source.FArrayDesc);
  if Source.FArrayBuffer <> nil then begin
    if FArrayBuffer = nil then
      AllocBuffer;
    MemUtils.CopyBuffer(Source.FArrayBuffer, FArrayBuffer, GetCachedSize);
  end;
end;

function TCustomIBCArray.GetIsNull: boolean;
begin
  Result := (GetArrayID = 0) and (FArrayBuffer = nil);
end;

procedure TCustomIBCArray.SetIsNull(const Value: boolean);
begin
  SetArrayID(0);
  FreeBuffer;
end;

function TCustomIBCArray.GetItemValue(Indices: array of integer): Variant;
var
  Offset: integer;
begin
  if not FCached then begin
    CheckArrayIndices(Indices);
    ReadArrayItem(Indices);
    Offset := 0;
  end
  else begin
    CheckCachedIndices(Indices);
    if FArrayBuffer = nil then
      ReadArray;
    Offset := GetItemOffset(Indices);
  end;
  Result := BufItemToVariant(Offset);
  if not FCached then
    FreeBuffer;
end;

procedure TCustomIBCArray.SetItemValue(Indices: array of integer; Value: Variant);
var
  Offset: integer;
  TempDesc: IntPtr;
  i: integer;
  ADType: TARRAYDESCType;
begin
  TempDesc := nil;
  ADType := adGDS7;
  if not FCached then begin
    if GDSVersion >= 7 then
      ADType := adGDS7
    else
      ADType := adGDS;
    TempDesc := Marshal.AllocHGlobal(ARRAYDESC_LENGTH(ADType));
    CopyBuffer(FArrayDesc, TempDesc, ARRAYDESC_LENGTH(ADType));
    FDescAccessor.Dimensions := Length(Indices);
    for i := 0 to FDescAccessor.Dimensions - 1 do begin
      FDescAccessor.LowBound[i] := Indices[i];
      FDescAccessor.HighBound[i] := Indices[i];
    end;
    AllocBuffer;
    Offset := 0;
  end
  else begin
    if FArrayBuffer = nil then
      AllocBuffer;
    Offset := GetItemOffset(Indices);
  end;
  VariantToBufItem(Value, Offset);
  if not FCached then begin
    PutArray(0, GetItemSize);
    if TempDesc <> nil then begin
      CopyBuffer(TempDesc, FArrayDesc, ARRAYDESC_LENGTH(ADType));
      Marshal.FreeHGlobal(TempDesc);
    end;
    FreeBuffer;
  end
  else
    FModified := True;
end;

function TCustomIBCArray.GetItemAsString(Indices: array of integer): string;
begin
  if FInternalItemType = dtString then
    Result := GetItemValue(Indices)
  else
    Result := '';
end;

procedure TCustomIBCArray.SetItemAsString(Indices: array of integer; Value: string);
begin
  if FInternalItemType = dtString then
    SetItemValue(Indices, Value);
end;

function TCustomIBCArray.GetItemAsWideString(Indices: array of integer): WideString;
begin
  if FInternalItemType = dtWideString then
    Result := GetItemValue(Indices)
  else
  if FInternalItemType = dtString then
    Result := GetItemAsString(Indices)
  else
    Result := '';
end;

procedure TCustomIBCArray.SetItemAsWideString(Indices: array of integer; Value: WideString);
begin
  if FInternalItemType in [dtWideString, dtString] then
    SetItemValue(Indices, Value);
end;

function TCustomIBCArray.GetItemAsInteger(Indices: array of integer): integer;
begin
  if FInternalItemType = dtInteger then
    Result := GetItemValue(Indices)
  else