ibcarrayuni.pas

CrLab UniDAC 1.0 include sources

//////////////////////////////////////////////////
//  InterBase Data Access Components
//  Copyright (c) 2006-2008 Core Lab. All right reserved.
//  InterBase Arrays
//////////////////////////////////////////////////

{$IFNDEF CLR}
{$I IbDac.inc}
unit IBCArrayUni;
{$ENDIF}

interface

uses
  Classes,
{$IFDEF CLR}
  Variants,
{$ELSE}
  CLRClasses,
{$ENDIF}
  SysUtils, MemData, MemUtils, {$IFNDEF UNIDACPRO}IBCCall{$ELSE}IBCCallUni{$ENDIF};

type
  TIBCIntegerDynArray = array of integer;

  TARRAYDESCType = (adGDS, adGDS7);

  TDescAccessor = class
  public
    FDesc: IntPtr;
    FArrayDescType: TARRAYDESCType;
    function GetDescVersion: SmallInt;
    procedure SetDescVersion(Value: SmallInt);
    function GetColumnName: string;
    procedure SetColumnName(Value: string);
    function GetRelationName: string;
    procedure SetRelationName(value: string);
    function GetLength: SmallInt;
    procedure SetLength(Value: SmallInt);
    function GetDimensions: SmallInt;
    procedure SetDimensions(Value: SmallInt);
    function GetHighBound(Dimension: integer): SmallInt;
    procedure SetHighBound(Dimension: integer; Value: SmallInt);
    function GetLowBound(Dimension: integer): SmallInt;
    procedure SetLowBound(Dimension: integer; Value: SmallInt);
    function GetDataType: byte;
    procedure SetDataType(Value: byte);
    function GetScale: ShortInt;
    procedure SetScale(Value: ShortInt);
  protected
    procedure SetDesc(Desc: IntPtr);
  public
    constructor Create(ArrayDescType: TARRAYDESCType; Desc: IntPtr);
    procedure Clear;
    property DescVersion: SmallInt read GetDescVersion write SetDescVersion;
    property ColumnName: string read GetColumnName write SetColumnName;
    property RelationName: string read GetRelationName write SetRelationName;
    property Length: SmallInt read GetLength write SetLength;
    property Dimensions: SmallInt read GetDimensions write SetDimensions;
    property HighBound[Dimension: integer]: SmallInt read GetHighBound write SetHighBound;
    property LowBound[Dimension: integer]: SmallInt read GetLowBound write SetLowBound;
    property DataType: byte read GetDataType write SetDataType;
    property Scale: ShortInt read GetScale write SetScale;
  end;

  TCustomIBCArray = class(TDBObject)
  private
    FStatusVector: TStatusVector;
    FDbHandle: PISC_DB_HANDLE;
    FTrHandle: PISC_TR_HANDLE;
    FArrayID: PISC_QUAD;
    FArrayDesc: IntPtr;
    FTableName: string;
    FColumnName: string;
    FArrayBuffer: IntPtr;
    FCached: boolean;
    FNativeDesc: boolean;
    FFirstWrite: boolean;

    FArrayDimensions: integer;
    FArrayHighBounds: array of integer;
    FArrayLowBounds: array of integer;

    FModified: boolean;

    procedure AllocBuffer;
    procedure FreeBuffer;

    procedure PutArray(Offset: integer; Size: integer);

    function BufItemToVariant(Offset: integer): variant;
    function BufToVarArray(Bounds: array of integer): variant;

    procedure VariantToBufItem(const Value: variant; Offset: integer);
    procedure VarArrayToBuf(const Values: variant);

    procedure Check(Status: ISC_STATUS);
    procedure CheckBounds(Bounds: array of integer);
    procedure CheckCachedIndices(Indices: array of integer);
    procedure CheckArrayIndices(Indices: array of integer);

    function GetArrayID: TISC_QUAD;
    procedure SetArrayID(const Value: TISC_QUAD);

    function GetDbHandle: TISC_DB_HANDLE;
    procedure SetDbHandle(Value: TISC_DB_HANDLE);

    function GetTrHandle: TISC_TR_HANDLE;
    procedure SetTrHandle(Value: TISC_TR_HANDLE);

    procedure SetColumnName(const Value: string);
    procedure SetTableName(const Value: string);

    procedure SetArrayDimensions(Value: integer);

    function GetArrayHighBound(Dimension: integer): integer;
    procedure SetArrayHighBound(Dimension: integer; Value: integer);

    function GetArrayLowBound(Dimension: integer): integer;
    procedure SetArrayLowBound(Dimension: integer; Value: integer);

    function GetCachedDimensions: integer;
    function GetCachedHighBound(Dimension: integer): integer;
    function GetCachedLowBound(Dimension: integer): integer;

    function GetItemScale: integer;
    procedure SetItemScale(Value: integer);

    function GetItemSize: integer;
    procedure SetItemSize(Value: integer);

    function GetItemOffset(Indices: array of integer): integer;
    function GetSliceOffset(Bounds: array of integer): integer;

    function GetItemCount(Bounds: array of integer): integer;

    function GetItemVarType: integer;

    function GetItems: variant;
    procedure SetItems(const Values: variant);

    function GetIsNull: boolean;
    procedure SetIsNull(const Value: boolean);

    function GetArraySize: integer;
    function GetSliceSize(Bounds: array of integer): integer;
    function GetCachedSize: integer;

    procedure SetCached(Value: boolean);
    function GetArrayIndices(Name: string): TIBCIntegerDynArray;

    function GetAsString: string;
    procedure SetAsString(Value: string);

  protected
    FInternalItemType: word;
    FDescAccessor: TDescAccessor;

    function GetInternalItemType: Word;

    procedure GetAttributeValue(Name: string; Dest: IntPtr; var IsBlank: boolean); override;
    procedure SetAttributeValue(Name: string; Source: IntPtr); override;

    procedure SetArrayDesc(Desc: IntPtr);
    function GetArrayIDPtr: PISC_QUAD;
  public
    constructor Create(DbHandle: TISC_DB_HANDLE; TrHandle: TISC_TR_HANDLE); overload;
    constructor Create(DbHandle: TISC_DB_HANDLE; TrHandle: TISC_TR_HANDLE; TableName, ColumnName: string); overload;
    destructor Destroy; override;

    procedure GetArrayInfo;

    procedure CreateTemporaryArray;

    procedure ReadArray;
    procedure ReadArraySlice(Bounds: array of integer);
    procedure ReadArrayItem(Indices: array of integer);

    procedure WriteArray;
    procedure WriteArraySlice(Bounds: array of integer);

    procedure ClearArray;

    procedure Assign(Source: TCustomIBCArray);
    property Modified: boolean read FModified;

    property DbHandle: TISC_DB_HANDLE read GetDbHandle write SetDbHandle;
    property TrHandle: TISC_TR_HANDLE read GetTrHandle write SetTrHandle;

    property TableName: string read FTableName write SetTableName;
    property ColumnName: string read FColumnName write SetColumnName;

    property ArrayID: TISC_QUAD read GetArrayID write SetArrayID;

    property ArrayDimensions: integer read FArrayDimensions write SetArrayDimensions;
    property ArrayLowBound[Dimension: integer]: integer read GetArrayLowBound write SetArrayLowBound;
    property ArrayHighBound[Dimension: integer]: integer read GetArrayHighBound write SetArrayHighBound;
    property ArraySize: integer read GetArraySize;

    property Cached: boolean read FCached write SetCached;
    property IsNull: boolean read GetIsNull write SetIsNull;

    property CachedDimensions: integer read GetCachedDimensions;
    property CachedLowBound[Dimension: integer]: integer read GetCachedLowBound;
    property CachedHighBound[Dimension: integer]: integer read GetCachedHighBound;
    property CachedSize: integer read GetCachedSize;
    property ItemSize: integer read GetItemSize write SetItemSize;
    property ItemScale: integer read GetItemScale write SetItemScale;

    property Items: variant read GetItems write SetItems;
    function GetItemsSlice(Bounds: array of integer): variant;
    procedure SetItemsSlice(const Values: variant);

    function GetItemValue(Indices: array of integer): variant;
    procedure SetItemValue(Indices: array of integer; Value: variant);

    function GetItemAsString(Indices: array of integer): string;
    procedure SetItemAsString(Indices: array of integer; Value: string);

    function GetItemAsWideString(Indices: array of integer): WideString;
    procedure SetItemAsWideString(Indices: array of integer; Value: WideString);

    function GetItemAsInteger(Indices: array of integer): integer;
    procedure SetItemAsInteger(Indices: array of integer; Value: integer);

    function GetItemAsSmallInt(Indices: array of integer): SmallInt;
    procedure SetItemAsSmallInt(Indices: array of integer; Value: SmallInt);

    function GetItemAsFloat(Indices: array of integer): double;
    procedure SetItemAsFloat(Indices: array of integer; Value: double);

    function GetItemAsDateTime(Indices: array of integer): TDateTime;
    procedure SetItemAsDateTime(Indices: array of integer; Value: TDateTime);

    property AsString: string read GetAsString write SetAsString;
  end;

  TIBCArrayType = class(TObjectType)
  private
    FDbHandle: PISC_DB_HANDLE;
    FTrHandle: PISC_TR_HANDLE;
    FTableName: string;
    FColumnName: string;
    FStatusVector: TStatusVector;
    FArrayDesc: IntPtr;
    FDescAccessor: TDescAccessor;
    FLowBound: integer;
    FADType: TARRAYDESCTYPE;
    function GetDbHandle: TISC_DB_HANDLE;
    procedure SetDbHandle(Value: TISC_DB_HANDLE);
    function GetTrHandle: TISC_TR_HANDLE;
    procedure SetTrHandle(Value: TISC_TR_HANDLE);
    procedure Check(Status: ISC_STATUS);
    procedure SetLowBound(const Value: integer);
  public
    constructor Create(DbHandle: TISC_DB_HANDLE; TrHandle: TISC_TR_HANDLE;
      TableName, ColumnName: string; NeedDescribe: boolean = True);
    destructor Destroy; override;
    procedure Describe(DbHandle: TISC_DB_HANDLE; TrHandle: TISC_TR_HANDLE; TableName, ColumnName: string);
    property DbHandle: TISC_DB_HANDLE read GetDbHandle write SetDbHandle;
    property TrHandle: TISC_TR_HANDLE read GetTrHandle write SetTrHandle;
    property ArrayDesc: IntPtr read FArrayDesc;

    property LowBound: integer read FLowBound write SetLowBound;
  end;

  TIBCArrayUtils = class
    class procedure SetArrayDesc(Obj: TCustomIBCArray; Desc: IntPtr);
    class function GetArrayIDPtr(Obj: TCustomIBCArray): PISC_QUAD;
  end;

