pfibdataset.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 pFIBDataSet;

interface
{$I FIBPlus.inc}

uses
  SysUtils, Classes,StdFuncs, DB, ibase, IB_Intf, IB_Externals,
  fib, FIBMiscellaneous, pFIBDatabase,  FIBDataBase, FIBDataSet, FIBQuery,
  pFIBLists,  pFIBQuery, DSContainer, pFIBProps,  IB_ErrorCodes,pFIBInterfaces,
  pFIBDataInfo,
  {$IFDEF WINDOWS}
    {$IFDEF D6+}FMTBcd, Variants, {$ENDIF}
    Windows,   Messages;
  {$ENDIF}
  {$IFDEF LINUX}
    Types,FMTBcd, Variants;
  {$ENDIF}




type

  TLockStatus = (lsSuccess, lsDeadLock, lsNotExist, lsMultiply, lsUnknownError);
  TLockErrorEvent =
    procedure(DataSet: TDataSet; LockError: TLockStatus;
    var ErrorMessage: string; var Action: TDataAction) of object;

  TCachRefreshKind = (frkEdit, frkInsert);
  TOnGetSQLTextProc = procedure(DataSet: TFIBDataSet; var SQLText: string) of object;


  TIncludeFieldsToSQL=(ifsAllFields,ifsNoBlob,ifsOnlyBlob);

  TpFIBDataSet = class(TFIBDataSet)
  private
    vQryRecordCount: TFIBQuery;
    vLockQry: TFIBQuery;
    FDataSet_ID: integer;
    FLoadedDataSet_ID: integer;
    FDefaultFormats: TFormatFields;
    FOnLockError: TLockErrorEvent;
    vUserOnPostError: TDataSetErrorEvent;
    vUserOnDeleteError: TDataSetErrorEvent;
    // lists of UpdateObjects
    vUpdates: TList;
    vDeletes: TList;
    vInserts: TList;


    FReceiveEvents: TStrings;
{$IFDEF USE_DEPRECATE_METHODS2}
    FOnUserEvent: TUserEvent;
{$ENDIF }

    FHaveUncommitedChanges: boolean;
    FHaveRollbackedChanges: boolean;

    FDescription: string;
    FOnAskRecordCount: TOnGetSQLTextProc;
    FOnApplyDefaultValue:TOnApplyDefaultValue;
    FSQLTextChanges: integer;
    FBlobsUpdate: TpFIBUpdateObject;
    FOnApplyFieldRepository:TOnApplyFieldRepository;
    FContainer: TDataSetsContainer;
    FDefaultsInited:boolean;
    FParamsForFields: array of TFIBXSQLVAR;
    FGeneratorBeUsed:boolean;
    procedure SetContainer(Value: TDataSetsContainer);
{$IFDEF USE_DEPRECATE_METHODS2}
    procedure SetReceiveEvents(Value: TStrings);
{$ENDIF}
    //Property access procedures
    function  GetSelectSQL: TStrings;
    procedure SetSelectSQL(Value: TStrings);

    // UpdateObjects support
    function ListForUO(KindUpdate: TUpdateKind): TList;
    procedure SynchroOrdersUO(List: TList);

    //

    procedure SetDataSet_ID(Value: Integer);
    function GetFieldForTable(const Relation: string): TField;
    function WillGenerateSQLs: boolean;
    function  GetFIBVersion: string;
    procedure SetFIBVersion(const vs: string);

  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation);  override;
    function  GetVisibleRecno: Integer;
    procedure SetVisibleRecno(Value: Integer);
    function  GetRecNo: Integer; override;
    procedure SetRecNo(Value: Integer); override;
    procedure InternalPost; override;
    procedure InternalOpen ;override;
    procedure SetPrepareOptions(Value: TpPrepareOptions); override;
    procedure DoOnPostError(DataSet: TDataSet; E: DB.EDatabaseError; var Action:
      TDataAction); override;
    procedure DoOnDeleteError(DataSet: TDataSet; E: DB.EDatabaseError; var
      Action: TDataAction);

    function  CompareFieldValues(Field:TField;const S1,S2:variant):integer; override;
    //     IProviderSupport
  protected
