pfibdatainfo.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 pFIBDataInfo;

interface

{$I FIBPlus.inc}
uses
  SysUtils,Classes,DB,FIBDataSet,FIBDataBase,FIBQuery,
  pFIBQuery,pFIBDataBase,pFIBProps
 {$IFDEF WINDOWS},Windows ; {$ENDIF}
 {$IFDEF LINUX},Libc ; {$ENDIF}

 type
        TExtBoolean= (eFalse,eTrue,eUnknown);

        TpFIBFieldInfo=class
        private
         FIsComputed  :boolean;
         FDefaultValue:string;
         FCanIncToWhereClause:boolean;
         FDomainName:string;
         FDefaultValueEmptyString: boolean;
// Info from FIB$FIELDS_INFO
         FWithAdditionalInfo:boolean;
         FDisplayLabel :string;
         FVisible      :boolean;
         FEditFormat   :string;
         FDisplayFormat:string;
         FIsTriggered  :boolean;
         FOtherInfo    :TStrings;
         FDisplayWidth :integer;
         FCanBeBoolean :TExtBoolean;
         FCanBeGUID    :TExtBoolean;
         FCharSet      :integer;
         function  GetCanBeBoolean:boolean;
         function  GetCanBeGUID:boolean;
         function  GetCharSet:string;
        public
         constructor Create;
         destructor  Destroy;override;
         procedure   SaveToStream(Stream:TStream);
         procedure   LoadFromStream(Stream:TStream;FromBegin:boolean);
         property    IsComputed  :boolean read FIsComputed;
         property    DefaultValue:string  read FDefaultValue;
         property    DomainName  :string  read FDomainName;
         property    CanIncToWhereClause:boolean read FCanIncToWhereClause;
// Info from FIB$FIELDS_INFO
         property WithAdditionalInfo:boolean read FWithAdditionalInfo;
         property DisplayLabel :string   read FDisplayLabel;
         property Visible      :boolean  read FVisible;
         property EditFormat   :string   read FEditFormat;
         property DisplayFormat:string   read FDisplayFormat;
         property IsTriggered  :boolean  read FIsTriggered;
         property OtherInfo    :TStrings read FOtherInfo;
         property DisplayWidth :integer  read FDisplayWidth;
         property DefaultValueEmptyString:boolean read FDefaultValueEmptyString;
         property CanBeBoolean :boolean  read GetCanBeBoolean;
         property CanBeGuid    :boolean  read GetCanBeGUID;
         property CharSetID    :integer  read FCharSet;
         property CharSet      :string   read GetCharSet;
        end;


        TpFIBTableInfoCollect= class;

        TpFIBTableInfo=class
        private
         FOwner:TpFIBTableInfoCollect;
         FDBName             :string;
         FTableName          :string;
         FPrimaryKeyFields   :string;
         FFieldList          :TStringList;
         FFormatNumber       :integer;
         FFIVersion          :integer;//FIB$FIELDS_INFO
         FWithFieldRepositaryInfo :boolean;
         FStreamVersion      :integer;
         FNonValidated       :boolean;
         FTableID            :integer;
         procedure GetInfoFields(const TableName:string;aTransaction:TFIBTransaction);
         procedure GetRepositaryFieldInfos(const TableName:string;aTransaction:TFIBTransaction);
         procedure ClearFieldList;
         procedure GetAdditionalInfo(FromQuery:TFIBDataset;
          const aFieldName:string;ToFieldInfo:TpFIBFieldInfo );
         procedure   FillInfo(DB:TFIBDataBase;Tr:TFIBTransaction; const ATableName:string);
         function    IsActualInfo(DB:TFIBDatabase) :boolean;
         function    GetPrimaryKeyFields(DB:TFIBDatabase): string;
         function    GetTableId(DB:TFIBDatabase):integer;
         procedure   LoadFromStreamVersion(Stream:TStream;aStreamVersion:integer);
        public
         constructor Create(AOwner:TpFIBTableInfoCollect);
         destructor  Destroy;override;
         procedure   SaveToStream(Stream:TStream);
         procedure   LoadFromStream(Stream:TStream;FromBegin:boolean);

         function    FieldInfo(const FieldName:string):TpFIBFieldInfo;
         property    TableName:string read FTableName ;
         property    PrimaryKeyFields[DB:TFIBDatabase]:string read GetPrimaryKeyFields;
         property    FieldList :TStringList read FFieldList;
         property    TableID[DB:TFIBDatabase]:integer read GetTableId;
        end;



       TpFIBTableInfoCollect= class(TComponent)
       private
        FDBNames    :TStringList;
        FListTabInfo:TStringList;
