fibdataset.pas

FIBPlus is a component suite intended for work with InterBase. It is direct, fast and flexible Inter

{***************************************************************}
{ 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:[e-mail]                                    }
{                                                               }
{    Copyright (c) 1998-2007 Devrace Ltd.                       }
{    Written by Serge Buzadzhy ([e-mail])               }
{                                                               }
{ ------------------------------------------------------------- }
{    FIBPlus home page: http://www.fibplus.com/                 }
{    FIBPlus support  : http://www.devrace.com/support/         }
{ ------------------------------------------------------------- }
{                                                               }
{  Please see the file License.txt for full license information }
{***************************************************************}


unit FIBDataSet;


interface

{$I FIBPlus.inc}
uses
 SysUtils, ibase,IB_Intf, ib_externals, fib,
 pFIBProps,pFIBFieldsDescr,DB,FIBCacheManage,
 DBCommon,DbConsts,DBParsers,//DSContainer,
 FIBDatabase, FIBQuery, FIBMiscellaneous,SqlTxtRtns,pFIBLists,FIBCloneComponents ,
 pFIBInterfaces,
 {$IFDEF WINDOWS}
  Windows, Classes,StdFuncs
  {$IFNDEF NO_GUI}
   ,Forms,Controls // IS GUI units
  {$ENDIF}
  {$IFDEF D6+},FMTBcd, Variants{$ENDIF}
 {$ENDIF}
 {$IFDEF LINUX}
  Types,Libc,Classes,StdFuncs,
  {$IFNDEF NO_GUI}
   QForms,QControls, // IS GUI units
  {$ENDIF}
  FMTBcd, Variants
 {$ENDIF}

 ;

const
  vBufferCacheSize    =  32;  // Allocate cache in this many record chunks
  vMinBufferChunksForLimCache=100;
type

  TFIBCustomDataSet = class;
  TFIBDataSet = class;

  TBlobDataArray =array[0..0] of TFIBBlobStream;
  PBlobDataArray = ^TBlobDataArray;


  TFieldData =record
    fdIsNull: Boolean;
  end;
  PFieldData = ^TFieldData;


  TCachedUpdateStatus =
   (cusUnmodified, cusModified, cusInserted,cusDeleted, cusUninserted,cusDeletedApplied);



  TRecordData =packed record
    rdRecordNumber: Long;
    rdBookmarkFlag: TBookmarkFlag;
    rdFlags       : Byte; // 3 bit - TCachedUpdateStatus
//    rdCachedUpdateStatus: TCachedUpdateStatus;// Bit 7 is Calcs
    rdFields: array[1..1] of TFieldData;
  end;
  PRecordData = ^TRecordData;

  TSavedRecordData =packed record
    rdFlags       : Byte;
    rdFields: array[1..1] of TFieldData;
  end;
  PSavedRecordData = ^TSavedRecordData;

  TFIBStringField = class(TStringField)
  private
   vInSetAsString    :boolean;
   FEmptyStrToNull   :boolean;
   FDefaultValueEmptyString:boolean;
   FValueLength      :integer;
   FSqlSubType       :integer;
   FReservedBuffer   :PChar;
   function     GetAsDB_KEY:string;
  protected
    class procedure CheckTypeSize(Value: Integer); override;
    procedure SetDataSet(ADataSet: TDataSet); override;
    function  GetValue(var Value: string): Boolean;
    function  GetAsString: string; override;
    function  GetAsVariant: Variant; override;
    procedure SetAsString(const Value: string); override;
    procedure SetSize(Value: Integer);  override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy;override;
    function  IsDBKey:boolean;
    function  SqlSubType:integer;
    function  CharacterSet :string;
    procedure Clear; override;
    property  DefaultValueEmptyString:boolean read FDefaultValueEmptyString write FDefaultValueEmptyString;
  published
   property EmptyStrToNull:boolean read FEmptyStrToNull write FEmptyStrToNull ;
  end;


  TFIBWideStringField = class(TWideStringField)
  protected
    function GetDataSize: Integer; override;
  public
    procedure Clear; override;
    function  CharacterSet :string;
    function  CollateNumber :Byte;
  end;

  TFIBLargeIntField   = class(TLargeIntField)
  private
   function GetOldAsInt64:Int64;
  protected
   procedure SetVarValue(const Value: Variant); override;
  public
   property OldValue:Int64 read GetOldAsInt64;
  end;

  TFIBIntegerField = class(TIntegerField)
   protected
     function  GetAsBoolean: Boolean; override;
     procedure SetAsBoolean(Value: Boolean); override;
   public
     procedure   Clear; override; 
     constructor Create(AOwner: TComponent); override;
   end;


   TFIBDateField = class(TDateField)
   public

   end;

   TFIBTimeField = class(TTimeField)
   private
     FShowMsec:boolean;
   protected
      procedure GetText(var Text: string; DisplayText: Boolean); override;
   public
   published
    property ShowMsec:boolean read FShowMsec write FShowMsec default False;

   end;

   TFIBDateTimeField = class(TDateTimeField)
   private
     FShowMsec:boolean;
     function GetAsTimeStamp:TTimeStamp;
     procedure SetAsTimeStamp(const Value:TTimeStamp);
   protected
     procedure GetText(var Text: string; DisplayText: Boolean); override;
   public
     property AsTimeStamp:TTimeStamp read GetAsTimeStamp write SetAsTimeStamp;
   published
    property ShowMsec:boolean read FShowMsec write FShowMsec default False;
   end;


   TFIBBlobField = class(TBlobField)
   private
    FSubType:SmallInt;
    FIsClientCalcField:boolean;
   protected
    function GetAsVariant: Variant; override;
    function GetBlobId:TISC_QUAD;
    function GetIsNull:boolean; override;
   public
    property  SubType:SmallInt read FSubType;
    property  Blob_ID:TISC_QUAD read GetBlobId;
   published
    property  IsClientField:boolean read FIsClientCalcField write FIsClientCalcField default False;
   end;

//TNT Controls Interface

  IWideStringField = interface
    ['{679C5F1A-4356-4696-A8F3-9C7C6970A9F6}']
    function GetAsWideString: WideString;
    procedure SetAsWideString(const Value: WideString);
    function GetWideDisplayText: WideString;
    function GetWideEditText: WideString;
    procedure SetWideEditText(const Value: WideString);
    //--
    property AsWideString: WideString read GetAsWideString write SetAsWideString{inherited};
    property WideDisplayText: WideString read GetWideDisplayText;
    property WideText: WideString read GetWideEditText write SetWideEditText;
  end;

   TFIBMemoField = class(TMemoField,IWideStringField)
   private
    FCharSetID:integer;
    function GetWideDisplayText: WideString;
    function GetWideEditText: WideString;
    procedure SetWideEditText(const Value: WideString);
   protected
    function GetAsWideString: WideString; {$IFDEF D10+} override; {$ENDIF}
    procedure SetAsWideString(const aValue: WideString); {$IFDEF D10+} override; {$ENDIF}
    procedure SetAsVariant(const Value: Variant); override;
    function GetAsVariant: Variant; override;
    function GetAsString: string;  override;
    procedure SetAsString(const Value: string); override;     
    function GetBlobId:TISC_QUAD;
   public
    procedure InternalSetCharSet(aValue:integer); // Internal use
    property  Blob_ID:TISC_QUAD read GetBlobId;
   end;


  TFIBSmallIntField =class(TSmallintField)
  protected
     function  GetAsBoolean: Boolean; override;
     procedure SetAsBoolean(Value: Boolean); override;
  end;

  TFIBFloatField =class(TFloatField)
   private
    FRoundByScale:boolean;
    function GetScale:integer;
   protected
     procedure SetAsFloat(Value: Double); override;
     procedure GetText(var Text: string; DisplayText: Boolean); override;
   public
     constructor Create(AOwner: TComponent); override;
     property    Scale:integer read GetScale;
   published
     property RoundByScale:boolean read FRoundByScale write FRoundByScale default True;
   end;

  TFIBBCDField = class(TBCDField)
  private
    FRoundByScale:boolean;
    FDataAsComp  :boolean;
    function GetScale:integer;
    function  ServerType:integer;
  protected
    class procedure CheckTypeSize(Value: Integer); override;
    function  GetAsCurrency: Currency; override;
    function  GetAsString: string; override;
    function  GetAsVariant: Variant; override;
    function  GetDataSize: Integer; override;
    procedure GetText(var Text: string; DisplayText: Boolean); override;
    function  GetValue(var Value: Currency): Boolean;
    procedure SetAsString(const Value: string); override;
    procedure SetAsCurrency(Value: Currency); override;
 {$IFNDEF NO_USE_COMP}
    function  GetAsComp: comp;
    procedure SetAsComp(Value: comp);
 {$ENDIF}    
    function  GetAsExtended: Extended;

    procedure SetAsExtended(Value: Extended);
    function  GetAsInt64: Int64;
    procedure SetAsInt64(const Value: Int64);
    function  GetAsBCD: TBcd;{$IFDEF D6+} override;{$ENDIF}
    procedure SetAsBCD(const Value: TBcd);{$IFDEF D6+} override;{$ENDIF}
    procedure SetVarValue(const Value: Variant); override;
    function  GetInternalData(var ValueIsNull:boolean):Int64;
    function  GetInternalOldData(var OldIsNull:boolean):Int64;
    function  GetData(Buffer: Pointer): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
{$IFDEF D6+}
    procedure AddExtended(const Value:Extended);
    procedure SubtractExtended(const Value:Extended);
    procedure MultiplyExtended(const Value:Extended);
    procedure DivideExtended(const Value:Extended);

    procedure AddBCD(const Value:TBCD);
    procedure SubtractBCD(const Value:TBCD);
    procedure MultiplyBCD(const Value:TBCD);
    procedure DivideBCD(const Value:TBCD);
{$ENDIF}
    property  AsInt64:Int64 read GetAsInt64 write SetAsInt64;
    procedure Assign(Source: TPersistent); override;
    function  FieldModified:boolean;
    property  AsBcd: TBcd read GetAsBcd write SetAsBcd;
    property Scale:integer read GetScale;
 {$IFNDEF NO_USE_COMP}
    property AsComp: Comp read GetAsComp write SetAsComp;
 {$ENDIF}    
    property AsExtended: Extended read GetAsExtended write SetAsExtended;
    property Value     : Variant read GetAsVariant write  SetVarValue;
  published
    property Size default 8;
    property RoundByScale:boolean read FRoundByScale write FRoundByScale;

  end;

   TFIBGuidField= class (TGuidField)
   protected
    class procedure CheckTypeSize(Value: Integer); override;
    function GetDataSize:  Integer;  override;
    function GetAsString: string; override;
    procedure SetAsString(const Value: string); override;
    function GetAsGuid: TGUID;
    procedure SetAsGuid(const Value: TGUID);
    function  GetAsVariant: variant; override;
    procedure SetAsVariant(const Value: Variant); override;
    
   public
    constructor Create(AOwner: TComponent); override;
    property AsGuid: TGUID read GetAsGuid write SetAsGuid;
   end;

   TFIBBooleanField= class (TBooleanField)
   private
    FStringFalse:string;
    FStringTrue :string;
   protected
    function  StoreStrFalse:boolean;
    function  StoreStrTrue :boolean;

    function  GetAsInteger: Longint; override;
    procedure SetAsString(const Value: string);override;
    procedure SetAsInteger(Value: Longint);override;
    procedure SetAsBoolean(Value: Boolean); override;
    function GetDataSize:  Integer;  override;
    function GetAsString:  string; override;
    function GetAsBoolean: Boolean; override;
    function GetAsVariant: Variant; override;

   public
    constructor Create(AOwner: TComponent); override;
   published
    property StringFalse:string read FStringFalse write FStringFalse
      stored StoreStrFalse
    ;
    property StringTrue :string read FStringTrue write FStringTrue
      stored StoreStrTrue
    ;

   end;

  {$IFDEF SUPPORT_ARRAY_FIELD}
   TFIBArrayField=class(TBytesField)
   private
    FOldValueBuffer:PChar;
    function GetFIBXSQLVAR:TFIBXSQLVAR;
   protected
    procedure GetText(var Text: string; DisplayText: Boolean); override;
    function  GetDimCount:integer;
    function  GetElementType:TFieldType;
    function  GetDimension(Index:integer):TISC_ARRAY_BOUND;
    function  GetArraySize:integer;
    procedure SaveOldBuffer   ;
    procedure RestoreOldBuffer;
    function  GetArrayId:TISC_QUAD;
    function GetAsVariant: Variant; override;
    procedure SetAsVariant(const Value: Variant); override;

   public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property DimensionCount:integer read GetDimCount;
    property ElementType:TFieldType read GetElementType;
    property Dimension[Index: Integer]: TISC_ARRAY_BOUND read GetDimension;
    property ArraySize:Integer read GetArraySize;
    property ArrayID:TISC_QUAD read GetArrayId;
   end;
  {$ENDIF}


  TUpdateKinds = set of TUpdateKind;
  TFIBUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApply, uaApplied);

  TFIBUpdateErrorEvent = procedure(DataSet: TDataSet; E: EFIBError;
    UpdateKind: TUpdateKind; var UpdateAction: TFIBUpdateAction) of object;
  TFIBUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
    var UpdateAction: TFIBUpdateAction) of object;

  TFIBAfterUpdateRecordEvent = procedure(DataSet: TDataSet; UpdateKind: TUpdateKind;
    var Resume:boolean) of object;

  TFIBUpdateRecordTypes = set of TCachedUpdateStatus;
  TOnFetchRecord  =procedure (FromQuery: TFIBQuery;RecordNumber:integer;
   var StopFetching:boolean
  ) of object;

  TpSQLKind = (skModify, skInsert, skDelete, skRefresh);
  TDispositionFieldType= (dfNormal,dfRRecNumber);
  TExtLocateOption =(eloCaseInsensitive, eloPartialKey,eloWildCards,