//    FParams: TParams;



{$IFNDEF D10+}
    function PSGetTableName: string; override;
    function PSGetKeyFields: string; override;
    function PSGetQuoteChar: string; override;
    procedure PSSetCommandText(const CommandText: string); override;
{$ELSE}
    procedure PSSetCommandText(const CommandText: Widestring); override;
    function PSGetTableNameW: WideString; override;
    function PSGetKeyFieldsW: WideString; override;
    function PSGetQuoteCharW: Widestring; override;
    function PSGetCommandTextW: WideString;override;
{$ENDIF}
    function PSGetUpdateException(E: Exception; Prev: EUpdateError):
      EUpdateError; override;
    function PSInTransaction: Boolean; override;
    function PSIsSQLBased: Boolean; override;
    function PSIsSQLSupported: Boolean; override;
    procedure PSStartTransaction; override;
    procedure PSEndTransaction(Commit: Boolean); override;

    procedure PSReset; override;
    function PSUpdateRecord(UpdateKind: TUpdateKind; Delta: TDataSet): Boolean;
      override;
    function PSExecuteStatement(const ASQL: {$IFNDEF D10+} string{$ELSE} Widestring{$ENDIF}; AParams: TParams;
      ResultSet: Pointer = nil): Integer; override;
    procedure PSExecute; override;
    function PSGetParams: TParams; override;
    procedure PSSetParams(AParams: TParams); override;




    function IsVisible(Buffer: PChar): Boolean; override;

    procedure InternalPostRecord(Qry: TFIBQuery; Buff: Pointer); override;
    procedure InternalDeleteRecord(Qry: TFIBQuery; Buff: Pointer); override;
    procedure AddedFilterRecord(DataSet: TDataSet; var Accept: Boolean);
      virtual;

    procedure InternalDoBeforeOpen; override;
    procedure DoBeforeOpen; override;
    procedure DoAfterOpen; override;
    procedure DoAfterClose; override;
    procedure DoBeforeInsert; override;
    procedure DoAfterInsert; override;
    procedure DoBeforeEdit; override;
    procedure DoBeforePost; override;
    procedure DoAfterPost; override;
    procedure DoBeforeCancel; override;
    procedure DoAfterCancel; override;
    procedure DoBeforeDelete; override;
    procedure DoOnNewRecord; override;
    procedure DoAfterDelete; override;
    procedure DoAfterEdit; override;
    procedure DoAfterScroll; override;
    procedure DoBeforeClose; override;
    procedure DoBeforeScroll; override;
    procedure DoOnCalcFields; override;

    procedure DoBeforeRefresh; override;
    procedure DoAfterRefresh; override;

    procedure DoOnApplyDefaultValue(Field:TField; var Applied:boolean); dynamic;

    function  GetRecordCount: Integer; override;
    procedure UpdateFieldsProps; virtual;

    procedure DoAfterEndUpdateTransaction(EndingTR:TFIBTransaction;Action: TTransactionAction;
      Force: Boolean); override;

    procedure ClearModifFlags(Kind: byte; NeedRefreshFields:boolean=True);
    procedure CloseProtect;
    function RaiseLockError(LockError: TLockStatus; ExceptMessage: string):
      TDataAction;
  private
