{***************************************************************}
{ FIBPlus - component library for direct access to Firebird and }
{ Interbase databases                                           }
{                                                               }
{    FIBPlus is based in part on the product                    }
{    Free IB Components, written by Gregory H. Deatz for        }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.            }
{    mailto:gdeatz@hlmdd.com                                    }
{                                                               }
{    Copyright (c) 1998-2001 Serge Buzadzhy                     }
{    Contact: buzz@devrace.com                                  }
{                                                               }
{ ------------------------------------------------------------- }
{    FIBPlus home page      : http://www.fibplus.net/           }
{    FIBPlus support e-mail : fibplus@devrace.com               }
{ ------------------------------------------------------------- }
{                                                               }
{  Please see the file License.txt for full license information }
{***************************************************************}



unit pFIBArray;
{$I FIBPlus.inc}

interface

uses
 {$IFDEF WINDOWS}
  Windows, SysUtils, Classes, ibase,IB_Intf, ib_externals,
  DB, fib, FIBDatabase, StdFuncs
  {$IFDEF D6+}, Variants{$ENDIF}
  ;

 {$ENDIF}
 {$IFDEF LINUX}
  Types, SysUtils, Classes, ibase,IB_Intf, IB_Externals,
  DB, fib, FIBDatabase,  StdFuncs,
   Variants;

 {$ENDIF}

 type TpFIBArray=class
      private
       FClientLibrary:IIBClientLibrary;
       FXSQLVAR:PXSQLVAR;
       FArrayType:TFieldType;
       FTableName:string;
       FFieldName:string;
       vISC_ARRAY_DESC:TISC_ARRAY_DESC;
       function GetDimensionCount:Integer;
       function GetDimension(Index: Integer): TISC_ARRAY_BOUND;
       function GetSliceSize(aISC_ARRAY_DESC:TISC_ARRAY_DESC):integer;
       function GetArraySize:integer;
       procedure VariantToBuffer(Value:Variant;var ToBuffer:PChar);
       procedure PutArrayBuf(var Buffer,ToBuffer:PChar;
        DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       );
       function GetElementBuf(Buffer:PChar;
         aISC_ARRAY_DESC:TISC_ARRAY_DESC;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       ):Variant;
       procedure PutElementBuf(Value:Variant;var ToBuffer:PChar;
        aISC_ARRAY_DESC:TISC_ARRAY_DESC;
        DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       );

       function GetFieldData(Field:TField;var ToBuffer:PChar):boolean;
       function GetScale: Byte;

      public
       constructor Create(ClientLibrary:IIBClientLibrary;aFXSQLVAR:PXSQLVAR;
        DBHandle: PISC_DB_HANDLE;
        TRHandle: PISC_TR_HANDLE;
        const ATableName,AFieldName:string
       ); overload;

       destructor Destroy; override;
       function GetArrayValues(bufData:PChar;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       ):Variant;                         // for Internal use from FibQuery
       procedure SetArrayValue(Value:Variant;var ToBuffer:PChar;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       );                                // for Internal use from FibQuery
       function GetFieldArrayValues(Field:TField;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       ):Variant;  // for Internal use from DataSet
       procedure SetFieldArrayValue(Value:Variant;Field:TField;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       );        // for Internal use  from DataSet

       function GetElementFromField(
        Field:TField;Indexes:array of integer;
        DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       ):Variant;        // for Internal use  from DataSet

       procedure PutElementToField(Field:TField;Value:Variant;
        Indexes:array of integer;
        DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       );        // for Internal use  from DataSet


      public
       property ArrayType:TFieldType read FArrayType;

       property TableName:string read FTableName;
       property FieldName:string read FFieldName;

       property DimensionCount:Integer read GetDimensionCount;
       property Dimension[Index: Integer]: TISC_ARRAY_BOUND read GetDimension;
       property ArraySize:Integer read GetArraySize;
       property Scale:Byte read GetScale;       
      end;

implementation

uses FIBDataSet,VariantRtn,StrUtil;
{
type

 TTraceArr=array [0..1] of  INT64;
 PTraceArr=^TTraceArr;


var
 TraceArr:TTraceArr;
}

const MaxDimCount=64;


 threadvar
 // vars for Callback functions from VariantRtn
   glBufArField:PChar;
   glArrayType :TFieldType;
   glScale     :integer;
   glErrInt    :byte;
   glISC_ARRAY_DESC:TISC_ARRAY_DESC;
   glCount     :Integer;
   glBufIsNull :boolean;
   TracePChar  :PChar;
   CurIBLib    :IIBClientLibrary;

constructor TpFIBArray.Create(ClientLibrary:IIBClientLibrary;aFXSQLVAR:PXSQLVAR;
        DBHandle: PISC_DB_HANDLE;
        TRHandle: PISC_TR_HANDLE;

        const ATableName,AFieldName:string

);
begin
 inherited Create;
 FClientLibrary :=ClientLibrary;
 with FClientLibrary do
 try
   FXSQLVAR       :=aFXSQLVAR;
   FTableName     :=ATableName;
   FFieldName     :=AFieldName;

   isc_array_lookup_bounds(StatusVector, DBHandle, TRHandle,
      PChar(FTableName), PChar(FFieldName), @vISC_ARRAY_DESC
   );
    with vISC_ARRAY_DESC do
    begin
    //Лишнее
      case array_desc_dtype of
        Blr_int64 :            FArrayType := ftBCD;
        Blr_text, Blr_Varying: FArrayType := ftString;
        Blr_Short:             FArrayType := ftSmallint;
        Blr_Long:              FArrayType := ftInteger;
        Blr_Float, Blr_Double,
        Blr_D_Float:           FArrayType := ftFloat;
        Blr_Date:              FArrayType := ftDateTime;
        Blr_sql_date:          FArrayType := ftDate;
        Blr_sql_time:          FArrayType := ftTime;
      end;
    end;

 except
   IbError(ClientLibrary,Self)
 end;
end;

destructor TpFIBArray.Destroy;
begin
  FClientLibrary:=nil;
  inherited;
end;

function TpFIBArray.GetScale: Byte;
begin
 Result:=
  256-Byte(vISC_ARRAY_DESC.array_desc_scale)
end;

function TpFIBArray.GetDimensionCount:Integer;
begin
 Result:=vISC_ARRAY_DESC.array_desc_dimensions
end;


function TpFIBArray.GetDimension(Index: Integer): TISC_ARRAY_BOUND;
begin
 if Index in [0..DimensionCount] then
   Result := vISC_ARRAY_DESC.array_desc_bounds[Index]
 else
  FIBError(feWrongDimension,[Index,FTableName+'.'+FFieldName])
end;

function TpFIBArray.GetSliceSize(aISC_ARRAY_DESC:TISC_ARRAY_DESC):integer;
var i:integer;
    DataSize:integer;
begin
{  Result := 0;
  with aISC_ARRAY_DESC do
  begin
   DataSize:=array_desc_length;
   if array_desc_dtype=Blr_Varying then   Inc(DataSize, 2);
   for i := 0 to Pred(DimensionCount)  do
    Inc(Result,
     DataSize *
     (array_desc_bounds[i].array_bound_upper -
      array_desc_bounds[i].array_bound_lower+ 1
     )
    );
   if array_desc_dtype=Blr_Varying then   Inc(Result, 2);
  end;}
  Result := 1;
  with aISC_ARRAY_DESC do
  begin
   DataSize:=array_desc_length;
   if array_desc_dtype=Blr_Varying then   Inc(DataSize, 2);
   //HONCHAROV 3A
   for i := 0 to Pred(DimensionCount)  do
   begin
    Result := Result *  (array_desc_bounds[i].array_bound_upper -
      array_desc_bounds[i].array_bound_lower+ 1);
   end;
   Result := Result * DataSize;
  end;

end;

function TpFIBArray.GetArraySize:integer;
begin
 Result:=GetSliceSize(vISC_ARRAY_DESC)
end;


procedure ReadElementFromBuffer(
 OldValue:Variant; IndexValue:array of integer;
 Var NewValue:Variant;  Var Continue:boolean
);
type
    PSmall=^Smallint;
var s:string;
    tm_date: TCTimeStructure;
    p:Pointer;
begin
   p:=glBufArField+glISC_ARRAY_DESC.array_desc_length*(glCount);

   with CurIBLib   ,glISC_ARRAY_DESC do
     if   glBufIsNull then
      NewValue:=null
     else
     case glArrayType  of //
      ftString   :
       begin
        s:=String(glBufArField+(array_desc_length+glErrInt )*(glCount));
        if glErrInt>0 then NewValue:=FastCopy(s,1,Length(s)-1)
       end;
      ftSmallint :   NewValue:=PSmall(p)^;
      ftInteger  :   NewValue:=PInteger(p)^;
      ftFloat    :   NewValue:=PDouble(p)^;
      ftDate :
      begin
        isc_decode_sql_date(PISC_DATE(p), @tm_date);
        try
          NewValue:=EncodeDate(Word(tm_date.tm_year + 1900), Word(tm_date.tm_mon + 1),
                               Word(tm_date.tm_mday)) ;
        except
        end;
      end;
      ftTime :
      begin
        isc_decode_sql_time(PISC_TIME(p), @tm_date);
        try
          NewValue:=
          EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
                 Word(tm_date.tm_sec), (PISC_TIME(p)^ mod 10000) div 10);
        except
        end;
      end;
      ftDateTime :
      begin
        isc_decode_date(PISC_QUAD(p), @tm_date);
        try
        NewValue:=EncodeDate(Word(tm_date.tm_year + 1900), Word(tm_date.tm_mon + 1),
                               Word(tm_date.tm_mday)) ;

        if NewValue>=0 then
          NewValue:=NewValue +
           EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
            Word(tm_date.tm_sec),(PISC_QUAD(p)^.gds_quad_low mod 10000) div 10
           )
        else
         NewValue:=NewValue -
          EncodeTime(Word(tm_date.tm_hour), Word(tm_date.tm_min),
           Word(tm_date.tm_sec),(PISC_QUAD(p)^.gds_quad_low mod 10000) div 10
          )
        except
        end;
      end;
      ftBCD:
       NewValue:=PInt64(p)^*E10[-glScale];
     else
     // Пока не реализовано

     end; // end Case
   Inc(glCount)
