pfibdatabase.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 pFIBDatabase;

interface
{$I FIBPlus.inc}

uses
 SysUtils, Classes, DB, ibase, IB_Intf, ib_externals,fib,FIBDatabase,FIBDataSet,
 FIBQuery,pFIBProps,StdFuncs,
 {$IFDEF WINDOWS}
   Windows, Messages {$IFDEF D6+} ,Variants{$ENDIF}
  {$IFNDEF  NO_GUI}
    ,Dialogs  // IS GUI units
  {$ENDIF}
 {$ENDIF}

 {$IFDEF LINUX}
  Types,Variants
  {$IFNDEF  NO_GUI}
     ,QDialogs // IS GUI units
  {$ENDIF}
 {$ENDIF}
;
type

  TFIBLoginEvent =
   procedure(Database: TFIBDatabase; LoginParams: TStrings; var DoConnect:boolean )
  of object;


  TpFIBAcceptCacheSchema=procedure (const ObjName:string;var Accept:boolean) of object;
  
  TOnLostConnectActions =(laTerminateApp,laCloseConnect,laIgnore,laWaitRestore);
  TFIBLostConnectEvent =
   procedure(Database: TFIBDatabase; E:EFIBError;var Actions:TOnLostConnectActions)
  of object;

  TFIBRestoreConnectEvent =   procedure(Database:TFIBDatabase) of object;
  

  TpFIBDatabase = class(TFIBDatabase)
  private
    vTimer    : TFIBTimer;
    FAliasName:string;
    FRewriteAlias:boolean;
    FBeforeConnect:TFIBLoginEvent;
    FOnLostConnect:TFIBLostConnectEvent;
    FOnErrorRestoreConnect:TFIBLostConnectEvent;
    FAfterRestoreConnect:TFIBRestoreConnectEvent;
    FBeforeStartTr:TNotifyEvent ;
    FAfterStartTr :TNotifyEvent ;
    FBeforeEndTr  :TEndTrEvent  ;
    FAfterEndTr   :TEndTrEvent  ;
    FCacheSchemaOptions :TCacheSchemaOptions;
    FOnAcceptCacheSchema:TpFIBAcceptCacheSchema;    
    procedure SetAliasName(Value:string);
    function  GetWaitRC:Cardinal;
    procedure SetWaitRC(Value:Cardinal);
    function  GetFIBDataSet(Index:integer):TFIBCustomDataSet;
    function  GetFIBQuery(Index:integer):TFIBQuery;
    function  GetFIBVersion: string;
    procedure SetFIBVersion(const vs: string);
    function GetInRestoreConnect: boolean;
  protected
    procedure InternalClose(Force: Boolean;DBinShutDown:boolean); override;
    procedure CloseLostConnect;
    procedure DoOnLostConnect
     (Database: TFIBDatabase; E:EFIBError;var Actions:TOnLostConnectActions);dynamic;
    procedure DoOnErrorRestoreConnect
     (Database: TFIBDatabase; E:EFIBError;var Actions:TOnLostConnectActions);dynamic;
    procedure DoAfterRestoreConnect;dynamic;
    function  GetAfterConnect:TNotifyEvent;
    procedure SetAfterConnect(Method:TNotifyEvent);
    procedure CreateRCTimer;

    procedure  ReadSaveDBParams(Reader: TReader);
    procedure  DefineProperties(Filer: TFiler); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    function  ReadParamsFromAlias:boolean;dynamic;
    procedure WriteParamsToAlias ;dynamic;
    procedure Open(RaiseExcept:boolean = True);override;
    function  ExTestConnected(Actions:TOnLostConnectActions): Boolean;
    procedure WaitRestoreConnect;
    procedure StopWaitRestoreConnect;
    procedure RestoreConnect(Sender:TObject);
    procedure GetTableNames(TableNames: TStrings; WithSystem: Boolean );
    procedure GetFieldNames(const TableName: string; FieldNames: TStrings;
     WithComputedFields:boolean =True
    );
    procedure ApplyUpdates(const DataSets: array of TDataSet);

    procedure ForceCloseTransactions;
    procedure CloseDataSets;
    function  FIBQueryCount: integer;
    function  FIBDataSetsCount:integer;
    property  FIBDataSets[Index: Integer]:TFIBCustomDataSet read GetFIBDataSet;
    property  FIBQueries[Index: Integer]: TFIBQuery read GetFIBQuery;
    property  SaveDBParams:boolean  read FRewriteAlias write FRewriteAlias default
     True ;
    property  InRestoreConnect:boolean read GetInRestoreConnect;

  published
    property CacheSchemaOptions:TCacheSchemaOptions read FCacheSchemaOptions write FCacheSchemaOptions;
    property AliasName:string  read FAliasName write SetAliasName ;
    property WaitForRestoreConnect:Cardinal  read GetWaitRC write SetWaitRC
     default 30000;
    property SaveAliasParamsAfterConnect:boolean  read FRewriteAlias write FRewriteAlias default
     True ;
    property BeforeConnect :TFIBLoginEvent  read FBeforeConnect write FBeforeConnect ;
    property AfterConnect :TNotifyEvent  read GetAfterConnect write SetAfterConnect ;
    property OnLostConnect:TFIBLostConnectEvent  read FOnLostConnect write FOnLostConnect;
    property OnErrorRestoreConnect:TFIBLostConnectEvent  read FOnErrorRestoreConnect write FOnErrorRestoreConnect;
    property AfterRestoreConnect:TFIBRestoreConnectEvent  read FAfterRestoreConnect write FAfterRestoreConnect;
    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 About   :string read GetFIBVersion write SetFIBVersion stored False;
    property OnLogin :TFIBLoginEvent  read FBeforeConnect write FBeforeConnect stored False; // obsolete    //
    property OnAcceptCacheSchema:TpFIBAcceptCacheSchema read FOnAcceptCacheSchema write FOnAcceptCacheSchema;    
  end;

  TOnSQLExecute = procedure(Query:TFIBQuery; SQLType:TFIBSQLTypes) of object;

  TpFIBTransaction = class(TFIBTransaction)
  private
   FTPBMode:TTPBMode;
   FBeforeStart:TNotifyEvent;
   FAfterStart :TNotifyEvent;
   FBeforeEnd  :TEndTrEvent;
   FAfterEnd   :TEndTrEvent;
   FBeforeSQLExecute:TOnSQLExecute;
   FAfterSQLExecute:TOnSQLExecute;
   FUserKindTransaction:string;
   function  StoreTRParams:boolean;
   function  StoreUKTR:boolean;
   procedure SetUserKindTransaction(const Value:string);
   function  GetFIBDataSet(Index:integer):TFIBCustomDataSet;
   function  GetFIBQuery(Index:integer):TFIBQuery;
   function  GetFIBVersion: string;
   procedure SetFIBVersion(const Value: string);
  protected
   procedure EndTransaction(Action: TTransactionAction; Force: Boolean); override;
  public
   constructor Create(AOwner:TComponent); override;
   procedure   DoOnSQLExec(Query:TComponent;Kind:TKindOnOperation); override;
   procedure   StartTransaction; override;
   function    FIBQueryCount: integer;
   function    FIBDataSetsCount:integer;
   property    FIBDataSets[Index: Integer]:TFIBCustomDataSet read GetFIBDataSet;
   property    FIBQueries[Index: Integer]: TFIBQuery read GetFIBQuery;   
  published
   property BeforeStart:TNotifyEvent  read FBeforeStart write FBeforeStart;
   property AfterStart :TNotifyEvent  read FAfterStart  write FAfterStart;
   property BeforeEnd  :TEndTrEvent  read FBeforeEnd   write FBeforeEnd;
   property AfterEnd   :TEndTrEvent  read FAfterEnd    write FAfterEnd;
   property TPBMode:TTPBMode  read FTPBMode write FTPBMode default tpbReadCommitted;
   property TRParams stored StoreTRParams;
   property UserKindTransaction:string read FUserKindTransaction write
     SetUserKindTransaction stored StoreUKTR;
   property About   :string read GetFIBVersion write SetFIBVersion stored False;
   property AfterSQLExecute:TOnSQLExecute read FAfterSQLExecute write FAfterSQLExecute;
   property BeforeSQLExecute:TOnSQLExecute read FBeforeSQLExecute write FBeforeSQLExecute;
  end;