//
    FBlockContextCount:integer;
    FBlockSize:Integer;
    FExecBlockStatement:TStrings;
    function  AddStatementToExecuteBlock(SK:TpSQLKind):boolean;
    //=Succes add to execblock
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function RecordCountFromSrv: integer; dynamic;
    function VisibleRecordCount: Integer;
    function VisibleRecnoToRecno(VisRN: integer): Integer;

    procedure ParseParamToFieldsLinks(Dest: TStrings);
    procedure Prepare; override;
    function CanEdit: Boolean; override;
    function CanInsert: Boolean; override;
    function CanDelete: Boolean; override;
    function IsSequenced: Boolean; override; // Scroll bar

    function ExistActiveUO(KindUpdate: TUpdateKind): boolean;
    // Exist active Update objects

    function AddUpdateObject(Value: TpFIBUpdateObject): integer;
    procedure RemoveUpdateObject(Value: TpFIBUpdateObject);

    function ParamByName(const ParamName: string): TFIBXSQLVAR;
    function FindParam(const ParamName: string): TFIBXSQLVAR;

    function RecordStatus(RecNumber: integer): TUpdateStatus;
    procedure CloneRecord(SrcRecord: integer; IgnoreFields: array of const);
    procedure CloneCurRecord(IgnoreFields: array of const);
    // Cached Routine
    procedure CommitUpdToCach; // Clear CU buffers
    procedure ApplyUpdToBase(DontChangeCacheFlags:boolean=True); // Send Updates to Base
    procedure ApplyUpdates;

    // SaveLoad Buffer functions

    procedure SaveToStream(Stream: TStream; SeekBegin: boolean);
    procedure LoadFromStream(Stream: TStream; SeekBegin: boolean);

    procedure SaveToFile(const FileName: string);
    procedure LoadFromFile(const FileName: string);

    // End SaveLoad

    function LockRecord(RaiseErr: boolean= True): TLockStatus;
    function FieldByFieldNo(FieldNo: Integer): TField;
    function ParamNameCount(const aParamName: string): integer;
    function ParamCount: integer;
    procedure ExecUpdateObjects(KindUpdate: TUpdateKind; Buff: Pointer;
      aExecuteOrder: TFIBOrderExecUO);
{$IFDEF USE_DEPRECATE_METHODS2}
    procedure DoUserEvent(Sender: TObject; const UDE: string; var Info: string);
      dynamic; deprecated;
{$ENDIF}
    procedure OpenWP(const ParamValues: array of Variant); overload;
    procedure OpenWP(const ParamNames : string;const ParamValues: array of Variant); overload;
    procedure OpenWPS(const ParamSources: array of ISQLObject);

    procedure ReOpenWP(const ParamValues: array of Variant); overload;
    procedure ReOpenWP(const ParamNames : string;const ParamValues: array of Variant); overload;
    procedure ReOpenWPS(const ParamSources: array of ISQLObject);


    procedure BatchRecordToQuery(ToQuery:TFIBQuery);
    procedure BatchAllRecordsToQuery(ToQuery:TFIBQuery);
    procedure AutoGenerateSQLText(ForState: TDataSetState);


    function GenerateSQLText
      (const TableName, KeyFieldNames: string; SK: TpSQLKind; IncludeFields:TIncludeFieldsToSQL=ifsAllFields): string;

    function GenerateSQLTextNoParams
      (const TableName, KeyFieldNames: string; SK: TpSQLKind): string;

    function GenerateSQLTextWA
      (const TableName: string; SK: TpSQLKind; IncludeFields:TIncludeFieldsToSQL=ifsAllFields): string;
      // Where All
    procedure GenerateUpdateBlobsSQL;
    procedure GenerateSQLs;
    function CanGenerateSQLs: boolean;

    //AutoUpdate operations
    function KeyField: TField;
    function SqlTextGenID: string;
    procedure IncGenerator; virtual;


    function AllKeyFields(const TableName: string): string;

    procedure CacheModify(
      aFields: array of integer; Values: array of Variant;  KindModify: byte
    );

    procedure CacheEdit(aFields: array of integer; Values: array of Variant);
    procedure CacheAppend(aFields: array of integer; Values: array of Variant);
      overload;
    procedure CacheAppend(Value: Variant; DoRefresh: boolean = False); overload;

    procedure CacheInsert(aFields: array of integer; Values: array of Variant);
      overload;
    procedure CacheInsert(Value: Variant; DoRefresh: boolean = False); overload;

    procedure CacheRefresh(FromDataSet: TDataSet; Kind: TCachRefreshKind
      ; FieldMap: Tstrings
      );
    procedure CacheRefreshByArrMap(
      FromDataSet: TDataSet; Kind: TCachRefreshKind;
      const SourceFields, DestFields: array of string
      );
    function RecordFieldAsFloat(Field: TField; RecNumber: integer;
      IsVisibleRecordNum: boolean = True): Double;

  public
    property HasUncommitedChanges: boolean read FHaveUncommitedChanges;
    property HaveRollbackedChanges: boolean read FHaveRollbackedChanges;
    property AllRecordCount: integer read FAllRecordCount;
    property VisibleRecno: integer read GetVisibleRecno write SetVisibleRecno;
  published

    //Added properties
    property Filtered;
    property OnFilterRecord;

    property DeleteSQL: TStrings read GetDeleteSQL write SetDeleteSQL;
    property UpdateSQL: TStrings read GetUpdateSQL write SetUpdateSQL;
    property InsertSQL: TStrings read GetInsertSQL write SetInsertSQL;
    property RefreshSQL: TStrings read GetRefreshSQL write SetRefreshSQL;
    property SelectSQL: TStrings read GetSelectSQL write SetSelectSQL;

    property DefaultFormats: TFormatFields read FDefaultFormats write
      FDefaultFormats;
    property OnPostError: TDataSetErrorEvent read vUserOnPostError write
      vUserOnPostError;
    property OnDeleteError: TDataSetErrorEvent read vUserOnDeleteError write
      vUserOnDeleteError;
    property OnLockError: TLockErrorEvent read FOnLockError write FOnLockError;
{$IFDEF USE_DEPRECATE_METHODS2}

    property OnUserEvent: TUserEvent read FOnUserEvent write FOnUserEvent;

    property ReceiveEvents: TStrings read FReceiveEvents write SetReceiveEvents;
{$ENDIF}    
    property DataSet_ID: integer read FDataSet_ID write SetDataSet_ID default 0;
    property Description: string read FDescription write FDescription;
    property Container:TDataSetsContainer read FContainer write SetContainer;
    property OnAskRecordCount: TOnGetSQLTextProc read FOnAskRecordCount write
      FOnAskRecordCount;
    property About: string read GetFIBVersion write SetFIBVersion stored False;
    property OnApplyDefaultValue:TOnApplyDefaultValue read FOnApplyDefaultValue write FOnApplyDefaultValue;
    property OnApplyFieldRepository:TOnApplyFieldRepository read FOnApplyFieldRepository write FOnApplyFieldRepository;
  end;