end;




function TpFIBArray.GetArrayValues(
  bufData:PChar; DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
):Variant;
var i,j:integer;
    ArrSize:integer;
    Buffer: PChar;
    a:array[0..MaxDimCount*2-1] of   Integer;
begin
 j:=0;
 for i:=0 to Pred(DimensionCount) do
 begin
   a[j]:=Dimension[i].array_bound_lower ;
   a[j+1]:=Dimension[i].array_bound_upper ;
   Inc(j,2);
 end;
 Result :=SafeVarArrayCreate(a,  varVariant,DimensionCount);
 ArrSize:=GetArraySize;
 Buffer := nil;
 FIBAlloc(Buffer, 0, ArrSize + 1);
 with FClientLibrary do
 try
  isc_array_get_slice (
   StatusVector, DBHandle, TRHandle,
   PISC_QUAD(bufData), @vISC_ARRAY_DESC, Pointer(Buffer) ,LongInt(@ArrSize)
  );
 with vISC_ARRAY_DESC do
  if array_desc_dtype=Blr_Varying then
   glErrInt:=2
  else
   glErrInt:=0;
  glBufIsNull :=ArrSize=0;
  glBufArField:=Buffer;
  glArrayType :=FArrayType;
  glScale     :=Scale;
  glISC_ARRAY_DESC:=vISC_ARRAY_DESC;
  glCount     :=0;
  CurIBLib    := FClientLibrary;
  CycleWriteArray(Result,ReadElementFromBuffer);
 finally
  FIBAlloc(Buffer, 0, 0);
 end;