procedure WriteDBParamsToAlias(Database:TpFIBDataBase) ;

implementation

uses
{$IFNDEF NO_REGISTRY} RegUtils, {$ENDIF}
StrUtil,pFIBCacheQueries,pFIBQuery,pFIBDataSet,pFIBDataInfo;

type  THackTransaction = class(TFIBTransaction)
      end;

      THackFIBQuery  = class (TFIBQuery);

function  GetQueriesCount(ForObj:TComponent):integer;
var i,bc:integer;
    CurB:TFIBBase;
    IncludedDS:TList;
begin
 Result:=0;
 if (ForObj is TFIBDatabase) then
  bc:=TFIBDatabase(ForObj).FIBBaseCount-1
 else
  bc:=TFIBTransaction(ForObj).FIBBaseCount-1;
 IncludedDS:=TList.Create;
 with IncludedDS do
 try
  for i:=0 to bc do
  begin
    if (ForObj is TFIBDatabase) then
     CurB:=TFIBDatabase(ForObj).FIBBases[i]
    else
     CurB:=TFIBTransaction(ForObj).FIBBases[i];
    if (CurB.Owner=nil) or not (CurB.Owner is TFIBQuery) then Continue;
    if (TFIBQuery(CurB.Owner).Owner is TFIBCustomDataSet) then Continue;
    if IndexOf(TFIBQuery(CurB.Owner))=-1 then
    begin
     Inc(Result);
     Add(TFIBQuery(CurB.Owner))
    end;
  end;
 finally
  Free
 end;