implementation

uses
{$IFDEF CLR}
  System.Runtime.InteropServices,
{$ELSE}
  {$IFDEF VER6P} Variants, {$ENDIF}
{$ENDIF}
  {$IFNDEF UNIDACPRO}IBCClasses{$ELSE}IBCClassesUni{$ENDIF}, CRParser,
  {$IFNDEF UNIDACPRO}IBCParser{$ELSE}IBCParserUni{$ENDIF},
  {$IFNDEF UNIDACPRO}IBCError{$ELSE}IBCErrorUni{$ENDIF}, DAConsts,
  {$IFNDEF UNIDACPRO}IBCConsts{$ELSE}IBCConstsUni{$ENDIF}, CRAccess;

function ARRAYDESC_LENGTH(ArrayDescType: TARRAYDESCType): integer;
begin
  if ArrayDescType = adGDS7 then
    Result := SizeOfISC_ARRAY_DESC_V2
  else
    Result := SizeOfISC_ARRAY_DESC;
end;

{$IFNDEF VER6P}
type
  TVarType = Word;

function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: Pointer; var pvData: Pointer): HResult; stdcall;
  external 'oleaut32.dll' name 'SafeArrayPtrOfIndex';

function SafeArrayGetElement(VarArray: PVarArray; Indices, Data: Pointer): Integer; stdcall;
  external 'oleaut32.dll' name 'SafeArrayGetElement';