//        FInternalTransaction:TpFIBTransaction;
        FLock: TMultiReadExclusiveWriteSynchronizer;
        FNeedValidate: boolean;
        FLastTransactionId:Integer;
        procedure PrepareInternalTransaction(aDataBase:TFIBDataBase);
       protected
         procedure Notification(AComponent: TComponent; Operation: TOperation); override;
       public
        constructor Create(AOwner:TComponent); override;
        destructor  Destroy;override;

        procedure   SaveToStream(Stream:TStream);
        procedure   LoadFromStream(Stream:TStream;DB:TFIBDatabase=nil);

        procedure   SaveToFile(const FileName:string);
        function    LoadFromFile(const FileName:string;DB:TFIBDatabase=nil):boolean;
        procedure   ValidateSchema(aDataBase:TFIBDataBase;Proc:TpFIBAcceptCacheSchema);

        function    FindTableInfo(const ADBName,ATableName:string):TpFIBTableInfo;
        function    GetTableInfo(aDataBase:TFIBDataBase;const ATableName:string;
              WithRepositaryInfo:boolean
        ):TpFIBTableInfo;
        function
         GetFieldInfo(aDataBase:TFIBDataBase; const ATableName,AFieldName:string;
                      RepositoryInfo:boolean
         ):TpFIBFieldInfo;

        procedure   Clear;
        procedure   ClearForDataBase(aDatabase:TFIBDataBase);
        procedure   ClearForTable(const TableName:string)   ;
        procedure   CommitInternalTransaction ;
        property    NeedValidate :boolean read FNeedValidate write FNeedValidate;
       end;


       TpDataSetInfo= class
       private
         FDBName:string;
         FVersion:integer;
         FSelectSQL:TStrings;
         FInsertSQL:TStrings;
         FUpdateSQL:TStrings;
         FDeleteSQL:TStrings;
         FRefreshSQL:TStrings;
         FKeyField:string;
         FGeneratorName:string;
         FDescription  :string;
         FUpdateTableName:string;
         FUpdateOnlyModifiedFields:boolean;
         FConditions   :string;
         FNonValidated :boolean;

       public
        constructor Create(DataSet:TFIBDataSet); overload;
        constructor Create; overload;
        destructor  Destroy;override;

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

       end;

       TpDataSetInfoCollect= class
       private
        FListDataSetInfo:TStringList;
        FLock: TRTLCriticalSection;
        FNeedValidate: boolean;
        function    ActualVersionDSInfo(DataSet:TFIBDataSet):integer;        
       public
        constructor Create;
        destructor  Destroy;override;
        function    FindDataSetInfo(DataSet:TFIBDataSet; var Index:integer):TpDataSetInfo; overload;
        function    FindDataSetInfo(const DBName:string;DS_ID:Integer ; var Index:integer):TpDataSetInfo; overload;
        function    GetDataSetInfo(DataSet:TFIBDataSet):TpDataSetInfo;
        function    LoadDataSetInfo(DataSet:TFIBDataSet):boolean;
        procedure   Clear;
        procedure   ClearDSInfo(DataSet:TFIBDataSet); overload;
        procedure   ClearDSInfo(DS_ID:integer); overload;

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

        procedure   SaveToFile(const FileName:string);
        function    LoadFromFile(const FileName:string):boolean;
        property    NeedValidate :boolean read FNeedValidate write FNeedValidate;
       end;

       TpStoredProcCollect= class
       private
        FStoredProcNames:TStringList;
        FSPParamTxt:TStringList;
        function  IndexOfSP(DB:TFIBDatabase;const SPName:string;
         ForceReQuery:boolean):integer;
        function  GetParamsText(DB:TFIBDatabase;const SPName:string):string;
       public
        constructor Create;
        destructor  Destroy;override;
        procedure   Clear;
        function    GetExecProcTxt(DB:TFIBDatabase;
         const SPName:string;   ForceReQuery:boolean
        ):string;
        procedure   ClearSPInfo(DB:TFIBDatabase);
       end;

       TpErrorMessage=class
       private
        FErrorMsg :string;
        FVersion  :integer;
       public
        constructor Create(const aErrorMsg:string; aVersion:integer);
       public
        property ErrorMsg :string  read  FErrorMsg ;
        property Version  :integer read FVersion;
       end;

       TpErrorMessagesCollect=class
       private
        FDatabases :TStringList;
        FMaxVersion:integer;
        FValidated :boolean;
        FLock: TMultiReadExclusiveWriteSynchronizer;
        function  FindErrorMessage(const DBName,ErrorName:string;
         var BaseIndex,ErrorIndex:integer):boolean;
       public
        constructor Create;
        destructor  Destroy; override;
        procedure   Clear;
       public
        procedure   SaveToStream(Stream:TStream);
        procedure   LoadFromStream(Stream:TStream);
        procedure   SaveToFile(const FileName:string);
        procedure   LoadFromFile(const FileName:string);
       public
        procedure   AddErrorMessage(const DBName,ErrorName,ErrorMsg:string;
         Version:integer);
        function    ErrorMessage(Tr:TFIBTransaction; const ErrorName:string):string;
       end;