end;

function TpFIBArray.GetFieldData(Field:TField;var ToBuffer:PChar):boolean;
begin
  ToBuffer:=nil;
  FIBAlloc(ToBuffer,0,ArraySize);
  Result:=Field.GetData(ToBuffer);
  if not Result then
  begin
    PISC_QUAD(ToBuffer)^.gds_quad_low:=0;
    PISC_QUAD(ToBuffer)^.gds_quad_high:=0;
  end;
end;

function TpFIBArray.GetFieldArrayValues(Field:TField;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       ):Variant;
var
  Buffer:PChar;
begin
  GetFieldData(Field,Buffer);
  try
    Result:=GetArrayValues(Buffer, DBHandle,TRHandle);
  finally
    FreeMem(Buffer);
  end;
end;


procedure WriteElementToBuffer(Value:Variant; IndexValue:array of integer;
       const HighBoundInd:integer;
       Var Continue:boolean
      );

var
  bufInt:integer;
  bufSmInt:SmallInt;
  bufStr:string;
  bufDouble:Double;
  p:Pointer;
  tm_date: TCTimeStructure;
  Yr, Mn, Dy, Hr, Mt, S, Ms: Word;
  bufInt64:Int64;
begin
   with CurIBLib   do
   case glArrayType of //glArrayType
     ftString: if not VarIsEmpty(Value) then
              begin
                if VarIsNull(Value) then
                 bufStr:=#0
                else
                 bufStr:=VarToStr(Value);
               if glErrInt>0 then bufStr:=bufStr+#10#0;
               p:=PChar(bufStr);
               Move(p^,glBufArField^,Length(bufStr));
              end;
    ftSmallint:if not VarIsEmpty(Value) then
               begin
                if VarIsNull(Value) then
                 bufSmInt:=0
                else
                 bufSmInt:=VarAsType(Value,varSmallint);
                 Move(bufSmInt,glBufArField^,SizeOf(bufSmInt));
               end;
     ftInteger: if not VarIsEmpty(Value) then
                begin
                if VarIsNull(Value) then
                 bufInt:=0
                else
                 bufInt:=VarAsType(Value,varInteger);
                 Move(bufInt,glBufArField^,SizeOf(bufInt));
                end;
     ftFloat : if not VarIsEmpty(Value) then
               begin
                if VarIsNull(Value) then
                 bufDouble:=0
                else
                 bufDouble:=VarAsType(Value,varDouble);
                Move(bufDouble,glBufArField^,SizeOf(bufDouble));
               end;
     ftDate : if not VarIsEmpty(Value) then
                 begin
                  if VarIsNull(Value) then
                   Value:=EncodeDate(1858,11,17)
                  else
                   Value:=VarToDateTime(Value);
                   DecodeDate(Value, Yr, Mn, Dy);
                   DecodeTime(Value, Hr, Mt, S, Ms);
                   with tm_date do
                   begin
                     tm_sec :=  S;
                     tm_min :=  Mt;
                     tm_hour := Hr;
                     tm_mday := Dy;
                     tm_mon :=  Mn - 1;
                     tm_year := Yr - 1900;
                   end;
                  isc_encode_sql_date(@tm_date, PISC_DATE(glBufArField));
                 end;
     ftTime : if not VarIsEmpty(Value) then
                 begin
                  if VarIsNull(Value) then
                   Value:=EncodeDate(1858,11,17)
                  else
                   Value:=VarToDateTime(Value);
                   DecodeDate(Value, Yr, Mn, Dy);
                   DecodeTime(Value, Hr, Mt, S, Ms);
                   with tm_date do
                   begin
                     tm_sec :=  S;
                     tm_min :=  Mt;
                     tm_hour := Hr;
                     tm_mday := Dy;
                     tm_mon :=  Mn - 1;
                     tm_year := Yr - 1900;
                   end;
                   isc_encode_sql_time(@tm_date, PISC_TIME(glBufArField));
                 end;
     ftDateTime:
                if not VarIsEmpty(Value) then
                 begin
                  if VarIsNull(Value) then
                   Value:=EncodeDate(1858,11,17)
                  else
                   Value:=VarToDateTime(Value);
                   DecodeDate(Value, Yr, Mn, Dy);
                   DecodeTime(Value, Hr, Mt, S, Ms);
                   with tm_date do
                   begin
                     tm_sec :=  S;
                     tm_min :=  Mt;
                     tm_hour := Hr;
                     tm_mday := Dy;
                     tm_mon :=  Mn - 1;
                     tm_year := Yr - 1900;
                   end;
                   isc_encode_date(@tm_date, PISC_QUAD(glBufArField));
                 end;
     ftBCD:
      if not VarIsEmpty(Value) then
      begin
        if VarIsNull(Value) then
         FillChar(glBufArField^,SizeOf(bufInt64),0)
        else
        begin
          {$IFDEF D6+}
           bufInt64:=Value*E10[glScale];
          {$ELSE}
           PComp(@bufInt64)^:=Value*E10[glScale];          
          {$ENDIF}
           Move(bufInt64,glBufArField^,SizeOf(bufInt64));

        end;
      end;
   end;
   glBufArField:=glBufArField+glISC_ARRAY_DESC.array_desc_length+glErrInt;