function SafeArrayPutElement(VarArray: PVarArray; Indices, Data: Pointer): Integer; stdcall;
  external 'oleaut32.dll' name 'SafeArrayPutElement';

function GetVarArray(const A: Variant): PVarArray;
begin
  if TVarData(A).VType and varArray = 0 then
    raise Exception.Create(SVarIsNotArray);
  if TVarData(A).VType and varByRef <> 0 then
    Result := PVarArray(TVarData(A).VPointer^)
  else
    Result := TVarData(A).VArray;
end;

function _VarArrayGet(var A: Variant; IndexCount: Integer;
  Indices: Integer): Variant; cdecl;
var
  VarArrayPtr: PVarArray;
  VarType: Integer;
  P: Pointer;
begin
  if TVarData(A).VType and varArray = 0 then
    raise Exception.Create(SVarIsNotArray);
  VarArrayPtr := GetVarArray(A);
  if VarArrayPtr^.DimCount <> IndexCount then
    raise Exception.create(SVarArrayBounds);
  VarType := TVarData(A).VType and varTypeMask;
  VarClear(Result);
  if VarType = varVariant then begin
    if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
      raise Exception.Create(SVarArrayBounds);
    Result := PVariant(P)^;
  end
  else begin
    if SafeArrayGetElement(VarArrayPtr, @Indices, @TVarData(Result).VPointer) <> 0 then
      raise Exception.Create(SVarArrayBounds);
    TVarData(Result).VType := VarType;
  end;
