fibdataset.pas

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

    property OnEndScroll      :TDataSetNotifyEvent read FOnEndScroll write SetOnEndScroll;
    property OnFillClientBlob:TOnFillClientBlob read FOnFillClientBlob write FOnFillClientBlob;
  {$IFNDEF NO_GUI}
    property SQLScreenCursor  :TCursor read FSQLScreenCursor write FSQLScreenCursor default crDefault ;
  {$ENDIF}
    property SQLs: TSQLs read FSQLs write FSQLs stored False;
    property RefreshTransactionKind:TTransactionKind read FRefreshTransactionKind
     write SetRefreshTransactionKind default tkReadTransaction;

    property BeforeStartTransaction:TNotifyEvent read FBeforeStartTr write FBeforeStartTr ;
    property AfterStartTransaction:TNotifyEvent read FAfterStartTr write FAfterStartTr;
    property BeforeEndTransaction :TEndTrEvent  read FBeforeEndTr write FBeforeEndTr;
    property AfterEndTransaction  :TEndTrEvent  read FAfterEndTr write FAfterEndTr;

    property BeforeStartUpdateTransaction:TNotifyEvent read FBeforeStartUpdTr write FBeforeStartUpdTr;
    property AfterStartUpdateTransaction :TNotifyEvent read FAfterStartUpdTr write FAfterStartUpdTr;
    property BeforeEndUpdateTransaction  :TEndTrEvent  read FBeforeEndUpdTr write FBeforeEndUpdTr;
    property AfterEndUpdateTransaction   :TEndTrEvent  read FAfterEndUpdTr write FAfterEndUpdTr;

    property AllowedUpdateKinds: TUpdateKinds read FAllowedUpdateKinds write
      FAllowedUpdateKinds  default [ukModify, ukInsert, ukDelete];
{$IFDEF CSMonitor}
    property CSMonitorSupport: TCSMonitorSupport read FCSMonitorSupport  write SetCSMonitorSupport;
{$ENDIF}

  end;

  TFIBDataSet = class(TFIBCustomDataSet)
  private
    function DoStoreActive:boolean;
  public
    property Params;
    property Prepared;
    property QDelete;
    property QInsert;
    property QRefresh;
    property QSelect;
    property QUpdate;
    property StatementType;
    property UpdatesPending;
  public
    property Bof;
    property Bookmark;
    property Designer;
    property Eof;
    property FieldCount;
    property FieldDefs;
    property Fields;
    property FieldValues;
    property Modified;
    property RecordCount;
    property State;
    property BufferChunks;
  published
    property CachedUpdates;
    property UniDirectional;
    property UpdateRecordTypes;

    property UpdateSQL;
    property DeleteSQL;
    property InsertSQL;
    property RefreshSQL;
    property SelectSQL;
    property Filter;
    property FilterOptions;
    property CacheModelOptions;    
    property DatabaseDisconnecting;
    property DatabaseDisconnected;
    property DatabaseFree;
    property OnUpdateError;
    property OnUpdateRecord;
    property AfterUpdateRecord;    
    property TransactionEnding;
    property TransactionEnded;
    property TransactionFree;
    property AutoUpdateOptions;

    property Conditions;
  published
    (*
     * Published out of TDataset
     *)

    property Active stored DoStoreActive;
    property AutoCalcFields;