end;


procedure TpFIBArray.VariantToBuffer(Value:Variant;var ToBuffer:PChar);
var
  ArrSize:integer;
begin
// procedure for Write to Buffer of Array Field
 if not VarIsArray(Value) then
  Exit;
 if VarArrayDimCount(Value) >DimensionCount then
  FIBError(feWrongDimension,[integer(Value),
    FTableName+'.'+FFieldName
  ]);
 ArrSize:=GetArraySize;
 FIBAlloc(ToBuffer, 0, ArrSize + 1);
 with vISC_ARRAY_DESC do
 if array_desc_dtype=Blr_Varying then
  glErrInt:=2
 else
  glErrInt:=0;

 glBufArField:=ToBuffer;
 TracePChar  :=ToBuffer;
 glArrayType :=FArrayType;
 glScale     :=Scale;
 glISC_ARRAY_DESC:=vISC_ARRAY_DESC;
 CurIBLib    := FClientLibrary;
 CycleReadArray(Value,WriteElementToBuffer);
end;

function TpFIBArray.GetElementBuf(Buffer:PChar;
         aISC_ARRAY_DESC:TISC_ARRAY_DESC;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       ):Variant;
var
  SliceSize:integer;
  Fake:boolean;
  FakeVar:Variant;
  BufElement:PChar;