end;

function VarArrayGet(const A: Variant; const Indices: array of Integer): Variant;
asm
        PUSH    EBX

        MOV     EBX,ECX
        INC     EBX
        JLE     @@endLoop
@@loop:
        PUSH    [EDX+ECX*4].Integer
        DEC     ECX
        JNS     @@loop
@@endLoop:
        PUSH    EBX
        PUSH    EAX
        MOV     EAX,[EBP+8]
        PUSH    EAX
        CALL    _VarArrayGet
        LEA     ESP,[ESP+EBX*4+3*4]

        POP     EBX
end;

procedure VarStringToOleStr(var Dest: Variant; const Source: Variant);
var
  OleStrPtr: PWideChar;
begin
  OleStrPtr := StringToOleStr(string(TVarData(Source).VString));
  VarClear(Dest);
  TVarData(Dest).VType := varOleStr;
  TVarData(Dest).VOleStr := OleStrPtr;
end;

procedure _VarArrayPut(var A: Variant; const Value: Variant;
  IndexCount: Integer; Indices: Integer); cdecl;
type
  TAnyPutArrayProc = procedure (var A: Variant; const Value: Variant; Index: Integer);
var
  VarArrayPtr: PVarArray;
  VarType: Integer;
  P: Pointer;
  Temp: TVarData;
begin
  if TVarData(A).VType and varArray = 0 then
    raise Exception.Create(SVarIsNotArray);
  VarArrayPtr := GetVarArray(A);
  if VarArrayPtr^.DimCount <> IndexCount then
    raise Exception.Create(SVarArrayBounds);
  VarType := TVarData(A).VType and varTypeMask;
  if (VarType = varVariant) and (TVarData(Value).VType <> varString) then
  begin
    if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
      raise Exception.Create(SVarArrayBounds);
    PVariant(P)^ := Value;
  end else
  begin
    Temp.VType := varEmpty;
    try
      if VarType = varVariant then
      begin
        VarStringToOleStr(Variant(Temp), Value);
        P := @Temp;
      end else
      begin
        VarCast(Variant(Temp), Value, VarType);
        case VarType of
          varOleStr, varDispatch, varUnknown:
            P := Temp.VPointer;
        else
          P := @Temp.VPointer;
        end;
      end;
      if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then
        raise Exception.Create(SVarArrayBounds);
    finally
      VarClear(Variant(Temp));
    end;