fibdataset.pas

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

  );

  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;
  TOnBlobFieldProcessing=procedure(Field:TBlobField;BlobSize:integer;Progress:integer;var Stop:boolean) of object;

  TDataSetRunStateValue=(drsInCacheRefresh,drsInSort,drsInOpenByTimer,
   drsInFilterProc,drsInGetRecordProc,drsInGotoBookMark, drsInClone,
   drsInApplyUpdates,drsInRefreshClientFields,drsDontCheckInactive,
   drsForceCreateCalcFields,drsInRefreshRow,drsInMoveRecord,drsInCacheDelete,drsInFetchingAll,drsInLoaded
  );
  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;
    FOnBlobFieldRead:TOnBlobFieldProcessing;
    FOnBlobFieldWrite:TOnBlobFieldProcessing;
    FWritingBlob:TField;

    vPredState:TDataSetState;
    vrdFieldCount:integer;
    FStringFieldCount:integer;
    FFilterParser:TExpressionParser;
    FAllowedUpdateKinds:TUpdateKinds;
    FRunState:TDataSetRunState;
    vCalcFieldsSavedCache: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
    );
    procedure CallBackBlobWrite(BlobSize:integer; BytesProcessing:integer; var Stop:boolean);
    (*
     * 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;

   {$DEFINE FIB_INTERFACE}
    {$I FIBDataSetLocate.inc}
   {$UNDEF FIB_INTERFACE}

    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;