end;

function  DoGetQuery(ForObj: TComponent; Index: Integer): TFIBQuery;
var i,j,bc:integer;
    CurB:TFIBBase;
    IncludedDS:TList;
begin
 Result:=nil;
 if Index<0 then Exit;
 if (ForObj is TFIBDatabase) then
  bc := TFIBDatabase(ForObj).FIBBaseCount-1
 else
  bc := TFIBTransaction(ForObj).FIBBaseCount-1;

 IncludedDS := TList.Create;
 with IncludedDS do
 try
  j:=0;
  for i:=0 to bc do
  begin
    if (ForObj is TFIBDatabase) then
     CurB := TFIBDatabase(ForObj).FIBBases[i]
    else
     CurB := TFIBTransaction(ForObj).FIBBases[i];

    if (CurB.Owner=nil) or not (CurB.Owner is TFIBQuery) then Continue;
    if (TFIBQuery(CurB.Owner).Owner is TFIBCustomDataSet) then Continue;
    if IndexOf(TFIBQuery(CurB.Owner)) = -1 then
    begin
     if j=Index then
     begin
      Result := TFIBQuery(CurB.Owner);
      Exit;
     end;
     Inc(j);
     Add(TFIBQuery(CurB.Owner));
    end;
  end;
 finally
  Free;
 end;
end;


function  GetDataSetsCount(ForObj:TComponent):integer;
var i,bc:integer;
    CurB:TFIBBase;
    IncludedDS:TList;
begin
 Result:=0;
 if (ForObj is TFIBDatabase) then
  bc:=TFIBDatabase(ForObj).FIBBaseCount-1
 else
  bc:=TFIBTransaction(ForObj).FIBBaseCount-1;
 IncludedDS:=TList.Create;
 with IncludedDS do
 try
  for i:=0 to bc do
  begin
    if (ForObj is TFIBDatabase) then
     CurB:=TFIBDatabase(ForObj).FIBBases[i]
    else
     CurB:=TFIBTransaction(ForObj).FIBBases[i];
    if
     (CurB=nil) or (CurB.Owner=nil) or not (CurB.Owner is TFIBQuery)
    then
      Continue;
    if not (TFIBQuery(CurB.Owner).Owner is TFIBCustomDataSet) then Continue;
    if IndexOf(TFIBQuery(CurB.Owner).Owner)=-1 then
    begin
     Inc(Result);
     Add(TFIBQuery(CurB.Owner).Owner)
    end;
  end;
 finally
  Free
 end;
end;

function  DoGetDataSet(ForObj:TComponent;Index:integer):TFIBCustomDataSet;
var i,j,bc:integer;
    CurB:TFIBBase;
    IncludedDS:TList;
begin
 Result:=nil;
 if Index<0 then Exit;
 if (ForObj is TFIBDatabase) then
  bc:=TFIBDatabase(ForObj).FIBBaseCount-1
 else
  bc:=TFIBTransaction(ForObj).FIBBaseCount-1;

 IncludedDS:=TList.Create;
 with IncludedDS do
 try
  j:=0;
  for i:=0 to bc do
  begin
    if (ForObj is TFIBDatabase) then
     CurB:=TFIBDatabase(ForObj).FIBBases[i]
    else
     CurB:=TFIBTransaction(ForObj).FIBBases[i];

    if (CurB.Owner=nil) or not (CurB.Owner is TFIBQuery) then Continue;
    if not (TFIBQuery(CurB.Owner).Owner is TFIBCustomDataSet) then Continue;
    if IndexOf(TFIBQuery(CurB.Owner).Owner)=-1 then
    begin
     if j=Index then
     begin
      Result:=TFIBCustomDataSet(TFIBQuery(CurB.Owner).Owner);
      Exit;
     end;
     Inc(j);
     Add(TFIBQuery(CurB.Owner).Owner)
    end;
  end;
 finally
  Free
 end;
end;

constructor TpFIBDatabase.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   FRewriteAlias:=True;
   FCacheSchemaOptions:=TCacheSchemaOptions.Create;
   FAliasName:='';
   vTimer :=nil;
end;

destructor TpFIBDatabase.Destroy;
begin
 inherited Destroy;
 FCacheSchemaOptions.Free;
end;

procedure TpFIBDatabase.CreateRCTimer;
begin
  if not Assigned(vTimer) then
  begin
    vTimer          := TFIBTimer.Create(Self);
    vTimer.Enabled  := False;
    vTimer.Interval := 30000; // 镱腱桧篁