//    property DataSource read GetDataSource write SetDataSource;
    property AfterCancel;
    property AfterClose;
    property AfterDelete;
    property AfterEdit;
    property AfterInsert;
    property AfterOpen;
    property AfterPost;
    property AfterScroll;
    property BeforeCancel;
    property BeforeClose;
    property BeforeDelete;
    property BeforeEdit;
    property BeforeInsert;
    property BeforeOpen;
    property BeforePost;
    property BeforeScroll;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnNewRecord;
    property OnPostError;

    property BeforeRefresh;
    property AfterRefresh;
{TFIBCustomDataSet}
    property AllowedUpdateKinds;
    property Transaction;
    property Database;
    property BeforeFetchRecord;
    property AfterFetchRecord;
    property OnGetRecordError;
    property Options;
    property DetailConditions;

    property  UpdateTransaction;
    property  PrepareOptions;
    property FieldOriginRule;    
    property AutoCommit;
    property OnFieldChange;
    property OnEnableControls;
    property OnDisableControls;
    property OnEndScroll     ;
    property OnFillClientBlob;
 {$IFNDEF NO_GUI}
    property SQLScreenCursor ;
 {$ENDIF}    
    property SQLs;
    property RefreshTransactionKind;

    property BeforeStartTransaction ;
    property AfterStartTransaction;
    property BeforeEndTransaction ;
    property AfterEndTransaction  ;

    property BeforeStartUpdateTransaction;
    property AfterStartUpdateTransaction ;
    property BeforeEndUpdateTransaction  ;
    property AfterEndUpdateTransaction   ;
    property DataSource read GetDataSource write SetDataSource;
{$IFDEF CSMonitor}
    property CSMonitorSupport;
{$ENDIF}

  end;

  (* TFIBDSBlobStream *)
  TFIBDSBlobStream = class(TStream)
  protected
    FBlobDataArray: PBlobDataArray;
    FBlobID   : TISC_QUAD;
    FModified :boolean;
    FField: TField;
    FBlobStream: TFIBBlobStream;
  public
    constructor Create(AField: TField; ABlobStream: TFIBBlobStream;
      Mode: TBlobStreamMode; ABlobID: TISC_QUAD;aBlobDataArray: PBlobDataArray);
    destructor Destroy; override;
    function  Read(var Buffer; Count: Longint): Longint; override;
    function  Seek(Offset: Longint; Origin: Word): Longint; override;
    procedure SetSize(NewSize: Longint); override;
    function  Write(const Buffer; Count: Longint): Longint; override;
  end;


(*
 * Support routines
 *)
function RecordDataLength(n: Integer): Long;
function IsDBKeyField(Field:TObject):boolean;
function LocateOptionsToExtLocateOptions(LocateOptions:TLocateOptions):TExtLocateOptions;

type
  TFIBFilterType = (ftByField, ftCopy);