var
     ListTableInfo  :TpFIBTableInfoCollect;
     ListDataSetInfo:TpDataSetInfoCollect;
     ListSPInfo     :TpStoredProcCollect;
     ListErrorMessages:TpErrorMessagesCollect;
// Manage Developer Info tables

procedure   CreateFRepositaryTable(DB:TFIBDatabase);
procedure   CreateDRepositaryTable(DB:TFIBDatabase);
procedure   CreateERepositaryTable(DB:TFIBDatabase);

function    ExistFRepositaryTable(DB:TFIBDatabase):boolean;
function    ExistDRepositaryTable(DB:TFIBDatabase):boolean;
function    ExistERepositaryTable(DB:TFIBDatabase):boolean;
function    ExistBooleanDomain(DB:TFIBDatabase):boolean;

function    SaveFIBDataSetInfo(DataSet:TFibDataSet; const Name:string):boolean;

// Routine function

function    GetFieldInfos(Field:TField;RepositaryInfo:boolean):TpFIBFieldInfo;
function    GetOtherFieldInfo(Field:TField;const InfoName:string):string;
procedure   Update1RepositaryTable(Tr:TFIBTransaction);
procedure   Update2RepositaryTable(Tr:TFIBTransaction);


function DBPrimaryKeyFields(const TableName:string;
  aTransaction:TFIBTransaction
 ):string;

implementation

uses pFIBDataSet,StrUtil,FIBConsts,pFIBCacheQueries,ibase,SqlTxtRtns;

type
   TFriendDatabase= class(TFIBDatabase);

var
    DatabaseRepositories:TStringList;
    LockRepList: TRTLCriticalSection;

const
  SDefer='@FIB_DEFERRED';

FormatNumbersSQL=
  'select a1.rdb$relation_name,a1.RDB$RELATION_ID VER  from RDB$RELATIONS a1'#13#10+
  'where a1.RDB$SYSTEM_FLAG = 0'#13#10+
  'and not  a1.rdb$view_blr is null'#13#10+
  'union'#13#10+
  'select R.rdb$relation_name,RDB$FORMAT from RDB$RELATIONS R'#13#10+
  'where R.RDB$SYSTEM_FLAG = 0'#13#10+
  'and  R.rdb$view_blr is null   order by 1';

function ExistRepositaryTable(DB:TFIBDatabase;Kind:byte):boolean;
var aTransaction:TFibTransaction;
    qry         :TFIBQuery;
    Index       :integer;
    s           :string;
    cr          :TExtBoolean;

function RepositaryIsRegistered:TExtBoolean;
begin
 Index:=DatabaseRepositories.IndexOfObject(DB);
 if Index>-1 then
 begin
  case DatabaseRepositories[Index][Kind] of
   '0': Result:=eFalse;
   '1': Result:=eTrue;
  else
    Result:=eUnknown;
  end
 end
 else
   Result:=eUnknown;
end;

begin
 EnterCriticalSection(LockRepList);
 try
   if csDesigning in DB.ComponentState then
   begin
     Index:=-1;
     DatabaseRepositories.Clear;
     cr    :=eUnknown;
   end
   else
    cr    :=RepositaryIsRegistered;
   Result:=cr =eTrue;
   if cr<>eUnknown then Exit;
   if not (TFIBUseRepository(Kind-1) in DB.UseRepositories) then  Exit;

   if Index<0 then
     s:='222'
   else