begin
  SliceSize:=GetSliceSize(aISC_ARRAY_DESC);
  BufElement:=nil;
  FIBAlloc(BufElement, 0, SliceSize+1);
  with FClientLibrary do
  try
   isc_array_get_slice    (
    StatusVector, DBHandle, TRHandle,
    PISC_QUAD(Buffer) ,
    @aISC_ARRAY_DESC, Pointer(BufElement) ,LongInt(@SliceSize)
   );
   glBufIsNull :=SliceSize=0;
   glBufArField:=BufElement;
   glArrayType :=FArrayType;
   glScale:=Scale;   
   glCount     :=0;   
   ReadElementFromBuffer(FakeVar, [1], Result, Fake);
  finally
   FreeMem(BufElement);
  end;
end;

procedure TpFIBArray.PutElementBuf(Value:Variant;var ToBuffer:PChar;
        aISC_ARRAY_DESC:TISC_ARRAY_DESC;
        DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
);
var
  SliceSize:integer;
  Buffer :PChar;
  Fake   :boolean;
  ArrayId:TISC_QUAD;
begin
  SliceSize:=GetSliceSize(aISC_ARRAY_DESC);
  Buffer:=nil;
  FIBAlloc(Buffer, 0, SliceSize + 1);
  with FClientLibrary do
  try
   glBufArField:=Buffer;
   glArrayType :=FArrayType;
   glScale:=Scale;
   WriteElementToBuffer(Value,[1],0,Fake);
   ArrayId:=PISC_QUAD(ToBuffer)^;
   isc_array_put_slice    (
    StatusVector, DBHandle, TRHandle,
    PISC_QUAD(ToBuffer) ,
    @aISC_ARRAY_DESC, Pointer(Buffer) ,@SliceSize
   );
  finally
   FIBAlloc(Buffer, 0, 0);
  end;