procedure FilterOut(FromDS: TFIBCustomDataSet);
(* Clear the entire record cache, and do everything short of
   closing the data set--but don't delete anything, etc.. *)



procedure Sort(DataSet: TFIBCustomDataSet; aFields: array of const;
  Ordering: array of Boolean);
 



(*
 * More constants
 *)
const
  DefaultFieldClasses: array[ftUnknown..ftTypedBinary] of TFieldClass = (
    nil,                (* ftUnknown *)
    TFIBStringField,    (* ftString *)
    TFIBSmallIntField,     (* ftSmallint *)
    TFIBIntegerField,      (* ftInteger *)
    TWordField,         (* ftWord *)
    TFIBBooleanField,      (* ftBoolean *)
    TFIBFloatField,     (* ftFloat *)
    TCurrencyField,     (* ftCurrency *)
    TFIBBCDField,          (* ftBCD *)

    TFIBDateField,         (* ftDate *)
    TFIBTimeField,         (* ftTime *)
    TFIBDateTimeField,     (* ftDateTime *)
  {$IFDEF SUPPORT_ARRAY_FIELD}
    TFIBArrayField,
  {$ELSE}
    TBytesField,        (* ftBytes *)
  {$ENDIF}
    TVarBytesField,     (* ftVarBytes *)
    TAutoIncField,      (* ftAutoInc *)

    TFIBBlobField,         (* ftBlob *)
    TFIBMemoField,         (* ftMemo *)
    TGraphicField,      (* ftGraphic *)

    TFIBBlobField,         (* ftFmtMemo *)
    TFIBBlobField,         (* ftParadoxOle *)
    TFIBBlobField,         (* ftDBaseOle *)
    TFIBBlobField          (* ftTypedBinary *)
   );



{$IFDEF LINUX}
const
  FILE_BEGIN = 0;
  FILE_CURRENT = 1;
  FILE_END = 2;
{$ENDIF}
const
  SNoAction = 'No Action';




procedure Register;

implementation
 uses StrUtil,FIBConsts,pFIBDataInfo,VariantRtn,IB_ErrorCodes,pFIBCacheQueries;

const
      DiffSizesRecData=SizeOf(TRecordData)-SizeOf(TSavedRecordData);
      LocateParamPrefix='LOCATE_';

procedure Register;
begin
  RegisterClass(TFIBStringField);
  RegisterClass(TFIBIntegerField);
  RegisterClass(TFIBSmallIntField);
  RegisterClass(TFIBFloatField);
  RegisterClass(TFIBBCDField);
  RegisterClass(TFIBBooleanField);

  {$IFDEF SUPPORT_ARRAY_FIELD}
   RegisterClass(TFIBArrayField);
  {$ENDIF}
   RegisterClass(TFIBLargeIntField);
   RegisterClass(TFIBGuidField);
   RegisterClass(TFIBDateField);
   RegisterClass(TFIBTimeField);
   RegisterClass(TFIBDateTimeField);
   RegisterClass(TFIBBlobField);
   RegisterClass(TFIBWideStringField);
   RegisterClass(TFIBMemoField);
end;


function IsDBKeyField(Field:TObject):boolean;
begin
   Result:=((Field is TFIBStringField) and(TFIBStringField(Field).IsDBKey))
    or
    ((Field is TFieldDef) and (TFieldDef(Field).DataType=ftString)
     and
      (TFieldDef(Field).Name='DB_KEY')
    )
end;

(*
 * TFIBStringField - implementation
 *)




constructor TFIBStringField.Create(AOwner: TComponent);
begin
  inherited;
  FSqlSubType             :=-1;
  FDefaultValueEmptyString:=False;
end;

destructor  TFIBStringField.Destroy;
begin
 if Assigned(FReservedBuffer) then
  FreeMem(FReservedBuffer);
 inherited;
end;

class procedure TFIBStringField.CheckTypeSize(Value: Integer);
begin
  (*
   * Just don't check. Any string size is valid.
   *)
end;

procedure TFIBStringField.SetDataSet(ADataSet: TDataSet); 
begin
  inherited SetDataSet(ADataSet);
  if Assigned(ADataSet) and (ADataSet is TFIBCustomDataSet)  then
  begin
    FEmptyStrToNull         :=
     psSetEmptyStrToNull in TFIBCustomDataSet(ADataSet).FPrepareOptions;
  end;    
end;

function   TFIBStringField.GetAsDB_KEY:string;
var
  i : Integer;
  p : Pointer;
begin
  if Dataset.IsEmpty then
  begin
    Result:=''; Exit;
  end;
  if not Assigned(FReservedBuffer) then
  begin
     GetMem(FReservedBuffer, Size + 1);
     FReservedBuffer[Size]:=#0;
  end;
  if not GetData(FReservedBuffer) then
     Result :=''
  else
  for i := 0 to (Size div 4) - 1 do
  begin
      p := Pointer(Integer(FReservedBuffer) + i * 4);
      Result := Result + Format('%-8.8x', [Integer(p^)]);
  end;
end;

function  TFIBStringField.IsDBKey:boolean;
begin
  with TFIBDataSet(DataSet) do
  if (FieldKind=fkData) and Assigned(vFieldDescrList) and (vFieldDescrList.Capacity>0) then
  begin
   Result:=vFieldDescrList[FieldNo-1]^.fdIsDBKey;
  end
  else
   Result:=False;
end;


function  TFIBStringField.SqlSubType:integer;
var
 F:TFIBXSQLVAR;
begin
 Result := -1;
 if FieldKind<>fkData then
  Exit;
 if FSqlSubType=-1 then
 begin
   with TFibDataSet(DataSet),TFibDataSet(DataSet).QSelect do
   begin
    F:=QSelect[Self.FieldName];
   end;
   if F<>nil then
   begin
     FSqlSubType:=F.SQLSubtype;
   end;
 end;
 Result:=FSqlSubType;
end;

function  TFIBStringField.CharacterSet :string;
var
 F:TFIBXSQLVAR;
begin
 Result:=UnknownStr;
if FieldKind<>fkData then
  Exit;
 with TFibDataSet(DataSet),TFibDataSet(DataSet).QSelect do
 try
  F:=QSelect[Self.FieldName];
  if F<>nil then
   Result:=F.CharacterSet;
 except
 end;
end;

function TFIBStringField.GetAsString: string;
begin        
  // 填