fibdataset.pas

FIBPlus version 6-96. This is somewhat usefull interbase database components. TFIBDatabase, TFIBTab

{***************************************************************}
{ 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
{$IFDEF D11+}
  dbPChar=PByte;
{$ELSE}
  dbPChar=PChar;
{$ENDIF}

  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:PAnsiChar;
   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;
    function GetDataSize: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;
  protected
    function GetValue(var Value:string):Boolean;
// function GetAsString:string; override;
    procedure SetAsString(const Value:string); override;
    function GetAsVariant:Variant; override;
    procedure SetAsWideString(const Value:UnicodeString); 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:UnicodeString;
    procedure SetAsWideString(const Value:UnicodeString);
    function GetWideDisplayText:WideString;
    function GetWideEditText:WideString;
    procedure SetWideEditText(const Value:WideString);
    //--
    property AsWideString:UnicodeString 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
    procedure SetAsVariant(const Value:Variant); override;
    function GetBlobId:TISC_QUAD;
   public
    function GetAsWideString:UnicodeString; {$IFDEF D10+} override; {$ENDIF}
    procedure SetAsWideString(const aValue:UnicodeString); {$IFDEF D10+} override; {$ENDIF}
    function GetAsVariant:Variant; override;
    function GetAsString:string; override;
    procedure SetAsString(const Value:string); override;

    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; override;
    procedure SetAsExtended(Value:Extended); override;
    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;
    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 SetVarValue(const Value:Variant); 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:PAnsiChar;
    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;