end;


procedure TpFIBArray.PutArrayBuf(var Buffer,ToBuffer:PChar;
        DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
);
var
  ArrSize:integer;
begin
  ArrSize:=GetArraySize;

  FClientLibrary.isc_array_put_slice    (
   StatusVector, DBHandle, TRHandle,
    PISC_QUAD(ToBuffer) ,
    @vISC_ARRAY_DESC, Pointer(Buffer) ,@ArrSize
  );

end;


procedure TpFIBArray.SetArrayValue(Value:Variant;
         var ToBuffer:PChar;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
);
var
  Buffer: PChar;
begin
 Buffer := nil;
 FIBAlloc(Buffer, 0, GetArraySize + 1);
 try
  VariantToBuffer(Value,Buffer);
  PutArrayBuf(Buffer,ToBuffer, DBHandle,TRHandle);
 finally
  FIBAlloc(Buffer, 0, 0);
 end;
end;


procedure TpFIBArray.SetFieldArrayValue(Value:Variant;Field:TField;
         DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
);
var ValueBuffer:PChar;
    EditBuffer :PChar;
begin
  ValueBuffer:=nil;
  GetFieldData(Field,EditBuffer);
  try
    VariantToBuffer(Value,ValueBuffer);
    PutArrayBuf(ValueBuffer,EditBuffer,DBHandle,TRHandle);
    Field.SetData(EditBuffer);
  finally
    FIBAlloc(ValueBuffer,0,0);
  end;
end;

function TpFIBArray.GetElementFromField(
        Field:TField;Indexes:array of integer;
        DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       ):Variant;        // for Internal use  from DataSet
var
   i:integer;
   loc_ISC_ARRAY_DESC:TISC_ARRAY_DESC;
   EditBuffer:PChar;
begin
  loc_ISC_ARRAY_DESC:=vISC_ARRAY_DESC;
  with loc_ISC_ARRAY_DESC do
   for i:=Low(Indexes) to High(Indexes) do
   begin
    array_desc_bounds[i].array_bound_upper:=Indexes[i];
    array_desc_bounds[i].array_bound_lower:=Indexes[i];
   end;
   GetFieldData(Field,EditBuffer);
   Result:=GetElementBuf(EditBuffer,
            loc_ISC_ARRAY_DESC, DBHandle,TRHandle
           );
   FreeMem(EditBuffer);           
end;

procedure TpFIBArray.PutElementToField(Field:TField;Value:Variant;
        Indexes:array of integer;
        DBHandle:PISC_DB_HANDLE;TRHandle: PISC_TR_HANDLE
       );        // for Internal use  from DataSet

var
   i:integer;
   loc_ISC_ARRAY_DESC:TISC_ARRAY_DESC;
   EditBuffer:PChar;
begin
  loc_ISC_ARRAY_DESC:=vISC_ARRAY_DESC;
  with loc_ISC_ARRAY_DESC do
   for i:=Low(Indexes) to High(Indexes) do
   begin
    array_desc_bounds[i].array_bound_upper:=Indexes[i];
    array_desc_bounds[i].array_bound_lower:=Indexes[i];
   end;
   GetFieldData(Field,EditBuffer);
   PutElementBuf(Value,EditBuffer,
         loc_ISC_ARRAY_DESC, DBHandle,TRHandle
   );
   Field.SetData(EditBuffer);
   FreeMem(EditBuffer);
end;





end.