function FieldInArray(Field: TField; Arr: array of const): boolean;


implementation

uses
{$IFNDEF NO_MONITOR}
  FIBSQLMonitor,
{$ENDIF}

  StrUtil, DBConsts, SqlTxtRtns, FIBConsts, //Commonib,
  pFIBFieldsDescr, pFIBCacheQueries,VariantRtn;

const
  SQLKindNames: array[TpSQLKind] of string = (
    'UpdateSQL',
    'InsertSQL',
    'DeleteSQL',
    'RefreshSQL'
    );

  StreamSignature = 'FIB$DATASET';

function UseFormat(const sFormat: string; Scale: integer): string;
var
  L, pD: integer;
begin
  L := Length(sFormat);
  if (L = 0) then
    Result := sFormat
  else
  if (sFormat[L] = '.') then
    Result := sFormat + MakeStr('0', Scale)
  else
  begin
    pD := PosCh('.', sFormat);
    if pD = 0 then
      Result := sFormat
    else
    if (pD = L - 1) then
      Result := FastCopy(sFormat, 1, Pred(pd)) + '.' + MakeStr(sFormat[L], Scale)
    else
      Result := sFormat
  end;
end;

//

constructor TpFIBDataSet.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDefaultFormats := TFormatFields.Create(Self);
  inherited OnPostError := DoOnPostError;
  inherited OnDeleteError := DoOnDeleteError;

  vUpdates := TList.Create;
  vDeletes := TList.Create;
  vInserts := TList.Create;

  FReceiveEvents := TStringList.Create;

  vQryRecordCount := TFIBQuery.Create(Self);
  vQryRecordCount.ParamCheck := True;
  vLockQry := TFIBQuery.Create(Self);
  vLockQry.ParamCheck := True;

end;

destructor TpFIBDataSet.Destroy;