fibdataset.pas

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

   eloInSortedDS,eloNearest,eloInFetchedRecords
  );

  TExtLocateOptions=set of TExtLocateOption;
  TLocateKind =(lkStandard,lkNext,lkPrior);

  TSortFieldInfo=record
                   FieldName:string;
                   InDataSetIndex:integer;
                   InOrderIndex:integer;
                   Asc  :boolean;
                   NullsFirst:boolean;
                  end;


  TFIBDataLink = class(TDetailDataLink)
  protected
    FDataSet: TFIBCustomDataSet;
  protected
    procedure ActiveChanged; override;
    procedure RecordChanged(Field: TField); override;
    procedure CheckBrowseMode; override;
    procedure DataSetChanged; override;
    function GetDetailDataSet: TDataSet; override;
  public
    constructor Create(ADataSet: TFIBCustomDataSet);
    destructor Destroy; override;
  end;

  TFIBBookmark = record
   bRecordNumber:integer;
   bActiveRecord:integer;
  end;

  PFIBBookMark=^TFIBBookmark;
  (*
   * TFIBCustomDataSet - declaration
   *)
  TTransactionKind=(tkReadTransaction,tkUpdateTransaction);
  TCompareFieldValues= function  (Field:TField;const S1,S2:variant):integer of object;

  TRecordsPartition = record
   BeginPartRecordNo: Integer;
   EndPartRecordNo  : Integer;
   IncludeBof       : boolean;
   IncludeEof       : boolean;
  end;
  PRecordsPartition=^TRecordsPartition;

  TCacheModelKind=(cmkStandard,cmkLimitedBufferSize);

  TCacheModelOptions = class(TPersistent)
  private
    vOwner:TFIBCustomDataSet;
    FCacheModelKind:TCacheModelKind;
    FBufferChunks  :Integer;
    FPlanForDescSQLs:string;
    FBlobCacheLimit :integer;
    procedure SetBufferChunks(Value: Integer);
    procedure SetCacheModelKind(Value:TCacheModelKind);
  public
    constructor Create(Owner:TFIBCustomDataSet);
  published
   property CacheModelKind:TCacheModelKind read FCacheModelKind write SetCacheModelKind default cmkStandard;
   property BufferChunks: Integer read FBufferChunks write SetBufferChunks default vBufferCacheSize;
   property PlanForDescSQLs:string read FPlanForDescSQLs write FPlanForDescSQLs;
   property BlobCacheLimit :integer read FBlobCacheLimit write FBlobCacheLimit default 0;
  end;


  TUpdateBlobInfo=(ubiCheckIsNull,ubiPost,ubiCancel,ubiClearOldValue);
  TOnFillClientBlob=procedure(DataSet:TFIBCustomDataSet;Field:TFIBBlobField;Stream:TFIBBlobStream) of object;

  TDataSetRunStateValue=(drsInCacheRefresh,drsInSort,drsInOpenByTimer,
   drsInFilterProc,drsInGetRecordProc,drsInGotoBookMark, drsInClone,
   drsInApplyUpdates,drsInRefreshClientFields,drsDontCheckInactive,
   drsForceCreateCalcFields,drsInRefreshRow,drsInMoveRecord,drsInCacheDelete
  );
  TDataSetRunState=set of TDataSetRunStateValue; //InternalUse


  TFilteredCacheInfo =
  record
    AllRecords: integer;
    FilteredRecords: integer;
    NonVisibleRecords: TSortedList;
  end;

  TFIBCustomDataSet = class({$IFDEF D10+}TWideDataset{$ELSE}TDataset{$ENDIF},ISQLObject)
  protected
    (*
     * Fields, and internal objects
     *)
    FBase: TFIBBase;          (* Manages database and transaction *)
    FBlobCacheBufferOffset: Integer;
    FBlobCacheOffset: Integer;
    FBlobStreamList: TList;
    FOpenedBlobStreams: TList;    
    FRecordsCache:TRecordsCache;
    FBufferChunkSize,
    FBPos,
    FOBPos,
    FBEnd,
    FOBEnd: DWord;
    FCachedUpdates: Boolean;
    FCalcFieldsOffset: Integer;
    FCurrentRecord: Long;
    FDeletedRecords: Long; (* How many records have been deleted? *)
    FSourceLink: TFIBDataLink;
    FOpen: Boolean;           (* Is the dataset open? *)
    FPrepared: Boolean;
    FQDelete,
    FQInsert,
    FQRefresh,
    FQSelect,
    FQUpdate: TFIBQuery;      (* Dataset management queries *)
    FRecordBufferSize: Integer;
    FBlockReadSize   : Integer;

    FRecordCount: Integer;
    FAllRecordCount:integer;
    FRecordSize: Integer;
    vDisableScrollCount:integer;

    FDatabaseDisconnecting,
    FDatabaseDisconnected,
    FDatabaseFree  : TNotifyEvent;
    FOnUpdateError : TFIBUpdateErrorEvent;
    FOnUpdateRecord: TFIBUpdateRecordEvent;
    FAfterUpdateRecord: TFIBAfterUpdateRecordEvent;
    FTransactionEnding: TNotifyEvent;
    FTransactionEnded : TNotifyEvent;
    FTransactionFree  : TNotifyEvent;

    FBeforeStartTr:TNotifyEvent ;
    FAfterStartTr :TNotifyEvent ;
    FBeforeEndTr  :TEndTrEvent  ;
    FAfterEndTr   :TEndTrEvent  ;

    FBeforeStartUpdTr:TNotifyEvent ;
    FAfterStartUpdTr :TNotifyEvent ;
    FBeforeEndUpdTr  :TEndTrEvent  ;
    FAfterEndUpdTr   :TEndTrEvent  ;

    FUpdatesPending: Boolean;
    FUpdateRecordTypes: TFIBUpdateRecordTypes;
    FUniDirectional: Boolean;
    FOnGetRecordError:  TDataSetErrorEvent;
    FOptions:TpFIBDsOptions;
    FDetailConditions:TDetailConditions;
    vInspectRecno:integer;
    vTypeDispositionField:TDispositionFieldType;
    vTimerForDetail:TFIBTimer;
    vScrollTimer   :TFIBTimer;
    FDisableCOCount:integer;
    FDisableCalcFieldsCount:integer;
    FPrepareOptions:TpPrepareOptions;
    vSelectSQLTextChanged:boolean;
    FRefreshTransactionKind:TTransactionKind;
    FAutoCommit:boolean;
    FWaitEndMasterInterval:integer;
    FOnFieldChange:TFieldNotifyEvent;
    FOnFillClientBlob:TOnFillClientBlob;
    vPredState     : TDataSetState;
    vrdFieldCount  :integer;
    FStringFieldCount  :integer;
    FFilterParser      : TExpressionParser;
    FAllowedUpdateKinds: TUpdateKinds;
    FRunState:TDataSetRunState;
    vCalcFieldsSavedCache:boolean;
    FIsUnicodeConnect :boolean;
    FFieldOriginRule:TFieldOriginRule;
    FFilteredCacheInfo: TFilteredCacheInfo;    
  protected
    FAutoUpdateOptions: TAutoUpdateOptions;
{$IFDEF CSMonitor}
    FCSMonitorSupport: TCSMonitorSupport;
    procedure SetCSMonitorSupport(Value:TCSMonitorSupport);    
{$ENDIF}

    function  IsDBKeyField(Field:TObject):boolean;


// GB
    procedure CheckDataFields(FieldList:TList; const CallerProc:string);
    procedure PrepareAdditionalSelects;
    function  CompareBookMarkAndRecno(BookMark:TBookMark; Rno:integer;OnlyFields:boolean=False ):boolean;
    function RefreshAround(BaseQuery: TFIBQuery; var BaseRecNum:integer;
     IgnoreEmptyBaseQuery:boolean = True;ReopenBaseQuery:boolean = True
    ):boolean;
//End GB
  private
// GB
    FCacheModelOptions:TCacheModelOptions;

    vPartition      :PRecordsPartition;
    FQCurrentSelect :TFIBQuery;
    FQSelectPart    :TFIBQuery;
    FQSelectDescPart:TFIBQuery;
    FQSelectDesc    :TFIBQuery;
    FQBookMark      :TFIBQuery;
    FKeyFieldsForBookMark :TStrings;
    FSortFields:variant;
    function  CanHaveLimitedCache:boolean;

    procedure SetCacheModelOptions(aCacheModelOptions:TCacheModelOptions);
    function  GetBufferChunks:Integer;
    procedure SetBufferChunks(Value:integer);
    procedure ShiftCurRec;    
//End GB


    function  StoreUpdTransaction: Boolean;
    procedure SetOnEndScroll(Event:TDataSetNotifyEvent);
    function  GetDefaultFields:boolean;
    procedure ClearBlobStreamList;

    function  CreateInternalQuery(const QName:string):TFIBQuery;
    function GetGroupByString: string;
    function GetMainWhereClause: string;
    procedure SetGroupByString(const Value: string);
    procedure SetMainWhereClause(const Value: string);
    function GetPlanClause: string;
    procedure SetPlanClause(const Value: string);
  protected
   FOnCompareFieldValues:TCompareFieldValues;
   function  CompareFieldValues(Field:TField;const S1,S2:variant):integer; virtual;
  public
   function AnsiCompareString(Field:TField;const val1, val2: variant): Integer;
   function StdAnsiCompareString(Field:TField;const S1, S2: variant): Integer;
   function StdCompareValues(const S1, S2: variant): Integer;
  published
   property  OnCompareFieldValues:TCompareFieldValues read    FOnCompareFieldValues
     write   FOnCompareFieldValues;
  protected
   {$DEFINE FIB_INTERFACE}
    {$I FIBDataSetPT.inc}
   {$UNDEF FIB_INTERFACE}

  protected
    function  GetXSQLVAR(Fld:TField):TXSQLVAR;
    function  GetFieldScale(Fld:TNumericField):Short;
    function  GetUpdateTransaction:TFIBTransaction;
    (*
     * Routines for managing access to the database, etc... They have
     * nothing to do with TDataset.
     *)
    function AdjustCurrentRecord(Buffer: Pointer; GetMode: TGetMode): TGetResult;
    function CanEdit: Boolean; virtual;
    function CanInsert: Boolean; virtual;
    function CanDelete: Boolean; virtual;
    procedure CheckFieldCompatibility(Field: TField; FieldDef: TFieldDef); override;
    procedure CheckInactive; override;
    procedure CheckEditState;
    procedure UpdateBlobInfo(Buff: Pointer;Operation:TUpdateBlobInfo;ClearModified,ForceWrite:boolean
     ; Field:TField=nil
    );
    (*
     * When copying a given record buffer, should we overwrite
     * the pointers to "memory" or should we just copy the
     * contents?
     *)
    procedure CopyRecordBuffer(Source, Dest: Pointer);
    procedure DoDatabaseDisconnecting(Sender: TObject);
    procedure DoDatabaseDisconnected(Sender: TObject);
    procedure DoDatabaseFree(Sender: TObject);
    procedure DoTransactionEnding(Sender: TObject); virtual;
    procedure DoTransactionEnded(Sender: TObject);  virtual;
    procedure DoTransactionFree(Sender: TObject);

    procedure DoBeforeStartTransaction(Sender: TObject);
    procedure DoAfterStartTransaction(Sender: TObject);
    procedure DoBeforeEndTransaction(EndingTR:TFIBTransaction;Action: TTransactionAction;
      Force: Boolean);
    procedure DoAfterEndTransaction(EndingTR:TFIBTransaction;Action: TTransactionAction;
      Force: Boolean);

    procedure DoBeforeStartUpdateTransaction(Sender: TObject);
    procedure DoAfterStartUpdateTransaction(Sender: TObject);
    procedure DoBeforeEndUpdateTransaction(EndingTR:TFIBTransaction;Action: TTransactionAction;
      Force: Boolean);
    procedure DoAfterEndUpdateTransaction(EndingTR:TFIBTransaction;Action: TTransactionAction;
      Force: Boolean); virtual;

    procedure FetchCurrentRecordToBuffer(
     Qry: TFIBQuery; RecordNumber: Integer;Buffer: PChar
    );
    procedure FetchRecordToCache(Qry: TFIBQuery; RecordNumber: Integer);
    procedure InitDataSetSchema;
    function GetActiveBuf: PChar;
    function GetDatabase: TFIBDatabase;
    function GetDBHandle: PISC_DB_HANDLE;
    function GetDeleteSQL: TStrings;
    function GetInsertSQL: TStrings;
    function GetParams: TFIBXSQLDA;
    function GetRefreshSQL: TStrings;
    function GetSelectSQL: TStrings;
    function GetStatementType: TFIBSQLTypes;
    function GetUpdateSQL: TStrings;
    function GetTransaction: TFIBTransaction;
    function GetTRHandle: PISC_TR_HANDLE;


    procedure InternalDeleteRecord(Qry: TFIBQuery; Buff: Pointer);virtual;
{$IFDEF FAST_LOCATE}
   {$DEFINE FIB_INTERFACE}
    {$I FIBDataSetLocate.inc}
   {$UNDEF FIB_INTERFACE}
{$ENDIF}   
    function  InternalLocate(const KeyFields: string; KeyValues:array of Variant;
      Options: TExtLocateOptions ;FromBegin:boolean = False;LocateKind:TLocateKind = lkStandard;
      ResyncToCenter:boolean=False
    ): Boolean; virtual;


    function  InternalLocateForLimCache(
     const KeyFields: string; const KeyValues:array of Variant;
      Options: TExtLocateOptions; LocateKind:TLocateKind = lkStandard;aQLocate:TFIBQuery=nil
    ): Boolean;

    function  InternalExtLocate(const KeyFields: string; const KeyValues:Variant;
     Options: TExtLocateOptions;LocateKind:TLocateKind):Boolean;

    procedure InternalPostRecord(Qry: TFIBQuery; Buff: Pointer); virtual;
    function  InternalRefreshRow(Qry: TFIBQuery; Buff:Pointer) :boolean;
    procedure InternalRevertRecord(RecordNumber: Integer;WithUnInserted:boolean);
    function  IsVisibleStat(Buffer: PChar): Boolean;
    function  IsVisible(Buffer: PChar): Boolean; virtual;
    procedure SaveOldBuffer(Buffer: PChar);
    procedure SetDatabase(Value: TFIBDatabase);
    procedure LiveChangeDatabase(Value: TFIBDatabase); // internal use
    procedure SetDeleteSQL(Value: TStrings);
    procedure SetInsertSQL(Value: TStrings);
    procedure SetQueryParams(Qry: TFIBQuery; Buffer: Pointer);
    procedure SetRefreshSQL(Value: TStrings);
    procedure SetSelectSQL(Value: TStrings);
    procedure SetUpdateSQL(Value: TStrings);
    procedure SetTransaction(Value: TFIBTransaction);
    procedure LiveChangeTransaction(Value: TFIBTransaction); // internal use    
    procedure SetUpdateTransaction(Value:TFIBTransaction) ; virtual;

    procedure SetUpdateRecordTypes(Value: TFIBUpdateRecordTypes);
    procedure SetUniDirectional(Value: Boolean);
    procedure SetPrepareOptions(Value:TpPrepareOptions); virtual;
    procedure SetRefreshTransactionKind(const Value: TTransactionKind);    
    procedure SourceChanged;
    procedure SourceDisabled;
  protected
    FParams: TParams;
    procedure SQLChanging(Sender: TObject);
    procedure ReadRecordCache(RecordNumber: Integer; Buffer: PChar;
      ReadOldBuffer: Boolean);
    procedure  WriteRecordCache(RecordNumber: Integer; Buffer: PChar);
    function   GetNewBuffer:PChar;
    function   GetOldBuffer(aRecordNo:integer =-1):PChar;
    procedure  CheckUpdateTransaction;
  protected
    vFieldDescrList:TFIBFieldDescrList;
    FFNFields: TStringList;    
    (*
     * Routines from TDataset that need to be overridden to use the IB API
     * directly.
     *)


    vIgnoreLocReno:integer;
    vControlsEnabled:boolean;
    FOnEnableControls:TDataSetNotifyEvent;
    FOnDisableControls:TDataSetNotifyEvent;
    FOnEndScroll:TDataSetNotifyEvent;
    FCachedActive       :boolean;
    vNeedReloadClientBlobs:boolean;
    procedure SetActive(Value: Boolean); override;
    procedure DataEvent(Event: TDataEvent; Info: Longint); override;
    procedure SetStateFieldValue(State: TDataSetState; Field: TField; const Value: Variant); override;
    procedure DoOnDisableControls(DataSet:TDataSet);
    procedure DoOnEnableControls(DataSet:TDataSet);
    function  AllocRecordBuffer: PChar; override; (* abstract *)
    procedure InternalDoBeforeOpen;   virtual;
    procedure DoBeforeOpen;   override;
    procedure DoAfterOpen;    override;
    procedure DoBeforeClose;  override;
    procedure DoAfterClose;   override;
    procedure DoBeforeCancel; override;
    procedure DoAfterCancel;  override;
    procedure DoBeforeDelete; override;
    procedure DoBeforeEdit;   override;
    procedure DoBeforeInsert; override;
    procedure DoBeforeScroll; override;
    procedure DoAfterScroll;  override;
    procedure DoBeforePost;   override;
    procedure DoAfterInsert;  override;
    procedure DoAfterPost;    override;
    procedure DoAfterDelete;  override;
    procedure DoOnEndScroll(Sender:TObject);
    procedure DoOnPostError(DataSet: TDataSet; E: EDatabaseError; var Action: TDataAction); virtual;
    procedure FreeRecordBuffer(var Buffer: PChar); override; (* abstract *)
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override; (* abstract *)
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override; (* abstract *)