--- ibx/trunk/runtime/IBExtract.pas 2012/08/05 18:28:19 7 +++ ibx/trunk/runtime/IBExtract.pas 2013/12/28 19:22:24 17 @@ -1,3142 +1,3142 @@ -{************************************************************************} -{ } -{ The contents of this file are subject to the InterBase } -{ Public License Version 1.0 (the "License"); you may not } -{ use this file except in compliance with the License. You } -{ may obtain a copy of the License at http://www.Inprise.com/IPL.html } -{ Software distributed under the License is distributed on } -{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either } -{ express or implied. See the License for the specific language } -{ governing rights and limitations under the License. } -{ } -{ The Original Code was created by Jeff Overcash. } -{ Portions based upon code by Inprise Corporation are Copyright (C) } -{ Inprise Corporation. All Rights Reserved. } -{ } -{ IBX Version 4.2 or higher required } -{ Contributor(s): Jeff Overcash } -{ } -{ IBX For Lazarus (Firebird Express) } -{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk } -{ Portions created by MWA Software are copyright McCallum Whyman } -{ Associates Ltd 2011 } -{ } -{************************************************************************} - -unit IBExtract; - -{$Mode Delphi} - -interface - -uses -{$IFDEF WINDOWS } - Windows, -{$ELSE} - unix, -{$ENDIF} - SysUtils, Classes, IBDatabase, IBDatabaseInfo, - IBSQL, IBUtils, IBHeader, IB, IBIntf; - -type - TExtractObjectTypes = - (eoDatabase, eoDomain, eoTable, eoView, eoProcedure, eoFunction, - eoGenerator, eoException, eoBLOBFilter, eoRole, eoTrigger, eoForeign, - eoIndexes, eoChecks, eoData); - - TExtractType = - (etDomain, etTable, etRole, etTrigger, etForeign, - etIndex, etData, etGrant, etCheck); - - TExtractTypes = Set of TExtractType; - - TIBExtract = class(TComponent) - private - FDatabase : TIBDatabase; - FTransaction : TIBTransaction; - FMetaData: TStrings; - FDatabaseInfo: TIBDatabaseInfo; - FShowSystem: Boolean; - { Private declarations } - function GetDatabase: TIBDatabase; - function GetIndexSegments ( indexname : String) : String; - function GetTransaction: TIBTransaction; - procedure SetDatabase(const Value: TIBDatabase); - procedure SetTransaction(const Value: TIBTransaction); - function PrintValidation(ToValidate : String; flag : Boolean) : String; - procedure ShowGrants(MetaObject: String; Terminator : String); - procedure ShowGrantRoles(Terminator : String); - procedure GetProcedureArgs(Proc : String); - protected - function ExtractDDL(Flag : Boolean; TableName : String) : Boolean; - function ExtractListTable(RelationName, NewName : String; DomainFlag : Boolean) : Boolean; - procedure ExtractListView (ViewName : String); - procedure ListData(ObjectName : String); - procedure ListRoles(ObjectName : String = ''); - procedure ListGrants; - procedure ListProcs(ProcedureName : String = ''); - procedure ListAllTables(flag : Boolean); - procedure ListTriggers(ObjectName : String = ''; ExtractType : TExtractType = etTrigger); - procedure ListCheck(ObjectName : String = ''; ExtractType : TExtractType = etCheck); - function PrintSet(var Used : Boolean) : String; - procedure ListCreateDb(TargetDb : String = ''); - procedure ListDomains(ObjectName : String = ''; ExtractType : TExtractType = etDomain); - procedure ListException(ExceptionName : String = ''); - procedure ListFilters(FilterName : String = ''); - procedure ListForeign(ObjectName : String = ''; ExtractType : TExtractType = etForeign); - procedure ListFunctions(FunctionName : String = ''); - procedure ListGenerators(GeneratorName : String = ''); - procedure ListIndex(ObjectName : String = ''; ExtractType : TExtractType = etIndex); - procedure ListViews(ViewName : String = ''); - - { Protected declarations } - public - { Public declarations } - constructor Create(AOwner : TComponent); override; - destructor Destroy; override; - function GetArrayField(FieldName : String) : String; - function GetFieldType(FieldType, FieldSubType, FieldScale, FieldSize, - FieldPrec, FieldLen : Integer) : String; - function GetCharacterSets(CharSetId, Collation : integer; CollateOnly : Boolean) : String; - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - procedure ExtractObject(ObjectType : TExtractObjectTypes; ObjectName : String = ''; - ExtractTypes : TExtractTypes = []); - property DatabaseInfo : TIBDatabaseInfo read FDatabaseInfo; - property Items : TStrings read FMetaData; - - published - { Published declarations } - property Database : TIBDatabase read GetDatabase write SetDatabase; - property Transaction : TIBTransaction read GetTransaction write SetTransaction; - property ShowSystem: Boolean read FShowSystem write FShowSystem; - end; - - TSQLType = record - SqlType : Integer; - TypeName : String; - end; - - TPrivTypes = record - PrivFlag : Integer; - PrivString : String; - end; - - TSQLTypes = Array[0..13] of TSQLType; - -const - - priv_UNKNOWN = 1; - priv_SELECT = 2; - priv_INSERT = 4; - priv_UPDATE = 8; - priv_DELETE = 16; - priv_EXECUTE = 32; - priv_REFERENCES = 64; - - PrivTypes : Array[0..5] of TPrivTypes = ( - (PrivFlag : priv_DELETE; PrivString : 'DELETE' ), - (PrivFlag : priv_EXECUTE; PrivString : 'EXECUTE' ), - (PrivFlag : priv_INSERT; PrivString : 'INSERT' ), - (PrivFlag : priv_SELECT; PrivString : 'SELECT' ), - (PrivFlag : priv_UPDATE; PrivString : 'UPDATE' ), - (PrivFlag : priv_REFERENCES; PrivString : 'REFERENCES')); - - ColumnTypes : TSQLTypes = ( - (SqlType : blr_short; TypeName : 'SMALLINT'), { NTX: keyword } - (SqlType : blr_long; TypeName : 'INTEGER'), { NTX: keyword } - (SqlType : blr_quad; TypeName : 'QUAD'), { NTX: keyword } - (SqlType : blr_float; TypeName : 'FLOAT'), { NTX: keyword } - (SqlType : blr_text; TypeName : 'CHAR'), { NTX: keyword } - (SqlType : blr_double; TypeName : 'DOUBLE PRECISION'), { NTX: keyword } - (SqlType : blr_varying; TypeName : 'VARCHAR'), { NTX: keyword } - (SqlType : blr_cstring; TypeName : 'CSTRING'), { NTX: keyword } - (SqlType : blr_blob_id; TypeName : 'BLOB_ID'), { NTX: keyword } - (SqlType : blr_blob; TypeName : 'BLOB'), { NTX: keyword } - (SqlType : blr_sql_time; TypeName : 'TIME'), { NTX: keyword } - (SqlType : blr_sql_date; TypeName : 'DATE'), { NTX: keyword } - (SqlType : blr_timestamp; TypeName : 'TIMESTAMP'), { NTX: keyword } - (SqlType : blr_int64; TypeName : 'INT64')); - - SubTypes : Array[0..8] of String = ( - 'UNKNOWN', { NTX: keyword } - 'TEXT', { NTX: keyword } - 'BLR', { NTX: keyword } - 'ACL', { NTX: keyword } - 'RANGES', { NTX: keyword } - 'SUMMARY', { NTX: keyword } - 'FORMAT', { NTX: keyword } - 'TRANSACTION_DESCRIPTION', { NTX: keyword } - 'EXTERNAL_FILE_DESCRIPTION'); { NTX: keyword } - - TriggerTypes : Array[0..6] of String = ( - '', - 'BEFORE INSERT', { NTX: keyword } - 'AFTER INSERT', { NTX: keyword } - 'BEFORE UPDATE', { NTX: keyword } - 'AFTER UPDATE', { NTX: keyword } - 'BEFORE DELETE', { NTX: keyword } - 'AFTER DELETE'); { NTX: keyword } - - IntegralSubtypes : Array[0..2] of String = ( - 'UNKNOWN', { Defined type, NTX: keyword } - 'NUMERIC', { NUMERIC, NTX: keyword } - 'DECIMAL'); { DECIMAL, NTX: keyword } - - ODS_VERSION6 = 6; { on-disk structure as of v3.0 } - ODS_VERSION7 = 7; { new on disk structure for fixing index bug } - ODS_VERSION8 = 8; { new btree structure to support pc semantics } - ODS_VERSION9 = 9; { btree leaf pages are always propogated up } - ODS_VERSION10 = 10; { V6.0 features. SQL delimited idetifier, - SQLDATE, and 64-bit exact numeric - type } - - { flags for RDB$FILE_FLAGS } - FILE_shadow = 1; - FILE_inactive = 2; - FILE_manual = 4; - FILE_cache = 8; - FILE_conditional = 16; - - { flags for RDB$LOG_FILES } - LOG_serial = 1; - LOG_default = 2; - LOG_raw = 4; - LOG_overflow = 8; - - - - MAX_INTSUBTYPES = 2; - MAXSUBTYPES = 8; { Top of subtypes array } - -{ Object types used in RDB$DEPENDENCIES and RDB$USER_PRIVILEGES } - - obj_relation = 0; - obj_view = 1; - obj_trigger = 2; - obj_computed = 3; - obj_validation = 4; - obj_procedure = 5; - obj_expression_index = 6; - obj_exception = 7; - obj_user = 8; - obj_field = 9; - obj_index = 10; - obj_count = 11; - obj_user_group = 12; - obj_sql_role = 13; - -implementation - -const - NEWLINE = #13#10; - TERM = ';'; - ProcTerm = '^'; - - CollationSQL = - 'SELECT CST.RDB$CHARACTER_SET_NAME, COL.RDB$COLLATION_NAME, CST.RDB$DEFAULT_COLLATE_NAME ' + - 'FROM RDB$COLLATIONS COL JOIN RDB$CHARACTER_SETS CST ON ' + - ' COL.RDB$CHARACTER_SET_ID = CST.RDB$CHARACTER_SET_ID ' + - 'WHERE ' + - ' COL.RDB$COLLATION_ID = :COLLATION AND ' + - ' CST.RDB$CHARACTER_SET_ID = :CHAR_SET_ID ' + - 'ORDER BY COL.RDB$COLLATION_NAME, CST.RDB$CHARACTER_SET_NAME'; - - NonCollationSQL = - 'SELECT CST.RDB$CHARACTER_SET_NAME ' + - 'FROM RDB$CHARACTER_SETS CST ' + - 'WHERE CST.RDB$CHARACTER_SET_ID = :CHARSETID ' + - 'ORDER BY CST.RDB$CHARACTER_SET_NAME'; - - PrecisionSQL = - 'SELECT * FROM RDB$FIELDS ' + - 'WHERE RDB$FIELD_NAME = :FIELDNAME'; - - ArraySQL = - 'SELECT * FROM RDB$FIELD_DIMENSIONS FDIM ' + - 'WHERE ' + - ' FDIM.RDB$FIELD_NAME = :FIELDNAME ' + - 'ORDER BY FDIM.RDB$DIMENSION'; - -{ TIBExtract } - -{ ArrayDimensions - Functional description - Retrieves the dimensions of arrays and prints them. - - Parameters: fieldname -- the actual name of the array field } - -function TIBExtract.GetArrayField(FieldName: String): String; -var - qryArray : TIBSQL; -begin - qryArray := TIBSQL.Create(FDatabase); - Result := '['; - qryArray.SQL.Add(ArraySQL); - qryArray.Params.ByName('FieldName').AsString := FieldName; - qryArray.ExecQuery; - - { Format is [lower:upper, lower:upper,..] } - - while not qryArray.Eof do - begin - if (qryArray.FieldByName('RDB$DIMENSION').AsInteger > 0) then - Result := Result + ', '; - Result := Result + qryArray.FieldByName('RDB$LOWER_BOUND').AsString + ':' + - qryArray.FieldByName('RDB$UPPER_BOUND').AsString; - qryArray.Next; - end; - - Result := Result + '] '; - qryArray.Free; - -end; - -constructor TIBExtract.Create(AOwner: TComponent); -begin - inherited; - FMetaData := TStringList.Create; - FDatabaseInfo := TIBDatabaseInfo.Create(nil); - FDatabaseInfo.Database := FDatabase; - if AOwner is TIBDatabase then - Database := TIBDatabase(AOwner); - if AOwner is TIBTransaction then - Transaction := TIBTransaction(AOwner); -end; - -destructor TIBExtract.Destroy; -begin - FMetaData.Free; - FDatabasEInfo.Free; - inherited; -end; - -function TIBExtract.ExtractDDL(Flag: Boolean; TableName: String) : Boolean; -var - DidConnect : Boolean; - DidStart : Boolean; -begin - Result := true; - DidConnect := false; - DidStart := false; - - if not FDatabase.Connected then - begin - FDatabase.Connected := true; - didConnect := true; - end; - - FMetaData.Add(Format('SET SQL DIALECT %d;', [FDatabase.SQLDialect])); - FMetaData.Add(''); - - if not FTransaction.Active then - begin - FTransaction.StartTransaction; - DidStart := true; - end; - - if TableName <> '' then - begin - if not ExtractListTable(TableName, '', true) then - Result := false; - end - else - begin - ListCreateDb; - ListFilters; - ListFunctions; - ListDomains; - ListAllTables(flag); - ListIndex; - ListForeign; - ListGenerators; - ListViews; - ListCheck; - ListException; - ListProcs; - ListTriggers; - ListGrants; - end; - - if DidStart then - FTransaction.Commit; - - if DidConnect then - FDatabase.Connected := false; -end; - -{ ExtractListTable - Functional description - Shows columns, types, info for a given table name - and text of views. - If a new_name is passed, substitute it for relation_name - - relation_name -- Name of table to investigate - new_name -- Name of a new name for a replacement table - domain_flag -- extract needed domains before the table } - -function TIBExtract.ExtractListTable(RelationName, NewName: String; - DomainFlag: Boolean) : Boolean; -const - TableListSQL = - 'SELECT * FROM RDB$RELATIONS REL JOIN RDB$RELATION_FIELDS RFR ON ' + {Do Not Localize} - ' RFR.RDB$RELATION_NAME = REL.RDB$RELATION_NAME JOIN RDB$FIELDS FLD ON ' + - ' RFR.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' + - 'WHERE REL.RDB$RELATION_NAME = :RelationName ' + - 'ORDER BY RFR.RDB$FIELD_POSITION, RFR.RDB$FIELD_NAME'; - - ConstraintSQL = - 'SELECT RCO.RDB$CONSTRAINT_NAME, RDB$CONSTRAINT_TYPE, RDB$RELATION_NAME, ' + - 'RDB$DEFERRABLE, RDB$INITIALLY_DEFERRED, RDB$INDEX_NAME, RDB$TRIGGER_NAME ' + - 'FROM RDB$RELATION_CONSTRAINTS RCO, RDB$CHECK_CONSTRAINTS CON ' + - 'WHERE ' + - ' CON.RDB$TRIGGER_NAME = :FIELDNAME AND ' + - ' CON.RDB$CONSTRAINT_NAME = RCO.RDB$CONSTRAINT_NAME AND ' + - ' RCO.RDB$CONSTRAINT_TYPE = ''NOT NULL'' AND ' + - ' RCO.RDB$RELATION_NAME = :RELATIONNAME'; - - RelConstraintsSQL = - 'SELECT * FROM RDB$RELATION_CONSTRAINTS RELC ' + - 'WHERE ' + - ' (RELC.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' OR ' + - ' RELC.RDB$CONSTRAINT_TYPE = ''UNIQUE'') AND ' + - ' RELC.RDB$RELATION_NAME = :RELATIONNAME ' + - 'ORDER BY RELC.RDB$CONSTRAINT_NAME'; - -var - Collation, CharSetId : integer; - i : integer; - ColList, Column, Constraint : String; - SubType : integer; - IntChar : integer; - qryTables, qryPrecision, qryConstraints, qryRelConstraints : TIBSQL; - PrecisionKnown, ValidRelation : Boolean; - FieldScale, FieldType : Integer; -begin - Result := true; - ColList := ''; - IntChar := 0; - ValidRelation := false; - - if DomainFlag then - ListDomains(RelationName); - qryTables := TIBSQL.Create(FDatabase); - qryPrecision := TIBSQL.Create(FDatabase); - qryConstraints := TIBSQL.Create(FDatabase); - qryRelConstraints := TIBSQL.Create(FDatabase); - try - qryTables.SQL.Add(TableListSQL); - qryTables.Params.ByName('RelationName').AsString := RelationName; - qryTables.ExecQuery; - qryPrecision.SQL.Add(PrecisionSQL); - qryConstraints.SQL.Add(ConstraintSQL); - qryRelConstraints.SQL.Add(RelConstraintsSQL); - if not qryTables.Eof then - begin - ValidRelation := true; - if (not qryTables.FieldByName('RDB$OWNER_NAME').IsNull) and - (Trim(qryTables.FieldByName('RDB$OWNER_NAME').AsString) <> '') then - FMetaData.Add(Format('%s/* Table: %s, Owner: %s */%s', - [NEWLINE, RelationName, - qryTables.FieldByName('RDB$OWNER_NAME').AsString, NEWLINE])); - if NewName <> '' then - FMetaData.Add(Format('CREATE TABLE %s ', [QuoteIdentifier(FDatabase.SQLDialect,NewName)])) - else - FMetaData.Add(Format('CREATE TABLE %s ', [QuoteIdentifier(FDatabase.SQLDialect,RelationName)])); - if not qryTables.FieldByName('RDB$EXTERNAL_FILE').IsNull then - FMetaData.Add(Format('EXTERNAL FILE %s ', - [QuotedStr(qryTables.FieldByName('RDB$EXTERNAL_FILE').AsString)])); - FMetaData.Add('('); - end; - - while not qryTables.Eof do - begin - Column := ' ' + QuoteIdentifier(FDatabase.SQLDialect, qryTables.FieldByName('RDB$FIELD_NAME').AsString) + TAB; - - { Check first for computed fields, then domains. - If this is a known domain, then just print the domain rather than type - Domains won't have length, array, or blob definitions, but they - may have not null, default and check overriding their definitions } - - if not qryTables.FieldByName('rdb$computed_blr').IsNull then - begin - Column := Column + ' COMPUTED BY '; - if not qryTables.FieldByName('RDB$COMPUTED_SOURCE').IsNull then - Column := Column + PrintValidation(qryTables.FieldByName('RDB$COMPUTED_SOURCE').AsString, true); - end - else - begin - FieldType := qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger; - FieldScale := qryTables.FieldByName('RDB$FIELD_SCALE').AsInteger; - if not ((Copy(qryTables.FieldByName('RDB$FIELD_NAME1').AsString, 1, 4) = 'RDB$') and - (qryTables.FieldByName('RDB$FIELD_NAME1').AsString[5] in ['0'..'9'])) and - (qryTables.FieldByName('RDB$SYSTEM_FLAG').AsInteger <> 1) then - begin - Column := Column + QuoteIdentifier(FDatabase.SQLDialect, qryTables.FieldByName('RDB$FIELD_NAME1').AsString); - { International character sets } - if (qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying]) - and (not qryTables.FieldByName('RDB$COLLATION_ID').IsNull) - and (qryTables.FieldByName('RDB$COLLATION_ID').AsInteger <> 0) then - begin - Collation := qryTables.FieldByName('RDB$COLLATION_ID').AsInteger; - Column := Column + GetCharacterSets(qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsShort, - Collation, true); - end; - end - else - begin - { Look through types array } - for i := Low(Columntypes) to High(ColumnTypes) do - begin - PrecisionKnown := false; - if qryTables.FieldByname('RDB$FIELD_TYPE').AsShort = ColumnTypes[i].SQLType then - begin - - if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then - begin - { Handle Integral subtypes NUMERIC and DECIMAL } - if qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger in - [blr_short, blr_long, blr_int64] then - begin - qryPrecision.Params.ByName('FIELDNAME').AsString := - qryTables.FieldByName('RDB$FIELD_NAME1').AsString; - qryPrecision.ExecQuery; - - { We are ODS >= 10 and could be any Dialect } - if not qryPrecision.FieldByName('RDB$FIELD_PRECISION').IsNull then - begin - { We are Dialect >=3 since FIELD_PRECISION is non-NULL } - if (qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and - (qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then - begin - Column := column + Format('%s(%d, %d)', - [IntegralSubtypes[qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger], - qryPrecision.FieldByName('RDB$FIELD_PRECISION').AsInteger, - -qryPrecision.FieldByName('RDB$FIELD_SCALE').AsInteger]); - PrecisionKnown := TRUE; - end; - end; - qryPrecision.Close; - end; - end; - - if PrecisionKnown = FALSE then - begin - { Take a stab at numerics and decimals } - if (FieldType = blr_short) and (FieldScale < 0) then - Column := Column + Format('NUMERIC(4, %d)', [-FieldScale]) - else - if (FieldType = blr_long) and (FieldScale < 0) then - Column := Column + Format('NUMERIC(9, %d)', [-FieldScale]) - else - if (FieldType = blr_double) and (FieldScale < 0) then - Column := Column + Format('NUMERIC(15, %d)', [-FieldScale]) - else - Column := Column + ColumnTypes[i].TypeName; - end; - end; - end; - if FieldType in [blr_text, blr_varying] then - if qryTables.FieldByName('RDB$CHARACTER_LENGTH').IsNull then - Column := Column + Format('(%d)', [qryTables.FieldByName('RDB$FIELD_LENGTH').AsInteger]) - else - Column := Column + Format('(%d)', [qryTables.FieldByName('RDB$CHARACTER_LENGTH').AsInteger]); - - { Catch arrays after printing the type } - - if not qryTables.FieldByName('RDB$DIMENSIONS').IsNull then - Column := column + GetArrayField(qryTables.FieldByName('RDB$FIELD_NAME').AsString); - - if FieldType = blr_blob then - begin - subtype := qryTables.FieldByName('RDB$FIELD_SUB_TYPE').AsShort; - Column := Column + ' SUB_TYPE '; - if (subtype > 0) and (subtype <= MAXSUBTYPES) then - Column := Column + SubTypes[subtype] - else - Column := Column + IntToStr(subtype); - column := Column + Format(' SEGMENT SIZE %d', - [qryTables.FieldByName('RDB$SEGMENT_LENGTH').AsInteger]); - end; - - { International character sets } - if ((FieldType in [blr_text, blr_varying]) or - (FieldType = blr_blob)) and - (not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull) and - (qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger <> 0) then - begin - { Override rdb$fields id with relation_fields if present } - - CharSetId := 0; - if not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull then - CharSetId := qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger; - - Column := Column + GetCharacterSets(CharSetId, 0, false); - intchar := 1; - end; - end; - - { Handle defaults for columns } - { Originally This called PrintMetadataTextBlob, - should no longer need } - if not qryTables.FieldByName('RDB$DEFAULT_SOURCE').IsNull then - Column := Column + ' ' + qryTables.FieldByName('RDB$DEFAULT_SOURCE').AsString; - - - { The null flag is either 1 or null (for nullable) . if there is - a constraint name, print that too. Domains cannot have named - constraints. The column name is in rdb$trigger_name in - rdb$check_constraints. We hope we get at most one row back. } - - if qryTables.FieldByName('RDB$NULL_FLAG').AsInteger = 1 then - begin - qryConstraints.Params.ByName('FIELDNAME').AsString := qryTables.FieldByName('RDB$FIELD_NAME').AsString; - qryConstraints.Params.ByName('RELATIONNAME').AsString := qryTables.FieldByName('RDB$RELATION_NAME').AsString; - qryConstraints.ExecQuery; - - while not qryConstraints.Eof do - begin - if Pos('INTEG', qryConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then - Column := Column + Format(' CONSTRAINT %s', - [ QuoteIdentifier( FDatabase.SQLDialect, - qryConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString)]); - qryConstraints.Next; - end; - qryConstraints.Close; - Column := Column + ' NOT NULL'; - end; - - if ((FieldType in [blr_text, blr_varying]) or - (FieldType = blr_blob)) and - (not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull) and - (qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger <> 0) and - (intchar <> 0) then - begin - Collation := 0; - if not qryTables.FieldByName('RDB$COLLATION_ID1').IsNull then - Collation := qryTables.FieldByName('RDB$COLLATION_ID1').AsInteger - else - if not qryTables.FieldByName('RDB$COLLATION_ID').IsNull then - Collation := qryTables.FieldByName('RDB$COLLATION_ID').AsInteger; - - CharSetId := 0; - if not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull then - CharSetId := qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger; - - if Collation <> 0 then - Column := Column + GetCharacterSets(CharSetId, Collation, true); - end; - end; - qryTables.Next; - if not qryTables.Eof then - Column := Column + ','; - FMetaData.Add(Column); - end; - - { Do primary and unique keys only. references come later } - - qryRelConstraints.Params.ByName('relationname').AsString := RelationName; - qryRelConstraints.ExecQuery; - while not qryRelConstraints.Eof do - begin - Constraint := ''; - FMetaData.Strings[FMetaData.Count - 1] := FMetaData.Strings[FMetaData.Count - 1] + ','; - { If the name of the constraint is not INTEG..., print it } - if Pos('INTEG', qryRelConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then - Constraint := Constraint + 'CONSTRAINT ' + - QuoteIdentifier(FDatabase.SQLDialect, - qryRelConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString); - - - if Pos('PRIMARY', qryRelConstraints.FieldByName('RDB$CONSTRAINT_TYPE').AsString) = 1 then - begin - FMetaData.Add(Constraint + Format(' PRIMARY KEY (%s)', - [GetIndexSegments(qryRelConstraints.FieldByName('RDB$INDEX_NAME').AsString)])); - end - else - if Pos('UNIQUE', qryRelConstraints.FieldByName('RDB$CONSTRAINT_TYPE').AsString) = 1 then - begin - FMetaData.Add(Constraint + Format(' UNIQUE (%s)', - [GetIndexSegments(qryRelConstraints.FieldByName('RDB$INDEX_NAME').AsString)])); - end; - qryRelConstraints.Next; - end; - if ValidRelation then - FMetaData.Add(')' + Term); - finally - qryTables.Free; - qryPrecision.Free; - qryConstraints.Free; - qryRelConstraints.Free; - end; -end; - -{ ExtractListView - Functional description - Show text of the specified view. - Use a SQL query to get the info and print it. - Note: This should also contain check option } - -procedure TIBExtract.ExtractListView(ViewName: String); -const - ViewsSQL = 'SELECT * FROM RDB$RELATIONS REL ' + - ' WHERE ' + - ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' + - ' NOT REL.RDB$VIEW_BLR IS NULL AND ' + - ' REL.RDB$RELATION_NAME = :VIEWNAME AND ' + - ' REL.RDB$FLAGS = 1 ' + - 'ORDER BY REL.RDB$RELATION_ID '; - - ColumnsSQL = 'SELECT * FROM RDB$RELATION_FIELDS RFR ' + - 'WHERE ' + - ' RFR.RDB$RELATION_NAME = :RELATIONNAME ' + - 'ORDER BY RFR.RDB$FIELD_POSITION '; - -var - qryViews, qryColumns : TIBSQL; - RelationName, ColList : String; -begin - qryViews := TIBSQL.Create(FDatabase); - qryColumns := TIBSQL.Create(FDatabase); - try - qryViews.SQL.Add(ViewsSQL); - qryViews.Params.ByName('viewname').AsString := ViewName; - qryViews.ExecQuery; - while not qryViews.Eof do - begin - FMetaData.Add(''); - RelationName := QuoteIdentifier(FDatabase.SQLDialect, - qryViews.FieldByName('RDB$RELATION_NAME').AsString); - FMetaData.Add(Format('%s/* View: %s, Owner: %s */%s', [ - RelationName, - Trim(qryViews.FieldByName('RDB$OWNER_NAME').AsString)])); - FMetaData.Add(''); - FMetaData.Add(Format('CREATE VIEW %s (', [RelationName])); - - { Get Column List} - qryColumns.SQL.Add(ColumnsSQL); - qryColumns.Params.ByName('relationname').AsString := RelationName; - qryColumns.ExecQuery; - while not qryColumns.Eof do - begin - ColList := ColList + QuoteIdentifier(FDatabase.SQLDialect, - qryColumns.FieldByName('RDB$FIELD_NAME').AsString); - qryColumns.Next; - if not qryColumns.Eof then - ColList := ColList + ', '; - end; - FMetaData.Add(ColList + ') AS'); - FMetaData.Add(qryViews.FieldByName('RDB$VIEW_SOURCE').AsString + Term); - qryViews.Next; - end; - finally - qryViews.Free; - qryColumns.Free; - end; -end; - -function TIBExtract.GetCharacterSets(CharSetId, Collation: integer; - CollateOnly: Boolean): String; -var - CharSetSQL : TIBSQL; - DidActivate : Boolean; -begin - if not FTransaction.Active then - begin - FTransaction.StartTransaction; - DidActivate := true; - end - else - DidActivate := false; - CharSetSQL := TIBSQL.Create(FDatabase); - try - if Collation <> 0 then - begin - CharSetSQL.SQL.Add(CollationSQL); - CharSetSQL.Params.ByName('Char_Set_Id').AsInteger := CharSetId; - CharSetSQL.Params.ByName('Collation').AsInteger := Collation; - CharSetSQL.ExecQuery; - - { Is specified collation the default collation for character set? } - if (Trim(CharSetSQL.FieldByName('RDB$DEFAULT_COLLATE_NAME').AsString) = - Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString)) then - begin - if not CollateOnly then - Result := ' CHARACTER SET ' + Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString); - end - else - if CollateOnly then - Result := ' COLLATE ' + Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString) - else - Result := ' CHARACTER SET ' + - Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString) + - ' COLLATE ' + - Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString); - end - else - if CharSetId <> 0 then - begin - CharSetSQL.SQL.Add(NonCollationSQL); - CharSetSQL.Params.ByName('CharSetId').AsShort := CharSetId; - CharSetSQL.ExecQuery; - Result := ' CHARACTER SET ' + Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString); - end; - finally - CharSetSQL.Free; - end; - if DidActivate then - FTransaction.Commit; -end; - -function TIBExtract.GetDatabase: TIBDatabase; -begin - result := FDatabase; -end; - - { GetIndexSegments - Functional description - returns the list of columns in an index. } - -function TIBExtract.GetIndexSegments(IndexName: String): String; -const - IndexNamesSQL = - 'SELECT * FROM RDB$INDEX_SEGMENTS SEG ' + - 'WHERE SEG.RDB$INDEX_NAME = :INDEXNAME ' + - 'ORDER BY SEG.RDB$FIELD_POSITION'; - -var - qryColNames : TIBSQL; -begin -{ Query to get column names } - Result := ''; - qryColNames := TIBSQL.Create(FDatabase); - try - qryColNames.SQL.Add(IndexNamesSQL); - qryColNames.Params.ByName('IndexName').AsString := IndexName; - qryColNames.ExecQuery; - while not qryColNames.Eof do - begin - { Place a comma and a blank between each segment column name } - - Result := Result + QuoteIdentifier(FDatabase.SQLDialect, - qryColNames.FieldByName('RDB$FIELD_NAME').AsString); - qryColNames.Next; - if not qryColNames.Eof then - Result := Result + ', '; - end; - finally - qryColNames.Free; - end; -end; - -function TIBExtract.GetTransaction: TIBTransaction; -begin - Result := FTransaction; -end; - -{ ListAllGrants - Functional description - Print the permissions on all user tables. - Get separate permissions on table/views and then procedures } - -procedure TIBExtract.ListGrants; -const - SecuritySQL = 'SELECT * FROM RDB$RELATIONS ' + - 'WHERE ' + - ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + - ' RDB$SECURITY_CLASS STARTING WITH ''SQL$'' ' + - 'ORDER BY RDB$RELATION_NAME'; - - ProcedureSQL = 'select * from RDB$PROCEDURES ' + - 'Order BY RDB$PROCEDURE_NAME'; - -var - qryRoles : TIBSQL; - RelationName : String; -begin - ListRoles; - qryRoles := TIBSQL.Create(FDatabase); - try - { This version of cursor gets only sql tables identified by security class - and misses views, getting only null view_source } - - FMetaData.Add(''); - FMetaData.Add('/* Grant permissions for this database */'); - FMetaData.Add(''); - - try - qryRoles.SQL.Text := SecuritySQL; - qryRoles.ExecQuery; - while not qryRoles.Eof do - begin - RelationName := Trim(qryRoles.FieldByName('rdb$relation_Name').AsString); - ShowGrants(RelationName, Term); - qryRoles.Next; - end; - finally - qryRoles.Close; - end; - - ShowGrantRoles(Term); - - qryRoles.SQL.Text := ProcedureSQL; - qryRoles.ExecQuery; - try - while not qryRoles.Eof do - begin - ShowGrants(Trim(qryRoles.FieldByName('RDB$PROCEDURE_NAME').AsString), Term); - qryRoles.Next; - end; - finally - qryRoles.Close; - end; - finally - qryRoles.Free; - end; -end; - -{ ListAllProcs - Functional description - Shows text of a stored procedure given a name. - or lists procedures if no argument. - Since procedures may reference each other, we will create all - dummy procedures of the correct name, then alter these to their - correct form. - Add the parameter names when these procedures are created. - - procname -- Name of procedure to investigate } - -procedure TIBExtract.ListProcs(ProcedureName : String); -const - CreateProcedureStr1 = 'CREATE PROCEDURE %s '; - CreateProcedureStr2 = 'BEGIN EXIT; END %s%s'; - ProcedureSQL = - 'SELECT * FROM RDB$PROCEDURES ' + - 'ORDER BY RDB$PROCEDURE_NAME'; - - ProcedureNameSQL = - 'SELECT * FROM RDB$PROCEDURES ' + - 'WHERE RDB$PROCEDURE_NAME = :ProcedureName ' + - 'ORDER BY RDB$PROCEDURE_NAME'; - -var - qryProcedures : TIBSQL; - ProcName : String; - SList : TStrings; - Header : Boolean; -begin - - Header := true; - qryProcedures := TIBSQL.Create(FDatabase); - SList := TStringList.Create; - try -{ First the dummy procedures - create the procedures with their parameters } - if ProcedureName = '' then - qryProcedures.SQL.Text := ProcedureSQL - else - begin - qryProcedures.SQL.Text := ProcedureNameSQL; - qryProcedures.Params.ByName('ProcedureName').AsString := ProcedureName; - end; - qryProcedures.ExecQuery; - while not qryProcedures.Eof do - begin - if Header then - begin - FMetaData.Add('COMMIT WORK;'); - FMetaData.Add('SET AUTODDL OFF;'); - FMetaData.Add(Format('SET TERM %s %s', [ProcTerm, Term])); - FMetaData.Add(Format('%s/* Stored procedures */%s', [NEWLINE, NEWLINE])); - Header := false; - end; - ProcName := Trim(qryProcedures.FieldByName('RDB$PROCEDURE_NAME').AsString); - FMetaData.Add(Format(CreateProcedureStr1, [QuoteIdentifier(FDatabase.SQLDialect, - ProcName)])); - GetProcedureArgs(ProcName); - FMetaData.Add(Format(CreateProcedureStr2, [ProcTerm, NEWLINE])); - qryProcedures.Next; - end; - - qryProcedures.Close; - qryProcedures.ExecQuery; - while not qryProcedures.Eof do - begin - SList.Clear; - ProcName := Trim(qryProcedures.FieldByName('RDB$PROCEDURE_NAME').AsString); - FMetaData.Add(Format('%sALTER PROCEDURE %s ', [NEWLINE, - QuoteIdentifier(FDatabase.SQLDialect, ProcName)])); - GetProcedureArgs(ProcName); - - if not qryProcedures.FieldByName('RDB$PROCEDURE_SOURCE').IsNull then - SList.Text := SList.Text + qryProcedures.FieldByName('RDB$PROCEDURE_SOURCE').AsString; - SList.Add(Format(' %s%s', [ProcTerm, NEWLINE])); - FMetaData.AddStrings(SList); - qryProcedures.Next; - end; - -{ This query gets the procedure name and the source. We then nest a query - to retrieve the parameters. Alter is used, because the procedures are - already there} - - if not Header then - begin - FMetaData.Add(Format('SET TERM %s %s', [Term, ProcTerm])); - FMetaData.Add('COMMIT WORK;'); - FMetaData.Add('SET AUTODDL ON;'); - end; - finally - qryProcedures.Free; - SList.Free; - end; -end; - -{ ListAllTables - Functional description - Extract the names of all user tables from - rdb$relations. Filter SQL tables by - security class after we fetch them - Parameters: flag -- 0, get all tables } - -procedure TIBExtract.ListAllTables(flag: Boolean); -const - TableSQL = - 'SELECT * FROM RDB$RELATIONS ' + - 'WHERE ' + - ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + - ' RDB$VIEW_BLR IS NULL ' + - 'ORDER BY RDB$RELATION_NAME'; - -var - qryTables : TIBSQL; -begin -{ This version of cursor gets only sql tables identified by security class - and misses views, getting only null view_source } - - qryTables := TIBSQL.Create(FDatabase); - try - qryTables.SQL.Text := TableSQL; - qryTables.ExecQuery; - while not qryTables.Eof do - begin - if ((qryTables.FieldByName('RDB$FLAGS').AsInteger <> 1) and - (not Flag)) then - continue; - if flag or (Pos('SQL$', qryTables.FieldByName('RDB$SECURITY_CLASS').AsString) <> 1) then - ExtractListTable(qryTables.FieldByName('RDB$RELATION_NAME').AsString, - '', false); - - qryTables.Next; - end; - finally - qryTables.Free; - end; -end; - -{ ListAllTriggers - Functional description - Lists triggers in general on non-system - tables with sql source only. } - -procedure TIBExtract.ListTriggers(ObjectName : String; ExtractType : TExtractType); -const -{ Query gets the trigger info for non-system triggers with - source that are not part of an SQL constraint } - - TriggerSQL = - 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$RELATIONS REL ON ' + - ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' + - 'WHERE ' + - ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' + - ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' + - ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' + - 'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' + - ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME'; - - TriggerNameSQL = - 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$RELATIONS REL ON ' + - ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' + - 'WHERE ' + - ' REL.RDB$RELATION_NAME = :TableName AND ' + - ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' + - ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' + - ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' + - 'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' + - ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME'; - - TriggerByNameSQL = - 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$RELATIONS REL ON ' + - ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' + - 'WHERE ' + - ' TRG.RDB$TRIGGER_NAME = :TriggerName AND ' + - ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' + - ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' + - ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' + - 'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' + - ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME'; - -var - Header : Boolean; - TriggerName, RelationName, InActive: String; - qryTriggers : TIBSQL; - SList : TStrings; -begin - Header := true; - SList := TStringList.Create; - qryTriggers := TIBSQL.Create(FDatabase); - try - if ObjectName = '' then - qryTriggers.SQL.Text := TriggerSQL - else - begin - if ExtractType = etTable then - begin - qryTriggers.SQL.Text := TriggerNameSQL; - qryTriggers.Params.ByName('TableName').AsString := ObjectName; - end - else - begin - qryTriggers.SQL.Text := TriggerByNameSQL; - qryTriggers.Params.ByName('TriggerName').AsString := ObjectName; - end; - end; - qryTriggers.ExecQuery; - while not qryTriggers.Eof do - begin - SList.Clear; - if Header then - begin - FMetaData.Add(Format('SET TERM %s %s%s', [Procterm, Term, NEWLINE])); - FMetaData.Add(Format('%s/* Triggers only will work for SQL triggers */%s', - [NEWLINE, NEWLINE])); - Header := false; - end; - TriggerName := qryTriggers.FieldByName('RDB$TRIGGER_NAME').AsString; - RelationName := qryTriggers.FieldByName('RDB$RELATION_NAME').AsString; - if qryTriggers.FieldByName('RDB$TRIGGER_INACTIVE').IsNull then - InActive := 'INACTIVE' - else - if qryTriggers.FieldByName('RDB$TRIGGER_INACTIVE').AsInteger = 1 then - InActive := 'INACTIVE' - else - InActive := 'ACTIVE'; - - if qryTriggers.FieldByName('RDB$FLAGS').AsInteger <> 1 then - SList.Add('/* '); - - SList.Add(Format('CREATE TRIGGER %s FOR %s %s%s %s POSITION %d', - [QuoteIdentifier(FDatabase.SQLDialect, TriggerName), - QuoteIdentifier(FDatabase.SQLDialect, RelationName), - NEWLINE, InActive, - TriggerTypes[qryTriggers.FieldByName('RDB$TRIGGER_TYPE').AsInteger], - qryTriggers.FieldByName('RDB$TRIGGER_SEQUENCE').AsInteger])); - if not qryTriggers.FieldByName('RDB$TRIGGER_SOURCE').IsNull then - SList.Text := SList.Text + - qryTriggers.FieldByName('RDB$TRIGGER_SOURCE').AsString; - SList.Add(' ' + ProcTerm + NEWLINE); - if qryTriggers.FieldByName('RDB$FLAGS').AsInteger <> 1 then - SList.Add(' */'); - FMetaData.AddStrings(SList); - qryTriggers.Next; - end; - if not Header then - begin - FMetaData.Add('COMMIT WORK ' + ProcTerm); - FMetaData.Add('SET TERM ' + Term + ProcTerm); - end; - finally - qryTriggers.Free; - SList.Free; - end; -end; - -{ ListCheck - Functional description - List check constraints for all objects to allow forward references } - -procedure TIBExtract.ListCheck(ObjectName : String; ExtractType : TExtractType); -const -{ Query gets the check clauses for triggers stored for check constraints } - CheckSQL = - 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' + - ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' + - 'WHERE ' + - ' TRG.RDB$TRIGGER_TYPE = 1 AND ' + - ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' + - ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' + - 'ORDER BY CHK.RDB$CONSTRAINT_NAME'; - - CheckNameSQL = - 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' + - ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' + - 'WHERE ' + - ' TRG.RDB$RELATION_NAME = :TableName AND ' + - ' TRG.RDB$TRIGGER_TYPE = 1 AND ' + - ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' + - ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' + - 'ORDER BY CHK.RDB$CONSTRAINT_NAME'; - - CheckByNameSQL = - 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' + - ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' + - 'WHERE ' + - ' TRG.RDB$TRIGGER_NAME = :TriggerName AND ' + - ' TRG.RDB$TRIGGER_TYPE = 1 AND ' + - ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' + - ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' + - 'ORDER BY CHK.RDB$CONSTRAINT_NAME'; - -var - qryChecks : TIBSQL; - SList : TStrings; - RelationName : String; -begin - qryChecks := TIBSQL.Create(FDatabase); - SList := TStringList.Create; - try - if ObjectName = '' then - qryChecks.SQL.Text := CheckSQL - else - if ExtractType = etTable then - begin - qryChecks.SQL.Text := CheckNameSQL; - qryChecks.Params.ByName('TableName').AsString := ObjectName; - end - else - begin - qryChecks.SQL.Text := CheckByNameSQL; - qryChecks.Params.ByName('TriggerName').AsString := ObjectName; - end; - qryChecks.ExecQuery; - while not qryChecks.Eof do - begin - SList.Clear; - RelationName := qryChecks.FieldByName('RDB$RELATION_NAME').AsString; - SList.Add(Format('ALTER TABLE %s ADD', - [QuoteIdentifier(FDatabase.SQLDialect, RelationName)])); - if Pos('INTEG', qryChecks.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then - SList.Add(Format('%sCONSTRAINT %s ', [TAB, - QuoteIdentifier(FDatabase.SQLDialect, qryChecks.FieldByName('RDB$CONSTRAINT_NAME').AsString)])); - - if not qryChecks.FieldByName('RDB$TRIGGER_SOURCE').IsNull then - SList.Text := SList.Text + qryChecks.FieldByName('RDB$TRIGGER_SOURCE').AsString; - - SList.Strings[SList.Count - 1] := SList.Strings[SList.Count - 1] + (Term) + NEWLINE; - FMetaData.AddStrings(SList); - qryChecks.Next; - end; - finally - qryChecks.Free; - SList.Free; - end; -end; - -{ ListCreateDb - Functional description - Print the create database command if requested. At least put - the page size in a comment with the extracted db name } - -procedure TIBExtract.ListCreateDb(TargetDb : String); -const - CharInfoSQL = - 'SELECT * FROM RDB$DATABASE DBP ' + - 'WHERE NOT DBP.RDB$CHARACTER_SET_NAME IS NULL ' + - ' AND DBP.RDB$CHARACTER_SET_NAME != '' '''; - - FilesSQL = - 'select * from RDB$FILES ' + - 'order BY RDB$SHADOW_NUMBER, RDB$FILE_SEQUENCE'; - - LogsSQL = - 'SELECT * FROM RDB$LOG_FILES ' + - 'ORDER BY RDB$FILE_FLAGS, RDB$FILE_SEQUENCE'; - -var - NoDb, First, FirstFile, HasWal, SetUsed : Boolean; - Buffer : String; - qryDB : TIBSQL; - FileFlags, FileLength, FileSequence, FileStart : Integer; - - function GetLongDatabaseInfo(DatabaseInfoCommand: Integer): LongInt; - var - local_buffer: array[0..IBLocalBufferLength - 1] of Char; - length: Integer; - _DatabaseInfoCommand: Char; - begin - _DatabaseInfoCommand := Char(DatabaseInfoCommand); - FDatabaseInfo.Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @_DatabaseInfoCommand, - IBLocalBufferLength, local_buffer), True); - length := isc_vax_integer(@local_buffer[1], 2); - result := isc_vax_integer(@local_buffer[3], length); - end; - -begin - NoDb := FALSE; - First := TRUE; - FirstFile := TRUE; - HasWal := FALSE; - SetUsed := FALSE; - Buffer := ''; - if TargetDb = '' then - begin - Buffer := '/* '; - TargetDb := FDatabase.DatabaseName; - NoDb := true; - end; - Buffer := Buffer + 'CREATE DATABASE ' + QuotedStr(TargetDb) + ' PAGE_SIZE ' + - IntToStr(FDatabaseInfo.PageSize) + NEWLINE; - FMetaData.Add(Buffer); - Buffer := ''; - - qryDB := TIBSQL.Create(FDatabase); - try - qryDB.SQL.Text := CharInfoSQL; - qryDB.ExecQuery; - - Buffer := Format(' DEFAULT CHARACTER SET %s', - [qryDB.FieldByName('RDB$CHARACTER_SET_NAME').AsString]); - if NoDB then - Buffer := Buffer + ' */' - else - Buffer := Buffer + Term; - FMetaData.Add(Buffer); - qryDB.Close; - {List secondary files and shadows as - alter db and create shadow in comment} - qryDB.SQL.Text := FilesSQL; - qryDB.ExecQuery; - while not qryDB.Eof do - begin - if First then - begin - FMetaData.Add(NEWLINE + '/* Add secondary files in comments '); - First := false; - end; //end_if - - if qryDB.FieldByName('RDB$FILE_FLAGS').IsNull then - FileFlags := 0 - else - FileFlags := qryDB.FieldByName('RDB$FILE_FLAGS').AsInteger; - if qryDB.FieldByName('RDB$FILE_LENGTH').IsNull then - FileLength := 0 - else - FileLength := qryDB.FieldByName('RDB$FILE_LENGTH').AsInteger; - if qryDB.FieldByName('RDB$FILE_SEQUENCE').IsNull then - FileSequence := 0 - else - FileSequence := qryDB.FieldByName('RDB$FILE_SEQUENCE').AsInteger; - if qryDB.FieldByName('RDB$FILE_START').IsNull then - FileStart := 0 - else - FileStart := qryDB.FieldByName('RDB$FILE_START').AsInteger; - - { Pure secondary files } - if FileFlags = 0 then - begin - Buffer := Format('%sALTER DATABASE ADD FILE ''%s''', - [NEWLINE, qryDB.FieldByName('RDB$FILE_NAME').AsString]); - if FileStart <> 0 then - Buffer := Buffer + Format(' STARTING %d', [FileStart]); - if FileLength <> 0 then - Buffer := Buffer + Format(' LENGTH %d', [FileLength]); - FMetaData.Add(Buffer); - end; //end_if - if (FileFlags and FILE_cache) <> 0 then - FMetaData.Add(Format('%sALTER DATABASE ADD CACHE ''%s'' LENGTH %d', - [NEWLINE, qryDB.FieldByName('RDB$FILE_NAME').AsString, FileLength])); - - Buffer := ''; - if (FileFlags and FILE_shadow) <> 0 then - begin - if FileSequence <> 0 then - Buffer := Format('%sFILE ''%s''', - [TAB, qryDB.FieldByName('RDB$FILE_NAME').AsString]) - else - begin - Buffer := Format('%sCREATE SHADOW %d ''%s'' ', - [NEWLINE, qryDB.FieldByName('RDB$SHADOW_NUMBER').AsInteger, - qryDB.FieldByName('RDB$FILE_NAME').AsString]); - if (FileFlags and FILE_inactive) <> 0 then - Buffer := Buffer + 'INACTIVE '; - if (FileFlags and FILE_manual) <> 0 then - Buffer := Buffer + 'MANUAL ' - else - Buffer := Buffer + 'AUTO '; - if (FileFlags and FILE_conditional) <> 0 then - Buffer := Buffer + 'CONDITIONAL '; - end; //end_else - if FileLength <> 0 then - Buffer := Buffer + Format('LENGTH %d ', [FileLength]); - if FileStart <> 0 then - Buffer := Buffer + Format('STARTING %d ', [FileStart]); - FMetaData.Add(Buffer); - end; //end_if - qryDB.Next; - end; - qryDB.Close; - - qryDB.SQL.Text := LogsSQL; - qryDB.ExecQuery; - while not qryDB.Eof do - begin - - if qryDB.FieldByName('RDB$FILE_FLAGS').IsNull then - FileFlags := 0 - else - FileFlags := qryDB.FieldByName('RDB$FILE_FLAGS').AsInteger; - if qryDB.FieldByName('RDB$FILE_LENGTH').IsNull then - FileLength := 0 - else - FileLength := qryDB.FieldByName('RDB$FILE_LENGTH').AsInteger; - - Buffer := ''; - HasWal := true; - if First then - begin - if NoDB then - Buffer := '/* '; - Buffer := Buffer + NEWLINE + 'ALTER DATABASE ADD '; - First := false; - end; //end_if - if FirstFile then - Buffer := Buffer + 'LOGFILE '; - { Overflow files also have the serial bit set } - if (FileFlags and LOG_default) = 0 then - begin - if (FileFlags and LOG_overflow) <> 0 then - Buffer := Buffer + Format(')%s OVERFLOW ''%s''', - [NEWLINE, qryDB.FieldByName('RDB$FILE_NAME').AsString]) - else - if (FileFlags and LOG_serial) <> 0 then - Buffer := Buffer + Format('%s BASE_NAME ''%s''', - [NEWLINE, qryDB.FieldByName('RDB$FILE_NAME').AsString]) - { Since we are fetching order by FILE_FLAGS, the LOG_0verflow will - be last. It will only appear if there were named round robin, - so we must close the parens first } - - { We have round robin and overflow file specifications } - else - begin - if FirstFile then - Buffer := Buffer + '(' - else - Buffer := Buffer + Format(',%s ', [NEWLINE]); - FirstFile := false; - - Buffer := Buffer + Format('''%s''', [qryDB.FieldByName('RDB$FILE_NAME').AsString]); - end; //end_else - end; - { Any file can have a length } - if FileLength <> 0 then - Buffer := Buffer + Format(' SIZE %d ', [FileLength]); - FMetaData.Add(Buffer); - qryDB.Next; - end; - qryDB.Close; - Buffer := ''; - if HasWal then - begin - Buffer := Buffer + PrintSet(SetUsed); - Buffer := Buffer + Format('NUM_LOG_BUFFERS = %d', - [GetLongDatabaseInfo(isc_info_num_wal_buffers)]); - Buffer := Buffer + PrintSet(SetUsed); - Buffer := Buffer + Format('LOG_BUFFER_SIZE = %d', - [GetLongDatabaseInfo(isc_info_wal_buffer_size)]); - Buffer := Buffer + PrintSet(SetUsed); - Buffer := Buffer + Format('GROUP_COMMIT_WAIT_TIME = %d', - [GetLongDatabaseInfo(isc_info_wal_grpc_wait_usecs)]); - Buffer := Buffer + PrintSet(SetUsed); - Buffer := Buffer + Format('CHECK_POINT_LENGTH = %d', - [GetLongDatabaseInfo(isc_info_wal_ckpt_length)]); - FMetaData.Add(Buffer); - - end; - if not First then - begin - if NoDB then - FMetaData.Add(Format('%s */%s', [NEWLINE, NEWLINE])) - else - FMetaData.Add(Format('%s%s%s', [Term, NEWLINE, NEWLINE])); - end; - finally - qryDB.Free; - end; - -(* -*) -end; - -{ ListDomainTable - Functional description - List domains as identified by fields with any constraints on them - for the named table - - Parameters: table_name == only extract domains for this table } - -procedure TIBExtract.ListDomains(ObjectName: String; ExtractType : TExtractType); -const - DomainSQL = - 'SELECT distinct fld.* FROM RDB$FIELDS FLD JOIN RDB$RELATION_FIELDS RFR ON ' + - ' RFR.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' + - 'WHERE RFR.RDB$RELATION_NAME = :TABLE_NAME ' + - 'ORDER BY FLD.RDB$FIELD_NAME'; - - DomainByNameSQL = - 'SELECT * FROM RDB$FIELDS FLD ' + - 'WHERE FLD.RDB$FIELD_NAME = :DomainName ' + - 'ORDER BY FLD.RDB$FIELD_NAME'; - - AllDomainSQL = - 'select * from RDB$FIELDS ' + - 'where RDB$SYSTEM_FLAG <> 1 ' + - 'order BY RDB$FIELD_NAME'; - -var - First : Boolean; - qryDomains : TIBSQL; - FieldName, Line : String; - - function FormatDomainStr : String; - var - i, SubType : Integer; - PrecisionKnown : Boolean; - begin - Result := ''; - for i := Low(ColumnTypes) to High(ColumnTypes) do - if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = ColumnTypes[i].SQLType then - begin - PrecisionKnown := FALSE; - if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then - begin - if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_short, blr_long, blr_int64] then - begin - { We are ODS >= 10 and could be any Dialect } - if (FDatabaseInfo.DBSQLDialect >= 3) and - (not qryDomains.FieldByName('RDB$FIELD_PRECISION').IsNull) and - (qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and - (qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then - begin - Result := Result + Format('%s(%d, %d)', [ - IntegralSubtypes [qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger], - qryDomains.FieldByName('RDB$FIELD_PRECISION').AsInteger, - -1 * qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger]); - PrecisionKnown := true; - end; - end; - end; - if PrecisionKnown = false then - begin - { Take a stab at numerics and decimals } - if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_short) and - (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - Result := Result + Format('NUMERIC(4, %d)', - [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] ) - else - if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_long) and - (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - Result := Result + Format('NUMERIC(9, %d)', - [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] ) - else - if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_double) and - (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - Result := Result + Format('NUMERIC(15, %d)', - [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] ) - else - Result := Result + ColumnTypes[i].TypeName; - end; - break; - end; - - if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_blob then - begin - subtype := qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger; - Result := Result + ' SUB_TYPE '; - if (subtype > 0) and (subtype <= MAXSUBTYPES) then - Result := Result + SubTypes[subtype] - else - Result := Result + Format('%d', [subtype]); - Result := Result + Format(' SEGMENT SIZE %d', [qryDomains.FieldByName('RDB$SEGMENT_LENGTH').AsInteger]); - end //end_if - else - if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying]) and - (not qryDomains.FieldByName('RDB$CHARACTER_LENGTH').IsNull) then - Result := Result + Format('(%d)', [qryDomains.FieldByName('RDB$FIELD_LENGTH').AsInteger]); - - { since the character set is part of the field type, display that - information now. } - if not qryDomains.FieldByName('RDB$CHARACTER_SET_ID').IsNull then - Result := Result + GetCharacterSets(qryDomains.FieldByName('RDB$CHARACTER_SET_ID').AsInteger, - 0, FALSE); - if not qryDomains.FieldByName('RDB$DIMENSIONS').IsNull then - Result := GetArrayField(FieldName); - - if not qryDomains.FieldByName('RDB$DEFAULT_SOURCE').IsNull then - Result := Result + Format('%s%s %s', [NEWLINE, TAB, - qryDomains.FieldByName('RDB$DEFAULT_SOURCE').AsString]); - - if not qryDomains.FieldByName('RDB$VALIDATION_SOURCE').IsNull then - if Pos('CHECK', AnsiUpperCase(qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString)) = 1 then - Result := Result + Format('%s%s %s', [NEWLINE, TAB, - qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString]) - else - Result := Result + Format('%s%s /* %s */', [NEWLINE, TAB, - qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString]); - - if qryDomains.FieldByName('RDB$NULL_FLAG').AsInteger = 1 then - Result := Result + ' NOT NULL'; - - { Show the collation order if one has been specified. If the collation - order is the default for the character set being used, then no collation - order will be shown ( because it isn't needed ). - - If the collation id is 0, then the default for the character set is - being used so there is no need to retrieve the collation information.} - - if (not qryDomains.FieldByName('RDB$COLLATION_ID').IsNull) and - (qryDomains.FieldByName('RDB$COLLATION_ID').AsInteger <> 0) then - Result := Result + GetCharacterSets(qryDomains.FieldByName('RDB$CHARACTER_SET_ID').AsInteger, - qryDomains.FieldByName('RDB$COLLATION_ID').AsInteger, true); - end; - -begin - First := true; - qryDomains := TIBSQL.Create(FDatabase); - try - if ObjectName <> '' then - begin - if ExtractType = etTable then - begin - qryDomains.SQL.Text := DomainSQL; - qryDomains.Params.ByName('table_name').AsString := ObjectName; - end - else - begin - qryDomains.SQL.Text := DomainByNameSQL; - qryDomains.Params.ByName('DomainName').AsString := ObjectName; - end; - end - else - qryDomains.SQL.Text := AllDomainSQL; - - qryDomains.ExecQuery; - while not qryDomains.Eof do - begin - FieldName := qryDomains.FieldByName('RDB$FIELD_NAME').AsString; - { Skip over artifical domains } - if (Pos('RDB$',FieldName) = 1) and - (FieldName[5] in ['0'..'9']) and - (qryDomains.FieldByName('RDB$SYSTEM_FLAG').AsInteger <> 1) then - begin - qryDomains.Next; - continue; - end; - - if First then - begin - FMetaData.Add('/* Domain definitions */'); - First := false; - end; - - Line := Format('CREATE DOMAIN %s AS ', [FieldName]); - Line := Line + FormatDomainStr + Term; - FMetaData.Add(Line); - qryDomains.Next; - end; - finally - qryDomains.Free; - end; -end; - -{ ListException - Functional description - List all exceptions defined in the database - - Parameters: none } - -procedure TIBExtract.ListException(ExceptionName : String = ''); -const - ExceptionSQL = - 'select * from RDB$EXCEPTIONS ' + - 'ORDER BY RDB$EXCEPTION_NAME'; - - ExceptionNameSQL = - 'select * from RDB$EXCEPTIONS ' + - 'WHERE RDB$EXCEPTION_NAME = :ExceptionName ' + - 'ORDER BY RDB$EXCEPTION_NAME'; - -var - First : Boolean; - qryException : TIBSQL; -begin - First := true; - qryException := TIBSQL.Create(FDatabase); - try - if ExceptionName = '' then - qryException.SQL.Text := ExceptionSQL - else - begin - qryException.SQL.Text := ExceptionNameSQL; - qryException.Params.ByName('ExceptionName').AsString := ExceptionName; - end; - - qryException.ExecQuery; - while not qryException.Eof do - begin - if First then - begin - FMetaData.Add(''); - FMetaData.Add('/* Exceptions */'); - FMetaData.Add(''); - First := false; - end; //end_if - - FMetaData.Add(Format('CREATE EXCEPTION %s %s%s', - [QuoteIdentifier(FDatabase.SQLDialect, qryException.FieldByName('RDB$EXCEPTION_NAME').AsString), - QuotedStr(qryException.FieldByName('RDB$MESSAGE').AsString), Term])); - qryException.Next; - end; - finally - qryException.Free; - end; -end; - -{ ListFilters - - Functional description - List all blob filters - - Parameters: none - Results in - DECLARE FILTER INPUT_TYPE OUTPUT_TYPE - ENTRY_POINT MODULE_NAME } - -procedure TIBExtract.ListFilters(FilterName : String = ''); -const - FiltersSQL = - 'SELECT * FROM RDB$FILTERS ' + - 'ORDER BY RDB$FUNCTION_NAME'; - FilterNameSQL = - 'SELECT * FROM RDB$FILTERS ' + - 'WHERE RDB$FUNCTION_NAME = :FunctionName ' + - 'ORDER BY RDB$FUNCTION_NAME'; - -var - First : Boolean; - qryFilters : TIBSQL; -begin - First := true; - qryFilters := TIBSQL.Create(FDatabase); - try - if FilterName = '' then - qryFilters.SQL.Text := FiltersSQL - else - begin - qryFilters.SQL.Text := FilterNameSQL; - qryFilters.Params.ByName('FunctionName').AsString := FilterName; - end; - qryFilters.ExecQuery; - while not qryFilters.Eof do - begin - if First then - begin - FMetaData.Add(''); - FMetaData.Add('/* BLOB Filter declarations */'); - FMetaData.Add(''); - First := false; - end; //end_if - - FMetaData.Add(Format('DECLARE FILTER %s INPUT_TYPE %d OUTPUT_TYPE %d', - [qryFilters.FieldByName('RDB$FUNCTION_NAME').AsString, - qryFilters.FieldByName('RDB$INPUT_SUB_TYPE').AsInteger, - qryFilters.FieldByName('RDB$OUTPUT_SUB_TYPE').AsInteger])); - FMetaData.Add(Format('%sENTRY_POINT ''%s'' MODULE_NAME ''%s''%s%', - [TAB, qryFilters.FieldByName('RDB$ENTRYPOINT').AsString, - qryFilters.FieldByName('RDB$MODULE_NAME').AsString, Term])); - FMetaData.Add(''); - - qryFilters.Next; - end; - - finally - qryFilters.Free; - end; -end; - -{ ListForeign - Functional description - List all foreign key constraints and alter the tables } - -procedure TIBExtract.ListForeign(ObjectName : String; ExtractType : TExtractType); -const - { Static queries for obtaining foreign constraints, where RELC1 is the - foreign key constraints, RELC2 is the primary key lookup and REFC - is the join table } - ForeignSQL = - 'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' + - ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' + - ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' + - ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' + - 'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' + - ' RDB$RELATION_CONSTRAINTS RELC2 ' + - 'WHERE ' + - ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' + - ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' + - ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' + - ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' + - ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' + - 'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME'; - - ForeignNameSQL = - 'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' + - ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' + - ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' + - ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' + - 'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' + - ' RDB$RELATION_CONSTRAINTS RELC2 ' + - 'WHERE ' + - ' RELC1.RDB$RELATION_NAME = :TableName AND ' + - ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' + - ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' + - ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' + - ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' + - ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' + - 'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME'; - - ForeignByNameSQL = - 'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' + - ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' + - ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' + - ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' + - 'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' + - ' RDB$RELATION_CONSTRAINTS RELC2 ' + - 'WHERE ' + - ' RELC1.RDB$CONSTRAINT_NAME = :ConstraintName AND ' + - ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' + - ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' + - ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' + - ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' + - ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' + - 'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME'; - -var - qryForeign : TIBSQL; - Line : String; - -begin - qryForeign := TIBSQL.Create(FDatabase); - try - if ObjectName = '' then - qryForeign.SQL.Text := ForeignSQL - else - begin - if ExtractType = etTable then - begin - qryForeign.SQL.Text := ForeignNameSQL; - qryForeign.Params.ByName('TableName').AsString := ObjectName; - end - else - begin - qryForeign.SQL.Text := ForeignByNameSQL; - qryForeign.Params.ByName('ConstraintName').AsString := ObjectName; - end; - end; - qryForeign.ExecQuery; - while not qryForeign.Eof do - begin - Line := Format('ALTER TABLE %s ADD ', [QuoteIdentifier(FDatabase.SQLDialect, - qryForeign.FieldByName('RELC1_RELATION_NAME').AsString)]); - - { If the name of the constraint is not INTEG..., print it. - INTEG... are internally generated names. } - if (not qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').IsNull) and - ( Pos('INTEG', qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').AsString) <> 1) then - Line := Line + Format('CONSTRAINT %s ', [QuoteIdentifier(FDatabase.SQLDialect, - Trim(qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').AsString))]); - - Line := Line + Format('FOREIGN KEY (%s) REFERENCES %s ', [ - GetIndexSegments(qryForeign.FieldByName('RELC1_INDEX_NAME').AsString), - Trim(qryForeign.FieldByName('RELC2_RELATION_NAME').AsString)]); - - Line := Line + Format('(%s)', - [GetIndexSegments(qryForeign.FieldByName('RELC2_INDEX_NAME').AsString)]); - - { Add the referential actions, if any } - if (not qryForeign.FieldByName('REFC_UPDATE_RULE').IsNull) and - (Trim(qryForeign.FieldByName('REFC_UPDATE_RULE').AsString) <> 'RESTRICT') then - Line := Line + Format(' ON UPDATE %s', - [Trim(qryForeign.FieldByName('REFC_UPDATE_RULE').AsString)]); - - if (not qryForeign.FieldByName('REFC_DELETE_RULE').IsNull) and - (Trim(qryForeign.FieldByName('REFC_DELETE_RULE').AsString) <> 'RESTRICT') then - Line := Line + Format(' ON DELETE %s', - [Trim(qryForeign.FieldByName('REFC_DELETE_RULE').AsString)]); - - Line := Line + Term; - FMetaData.Add(Line); - qryForeign.Next; - end; - finally - qryForeign.Free; - end; -end; - -{ ListFunctions - - Functional description - List all external functions - - Parameters: none - Results in - DECLARE EXTERNAL FUNCTION function_name - CHAR [256] , INTEGER, .... - RETURNS INTEGER BY VALUE - ENTRY_POINT entrypoint MODULE_NAME module; } - -procedure TIBExtract.ListFunctions(FunctionName : String = ''); -const - FunctionSQL = - 'SELECT * FROM RDB$FUNCTIONS ' + - 'ORDER BY RDB$FUNCTION_NAME'; - - FunctionNameSQL = - 'SELECT * FROM RDB$FUNCTIONS ' + - 'WHERE RDB$FUNCTION_NAME = :FunctionName ' + - 'ORDER BY RDB$FUNCTION_NAME'; - - FunctionArgsSQL = - 'SELECT * FROM RDB$FUNCTION_ARGUMENTS ' + - 'WHERE ' + - ' :FUNCTION_NAME = RDB$FUNCTION_NAME ' + - 'ORDER BY RDB$ARGUMENT_POSITION'; - - FuncArgsPosSQL = - 'SELECT * FROM RDB$FUNCTION_ARGUMENTS ' + - 'WHERE ' + - ' RDB$FUNCTION_NAME = :RDB$FUNCTION_NAME AND ' + - ' RDB$ARGUMENT_POSITION = :RDB$ARGUMENT_POSITION'; - - CharSetSQL = - 'SELECT * FROM RDB$CHARACTER_SETS ' + - 'WHERE ' + - ' RDB$CHARACTER_SET_ID = :CHARACTER_SET_ID'; - -var - qryFunctions, qryFuncArgs, qryCharSets, qryFuncPos : TIBSQL; - First, FirstArg, DidCharset, PrecisionKnown : Boolean; - ReturnBuffer, TypeBuffer, Line : String; - i, FieldType : Integer; -begin - First := true; - qryFunctions := TIBSQL.Create(FDatabase); - qryFuncArgs := TIBSQL.Create(FDatabase); - qryFuncPos := TIBSQL.Create(FDatabase); - qryCharSets := TIBSQL.Create(FDatabase); - try - if FunctionName = '' then - qryFunctions.SQL.Text := FunctionSQL - else - begin - qryFunctions.SQL.Text := FunctionNameSQL; - qryFunctions.Params.ByName('FunctionName').AsString := FunctionName; - end; - qryFuncArgs.SQL.Text := FunctionArgsSQL; - qryFuncPos.SQL.Text := FuncArgsPosSQL; - qryCharSets.SQL.Text := CharSetSQL; - qryFunctions.ExecQuery; - while not qryFunctions.Eof do - begin - if First then - begin - FMEtaData.Add(Format('%s/* External Function declarations */%s', - [NEWLINE, NEWLINE])); - First := false; - end; //end_if - { Start new function declaration } - FMetaData.Add(Format('DECLARE EXTERNAL FUNCTION %s', - [qryFunctions.FieldByName('RDB$FUNCTION_NAME').AsString])); - Line := ''; - - FirstArg := true; - qryFuncArgs.Params.ByName('FUNCTION_NAME').AsString := - qryFunctions.FieldByName('RDB$FUNCTION_NAME').AsString; - - qryFuncArgs.ExecQuery; - while not qryFuncArgs.Eof do - begin - { Find parameter type } - i := 0; - FieldType := qryFuncArgs.FieldByName('RDB$FIELD_TYPE').AsInteger; - while FieldType <> ColumnTypes[i].SQLType do - Inc(i); - - { Print length where appropriate } - if FieldType in [ blr_text, blr_varying, blr_cstring] then - begin - DidCharset := false; - - qryCharSets.Params.ByName('CHARACTER_SET_ID').AsString := - qryFuncArgs.FieldByName('RDB$CHARACTER_SET_ID').AsString; - qryCharSets.ExecQuery; - while not qryCharSets.Eof do - begin - DidCharset := true; - TypeBuffer := Format('%s(%d) CHARACTER SET %s', - [ColumnTypes[i].TypeName, - qryFuncArgs.FieldByName('RDB$FIELD_LENGTH').AsInteger div - Max(1,qryCharSets.FieldByName('RDB$BYTES_PER_CHARACTER').AsInteger), - qryCharSets.FieldByName('RDB$CHARACTER_SET_NAME').AsString]); - qryCharSets.Next; - end; - qryCharSets.Close; - if not DidCharset then - TypeBuffer := Format('%s(%d)', [ColumnTypes[i].TypeName, - qryFuncArgs.FieldByName('RDB$FIELD_LENGTH').AsInteger]); - end //end_if - else - begin - PrecisionKnown := false; - if (FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10) and - (FieldType in [blr_short, blr_long, blr_int64]) then - begin - qryFuncPos.Params.ByName('RDB$FUNCTION_NAME').AsString := - qryFuncArgs.FieldByName('RDB$FUNCTION_NAME').AsString; - qryFuncPos.Params.ByName('RDB$ARGUMENT_POSITION').AsInteger := - qryFuncArgs.FieldByName('RDB$ARGUMENT_POSITION').AsInteger; - - qryFuncPos.ExecQuery; - while not qryFuncPos.Eof do - begin - { We are ODS >= 10 and could be any Dialect } - if not qryFuncPos.FieldByName('RDB$FIELD_PRECISION').IsNull then - begin - { We are Dialect >=3 since FIELD_PRECISION is non-NULL } - if (qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and - (qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then - begin - TypeBuffer := Format('%s(%d, %d)', - [IntegralSubtypes[qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger], - qryFuncPos.FieldByName('RDB$FIELD_PRECISION').AsInteger, - -qryFuncPos.FieldByName('RDB$FIELD_SCALE').AsInteger] ); - PrecisionKnown := true; - end; //end_if - end; { if field_precision is not null } - qryFuncPos.Next; - end; - qryFuncPos.Close; - end; { if major_ods >= ods_version10 && } - if not PrecisionKnown then - begin - { Take a stab at numerics and decimals } - if (FieldType = blr_short) and - (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - TypeBuffer := Format('NUMERIC(4, %d)', - [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger]) - else - if (FieldType = blr_long) and - (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - TypeBuffer := Format('NUMERIC(9, %d)', - [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger]) - else - if (FieldType = blr_double) and - (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - TypeBuffer := Format('NUMERIC(15, %d)', - [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger]) - else - TypeBuffer := ColumnTypes[i].TypeName; - end; { if not PrecisionKnown } - end; { if FCHAR or VARCHAR or CSTRING ... else } - - if qryFunctions.FieldByName('RDB$RETURN_ARGUMENT').AsInteger = - qryFuncArgs.FieldByName('RDB$ARGUMENT_POSITION').AsInteger then - begin - ReturnBuffer := 'RETURNS ' + TypeBuffer; - if qryFuncArgs.FieldByName('RDB$MECHANISM').AsInteger = 0 then - ReturnBuffer := ReturnBuffer + ' BY VALUE '; - if qryFuncArgs.FieldByName('RDB$MECHANISM').AsInteger < 0 then - ReturnBuffer := ReturnBuffer + ' FREE_IT'; - end - else - begin - { First arg needs no comma } - if FirstArg then - begin - Line := Line + TypeBuffer; - FirstArg := false; - end - else - Line := Line + ', ' + TypeBuffer; - end; //end_else - qryFuncArgs.Next; - end; - qryFuncArgs.Close; - - FMetaData.Add(Line); - FMetaData.Add(ReturnBuffer); - FMetaData.Add(Format('ENTRY_POINT ''%s'' MODULE_NAME ''%s''%s%s%s', - [qryFunctions.FieldByName('RDB$ENTRYPOINT').AsString, - qryFunctions.FieldByName('RDB$MODULE_NAME').AsString, - Term, NEWLINE, NEWLINE])); - - qryFunctions.Next; - end; - finally - qryFunctions.Free; - qryFuncArgs.Free; - qryCharSets.Free; - qryFuncPos.Free; - end; -end; - -{ ListGenerators - Functional description - Re create all non-system generators } - -procedure TIBExtract.ListGenerators(GeneratorName : String = ''); -const - GeneratorSQL = - 'SELECT RDB$GENERATOR_NAME ' + - 'FROM RDB$GENERATORS ' + - 'WHERE ' + - ' (RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG <> 1) ' + - 'ORDER BY RDB$GENERATOR_NAME'; - - GeneratorNameSQL = - 'SELECT RDB$GENERATOR_NAME ' + - 'FROM RDB$GENERATORS ' + - 'WHERE RDB$GENERATOR_NAME = :GeneratorName AND ' + - ' (RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG <> 1) ' + - 'ORDER BY RDB$GENERATOR_NAME'; - -var - qryGenerator : TIBSQL; - GenName : String; -begin - qryGenerator := TIBSQL.Create(FDatabase); - try - if GeneratorName = '' then - qryGenerator.SQL.Text := GeneratorSQL - else - begin - qryGenerator.SQL.Text := GeneratorNameSQL; - qryGenerator.Params.ByName('GeneratorName').AsString := GeneratorName; - end; - qryGenerator.ExecQuery; - FMetaData.Add(''); - while not qryGenerator.Eof do - begin - GenName := qryGenerator.FieldByName('RDB$GENERATOR_NAME').AsString; - if ((Pos('RDB$',GenName) = 1) and - (GenName[5] in ['0'..'9'])) or - ((Pos('SQL$',GenName) = 1) and - (GenName[5] in ['0'..'9'])) then - begin - qryGenerator.Next; - continue; - end; - FMetaData.Add(Format('CREATE GENERATOR %s%s', - [QuoteIdentifier(FDatabase.SQLDialect, GenName), - Term])); - qryGenerator.Next; - end; - finally - qryGenerator.Free; - end; -end; - -{ ListIndex - Functional description - Define all non-constraint indices - Use a static SQL query to get the info and print it. - - Uses get_index_segment to provide a key list for each index } - -procedure TIBExtract.ListIndex(ObjectName : String; ExtractType : TExtractType); -const - IndexSQL = - 'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' + - ' IDX.RDB$INDEX_TYPE ' + - 'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' + - ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' + - 'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' + - ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' + - ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' + - 'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME'; - - IndexNameSQL = - 'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' + - ' IDX.RDB$INDEX_TYPE ' + - 'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' + - ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' + - 'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' + - ' RELC.RDB$RELATION_NAME = :RelationName AND ' + - ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' + - ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' + - 'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME'; - - IndexByNameSQL = - 'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' + - ' IDX.RDB$INDEX_TYPE ' + - 'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' + - ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' + - 'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' + - ' IDX.RDB$INDEX_NAME = :IndexName AND ' + - ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' + - ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' + - 'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME'; - -var - qryIndex : TIBSQL; - First : Boolean; - Unique, IdxType, Line : String; -begin - First := true; - qryIndex := TIBSQL.Create(FDatabase); - try - if ObjectName = '' then - qryIndex.SQL.Text := IndexSQL - else - begin - if ExtractType = etTable then - begin - qryIndex.SQL.Text := IndexNameSQL; - qryIndex.Params.ByName('RelationName').AsString := ObjectName; - end - else - begin - qryIndex.SQL.Text := IndexByNameSQL; - qryIndex.Params.ByName('IndexName').AsString := ObjectName; - end; - end; - qryIndex.ExecQuery; - while not qryIndex.Eof do - begin - if First then - begin - if ObjectName = '' then - FMetaData.Add(NEWLINE + '/* Index definitions for all user tables */' + NEWLINE) - else - FMetaData.Add(NEWLINE + '/* Index definitions for ' + ObjectName + ' */' + NEWLINE); - First := false; - end; //end_if - - if qryIndex.FieldByName('RDB$UNIQUE_FLAG').AsInteger = 1 then - Unique := ' UNIQUE' - else - Unique := ''; - - if qryIndex.FieldByName('RDB$INDEX_TYPE').AsInteger = 1 then - IdxType := ' DESCENDING' - else - IdxType := ''; - - Line := Format('CREATE%s%s INDEX %s ON %s(', [Unique, IdxType, - QuoteIdentifier(FDataBase.SQLDialect, - qryIndex.FieldByName('RDB$INDEX_NAME').AsString), - QuoteIdentifier(FDataBase.SQLDialect, - qryIndex.FieldByName('RDB$RELATION_NAME').AsString)]); - - Line := Line + GetIndexSegments(qryIndex.FieldByName('RDB$INDEX_NAME').AsString) + - ')' + Term; - - FMetaData.Add(Line); - qryIndex.Next; - end; - finally - qryIndex.Free; - end; -end; - -{ ListViews - Functional description - Show text of views. - Use a SQL query to get the info and print it. - Note: This should also contain check option } - -procedure TIBExtract.ListViews(ViewName : String); -const - ViewSQL = - 'SELECT RDB$RELATION_NAME, RDB$OWNER_NAME, RDB$VIEW_SOURCE ' + - 'FROM RDB$RELATIONS ' + - 'WHERE ' + - ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + - ' NOT RDB$VIEW_BLR IS NULL AND ' + - ' RDB$FLAGS = 1 ' + - 'ORDER BY RDB$RELATION_ID'; - - ViewNameSQL = - 'SELECT RDB$RELATION_NAME, RDB$OWNER_NAME, RDB$VIEW_SOURCE ' + - 'FROM RDB$RELATIONS ' + - 'WHERE ' + - ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + - ' NOT RDB$VIEW_BLR IS NULL AND ' + - ' RDB$FLAGS = 1 AND ' + - ' RDB$RELATION_NAME = :ViewName ' + - 'ORDER BY RDB$RELATION_ID'; - - ColumnSQL = - 'SELECT RDB$FIELD_NAME FROM RDB$RELATION_FIELDS ' + - 'WHERE ' + - ' RDB$RELATION_NAME = :RELATION_NAME ' + - 'ORDER BY RDB$FIELD_POSITION'; - -var - qryView, qryColumns : TIBSQL; - SList : TStrings; -begin - qryView := TIBSQL.Create(FDatabase); - qryColumns := TIBSQL.Create(FDatabase); - SList := TStringList.Create; - try - if ViewName = '' then - qryView.SQL.Text := ViewSQL - else - begin - qryView.SQL.Text := ViewNameSQL; - qryView.Params.ByName('ViewName').AsString := ViewName; - end; - qryColumns.SQL.Text := ColumnSQL; - qryView.ExecQuery; - while not qryView.Eof do - begin - SList.Add(Format('%s/* View: %s, Owner: %s */%s', - [NEWLINE, qryView.FieldByName('RDB$RELATION_NAME').AsString, - qryView.FieldByName('RDB$OWNER_NAME').AsString, NEWLINE])); - - SList.Add(Format('CREATE VIEW %s (', [QuoteIdentifier(FDatabase.SQLDialect, - qryView.FieldByName('RDB$RELATION_NAME').AsString)])); - - qryColumns.Params.ByName('RELATION_NAME').AsString := - qryView.FieldByName('RDB$RELATION_NAME').AsString; - qryColumns.ExecQuery; - while not qryColumns.Eof do - begin - SList.Add(' ' + QuoteIdentifier(FDatabase.SQLDialect, - qryColumns.FieldByName('RDB$FIELD_NAME').AsString)); - qryColumns.Next; - if not qryColumns.Eof then - SList.Strings[SList.Count - 1] := SList.Strings[SList.Count - 1] + ', '; - end; - qryColumns.Close; - SList.Text := SList.Text + Format(') AS%s', [NEWLINE]); - if not qryView.FieldByName('RDB$VIEW_SOURCE').IsNull then - SList.Text := SList.Text + qryView.FieldByName('RDB$VIEW_SOURCE').AsString; - SList.Text := SList.Text + Format('%s%s', [Term, NEWLINE]); - FMetaData.AddStrings(SList); - SList.Clear; - qryView.Next; - end; - finally - qryView.Free; - qryColumns.Free; - SList.Free; - end; -end; - -{ PrintSet - Functional description - print (using ISQL_printf) the word "SET" - if the first line of the ALTER DATABASE - settings options. Also, add trailing - comma for end of prior line if needed. - - uses Print_buffer, a global } - -function TIBExtract.PrintSet(var Used: Boolean) : String; -begin - if not Used then - begin - Result := ' SET '; - Used := true; - end - else - Result := Format(', %s ', [NEWLINE]); -end; - -{ - PrintValidation - Functional description - This does some minor syntax adjustmet for extracting - validation blobs and computed fields. - if it does not start with the word CHECK - if this is a computed field blob,look for () or insert them. - if flag = false, this is a validation clause, - if flag = true, this is a computed field } - -function TIBExtract.PrintValidation(ToValidate: String; - flag: Boolean): String; -var - IsSQL : Boolean; -begin - IsSql := false; - - Result := ''; - ToValidate := Trim(ToValidate); - - if flag then - begin - if ToValidate[1] = '(' then - IsSQL := true; - end - else - if (Pos(ToValidate, 'check') = 1) or (Pos(ToValidate, 'CHECK') = 1) then - IsSQL := TRUE; - - if not IsSQL then - begin - if Flag then - Result := Result + '/* ' + ToValidate + ' */' - else - Result := Result + '(' + ToValidate + ')'; - end - else - Result := ToValidate; -end; - -procedure TIBExtract.SetDatabase(const Value: TIBDatabase); -begin - if FDatabase <> Value then - begin - FDatabase := Value; - if (not Assigned(FTransaction)) and (FDatabase <> nil) then - Transaction := FDatabase.DefaultTransaction; - FDatabaseInfo.Database := FDatabase; - end; -end; - -procedure TIBExtract.SetTransaction(const Value: TIBTransaction); -begin - if FTransaction <> Value then - begin - FTransaction := Value; - if (not Assigned(FDatabase)) and (FTransaction <> nil) then - Database := FTransaction.DefaultDatabase; - end; -end; - -procedure TIBExtract.ExtractObject(ObjectType : TExtractObjectTypes; - ObjectName : String = ''; ExtractTypes : TExtractTypes = []); -var - DidActivate : Boolean; -begin - DidActivate := false; - if not FTransaction.Active then - begin - FTransaction.StartTransaction; - DidActivate := true; - end; - FMetaData.Clear; - case ObjectType of - eoDatabase : ExtractDDL(true, ''); - eoDomain : - if etTable in ExtractTypes then - ListDomains(ObjectName, etTable) - else - ListDomains(ObjectName); - eoTable : - begin - if ObjectName <> '' then - begin - if etDomain in ExtractTypes then - ListDomains(ObjectName, etTable); - ExtractListTable(ObjectName, '', false); - if etIndex in ExtractTypes then - ListIndex(ObjectName, etTable); - if etForeign in ExtractTypes then - ListForeign(ObjectName, etTable); - if etCheck in ExtractTypes then - ListCheck(ObjectName, etTable); - if etTrigger in ExtractTypes then - ListTriggers(ObjectName, etTable); - if etGrant in ExtractTypes then - ShowGrants(ObjectName, Term); - if etData in ExtractTypes then - ListData(ObjectName); - end - else - ListAllTables(true); - end; - eoView : ListViews(ObjectName); - eoProcedure : ListProcs(ObjectName); - eoFunction : ListFunctions(ObjectName); - eoGenerator : ListGenerators(ObjectName); - eoException : ListException(ObjectName); - eoBLOBFilter : ListFilters(ObjectName); - eoRole : ListRoles(ObjectName); - eoTrigger : - if etTable in ExtractTypes then - ListTriggers(ObjectName, etTable) - else - ListTriggers(ObjectName); - eoForeign : - if etTable in ExtractTypes then - ListForeign(ObjectName, etTable) - else - ListForeign(ObjectName); - eoIndexes : - if etTable in ExtractTypes then - ListIndex(ObjectName, etTable) - else - ListIndex(ObjectName); - eoChecks : - if etTable in ExtractTypes then - ListCheck(ObjectName, etTable) - else - ListCheck(ObjectName); - eoData : ListData(ObjectName); - end; - if DidActivate then - FTransaction.Commit; -end; - -function TIBExtract.GetFieldType(FieldType, FieldSubType, FieldScale, - FieldSize, FieldPrec, FieldLen: Integer): String; -var - i : Integer; - PrecisionKnown : Boolean; -begin - Result := ''; - for i := Low(ColumnTypes) to High(ColumnTypes) do - if FieldType = ColumnTypes[i].SQLType then - begin - PrecisionKnown := FALSE; - if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then - begin - if FieldType in [blr_short, blr_long, blr_int64] then - begin - { We are ODS >= 10 and could be any Dialect } - if (FDatabaseInfo.DBSQLDialect >= 3) and - (FieldPrec <> 0) and - (FieldSubType > 0) and - (FieldSubType <= MAX_INTSUBTYPES) then - begin - Result := Result + Format('%s(%d, %d)', [ - IntegralSubtypes [FieldSubType], - FieldPrec, - -1 * FieldScale]); - PrecisionKnown := true; - end; - end; - end; - if PrecisionKnown = false then - begin - { Take a stab at numerics and decimals } - if (FieldType = blr_short) and - (FieldScale < 0) then - Result := Result + Format('NUMERIC(4, %d)', - [-FieldScale] ) - else - if (FieldType = blr_long) and - (FieldScale < 0) then - Result := Result + Format('NUMERIC(9, %d)', - [-FieldScale] ) - else - if (FieldType = blr_double) and - (FieldScale < 0) then - Result := Result + Format('NUMERIC(15, %d)', - [-FieldScale] ) - else - Result := Result + ColumnTypes[i].TypeName; - end; - break; - end; - if (FieldType in [blr_text, blr_varying]) and - (FieldSize <> 0) then - Result := Result + Format('(%d)', [FieldSize]); -end; - -{ S H O W _ g r a n t s - Functional description - Show grants for given object name - This function is also called by extract for privileges. - It must extract granted privileges on tables/views to users, - - these may be compound, so put them on the same line. - Grant execute privilege on procedures to users - Grant various privilegs to procedures. - All privileges may have the with_grant option set. } - -procedure TIBExtract.ShowGrants(MetaObject, Terminator: String); -const - { This query only finds tables, eliminating owner privileges } - OwnerPrivSQL = - 'SELECT PRV.RDB$USER, PRV.RDB$GRANT_OPTION, PRV.RDB$FIELD_NAME, ' + - ' PRV.RDB$USER_TYPE, PRV.RDB$PRIVILEGE ' + - 'FROM RDB$USER_PRIVILEGES PRV, RDB$RELATIONS REL ' + - 'WHERE ' + - ' PRV.RDB$RELATION_NAME = :METAOBJECT AND ' + - ' REL.RDB$RELATION_NAME = :METAOBJECT AND ' + - ' PRV.RDB$PRIVILEGE <> ''M'' AND ' + - ' REL.RDB$OWNER_NAME <> PRV.RDB$USER ' + - 'ORDER BY PRV.RDB$USER, PRV.RDB$FIELD_NAME, PRV.RDB$GRANT_OPTION'; - - ProcPrivSQL = - 'SELECT PRV.RDB$USER, PRV.RDB$GRANT_OPTION, PRV.RDB$FIELD_NAME, ' + - ' PRV.RDB$USER_TYPE, PRV.RDB$PRIVILEGE, PRV.RDB$RELATION_NAME ' + - 'FROM RDB$USER_PRIVILEGES PRV, RDB$PROCEDURES PRC ' + - 'where ' + - ' PRV.RDB$OBJECT_TYPE = 5 AND ' + - ' PRV.RDB$RELATION_NAME = :METAOBJECT AND ' + - ' PRC.RDB$PROCEDURE_NAME = :METAOBJECT AND ' + - ' PRV.RDB$PRIVILEGE = ''X'' AND ' + - ' PRC.RDB$OWNER_NAME <> PRV.RDB$USER ' + - 'ORDER BY PRV.RDB$USER, PRV.RDB$FIELD_NAME, PRV.RDB$GRANT_OPTION'; - - RolePrivSQL = - 'SELECT * FROM RDB$USER_PRIVILEGES ' + - 'WHERE ' + - ' RDB$OBJECT_TYPE = 13 AND ' + - ' RDB$USER_TYPE = 8 AND ' + - ' RDB$RELATION_NAME = :METAOBJECT AND ' + - ' RDB$PRIVILEGE = ''M'' ' + - 'ORDER BY RDB$USER'; - -var - PrevUser, PrevField, WithOption, - PrivString, ColString, UserString, - FieldName, User : String; - c : Char; - PrevOption, PrivFlags, GrantOption : Integer; - First, PrevFieldNull : Boolean; - qryOwnerPriv : TIBSQL; - - { Given a bit-vector of privileges, turn it into a - string list. } - function MakePrivString(cflags : Integer) : String; - var - i : Integer; - begin - for i := Low(PrivTypes) to High(PrivTypes) do - begin - if (cflags and PrivTypes[i].PrivFlag) <> 0 then - begin - if Result <> '' then - Result := Result + ', '; - Result := Result + PrivTypes[i].PrivString; - end; //end_if - end; //end_for - end; //end_fcn MakePrivDtring - -begin - if MetaObject = '' then - exit; - - First := true; - PrevOption := -1; - PrevUser := ''; - PrivString := ''; - ColString := ''; - WithOption := ''; - PrivFlags := 0; - PrevFieldNull := false; - PrevField := ''; - - qryOwnerPriv := TIBSQL.Create(FDatabase); - try - qryOwnerPriv.SQL.Text := OwnerPrivSQL; - qryOwnerPriv.Params.ByName('metaobject').AsString := MetaObject; - qryOwnerPriv.ExecQuery; - while not qryOwnerPriv.Eof do - begin - { Sometimes grant options are null, sometimes 0. Both same } - if qryOwnerPriv.FieldByName('RDB$GRANT_OPTION').IsNull then - GrantOption := 0 - else - GrantOption := qryOwnerPriv.FieldByName('RDB$GRANT_OPTION').AsInteger; - - if qryOwnerPriv.FieldByName('RDB$FIELD_NAME').IsNull then - FieldName := '' - else - FieldName := qryOwnerPriv.FieldByName('RDB$FIELD_NAME').AsString; - - User := Trim(qryOwnerPriv.FieldByName('RDB$USER').AsString); - { Print a new grant statement for each new user or change of option } - - if ((PrevUser <> '') and (PrevUser <> User)) or - ((Not First) and - (PrevFieldNull <> qryOwnerPriv.FieldByName('RDB$FIELD_NAME').IsNull)) or - ((not PrevFieldNull) and (PrevField <> FieldName)) or - ((PrevOption <> -1) and (PrevOption <> GrantOption)) then - begin - PrivString := MakePrivString(PrivFlags); - - First := false; - FMetaData.Add(Format('GRANT %s%s ON %s TO %s%s%s', [PrivString, - ColString, QuoteIdentifier(FDatabase.SQLDialect, MetaObject), - UserString, WithOption, Terminator])); - { re-initialize strings } - - PrivString := ''; - WithOption := ''; - ColString := ''; - PrivFlags := 0; - end; //end_if - - PrevUser := User; - PrevOption := GrantOption; - PrevFieldNull := qryOwnerPriv.FieldByName('RDB$FIELD_NAME').IsNull; - PrevField := FieldName; - - case qryOwnerPriv.FieldByName('RDB$USER_TYPE').AsInteger of - obj_relation, - obj_view, - obj_trigger, - obj_procedure, - obj_sql_role: - UserString := QuoteIdentifier(FDatabase.SQLDialect, User); - else - UserString := User; - end; //end_case - - case qryOwnerPriv.FieldByName('RDB$USER_TYPE').AsInteger of - obj_view : - UserString := 'VIEW ' + UserString; - obj_trigger : - UserString := 'TRIGGER '+ UserString; - obj_procedure : - UserString := 'PROCEDURE ' + UserString; - end; //end_case - - c := qryOwnerPriv.FieldByName('RDB$PRIVILEGE').AsString[1]; - - case c of - 'S' : PrivFlags := PrivFlags or priv_SELECT; - 'I' : PrivFlags := PrivFlags or priv_INSERT; - 'U' : PrivFlags := PrivFlags or priv_UPDATE; - 'D' : PrivFlags := PrivFlags or priv_DELETE; - 'R' : PrivFlags := PrivFlags or priv_REFERENCES; - 'X' : ; - { Execute should not be here -- special handling below } - else - PrivFlags := PrivFlags or priv_UNKNOWN; - end; //end_switch - - { Column level privileges for update only } - - if FieldName = '' then - ColString := '' - else - ColString := Format(' (%s)', [QuoteIdentifier(FDatabase.SQLDialect, FieldName)]); - - if GrantOption <> 0 then - WithOption := ' WITH GRANT OPTION'; - - qryOwnerPriv.Next; - end; - { Print last case if there was anything to print } - if PrevOption <> -1 then - begin - PrivString := MakePrivString(PrivFlags); - First := false; - FMetaData.Add(Format('GRANT %s%s ON %s TO %s%s%s', [PrivString, - ColString, QuoteIdentifier(FDatabase.SQLDialect, MetaObject), - UserString, WithOption, Terminator])); - { re-initialize strings } - end; //end_if - qryOwnerPriv.Close; - - if First then - begin - { Part two is for stored procedures only } - qryOwnerPriv.SQL.Text := ProcPrivSQL; - qryOwnerPriv.Params.ByName('metaobject').AsString := MetaObject; - qryOwnerPriv.ExecQuery; - while not qryOwnerPriv.Eof do - begin - First := false; - User := Trim(qryOwnerPriv.FieldByName('RDB$USER').AsString); - - case qryOwnerPriv.FieldByName('RDB$USER_TYPE').AsInteger of - obj_relation, - obj_view, - obj_trigger, - obj_procedure, - obj_sql_role: - UserString := QuoteIdentifier(FDatabase.SQLDialect, User); - else - UserString := User; - end; //end_case - case qryOwnerPriv.FieldByName('RDB$USER_TYPE').AsInteger of - obj_view : - UserString := 'VIEW ' + UserString; - obj_trigger : - UserString := 'TRIGGER '+ UserString; - obj_procedure : - UserString := 'PROCEDURE ' + UserString; - end; //end_case - - if qryOwnerPriv.FieldByName('RDB$GRANT_OPTION').AsInteger = 1 then - WithOption := ' WITH GRANT OPTION' - else - WithOption := ''; - - FMetaData.Add(Format('GRANT EXECUTE ON PROCEDURE %s TO %s%s%s', - [QuoteIdentifier(FDatabase.SQLDialect, MetaObject), UserString, - WithOption, terminator])); - - qryOwnerPriv.Next; - end; - qryOwnerPriv.Close; - end; - if First then - begin - qryOwnerPriv.SQL.Text := RolePrivSQL; - qryOwnerPriv.Params.ByName('metaobject').AsString := MetaObject; - qryOwnerPriv.ExecQuery; - while not qryOwnerPriv.Eof do - begin - if qryOwnerPriv.FieldByName('RDB$GRANT_OPTION').AsInteger = 1 then - WithOption := ' WITH ADMIN OPTION' - else - WithOption := ''; - - FMetaData.Add(Format('GRANT %s TO %s%s%s', - [QuoteIdentifier(FDatabase.SQLDialect, qryOwnerPriv.FieldByName('RDB$RELATION_NAME').AsString), - qryOwnerPriv.FieldByName('RDB$USER_NAME').AsString, - WithOption, terminator])); - - qryOwnerPriv.Next; - end; - end; - qryOwnerPriv.Close; - finally - qryOwnerPriv.Free; - end; -end; - -{ ShowGrantRoles - Functional description - Show grants for given role name - This function is also called by extract for privileges. - All membership privilege may have the with_admin option set. } - -procedure TIBExtract.ShowGrantRoles(Terminator: String); -const - RoleSQL = - 'SELECT RDB$USER, RDB$GRANT_OPTION, RDB$RELATION_NAME ' + - 'FROM RDB$USER_PRIVILEGES ' + - 'WHERE ' + - ' RDB$OBJECT_TYPE = %d AND ' + - ' RDB$USER_TYPE = %d AND ' + - ' RDB$PRIVILEGE = ''M'' ' + - 'ORDER BY RDB$RELATION_NAME, RDB$USER'; - -var - WithOption, UserString : String; - qryRole : TIBSQL; - -begin - qryRole := TIBSQL.Create(FDatabase); - try - qryRole.SQL.Text := Format(RoleSQL, [obj_sql_role, obj_user]); - qryRole.ExecQuery; - while not qryRole.Eof do - begin - UserString := Trim(qryRole.FieldByName('RDB$USER').AsString); - - if (not qryRole.FieldByName('RDB$GRANT_OPTION').IsNull) and - (qryRole.FieldByName('RDB$GRANT_OPTION').AsInteger = 1) then - WithOption := ' WITH ADMIN OPTION' - else - WithOption := ''; - FMetaData.Add(Format('GRANT %s TO %s%s%s%s', - [ QuoteIdentifier(FDatabase.SQLDialect, qryRole.FieldByName('RDB$RELATION_NAME').AsString), - UserString, WithOption, Terminator, NEWLINE])); - - qryRole.Next; - end; - finally - qryRole.Free; - end; -end; - -{ GetProcedureArgs - Functional description - This function extract the procedure parameters and adds it to the - extract file } - -procedure TIBExtract.GetProcedureArgs(Proc: String); -const -{ query to retrieve the input parameters. } - ProcHeaderSQL = - 'SELECT * ' + - ' FROM RDB$PROCEDURE_PARAMETERS PRM JOIN RDB$FIELDS FLD ON ' + - ' PRM.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' + - 'WHERE ' + - ' PRM.RDB$PROCEDURE_NAME = :PROCNAME AND ' + - ' PRM.RDB$PARAMETER_TYPE = :Input ' + - 'ORDER BY PRM.RDB$PARAMETER_NUMBER'; - -var - FirstTime, PrecisionKnown : Boolean; - Line : String; - qryHeader : TIBSQL; - - function FormatParamStr : String; - var - i, CollationID, CharSetID : Integer; - begin - Result := Format(' %s ', [qryHeader.FieldByName('RDB$PARAMETER_NAME').AsString]); - for i := Low(ColumnTypes) to High(ColumnTypes) do - if qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = ColumnTypes[i].SQLType then - begin - PrecisionKnown := FALSE; - if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then - begin - if qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_short, blr_long, blr_int64] then - begin - { We are ODS >= 10 and could be any Dialect } - if (FDatabaseInfo.DBSQLDialect >= 3) and - (not qryHeader.FieldByName('RDB$FIELD_PRECISION').IsNull) and - (qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and - (qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then - begin - Result := Result + Format('%s(%d, %d)', [ - IntegralSubtypes [qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger], - qryHeader.FieldByName('RDB$FIELD_PRECISION').AsInteger, - -1 * qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger]); - PrecisionKnown := true; - end; - end; - end; - if PrecisionKnown = false then - begin - { Take a stab at numerics and decimals } - if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_short) and - (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - Result := Result + Format('NUMERIC(4, %d)', - [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] ) - else - if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_long) and - (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - Result := Result + Format('NUMERIC(9, %d)', - [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] ) - else - if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_double) and - (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then - Result := Result + Format('NUMERIC(15, %d)', - [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] ) - else - Result := Result + ColumnTypes[i].TypeName; - end; - break; - end; - if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying]) and - (not qryHeader.FieldByName('RDB$CHARACTER_LENGTH').IsNull) then - Result := Result + Format('(%d)', [qryHeader.FieldByName('RDB$FIELD_LENGTH').AsInteger]); - - { Show international character sets and collations } - - if (not qryHeader.FieldByName('RDB$COLLATION_ID').IsNull) or - (not qryHeader.FieldByName('RDB$CHARACTER_SET_ID').IsNull) then - begin - if qryHeader.FieldByName('RDB$COLLATION_ID').IsNull then - CollationId := 0 - else - CollationId := qryHeader.FieldByName('RDB$COLLATION_ID').AsInteger; - - if qryHeader.FieldByName('RDB$CHARACTER_SET_ID').IsNull then - CharSetId := 0 - else - CharSetId := qryHeader.FieldByName('RDB$CHARACTER_SET_ID').AsInteger; - - Result := Result + GetCharacterSets(CharSetId, CollationId, false); - end; - end; - -begin - FirstTime := true; - qryHeader := TIBSQL.Create(FDatabase); - try - qryHeader.SQL.Text := ProcHeaderSQL; - qryHeader.Params.ByName('procname').AsString := Proc; - qryHeader.Params.ByName('Input').AsInteger := 0; - qryHeader.ExecQuery; - while not qryHeader.Eof do - begin - if FirstTime then - begin - FirstTime := false; - FMetaData.Add('('); - end; - - Line := FormatParamStr; - - qryHeader.Next; - if not qryHeader.Eof then - Line := Line + ','; - FMetaData.Add(Line); - end; - - { If there was at least one param, close parens } - if not FirstTime then - begin - FMetaData.Add( ')'); - end; - - FirstTime := true; - qryHeader.Close; - qryHeader.Params.ByName('Input').AsInteger := 1; - qryHeader.ExecQuery; - - while not qryHeader.Eof do - begin - if FirstTime then - begin - FirstTime := false; - FMetaData.Add('RETURNS' + NEWLINE + '('); - end; - - Line := FormatParamStr; - - qryHeader.Next; - if not qryHeader.Eof then - Line := Line + ','; - FMetaData.Add(Line); - end; - - { If there was at least one param, close parens } - if not FirstTime then - begin - FMetaData.Add( ')'); - end; - - FMetaData.Add('AS'); - finally - qryHeader.Free; - end; -end; - -procedure TIBExtract.Notification(AComponent: TComponent; - Operation: TOperation); -begin - inherited; - if (AComponent = FDatabase) and (Operation = opRemove) then - FDatabase := nil; - if (AComponent = FTransaction) and (Operation = opRemove) then - FTransaction := nil; -end; - -procedure TIBExtract.ListData(ObjectName: String); -const - SelectSQL = 'SELECT * FROM %s'; -var - qrySelect : TIBSQL; - Line : String; - i : Integer; -begin - qrySelect := TIBSQL.Create(FDatabase); - try - qrySelect.SQL.Text := Format(SelectSQL, - [QuoteIdentifier(FDatabase.SQLDialect, ObjectName)]); - qrySelect.ExecQuery; - while not qrySelect.Eof do - begin - Line := 'INSERT INTO ' + QuoteIdentifier(FDatabase.SQLDialect, ObjectName) + ' ('; - for i := 0 to qrySelect.Current.Count - 1 do - if (qrySelect.Fields[i].SQLType <> SQL_ARRAY) and - (qrySelect.Fields[i].SQLType <> SQL_BLOB) then - begin - Line := Line + QuoteIdentifier(FDatabase.SQLDialect, qrySelect.Fields[i].Name); - if i <> (qrySelect.Current.Count - 1) then - Line := Line + ', '; - end; - Line := Line + ') VALUES ('; - for i := 0 to qrySelect.Current.Count - 1 do - begin - if qrySelect.Fields[i].IsNull and - (qrySelect.Fields[i].SQLType <> SQL_ARRAY) and - (qrySelect.Fields[i].SQLType <> SQL_BLOB) then - begin - Line := Line + 'NULL'; - if i <> (qrySelect.Current.Count - 1) then - Line := Line + ', '; - end - else - case qrySelect.Fields[i].SQLType of - SQL_TEXT, SQL_VARYING, SQL_TYPE_DATE, - SQL_TYPE_TIME, SQL_TIMESTAMP : - begin - Line := Line + QuotedStr(qrySelect.Fields[i].AsString); - if i <> (qrySelect.Current.Count - 1) then - Line := Line + ', '; - end; - SQL_SHORT, SQL_LONG, SQL_INT64, - SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: - begin - Line := Line + qrySelect.Fields[i].AsString; - if i <> (qrySelect.Current.Count - 1) then - Line := Line + ', '; - end; - SQL_ARRAY, SQL_BLOB : ; - else - IBError(ibxeInvalidDataConversion, [nil]); - end; - end; - Line := Line + ')' + Term; - FMetaData.Add(Line); - qrySelect.Next; - end; - finally - qrySelect.Free; - end; -end; - -procedure TIBExtract.ListRoles(ObjectName: String); -const - RolesSQL = - 'select * from RDB$ROLES ' + - 'order by RDB$ROLE_NAME'; - - RolesByNameSQL = - 'select * from RDB$ROLES ' + - 'WHERE RDB$ROLE_NAME = :RoleName ' + - 'order by RDB$ROLE_NAME'; - -var - qryRoles : TIBSQL; - PrevOwner, RoleName, OwnerName : String; -begin - {Process GRANT roles} - qryRoles := TIBSQL.Create(FDatabase); - try - if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION9 then - begin - PrevOwner := ''; - FMetaData.Add(''); - FMetaData.Add('/* Grant Roles for this database */'); - FMetaData.Add(''); - - if ObjectName = '' then - qryRoles.SQL.Text := RolesSQL - else - begin - qryRoles.SQL.Text := RolesByNameSQL; - qryRoles.Params.ByName('RoleName').AsString := ObjectName; - end; - qryRoles.ExecQuery; - try - while not qryRoles.Eof do - begin - RoleName := QuoteIdentifier(FDatabase.SQLDialect, - qryRoles.FieldByName('rdb$Role_Name').AsString); - OwnerName := Trim(qryRoles.FieldByName('rdb$Owner_Name').AsString); - if PrevOwner <> OwnerName then - begin - FMetaData.Add(''); - FMetaData.Add(Format('/* Role: %s, Owner: %s */', [RoleName, OwnerName])); - FMetaData.Add(''); - PrevOwner := OwnerName; - end; - FMetaData.Add('CREATE ROLE ' + RoleName + Term); - qryRoles.Next; - end; - finally - qryRoles.Close; - end; - end; - finally - qryRoles.Free; - end; -end; - -end. - - +{************************************************************************} +{ } +{ The contents of this file are subject to the InterBase } +{ Public License Version 1.0 (the "License"); you may not } +{ use this file except in compliance with the License. You } +{ may obtain a copy of the License at http://www.Inprise.com/IPL.html } +{ Software distributed under the License is distributed on } +{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either } +{ express or implied. See the License for the specific language } +{ governing rights and limitations under the License. } +{ } +{ The Original Code was created by Jeff Overcash. } +{ Portions based upon code by Inprise Corporation are Copyright (C) } +{ Inprise Corporation. All Rights Reserved. } +{ } +{ IBX Version 4.2 or higher required } +{ Contributor(s): Jeff Overcash } +{ } +{ IBX For Lazarus (Firebird Express) } +{ Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk } +{ Portions created by MWA Software are copyright McCallum Whyman } +{ Associates Ltd 2011 } +{ } +{************************************************************************} + +unit IBExtract; + +{$Mode Delphi} + +interface + +uses +{$IFDEF WINDOWS } + Windows, +{$ELSE} + unix, +{$ENDIF} + SysUtils, Classes, IBDatabase, IBDatabaseInfo, + IBSQL, IBUtils, IBHeader, IB, IBIntf; + +type + TExtractObjectTypes = + (eoDatabase, eoDomain, eoTable, eoView, eoProcedure, eoFunction, + eoGenerator, eoException, eoBLOBFilter, eoRole, eoTrigger, eoForeign, + eoIndexes, eoChecks, eoData); + + TExtractType = + (etDomain, etTable, etRole, etTrigger, etForeign, + etIndex, etData, etGrant, etCheck); + + TExtractTypes = Set of TExtractType; + + TIBExtract = class(TComponent) + private + FDatabase : TIBDatabase; + FTransaction : TIBTransaction; + FMetaData: TStrings; + FDatabaseInfo: TIBDatabaseInfo; + FShowSystem: Boolean; + { Private declarations } + function GetDatabase: TIBDatabase; + function GetIndexSegments ( indexname : String) : String; + function GetTransaction: TIBTransaction; + procedure SetDatabase(const Value: TIBDatabase); + procedure SetTransaction(const Value: TIBTransaction); + function PrintValidation(ToValidate : String; flag : Boolean) : String; + procedure ShowGrants(MetaObject: String; Terminator : String); + procedure ShowGrantRoles(Terminator : String); + procedure GetProcedureArgs(Proc : String); + protected + function ExtractDDL(Flag : Boolean; TableName : String) : Boolean; + function ExtractListTable(RelationName, NewName : String; DomainFlag : Boolean) : Boolean; + procedure ExtractListView (ViewName : String); + procedure ListData(ObjectName : String); + procedure ListRoles(ObjectName : String = ''); + procedure ListGrants; + procedure ListProcs(ProcedureName : String = ''); + procedure ListAllTables(flag : Boolean); + procedure ListTriggers(ObjectName : String = ''; ExtractType : TExtractType = etTrigger); + procedure ListCheck(ObjectName : String = ''; ExtractType : TExtractType = etCheck); + function PrintSet(var Used : Boolean) : String; + procedure ListCreateDb(TargetDb : String = ''); + procedure ListDomains(ObjectName : String = ''; ExtractType : TExtractType = etDomain); + procedure ListException(ExceptionName : String = ''); + procedure ListFilters(FilterName : String = ''); + procedure ListForeign(ObjectName : String = ''; ExtractType : TExtractType = etForeign); + procedure ListFunctions(FunctionName : String = ''); + procedure ListGenerators(GeneratorName : String = ''); + procedure ListIndex(ObjectName : String = ''; ExtractType : TExtractType = etIndex); + procedure ListViews(ViewName : String = ''); + + { Protected declarations } + public + { Public declarations } + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + function GetArrayField(FieldName : String) : String; + function GetFieldType(FieldType, FieldSubType, FieldScale, FieldSize, + FieldPrec, FieldLen : Integer) : String; + function GetCharacterSets(CharSetId, Collation : integer; CollateOnly : Boolean) : String; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + procedure ExtractObject(ObjectType : TExtractObjectTypes; ObjectName : String = ''; + ExtractTypes : TExtractTypes = []); + property DatabaseInfo : TIBDatabaseInfo read FDatabaseInfo; + property Items : TStrings read FMetaData; + + published + { Published declarations } + property Database : TIBDatabase read GetDatabase write SetDatabase; + property Transaction : TIBTransaction read GetTransaction write SetTransaction; + property ShowSystem: Boolean read FShowSystem write FShowSystem; + end; + + TSQLType = record + SqlType : Integer; + TypeName : String; + end; + + TPrivTypes = record + PrivFlag : Integer; + PrivString : String; + end; + + TSQLTypes = Array[0..13] of TSQLType; + +const + + priv_UNKNOWN = 1; + priv_SELECT = 2; + priv_INSERT = 4; + priv_UPDATE = 8; + priv_DELETE = 16; + priv_EXECUTE = 32; + priv_REFERENCES = 64; + + PrivTypes : Array[0..5] of TPrivTypes = ( + (PrivFlag : priv_DELETE; PrivString : 'DELETE' ), + (PrivFlag : priv_EXECUTE; PrivString : 'EXECUTE' ), + (PrivFlag : priv_INSERT; PrivString : 'INSERT' ), + (PrivFlag : priv_SELECT; PrivString : 'SELECT' ), + (PrivFlag : priv_UPDATE; PrivString : 'UPDATE' ), + (PrivFlag : priv_REFERENCES; PrivString : 'REFERENCES')); + + ColumnTypes : TSQLTypes = ( + (SqlType : blr_short; TypeName : 'SMALLINT'), { NTX: keyword } + (SqlType : blr_long; TypeName : 'INTEGER'), { NTX: keyword } + (SqlType : blr_quad; TypeName : 'QUAD'), { NTX: keyword } + (SqlType : blr_float; TypeName : 'FLOAT'), { NTX: keyword } + (SqlType : blr_text; TypeName : 'CHAR'), { NTX: keyword } + (SqlType : blr_double; TypeName : 'DOUBLE PRECISION'), { NTX: keyword } + (SqlType : blr_varying; TypeName : 'VARCHAR'), { NTX: keyword } + (SqlType : blr_cstring; TypeName : 'CSTRING'), { NTX: keyword } + (SqlType : blr_blob_id; TypeName : 'BLOB_ID'), { NTX: keyword } + (SqlType : blr_blob; TypeName : 'BLOB'), { NTX: keyword } + (SqlType : blr_sql_time; TypeName : 'TIME'), { NTX: keyword } + (SqlType : blr_sql_date; TypeName : 'DATE'), { NTX: keyword } + (SqlType : blr_timestamp; TypeName : 'TIMESTAMP'), { NTX: keyword } + (SqlType : blr_int64; TypeName : 'INT64')); + + SubTypes : Array[0..8] of String = ( + 'UNKNOWN', { NTX: keyword } + 'TEXT', { NTX: keyword } + 'BLR', { NTX: keyword } + 'ACL', { NTX: keyword } + 'RANGES', { NTX: keyword } + 'SUMMARY', { NTX: keyword } + 'FORMAT', { NTX: keyword } + 'TRANSACTION_DESCRIPTION', { NTX: keyword } + 'EXTERNAL_FILE_DESCRIPTION'); { NTX: keyword } + + TriggerTypes : Array[0..6] of String = ( + '', + 'BEFORE INSERT', { NTX: keyword } + 'AFTER INSERT', { NTX: keyword } + 'BEFORE UPDATE', { NTX: keyword } + 'AFTER UPDATE', { NTX: keyword } + 'BEFORE DELETE', { NTX: keyword } + 'AFTER DELETE'); { NTX: keyword } + + IntegralSubtypes : Array[0..2] of String = ( + 'UNKNOWN', { Defined type, NTX: keyword } + 'NUMERIC', { NUMERIC, NTX: keyword } + 'DECIMAL'); { DECIMAL, NTX: keyword } + + ODS_VERSION6 = 6; { on-disk structure as of v3.0 } + ODS_VERSION7 = 7; { new on disk structure for fixing index bug } + ODS_VERSION8 = 8; { new btree structure to support pc semantics } + ODS_VERSION9 = 9; { btree leaf pages are always propogated up } + ODS_VERSION10 = 10; { V6.0 features. SQL delimited idetifier, + SQLDATE, and 64-bit exact numeric + type } + + { flags for RDB$FILE_FLAGS } + FILE_shadow = 1; + FILE_inactive = 2; + FILE_manual = 4; + FILE_cache = 8; + FILE_conditional = 16; + + { flags for RDB$LOG_FILES } + LOG_serial = 1; + LOG_default = 2; + LOG_raw = 4; + LOG_overflow = 8; + + + + MAX_INTSUBTYPES = 2; + MAXSUBTYPES = 8; { Top of subtypes array } + +{ Object types used in RDB$DEPENDENCIES and RDB$USER_PRIVILEGES } + + obj_relation = 0; + obj_view = 1; + obj_trigger = 2; + obj_computed = 3; + obj_validation = 4; + obj_procedure = 5; + obj_expression_index = 6; + obj_exception = 7; + obj_user = 8; + obj_field = 9; + obj_index = 10; + obj_count = 11; + obj_user_group = 12; + obj_sql_role = 13; + +implementation + +const + NEWLINE = #13#10; + TERM = ';'; + ProcTerm = '^'; + + CollationSQL = + 'SELECT CST.RDB$CHARACTER_SET_NAME, COL.RDB$COLLATION_NAME, CST.RDB$DEFAULT_COLLATE_NAME ' + + 'FROM RDB$COLLATIONS COL JOIN RDB$CHARACTER_SETS CST ON ' + + ' COL.RDB$CHARACTER_SET_ID = CST.RDB$CHARACTER_SET_ID ' + + 'WHERE ' + + ' COL.RDB$COLLATION_ID = :COLLATION AND ' + + ' CST.RDB$CHARACTER_SET_ID = :CHAR_SET_ID ' + + 'ORDER BY COL.RDB$COLLATION_NAME, CST.RDB$CHARACTER_SET_NAME'; + + NonCollationSQL = + 'SELECT CST.RDB$CHARACTER_SET_NAME ' + + 'FROM RDB$CHARACTER_SETS CST ' + + 'WHERE CST.RDB$CHARACTER_SET_ID = :CHARSETID ' + + 'ORDER BY CST.RDB$CHARACTER_SET_NAME'; + + PrecisionSQL = + 'SELECT * FROM RDB$FIELDS ' + + 'WHERE RDB$FIELD_NAME = :FIELDNAME'; + + ArraySQL = + 'SELECT * FROM RDB$FIELD_DIMENSIONS FDIM ' + + 'WHERE ' + + ' FDIM.RDB$FIELD_NAME = :FIELDNAME ' + + 'ORDER BY FDIM.RDB$DIMENSION'; + +{ TIBExtract } + +{ ArrayDimensions + Functional description + Retrieves the dimensions of arrays and prints them. + + Parameters: fieldname -- the actual name of the array field } + +function TIBExtract.GetArrayField(FieldName: String): String; +var + qryArray : TIBSQL; +begin + qryArray := TIBSQL.Create(FDatabase); + Result := '['; + qryArray.SQL.Add(ArraySQL); + qryArray.Params.ByName('FieldName').AsString := FieldName; + qryArray.ExecQuery; + + { Format is [lower:upper, lower:upper,..] } + + while not qryArray.Eof do + begin + if (qryArray.FieldByName('RDB$DIMENSION').AsInteger > 0) then + Result := Result + ', '; + Result := Result + qryArray.FieldByName('RDB$LOWER_BOUND').AsString + ':' + + qryArray.FieldByName('RDB$UPPER_BOUND').AsString; + qryArray.Next; + end; + + Result := Result + '] '; + qryArray.Free; + +end; + +constructor TIBExtract.Create(AOwner: TComponent); +begin + inherited; + FMetaData := TStringList.Create; + FDatabaseInfo := TIBDatabaseInfo.Create(nil); + FDatabaseInfo.Database := FDatabase; + if AOwner is TIBDatabase then + Database := TIBDatabase(AOwner); + if AOwner is TIBTransaction then + Transaction := TIBTransaction(AOwner); +end; + +destructor TIBExtract.Destroy; +begin + FMetaData.Free; + FDatabasEInfo.Free; + inherited; +end; + +function TIBExtract.ExtractDDL(Flag: Boolean; TableName: String) : Boolean; +var + DidConnect : Boolean; + DidStart : Boolean; +begin + Result := true; + DidConnect := false; + DidStart := false; + + if not FDatabase.Connected then + begin + FDatabase.Connected := true; + didConnect := true; + end; + + FMetaData.Add(Format('SET SQL DIALECT %d;', [FDatabase.SQLDialect])); + FMetaData.Add(''); + + if not FTransaction.Active then + begin + FTransaction.StartTransaction; + DidStart := true; + end; + + if TableName <> '' then + begin + if not ExtractListTable(TableName, '', true) then + Result := false; + end + else + begin + ListCreateDb; + ListFilters; + ListFunctions; + ListDomains; + ListAllTables(flag); + ListIndex; + ListForeign; + ListGenerators; + ListViews; + ListCheck; + ListException; + ListProcs; + ListTriggers; + ListGrants; + end; + + if DidStart then + FTransaction.Commit; + + if DidConnect then + FDatabase.Connected := false; +end; + +{ ExtractListTable + Functional description + Shows columns, types, info for a given table name + and text of views. + If a new_name is passed, substitute it for relation_name + + relation_name -- Name of table to investigate + new_name -- Name of a new name for a replacement table + domain_flag -- extract needed domains before the table } + +function TIBExtract.ExtractListTable(RelationName, NewName: String; + DomainFlag: Boolean) : Boolean; +const + TableListSQL = + 'SELECT * FROM RDB$RELATIONS REL JOIN RDB$RELATION_FIELDS RFR ON ' + {Do Not Localize} + ' RFR.RDB$RELATION_NAME = REL.RDB$RELATION_NAME JOIN RDB$FIELDS FLD ON ' + + ' RFR.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' + + 'WHERE REL.RDB$RELATION_NAME = :RelationName ' + + 'ORDER BY RFR.RDB$FIELD_POSITION, RFR.RDB$FIELD_NAME'; + + ConstraintSQL = + 'SELECT RCO.RDB$CONSTRAINT_NAME, RDB$CONSTRAINT_TYPE, RDB$RELATION_NAME, ' + + 'RDB$DEFERRABLE, RDB$INITIALLY_DEFERRED, RDB$INDEX_NAME, RDB$TRIGGER_NAME ' + + 'FROM RDB$RELATION_CONSTRAINTS RCO, RDB$CHECK_CONSTRAINTS CON ' + + 'WHERE ' + + ' CON.RDB$TRIGGER_NAME = :FIELDNAME AND ' + + ' CON.RDB$CONSTRAINT_NAME = RCO.RDB$CONSTRAINT_NAME AND ' + + ' RCO.RDB$CONSTRAINT_TYPE = ''NOT NULL'' AND ' + + ' RCO.RDB$RELATION_NAME = :RELATIONNAME'; + + RelConstraintsSQL = + 'SELECT * FROM RDB$RELATION_CONSTRAINTS RELC ' + + 'WHERE ' + + ' (RELC.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' OR ' + + ' RELC.RDB$CONSTRAINT_TYPE = ''UNIQUE'') AND ' + + ' RELC.RDB$RELATION_NAME = :RELATIONNAME ' + + 'ORDER BY RELC.RDB$CONSTRAINT_NAME'; + +var + Collation, CharSetId : integer; + i : integer; + ColList, Column, Constraint : String; + SubType : integer; + IntChar : integer; + qryTables, qryPrecision, qryConstraints, qryRelConstraints : TIBSQL; + PrecisionKnown, ValidRelation : Boolean; + FieldScale, FieldType : Integer; +begin + Result := true; + ColList := ''; + IntChar := 0; + ValidRelation := false; + + if DomainFlag then + ListDomains(RelationName); + qryTables := TIBSQL.Create(FDatabase); + qryPrecision := TIBSQL.Create(FDatabase); + qryConstraints := TIBSQL.Create(FDatabase); + qryRelConstraints := TIBSQL.Create(FDatabase); + try + qryTables.SQL.Add(TableListSQL); + qryTables.Params.ByName('RelationName').AsString := RelationName; + qryTables.ExecQuery; + qryPrecision.SQL.Add(PrecisionSQL); + qryConstraints.SQL.Add(ConstraintSQL); + qryRelConstraints.SQL.Add(RelConstraintsSQL); + if not qryTables.Eof then + begin + ValidRelation := true; + if (not qryTables.FieldByName('RDB$OWNER_NAME').IsNull) and + (Trim(qryTables.FieldByName('RDB$OWNER_NAME').AsString) <> '') then + FMetaData.Add(Format('%s/* Table: %s, Owner: %s */%s', + [NEWLINE, RelationName, + qryTables.FieldByName('RDB$OWNER_NAME').AsString, NEWLINE])); + if NewName <> '' then + FMetaData.Add(Format('CREATE TABLE %s ', [QuoteIdentifier(FDatabase.SQLDialect,NewName)])) + else + FMetaData.Add(Format('CREATE TABLE %s ', [QuoteIdentifier(FDatabase.SQLDialect,RelationName)])); + if not qryTables.FieldByName('RDB$EXTERNAL_FILE').IsNull then + FMetaData.Add(Format('EXTERNAL FILE %s ', + [QuotedStr(qryTables.FieldByName('RDB$EXTERNAL_FILE').AsString)])); + FMetaData.Add('('); + end; + + while not qryTables.Eof do + begin + Column := ' ' + QuoteIdentifier(FDatabase.SQLDialect, qryTables.FieldByName('RDB$FIELD_NAME').AsString) + TAB; + + { Check first for computed fields, then domains. + If this is a known domain, then just print the domain rather than type + Domains won't have length, array, or blob definitions, but they + may have not null, default and check overriding their definitions } + + if not qryTables.FieldByName('rdb$computed_blr').IsNull then + begin + Column := Column + ' COMPUTED BY '; + if not qryTables.FieldByName('RDB$COMPUTED_SOURCE').IsNull then + Column := Column + PrintValidation(qryTables.FieldByName('RDB$COMPUTED_SOURCE').AsString, true); + end + else + begin + FieldType := qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger; + FieldScale := qryTables.FieldByName('RDB$FIELD_SCALE').AsInteger; + if not ((Copy(qryTables.FieldByName('RDB$FIELD_NAME1').AsString, 1, 4) = 'RDB$') and + (qryTables.FieldByName('RDB$FIELD_NAME1').AsString[5] in ['0'..'9'])) and + (qryTables.FieldByName('RDB$SYSTEM_FLAG').AsInteger <> 1) then + begin + Column := Column + QuoteIdentifier(FDatabase.SQLDialect, qryTables.FieldByName('RDB$FIELD_NAME1').AsString); + { International character sets } + if (qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying]) + and (not qryTables.FieldByName('RDB$COLLATION_ID').IsNull) + and (qryTables.FieldByName('RDB$COLLATION_ID').AsInteger <> 0) then + begin + Collation := qryTables.FieldByName('RDB$COLLATION_ID').AsInteger; + Column := Column + GetCharacterSets(qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsShort, + Collation, true); + end; + end + else + begin + { Look through types array } + for i := Low(Columntypes) to High(ColumnTypes) do + begin + PrecisionKnown := false; + if qryTables.FieldByname('RDB$FIELD_TYPE').AsShort = ColumnTypes[i].SQLType then + begin + + if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then + begin + { Handle Integral subtypes NUMERIC and DECIMAL } + if qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger in + [blr_short, blr_long, blr_int64] then + begin + qryPrecision.Params.ByName('FIELDNAME').AsString := + qryTables.FieldByName('RDB$FIELD_NAME1').AsString; + qryPrecision.ExecQuery; + + { We are ODS >= 10 and could be any Dialect } + if not qryPrecision.FieldByName('RDB$FIELD_PRECISION').IsNull then + begin + { We are Dialect >=3 since FIELD_PRECISION is non-NULL } + if (qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and + (qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then + begin + Column := column + Format('%s(%d, %d)', + [IntegralSubtypes[qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger], + qryPrecision.FieldByName('RDB$FIELD_PRECISION').AsInteger, + -qryPrecision.FieldByName('RDB$FIELD_SCALE').AsInteger]); + PrecisionKnown := TRUE; + end; + end; + qryPrecision.Close; + end; + end; + + if PrecisionKnown = FALSE then + begin + { Take a stab at numerics and decimals } + if (FieldType = blr_short) and (FieldScale < 0) then + Column := Column + Format('NUMERIC(4, %d)', [-FieldScale]) + else + if (FieldType = blr_long) and (FieldScale < 0) then + Column := Column + Format('NUMERIC(9, %d)', [-FieldScale]) + else + if (FieldType = blr_double) and (FieldScale < 0) then + Column := Column + Format('NUMERIC(15, %d)', [-FieldScale]) + else + Column := Column + ColumnTypes[i].TypeName; + end; + end; + end; + if FieldType in [blr_text, blr_varying] then + if qryTables.FieldByName('RDB$CHARACTER_LENGTH').IsNull then + Column := Column + Format('(%d)', [qryTables.FieldByName('RDB$FIELD_LENGTH').AsInteger]) + else + Column := Column + Format('(%d)', [qryTables.FieldByName('RDB$CHARACTER_LENGTH').AsInteger]); + + { Catch arrays after printing the type } + + if not qryTables.FieldByName('RDB$DIMENSIONS').IsNull then + Column := column + GetArrayField(qryTables.FieldByName('RDB$FIELD_NAME').AsString); + + if FieldType = blr_blob then + begin + subtype := qryTables.FieldByName('RDB$FIELD_SUB_TYPE').AsShort; + Column := Column + ' SUB_TYPE '; + if (subtype > 0) and (subtype <= MAXSUBTYPES) then + Column := Column + SubTypes[subtype] + else + Column := Column + IntToStr(subtype); + column := Column + Format(' SEGMENT SIZE %d', + [qryTables.FieldByName('RDB$SEGMENT_LENGTH').AsInteger]); + end; + + { International character sets } + if ((FieldType in [blr_text, blr_varying]) or + (FieldType = blr_blob)) and + (not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull) and + (qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger <> 0) then + begin + { Override rdb$fields id with relation_fields if present } + + CharSetId := 0; + if not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull then + CharSetId := qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger; + + Column := Column + GetCharacterSets(CharSetId, 0, false); + intchar := 1; + end; + end; + + { Handle defaults for columns } + { Originally This called PrintMetadataTextBlob, + should no longer need } + if not qryTables.FieldByName('RDB$DEFAULT_SOURCE').IsNull then + Column := Column + ' ' + qryTables.FieldByName('RDB$DEFAULT_SOURCE').AsString; + + + { The null flag is either 1 or null (for nullable) . if there is + a constraint name, print that too. Domains cannot have named + constraints. The column name is in rdb$trigger_name in + rdb$check_constraints. We hope we get at most one row back. } + + if qryTables.FieldByName('RDB$NULL_FLAG').AsInteger = 1 then + begin + qryConstraints.Params.ByName('FIELDNAME').AsString := qryTables.FieldByName('RDB$FIELD_NAME').AsString; + qryConstraints.Params.ByName('RELATIONNAME').AsString := qryTables.FieldByName('RDB$RELATION_NAME').AsString; + qryConstraints.ExecQuery; + + while not qryConstraints.Eof do + begin + if Pos('INTEG', qryConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then + Column := Column + Format(' CONSTRAINT %s', + [ QuoteIdentifier( FDatabase.SQLDialect, + qryConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString)]); + qryConstraints.Next; + end; + qryConstraints.Close; + Column := Column + ' NOT NULL'; + end; + + if ((FieldType in [blr_text, blr_varying]) or + (FieldType = blr_blob)) and + (not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull) and + (qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger <> 0) and + (intchar <> 0) then + begin + Collation := 0; + if not qryTables.FieldByName('RDB$COLLATION_ID1').IsNull then + Collation := qryTables.FieldByName('RDB$COLLATION_ID1').AsInteger + else + if not qryTables.FieldByName('RDB$COLLATION_ID').IsNull then + Collation := qryTables.FieldByName('RDB$COLLATION_ID').AsInteger; + + CharSetId := 0; + if not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull then + CharSetId := qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger; + + if Collation <> 0 then + Column := Column + GetCharacterSets(CharSetId, Collation, true); + end; + end; + qryTables.Next; + if not qryTables.Eof then + Column := Column + ','; + FMetaData.Add(Column); + end; + + { Do primary and unique keys only. references come later } + + qryRelConstraints.Params.ByName('relationname').AsString := RelationName; + qryRelConstraints.ExecQuery; + while not qryRelConstraints.Eof do + begin + Constraint := ''; + FMetaData.Strings[FMetaData.Count - 1] := FMetaData.Strings[FMetaData.Count - 1] + ','; + { If the name of the constraint is not INTEG..., print it } + if Pos('INTEG', qryRelConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then + Constraint := Constraint + 'CONSTRAINT ' + + QuoteIdentifier(FDatabase.SQLDialect, + qryRelConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString); + + + if Pos('PRIMARY', qryRelConstraints.FieldByName('RDB$CONSTRAINT_TYPE').AsString) = 1 then + begin + FMetaData.Add(Constraint + Format(' PRIMARY KEY (%s)', + [GetIndexSegments(qryRelConstraints.FieldByName('RDB$INDEX_NAME').AsString)])); + end + else + if Pos('UNIQUE', qryRelConstraints.FieldByName('RDB$CONSTRAINT_TYPE').AsString) = 1 then + begin + FMetaData.Add(Constraint + Format(' UNIQUE (%s)', + [GetIndexSegments(qryRelConstraints.FieldByName('RDB$INDEX_NAME').AsString)])); + end; + qryRelConstraints.Next; + end; + if ValidRelation then + FMetaData.Add(')' + Term); + finally + qryTables.Free; + qryPrecision.Free; + qryConstraints.Free; + qryRelConstraints.Free; + end; +end; + +{ ExtractListView + Functional description + Show text of the specified view. + Use a SQL query to get the info and print it. + Note: This should also contain check option } + +procedure TIBExtract.ExtractListView(ViewName: String); +const + ViewsSQL = 'SELECT * FROM RDB$RELATIONS REL ' + + ' WHERE ' + + ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' + + ' NOT REL.RDB$VIEW_BLR IS NULL AND ' + + ' REL.RDB$RELATION_NAME = :VIEWNAME AND ' + + ' REL.RDB$FLAGS = 1 ' + + 'ORDER BY REL.RDB$RELATION_ID '; + + ColumnsSQL = 'SELECT * FROM RDB$RELATION_FIELDS RFR ' + + 'WHERE ' + + ' RFR.RDB$RELATION_NAME = :RELATIONNAME ' + + 'ORDER BY RFR.RDB$FIELD_POSITION '; + +var + qryViews, qryColumns : TIBSQL; + RelationName, ColList : String; +begin + qryViews := TIBSQL.Create(FDatabase); + qryColumns := TIBSQL.Create(FDatabase); + try + qryViews.SQL.Add(ViewsSQL); + qryViews.Params.ByName('viewname').AsString := ViewName; + qryViews.ExecQuery; + while not qryViews.Eof do + begin + FMetaData.Add(''); + RelationName := QuoteIdentifier(FDatabase.SQLDialect, + qryViews.FieldByName('RDB$RELATION_NAME').AsString); + FMetaData.Add(Format('%s/* View: %s, Owner: %s */%s', [ + RelationName, + Trim(qryViews.FieldByName('RDB$OWNER_NAME').AsString)])); + FMetaData.Add(''); + FMetaData.Add(Format('CREATE VIEW %s (', [RelationName])); + + { Get Column List} + qryColumns.SQL.Add(ColumnsSQL); + qryColumns.Params.ByName('relationname').AsString := RelationName; + qryColumns.ExecQuery; + while not qryColumns.Eof do + begin + ColList := ColList + QuoteIdentifier(FDatabase.SQLDialect, + qryColumns.FieldByName('RDB$FIELD_NAME').AsString); + qryColumns.Next; + if not qryColumns.Eof then + ColList := ColList + ', '; + end; + FMetaData.Add(ColList + ') AS'); + FMetaData.Add(qryViews.FieldByName('RDB$VIEW_SOURCE').AsString + Term); + qryViews.Next; + end; + finally + qryViews.Free; + qryColumns.Free; + end; +end; + +function TIBExtract.GetCharacterSets(CharSetId, Collation: integer; + CollateOnly: Boolean): String; +var + CharSetSQL : TIBSQL; + DidActivate : Boolean; +begin + if not FTransaction.Active then + begin + FTransaction.StartTransaction; + DidActivate := true; + end + else + DidActivate := false; + CharSetSQL := TIBSQL.Create(FDatabase); + try + if Collation <> 0 then + begin + CharSetSQL.SQL.Add(CollationSQL); + CharSetSQL.Params.ByName('Char_Set_Id').AsInteger := CharSetId; + CharSetSQL.Params.ByName('Collation').AsInteger := Collation; + CharSetSQL.ExecQuery; + + { Is specified collation the default collation for character set? } + if (Trim(CharSetSQL.FieldByName('RDB$DEFAULT_COLLATE_NAME').AsString) = + Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString)) then + begin + if not CollateOnly then + Result := ' CHARACTER SET ' + Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString); + end + else + if CollateOnly then + Result := ' COLLATE ' + Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString) + else + Result := ' CHARACTER SET ' + + Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString) + + ' COLLATE ' + + Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString); + end + else + if CharSetId <> 0 then + begin + CharSetSQL.SQL.Add(NonCollationSQL); + CharSetSQL.Params.ByName('CharSetId').AsShort := CharSetId; + CharSetSQL.ExecQuery; + Result := ' CHARACTER SET ' + Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString); + end; + finally + CharSetSQL.Free; + end; + if DidActivate then + FTransaction.Commit; +end; + +function TIBExtract.GetDatabase: TIBDatabase; +begin + result := FDatabase; +end; + + { GetIndexSegments + Functional description + returns the list of columns in an index. } + +function TIBExtract.GetIndexSegments(IndexName: String): String; +const + IndexNamesSQL = + 'SELECT * FROM RDB$INDEX_SEGMENTS SEG ' + + 'WHERE SEG.RDB$INDEX_NAME = :INDEXNAME ' + + 'ORDER BY SEG.RDB$FIELD_POSITION'; + +var + qryColNames : TIBSQL; +begin +{ Query to get column names } + Result := ''; + qryColNames := TIBSQL.Create(FDatabase); + try + qryColNames.SQL.Add(IndexNamesSQL); + qryColNames.Params.ByName('IndexName').AsString := IndexName; + qryColNames.ExecQuery; + while not qryColNames.Eof do + begin + { Place a comma and a blank between each segment column name } + + Result := Result + QuoteIdentifier(FDatabase.SQLDialect, + qryColNames.FieldByName('RDB$FIELD_NAME').AsString); + qryColNames.Next; + if not qryColNames.Eof then + Result := Result + ', '; + end; + finally + qryColNames.Free; + end; +end; + +function TIBExtract.GetTransaction: TIBTransaction; +begin + Result := FTransaction; +end; + +{ ListAllGrants + Functional description + Print the permissions on all user tables. + Get separate permissions on table/views and then procedures } + +procedure TIBExtract.ListGrants; +const + SecuritySQL = 'SELECT * FROM RDB$RELATIONS ' + + 'WHERE ' + + ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + + ' RDB$SECURITY_CLASS STARTING WITH ''SQL$'' ' + + 'ORDER BY RDB$RELATION_NAME'; + + ProcedureSQL = 'select * from RDB$PROCEDURES ' + + 'Order BY RDB$PROCEDURE_NAME'; + +var + qryRoles : TIBSQL; + RelationName : String; +begin + ListRoles; + qryRoles := TIBSQL.Create(FDatabase); + try + { This version of cursor gets only sql tables identified by security class + and misses views, getting only null view_source } + + FMetaData.Add(''); + FMetaData.Add('/* Grant permissions for this database */'); + FMetaData.Add(''); + + try + qryRoles.SQL.Text := SecuritySQL; + qryRoles.ExecQuery; + while not qryRoles.Eof do + begin + RelationName := Trim(qryRoles.FieldByName('rdb$relation_Name').AsString); + ShowGrants(RelationName, Term); + qryRoles.Next; + end; + finally + qryRoles.Close; + end; + + ShowGrantRoles(Term); + + qryRoles.SQL.Text := ProcedureSQL; + qryRoles.ExecQuery; + try + while not qryRoles.Eof do + begin + ShowGrants(Trim(qryRoles.FieldByName('RDB$PROCEDURE_NAME').AsString), Term); + qryRoles.Next; + end; + finally + qryRoles.Close; + end; + finally + qryRoles.Free; + end; +end; + +{ ListAllProcs + Functional description + Shows text of a stored procedure given a name. + or lists procedures if no argument. + Since procedures may reference each other, we will create all + dummy procedures of the correct name, then alter these to their + correct form. + Add the parameter names when these procedures are created. + + procname -- Name of procedure to investigate } + +procedure TIBExtract.ListProcs(ProcedureName : String); +const + CreateProcedureStr1 = 'CREATE PROCEDURE %s '; + CreateProcedureStr2 = 'BEGIN EXIT; END %s%s'; + ProcedureSQL = + 'SELECT * FROM RDB$PROCEDURES ' + + 'ORDER BY RDB$PROCEDURE_NAME'; + + ProcedureNameSQL = + 'SELECT * FROM RDB$PROCEDURES ' + + 'WHERE RDB$PROCEDURE_NAME = :ProcedureName ' + + 'ORDER BY RDB$PROCEDURE_NAME'; + +var + qryProcedures : TIBSQL; + ProcName : String; + SList : TStrings; + Header : Boolean; +begin + + Header := true; + qryProcedures := TIBSQL.Create(FDatabase); + SList := TStringList.Create; + try +{ First the dummy procedures + create the procedures with their parameters } + if ProcedureName = '' then + qryProcedures.SQL.Text := ProcedureSQL + else + begin + qryProcedures.SQL.Text := ProcedureNameSQL; + qryProcedures.Params.ByName('ProcedureName').AsString := ProcedureName; + end; + qryProcedures.ExecQuery; + while not qryProcedures.Eof do + begin + if Header then + begin + FMetaData.Add('COMMIT WORK;'); + FMetaData.Add('SET AUTODDL OFF;'); + FMetaData.Add(Format('SET TERM %s %s', [ProcTerm, Term])); + FMetaData.Add(Format('%s/* Stored procedures */%s', [NEWLINE, NEWLINE])); + Header := false; + end; + ProcName := Trim(qryProcedures.FieldByName('RDB$PROCEDURE_NAME').AsString); + FMetaData.Add(Format(CreateProcedureStr1, [QuoteIdentifier(FDatabase.SQLDialect, + ProcName)])); + GetProcedureArgs(ProcName); + FMetaData.Add(Format(CreateProcedureStr2, [ProcTerm, NEWLINE])); + qryProcedures.Next; + end; + + qryProcedures.Close; + qryProcedures.ExecQuery; + while not qryProcedures.Eof do + begin + SList.Clear; + ProcName := Trim(qryProcedures.FieldByName('RDB$PROCEDURE_NAME').AsString); + FMetaData.Add(Format('%sALTER PROCEDURE %s ', [NEWLINE, + QuoteIdentifier(FDatabase.SQLDialect, ProcName)])); + GetProcedureArgs(ProcName); + + if not qryProcedures.FieldByName('RDB$PROCEDURE_SOURCE').IsNull then + SList.Text := SList.Text + qryProcedures.FieldByName('RDB$PROCEDURE_SOURCE').AsString; + SList.Add(Format(' %s%s', [ProcTerm, NEWLINE])); + FMetaData.AddStrings(SList); + qryProcedures.Next; + end; + +{ This query gets the procedure name and the source. We then nest a query + to retrieve the parameters. Alter is used, because the procedures are + already there} + + if not Header then + begin + FMetaData.Add(Format('SET TERM %s %s', [Term, ProcTerm])); + FMetaData.Add('COMMIT WORK;'); + FMetaData.Add('SET AUTODDL ON;'); + end; + finally + qryProcedures.Free; + SList.Free; + end; +end; + +{ ListAllTables + Functional description + Extract the names of all user tables from + rdb$relations. Filter SQL tables by + security class after we fetch them + Parameters: flag -- 0, get all tables } + +procedure TIBExtract.ListAllTables(flag: Boolean); +const + TableSQL = + 'SELECT * FROM RDB$RELATIONS ' + + 'WHERE ' + + ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + + ' RDB$VIEW_BLR IS NULL ' + + 'ORDER BY RDB$RELATION_NAME'; + +var + qryTables : TIBSQL; +begin +{ This version of cursor gets only sql tables identified by security class + and misses views, getting only null view_source } + + qryTables := TIBSQL.Create(FDatabase); + try + qryTables.SQL.Text := TableSQL; + qryTables.ExecQuery; + while not qryTables.Eof do + begin + if ((qryTables.FieldByName('RDB$FLAGS').AsInteger <> 1) and + (not Flag)) then + continue; + if flag or (Pos('SQL$', qryTables.FieldByName('RDB$SECURITY_CLASS').AsString) <> 1) then + ExtractListTable(qryTables.FieldByName('RDB$RELATION_NAME').AsString, + '', false); + + qryTables.Next; + end; + finally + qryTables.Free; + end; +end; + +{ ListAllTriggers + Functional description + Lists triggers in general on non-system + tables with sql source only. } + +procedure TIBExtract.ListTriggers(ObjectName : String; ExtractType : TExtractType); +const +{ Query gets the trigger info for non-system triggers with + source that are not part of an SQL constraint } + + TriggerSQL = + 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$RELATIONS REL ON ' + + ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' + + 'WHERE ' + + ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' + + ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' + + ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' + + 'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' + + ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME'; + + TriggerNameSQL = + 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$RELATIONS REL ON ' + + ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' + + 'WHERE ' + + ' REL.RDB$RELATION_NAME = :TableName AND ' + + ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' + + ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' + + ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' + + 'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' + + ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME'; + + TriggerByNameSQL = + 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$RELATIONS REL ON ' + + ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' + + 'WHERE ' + + ' TRG.RDB$TRIGGER_NAME = :TriggerName AND ' + + ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' + + ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' + + ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' + + 'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' + + ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME'; + +var + Header : Boolean; + TriggerName, RelationName, InActive: String; + qryTriggers : TIBSQL; + SList : TStrings; +begin + Header := true; + SList := TStringList.Create; + qryTriggers := TIBSQL.Create(FDatabase); + try + if ObjectName = '' then + qryTriggers.SQL.Text := TriggerSQL + else + begin + if ExtractType = etTable then + begin + qryTriggers.SQL.Text := TriggerNameSQL; + qryTriggers.Params.ByName('TableName').AsString := ObjectName; + end + else + begin + qryTriggers.SQL.Text := TriggerByNameSQL; + qryTriggers.Params.ByName('TriggerName').AsString := ObjectName; + end; + end; + qryTriggers.ExecQuery; + while not qryTriggers.Eof do + begin + SList.Clear; + if Header then + begin + FMetaData.Add(Format('SET TERM %s %s%s', [Procterm, Term, NEWLINE])); + FMetaData.Add(Format('%s/* Triggers only will work for SQL triggers */%s', + [NEWLINE, NEWLINE])); + Header := false; + end; + TriggerName := qryTriggers.FieldByName('RDB$TRIGGER_NAME').AsString; + RelationName := qryTriggers.FieldByName('RDB$RELATION_NAME').AsString; + if qryTriggers.FieldByName('RDB$TRIGGER_INACTIVE').IsNull then + InActive := 'INACTIVE' + else + if qryTriggers.FieldByName('RDB$TRIGGER_INACTIVE').AsInteger = 1 then + InActive := 'INACTIVE' + else + InActive := 'ACTIVE'; + + if qryTriggers.FieldByName('RDB$FLAGS').AsInteger <> 1 then + SList.Add('/* '); + + SList.Add(Format('CREATE TRIGGER %s FOR %s %s%s %s POSITION %d', + [QuoteIdentifier(FDatabase.SQLDialect, TriggerName), + QuoteIdentifier(FDatabase.SQLDialect, RelationName), + NEWLINE, InActive, + TriggerTypes[qryTriggers.FieldByName('RDB$TRIGGER_TYPE').AsInteger], + qryTriggers.FieldByName('RDB$TRIGGER_SEQUENCE').AsInteger])); + if not qryTriggers.FieldByName('RDB$TRIGGER_SOURCE').IsNull then + SList.Text := SList.Text + + qryTriggers.FieldByName('RDB$TRIGGER_SOURCE').AsString; + SList.Add(' ' + ProcTerm + NEWLINE); + if qryTriggers.FieldByName('RDB$FLAGS').AsInteger <> 1 then + SList.Add(' */'); + FMetaData.AddStrings(SList); + qryTriggers.Next; + end; + if not Header then + begin + FMetaData.Add('COMMIT WORK ' + ProcTerm); + FMetaData.Add('SET TERM ' + Term + ProcTerm); + end; + finally + qryTriggers.Free; + SList.Free; + end; +end; + +{ ListCheck + Functional description + List check constraints for all objects to allow forward references } + +procedure TIBExtract.ListCheck(ObjectName : String; ExtractType : TExtractType); +const +{ Query gets the check clauses for triggers stored for check constraints } + CheckSQL = + 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' + + ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' + + 'WHERE ' + + ' TRG.RDB$TRIGGER_TYPE = 1 AND ' + + ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' + + ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' + + 'ORDER BY CHK.RDB$CONSTRAINT_NAME'; + + CheckNameSQL = + 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' + + ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' + + 'WHERE ' + + ' TRG.RDB$RELATION_NAME = :TableName AND ' + + ' TRG.RDB$TRIGGER_TYPE = 1 AND ' + + ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' + + ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' + + 'ORDER BY CHK.RDB$CONSTRAINT_NAME'; + + CheckByNameSQL = + 'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' + + ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' + + 'WHERE ' + + ' TRG.RDB$TRIGGER_NAME = :TriggerName AND ' + + ' TRG.RDB$TRIGGER_TYPE = 1 AND ' + + ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' + + ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' + + 'ORDER BY CHK.RDB$CONSTRAINT_NAME'; + +var + qryChecks : TIBSQL; + SList : TStrings; + RelationName : String; +begin + qryChecks := TIBSQL.Create(FDatabase); + SList := TStringList.Create; + try + if ObjectName = '' then + qryChecks.SQL.Text := CheckSQL + else + if ExtractType = etTable then + begin + qryChecks.SQL.Text := CheckNameSQL; + qryChecks.Params.ByName('TableName').AsString := ObjectName; + end + else + begin + qryChecks.SQL.Text := CheckByNameSQL; + qryChecks.Params.ByName('TriggerName').AsString := ObjectName; + end; + qryChecks.ExecQuery; + while not qryChecks.Eof do + begin + SList.Clear; + RelationName := qryChecks.FieldByName('RDB$RELATION_NAME').AsString; + SList.Add(Format('ALTER TABLE %s ADD', + [QuoteIdentifier(FDatabase.SQLDialect, RelationName)])); + if Pos('INTEG', qryChecks.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then + SList.Add(Format('%sCONSTRAINT %s ', [TAB, + QuoteIdentifier(FDatabase.SQLDialect, qryChecks.FieldByName('RDB$CONSTRAINT_NAME').AsString)])); + + if not qryChecks.FieldByName('RDB$TRIGGER_SOURCE').IsNull then + SList.Text := SList.Text + qryChecks.FieldByName('RDB$TRIGGER_SOURCE').AsString; + + SList.Strings[SList.Count - 1] := SList.Strings[SList.Count - 1] + (Term) + NEWLINE; + FMetaData.AddStrings(SList); + qryChecks.Next; + end; + finally + qryChecks.Free; + SList.Free; + end; +end; + +{ ListCreateDb + Functional description + Print the create database command if requested. At least put + the page size in a comment with the extracted db name } + +procedure TIBExtract.ListCreateDb(TargetDb : String); +const + CharInfoSQL = + 'SELECT * FROM RDB$DATABASE DBP ' + + 'WHERE NOT DBP.RDB$CHARACTER_SET_NAME IS NULL ' + + ' AND DBP.RDB$CHARACTER_SET_NAME != '' '''; + + FilesSQL = + 'select * from RDB$FILES ' + + 'order BY RDB$SHADOW_NUMBER, RDB$FILE_SEQUENCE'; + + LogsSQL = + 'SELECT * FROM RDB$LOG_FILES ' + + 'ORDER BY RDB$FILE_FLAGS, RDB$FILE_SEQUENCE'; + +var + NoDb, First, FirstFile, HasWal, SetUsed : Boolean; + Buffer : String; + qryDB : TIBSQL; + FileFlags, FileLength, FileSequence, FileStart : Integer; + + function GetLongDatabaseInfo(DatabaseInfoCommand: Integer): LongInt; + var + local_buffer: array[0..IBLocalBufferLength - 1] of Char; + length: Integer; + _DatabaseInfoCommand: Char; + begin + _DatabaseInfoCommand := Char(DatabaseInfoCommand); + FDatabaseInfo.Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @_DatabaseInfoCommand, + IBLocalBufferLength, local_buffer), True); + length := isc_vax_integer(@local_buffer[1], 2); + result := isc_vax_integer(@local_buffer[3], length); + end; + +begin + NoDb := FALSE; + First := TRUE; + FirstFile := TRUE; + HasWal := FALSE; + SetUsed := FALSE; + Buffer := ''; + if TargetDb = '' then + begin + Buffer := '/* '; + TargetDb := FDatabase.DatabaseName; + NoDb := true; + end; + Buffer := Buffer + 'CREATE DATABASE ' + QuotedStr(TargetDb) + ' PAGE_SIZE ' + + IntToStr(FDatabaseInfo.PageSize) + NEWLINE; + FMetaData.Add(Buffer); + Buffer := ''; + + qryDB := TIBSQL.Create(FDatabase); + try + qryDB.SQL.Text := CharInfoSQL; + qryDB.ExecQuery; + + Buffer := Format(' DEFAULT CHARACTER SET %s', + [qryDB.FieldByName('RDB$CHARACTER_SET_NAME').AsString]); + if NoDB then + Buffer := Buffer + ' */' + else + Buffer := Buffer + Term; + FMetaData.Add(Buffer); + qryDB.Close; + {List secondary files and shadows as + alter db and create shadow in comment} + qryDB.SQL.Text := FilesSQL; + qryDB.ExecQuery; + while not qryDB.Eof do + begin + if First then + begin + FMetaData.Add(NEWLINE + '/* Add secondary files in comments '); + First := false; + end; //end_if + + if qryDB.FieldByName('RDB$FILE_FLAGS').IsNull then + FileFlags := 0 + else + FileFlags := qryDB.FieldByName('RDB$FILE_FLAGS').AsInteger; + if qryDB.FieldByName('RDB$FILE_LENGTH').IsNull then + FileLength := 0 + else + FileLength := qryDB.FieldByName('RDB$FILE_LENGTH').AsInteger; + if qryDB.FieldByName('RDB$FILE_SEQUENCE').IsNull then + FileSequence := 0 + else + FileSequence := qryDB.FieldByName('RDB$FILE_SEQUENCE').AsInteger; + if qryDB.FieldByName('RDB$FILE_START').IsNull then + FileStart := 0 + else + FileStart := qryDB.FieldByName('RDB$FILE_START').AsInteger; + + { Pure secondary files } + if FileFlags = 0 then + begin + Buffer := Format('%sALTER DATABASE ADD FILE ''%s''', + [NEWLINE, qryDB.FieldByName('RDB$FILE_NAME').AsString]); + if FileStart <> 0 then + Buffer := Buffer + Format(' STARTING %d', [FileStart]); + if FileLength <> 0 then + Buffer := Buffer + Format(' LENGTH %d', [FileLength]); + FMetaData.Add(Buffer); + end; //end_if + if (FileFlags and FILE_cache) <> 0 then + FMetaData.Add(Format('%sALTER DATABASE ADD CACHE ''%s'' LENGTH %d', + [NEWLINE, qryDB.FieldByName('RDB$FILE_NAME').AsString, FileLength])); + + Buffer := ''; + if (FileFlags and FILE_shadow) <> 0 then + begin + if FileSequence <> 0 then + Buffer := Format('%sFILE ''%s''', + [TAB, qryDB.FieldByName('RDB$FILE_NAME').AsString]) + else + begin + Buffer := Format('%sCREATE SHADOW %d ''%s'' ', + [NEWLINE, qryDB.FieldByName('RDB$SHADOW_NUMBER').AsInteger, + qryDB.FieldByName('RDB$FILE_NAME').AsString]); + if (FileFlags and FILE_inactive) <> 0 then + Buffer := Buffer + 'INACTIVE '; + if (FileFlags and FILE_manual) <> 0 then + Buffer := Buffer + 'MANUAL ' + else + Buffer := Buffer + 'AUTO '; + if (FileFlags and FILE_conditional) <> 0 then + Buffer := Buffer + 'CONDITIONAL '; + end; //end_else + if FileLength <> 0 then + Buffer := Buffer + Format('LENGTH %d ', [FileLength]); + if FileStart <> 0 then + Buffer := Buffer + Format('STARTING %d ', [FileStart]); + FMetaData.Add(Buffer); + end; //end_if + qryDB.Next; + end; + qryDB.Close; + + qryDB.SQL.Text := LogsSQL; + qryDB.ExecQuery; + while not qryDB.Eof do + begin + + if qryDB.FieldByName('RDB$FILE_FLAGS').IsNull then + FileFlags := 0 + else + FileFlags := qryDB.FieldByName('RDB$FILE_FLAGS').AsInteger; + if qryDB.FieldByName('RDB$FILE_LENGTH').IsNull then + FileLength := 0 + else + FileLength := qryDB.FieldByName('RDB$FILE_LENGTH').AsInteger; + + Buffer := ''; + HasWal := true; + if First then + begin + if NoDB then + Buffer := '/* '; + Buffer := Buffer + NEWLINE + 'ALTER DATABASE ADD '; + First := false; + end; //end_if + if FirstFile then + Buffer := Buffer + 'LOGFILE '; + { Overflow files also have the serial bit set } + if (FileFlags and LOG_default) = 0 then + begin + if (FileFlags and LOG_overflow) <> 0 then + Buffer := Buffer + Format(')%s OVERFLOW ''%s''', + [NEWLINE, qryDB.FieldByName('RDB$FILE_NAME').AsString]) + else + if (FileFlags and LOG_serial) <> 0 then + Buffer := Buffer + Format('%s BASE_NAME ''%s''', + [NEWLINE, qryDB.FieldByName('RDB$FILE_NAME').AsString]) + { Since we are fetching order by FILE_FLAGS, the LOG_0verflow will + be last. It will only appear if there were named round robin, + so we must close the parens first } + + { We have round robin and overflow file specifications } + else + begin + if FirstFile then + Buffer := Buffer + '(' + else + Buffer := Buffer + Format(',%s ', [NEWLINE]); + FirstFile := false; + + Buffer := Buffer + Format('''%s''', [qryDB.FieldByName('RDB$FILE_NAME').AsString]); + end; //end_else + end; + { Any file can have a length } + if FileLength <> 0 then + Buffer := Buffer + Format(' SIZE %d ', [FileLength]); + FMetaData.Add(Buffer); + qryDB.Next; + end; + qryDB.Close; + Buffer := ''; + if HasWal then + begin + Buffer := Buffer + PrintSet(SetUsed); + Buffer := Buffer + Format('NUM_LOG_BUFFERS = %d', + [GetLongDatabaseInfo(isc_info_num_wal_buffers)]); + Buffer := Buffer + PrintSet(SetUsed); + Buffer := Buffer + Format('LOG_BUFFER_SIZE = %d', + [GetLongDatabaseInfo(isc_info_wal_buffer_size)]); + Buffer := Buffer + PrintSet(SetUsed); + Buffer := Buffer + Format('GROUP_COMMIT_WAIT_TIME = %d', + [GetLongDatabaseInfo(isc_info_wal_grpc_wait_usecs)]); + Buffer := Buffer + PrintSet(SetUsed); + Buffer := Buffer + Format('CHECK_POINT_LENGTH = %d', + [GetLongDatabaseInfo(isc_info_wal_ckpt_length)]); + FMetaData.Add(Buffer); + + end; + if not First then + begin + if NoDB then + FMetaData.Add(Format('%s */%s', [NEWLINE, NEWLINE])) + else + FMetaData.Add(Format('%s%s%s', [Term, NEWLINE, NEWLINE])); + end; + finally + qryDB.Free; + end; + +(* +*) +end; + +{ ListDomainTable + Functional description + List domains as identified by fields with any constraints on them + for the named table + + Parameters: table_name == only extract domains for this table } + +procedure TIBExtract.ListDomains(ObjectName: String; ExtractType : TExtractType); +const + DomainSQL = + 'SELECT distinct fld.* FROM RDB$FIELDS FLD JOIN RDB$RELATION_FIELDS RFR ON ' + + ' RFR.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' + + 'WHERE RFR.RDB$RELATION_NAME = :TABLE_NAME ' + + 'ORDER BY FLD.RDB$FIELD_NAME'; + + DomainByNameSQL = + 'SELECT * FROM RDB$FIELDS FLD ' + + 'WHERE FLD.RDB$FIELD_NAME = :DomainName ' + + 'ORDER BY FLD.RDB$FIELD_NAME'; + + AllDomainSQL = + 'select * from RDB$FIELDS ' + + 'where RDB$SYSTEM_FLAG <> 1 ' + + 'order BY RDB$FIELD_NAME'; + +var + First : Boolean; + qryDomains : TIBSQL; + FieldName, Line : String; + + function FormatDomainStr : String; + var + i, SubType : Integer; + PrecisionKnown : Boolean; + begin + Result := ''; + for i := Low(ColumnTypes) to High(ColumnTypes) do + if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = ColumnTypes[i].SQLType then + begin + PrecisionKnown := FALSE; + if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then + begin + if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_short, blr_long, blr_int64] then + begin + { We are ODS >= 10 and could be any Dialect } + if (FDatabaseInfo.DBSQLDialect >= 3) and + (not qryDomains.FieldByName('RDB$FIELD_PRECISION').IsNull) and + (qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and + (qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then + begin + Result := Result + Format('%s(%d, %d)', [ + IntegralSubtypes [qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger], + qryDomains.FieldByName('RDB$FIELD_PRECISION').AsInteger, + -1 * qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger]); + PrecisionKnown := true; + end; + end; + end; + if PrecisionKnown = false then + begin + { Take a stab at numerics and decimals } + if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_short) and + (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + Result := Result + Format('NUMERIC(4, %d)', + [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] ) + else + if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_long) and + (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + Result := Result + Format('NUMERIC(9, %d)', + [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] ) + else + if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_double) and + (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + Result := Result + Format('NUMERIC(15, %d)', + [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] ) + else + Result := Result + ColumnTypes[i].TypeName; + end; + break; + end; + + if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_blob then + begin + subtype := qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger; + Result := Result + ' SUB_TYPE '; + if (subtype > 0) and (subtype <= MAXSUBTYPES) then + Result := Result + SubTypes[subtype] + else + Result := Result + Format('%d', [subtype]); + Result := Result + Format(' SEGMENT SIZE %d', [qryDomains.FieldByName('RDB$SEGMENT_LENGTH').AsInteger]); + end //end_if + else + if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying]) and + (not qryDomains.FieldByName('RDB$CHARACTER_LENGTH').IsNull) then + Result := Result + Format('(%d)', [qryDomains.FieldByName('RDB$FIELD_LENGTH').AsInteger]); + + { since the character set is part of the field type, display that + information now. } + if not qryDomains.FieldByName('RDB$CHARACTER_SET_ID').IsNull then + Result := Result + GetCharacterSets(qryDomains.FieldByName('RDB$CHARACTER_SET_ID').AsInteger, + 0, FALSE); + if not qryDomains.FieldByName('RDB$DIMENSIONS').IsNull then + Result := GetArrayField(FieldName); + + if not qryDomains.FieldByName('RDB$DEFAULT_SOURCE').IsNull then + Result := Result + Format('%s%s %s', [NEWLINE, TAB, + qryDomains.FieldByName('RDB$DEFAULT_SOURCE').AsString]); + + if not qryDomains.FieldByName('RDB$VALIDATION_SOURCE').IsNull then + if Pos('CHECK', AnsiUpperCase(qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString)) = 1 then + Result := Result + Format('%s%s %s', [NEWLINE, TAB, + qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString]) + else + Result := Result + Format('%s%s /* %s */', [NEWLINE, TAB, + qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString]); + + if qryDomains.FieldByName('RDB$NULL_FLAG').AsInteger = 1 then + Result := Result + ' NOT NULL'; + + { Show the collation order if one has been specified. If the collation + order is the default for the character set being used, then no collation + order will be shown ( because it isn't needed ). + + If the collation id is 0, then the default for the character set is + being used so there is no need to retrieve the collation information.} + + if (not qryDomains.FieldByName('RDB$COLLATION_ID').IsNull) and + (qryDomains.FieldByName('RDB$COLLATION_ID').AsInteger <> 0) then + Result := Result + GetCharacterSets(qryDomains.FieldByName('RDB$CHARACTER_SET_ID').AsInteger, + qryDomains.FieldByName('RDB$COLLATION_ID').AsInteger, true); + end; + +begin + First := true; + qryDomains := TIBSQL.Create(FDatabase); + try + if ObjectName <> '' then + begin + if ExtractType = etTable then + begin + qryDomains.SQL.Text := DomainSQL; + qryDomains.Params.ByName('table_name').AsString := ObjectName; + end + else + begin + qryDomains.SQL.Text := DomainByNameSQL; + qryDomains.Params.ByName('DomainName').AsString := ObjectName; + end; + end + else + qryDomains.SQL.Text := AllDomainSQL; + + qryDomains.ExecQuery; + while not qryDomains.Eof do + begin + FieldName := qryDomains.FieldByName('RDB$FIELD_NAME').AsString; + { Skip over artifical domains } + if (Pos('RDB$',FieldName) = 1) and + (FieldName[5] in ['0'..'9']) and + (qryDomains.FieldByName('RDB$SYSTEM_FLAG').AsInteger <> 1) then + begin + qryDomains.Next; + continue; + end; + + if First then + begin + FMetaData.Add('/* Domain definitions */'); + First := false; + end; + + Line := Format('CREATE DOMAIN %s AS ', [FieldName]); + Line := Line + FormatDomainStr + Term; + FMetaData.Add(Line); + qryDomains.Next; + end; + finally + qryDomains.Free; + end; +end; + +{ ListException + Functional description + List all exceptions defined in the database + + Parameters: none } + +procedure TIBExtract.ListException(ExceptionName : String = ''); +const + ExceptionSQL = + 'select * from RDB$EXCEPTIONS ' + + 'ORDER BY RDB$EXCEPTION_NAME'; + + ExceptionNameSQL = + 'select * from RDB$EXCEPTIONS ' + + 'WHERE RDB$EXCEPTION_NAME = :ExceptionName ' + + 'ORDER BY RDB$EXCEPTION_NAME'; + +var + First : Boolean; + qryException : TIBSQL; +begin + First := true; + qryException := TIBSQL.Create(FDatabase); + try + if ExceptionName = '' then + qryException.SQL.Text := ExceptionSQL + else + begin + qryException.SQL.Text := ExceptionNameSQL; + qryException.Params.ByName('ExceptionName').AsString := ExceptionName; + end; + + qryException.ExecQuery; + while not qryException.Eof do + begin + if First then + begin + FMetaData.Add(''); + FMetaData.Add('/* Exceptions */'); + FMetaData.Add(''); + First := false; + end; //end_if + + FMetaData.Add(Format('CREATE EXCEPTION %s %s%s', + [QuoteIdentifier(FDatabase.SQLDialect, qryException.FieldByName('RDB$EXCEPTION_NAME').AsString), + QuotedStr(qryException.FieldByName('RDB$MESSAGE').AsString), Term])); + qryException.Next; + end; + finally + qryException.Free; + end; +end; + +{ ListFilters + + Functional description + List all blob filters + + Parameters: none + Results in + DECLARE FILTER INPUT_TYPE OUTPUT_TYPE + ENTRY_POINT MODULE_NAME } + +procedure TIBExtract.ListFilters(FilterName : String = ''); +const + FiltersSQL = + 'SELECT * FROM RDB$FILTERS ' + + 'ORDER BY RDB$FUNCTION_NAME'; + FilterNameSQL = + 'SELECT * FROM RDB$FILTERS ' + + 'WHERE RDB$FUNCTION_NAME = :FunctionName ' + + 'ORDER BY RDB$FUNCTION_NAME'; + +var + First : Boolean; + qryFilters : TIBSQL; +begin + First := true; + qryFilters := TIBSQL.Create(FDatabase); + try + if FilterName = '' then + qryFilters.SQL.Text := FiltersSQL + else + begin + qryFilters.SQL.Text := FilterNameSQL; + qryFilters.Params.ByName('FunctionName').AsString := FilterName; + end; + qryFilters.ExecQuery; + while not qryFilters.Eof do + begin + if First then + begin + FMetaData.Add(''); + FMetaData.Add('/* BLOB Filter declarations */'); + FMetaData.Add(''); + First := false; + end; //end_if + + FMetaData.Add(Format('DECLARE FILTER %s INPUT_TYPE %d OUTPUT_TYPE %d', + [qryFilters.FieldByName('RDB$FUNCTION_NAME').AsString, + qryFilters.FieldByName('RDB$INPUT_SUB_TYPE').AsInteger, + qryFilters.FieldByName('RDB$OUTPUT_SUB_TYPE').AsInteger])); + FMetaData.Add(Format('%sENTRY_POINT ''%s'' MODULE_NAME ''%s''%s%', + [TAB, qryFilters.FieldByName('RDB$ENTRYPOINT').AsString, + qryFilters.FieldByName('RDB$MODULE_NAME').AsString, Term])); + FMetaData.Add(''); + + qryFilters.Next; + end; + + finally + qryFilters.Free; + end; +end; + +{ ListForeign + Functional description + List all foreign key constraints and alter the tables } + +procedure TIBExtract.ListForeign(ObjectName : String; ExtractType : TExtractType); +const + { Static queries for obtaining foreign constraints, where RELC1 is the + foreign key constraints, RELC2 is the primary key lookup and REFC + is the join table } + ForeignSQL = + 'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' + + ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' + + ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' + + ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' + + 'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' + + ' RDB$RELATION_CONSTRAINTS RELC2 ' + + 'WHERE ' + + ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' + + ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' + + ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' + + ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' + + ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' + + 'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME'; + + ForeignNameSQL = + 'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' + + ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' + + ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' + + ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' + + 'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' + + ' RDB$RELATION_CONSTRAINTS RELC2 ' + + 'WHERE ' + + ' RELC1.RDB$RELATION_NAME = :TableName AND ' + + ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' + + ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' + + ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' + + ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' + + ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' + + 'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME'; + + ForeignByNameSQL = + 'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' + + ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' + + ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' + + ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' + + 'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' + + ' RDB$RELATION_CONSTRAINTS RELC2 ' + + 'WHERE ' + + ' RELC1.RDB$CONSTRAINT_NAME = :ConstraintName AND ' + + ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' + + ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' + + ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' + + ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' + + ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' + + 'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME'; + +var + qryForeign : TIBSQL; + Line : String; + +begin + qryForeign := TIBSQL.Create(FDatabase); + try + if ObjectName = '' then + qryForeign.SQL.Text := ForeignSQL + else + begin + if ExtractType = etTable then + begin + qryForeign.SQL.Text := ForeignNameSQL; + qryForeign.Params.ByName('TableName').AsString := ObjectName; + end + else + begin + qryForeign.SQL.Text := ForeignByNameSQL; + qryForeign.Params.ByName('ConstraintName').AsString := ObjectName; + end; + end; + qryForeign.ExecQuery; + while not qryForeign.Eof do + begin + Line := Format('ALTER TABLE %s ADD ', [QuoteIdentifier(FDatabase.SQLDialect, + qryForeign.FieldByName('RELC1_RELATION_NAME').AsString)]); + + { If the name of the constraint is not INTEG..., print it. + INTEG... are internally generated names. } + if (not qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').IsNull) and + ( Pos('INTEG', qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').AsString) <> 1) then + Line := Line + Format('CONSTRAINT %s ', [QuoteIdentifier(FDatabase.SQLDialect, + Trim(qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').AsString))]); + + Line := Line + Format('FOREIGN KEY (%s) REFERENCES %s ', [ + GetIndexSegments(qryForeign.FieldByName('RELC1_INDEX_NAME').AsString), + Trim(qryForeign.FieldByName('RELC2_RELATION_NAME').AsString)]); + + Line := Line + Format('(%s)', + [GetIndexSegments(qryForeign.FieldByName('RELC2_INDEX_NAME').AsString)]); + + { Add the referential actions, if any } + if (not qryForeign.FieldByName('REFC_UPDATE_RULE').IsNull) and + (Trim(qryForeign.FieldByName('REFC_UPDATE_RULE').AsString) <> 'RESTRICT') then + Line := Line + Format(' ON UPDATE %s', + [Trim(qryForeign.FieldByName('REFC_UPDATE_RULE').AsString)]); + + if (not qryForeign.FieldByName('REFC_DELETE_RULE').IsNull) and + (Trim(qryForeign.FieldByName('REFC_DELETE_RULE').AsString) <> 'RESTRICT') then + Line := Line + Format(' ON DELETE %s', + [Trim(qryForeign.FieldByName('REFC_DELETE_RULE').AsString)]); + + Line := Line + Term; + FMetaData.Add(Line); + qryForeign.Next; + end; + finally + qryForeign.Free; + end; +end; + +{ ListFunctions + + Functional description + List all external functions + + Parameters: none + Results in + DECLARE EXTERNAL FUNCTION function_name + CHAR [256] , INTEGER, .... + RETURNS INTEGER BY VALUE + ENTRY_POINT entrypoint MODULE_NAME module; } + +procedure TIBExtract.ListFunctions(FunctionName : String = ''); +const + FunctionSQL = + 'SELECT * FROM RDB$FUNCTIONS ' + + 'ORDER BY RDB$FUNCTION_NAME'; + + FunctionNameSQL = + 'SELECT * FROM RDB$FUNCTIONS ' + + 'WHERE RDB$FUNCTION_NAME = :FunctionName ' + + 'ORDER BY RDB$FUNCTION_NAME'; + + FunctionArgsSQL = + 'SELECT * FROM RDB$FUNCTION_ARGUMENTS ' + + 'WHERE ' + + ' :FUNCTION_NAME = RDB$FUNCTION_NAME ' + + 'ORDER BY RDB$ARGUMENT_POSITION'; + + FuncArgsPosSQL = + 'SELECT * FROM RDB$FUNCTION_ARGUMENTS ' + + 'WHERE ' + + ' RDB$FUNCTION_NAME = :RDB$FUNCTION_NAME AND ' + + ' RDB$ARGUMENT_POSITION = :RDB$ARGUMENT_POSITION'; + + CharSetSQL = + 'SELECT * FROM RDB$CHARACTER_SETS ' + + 'WHERE ' + + ' RDB$CHARACTER_SET_ID = :CHARACTER_SET_ID'; + +var + qryFunctions, qryFuncArgs, qryCharSets, qryFuncPos : TIBSQL; + First, FirstArg, DidCharset, PrecisionKnown : Boolean; + ReturnBuffer, TypeBuffer, Line : String; + i, FieldType : Integer; +begin + First := true; + qryFunctions := TIBSQL.Create(FDatabase); + qryFuncArgs := TIBSQL.Create(FDatabase); + qryFuncPos := TIBSQL.Create(FDatabase); + qryCharSets := TIBSQL.Create(FDatabase); + try + if FunctionName = '' then + qryFunctions.SQL.Text := FunctionSQL + else + begin + qryFunctions.SQL.Text := FunctionNameSQL; + qryFunctions.Params.ByName('FunctionName').AsString := FunctionName; + end; + qryFuncArgs.SQL.Text := FunctionArgsSQL; + qryFuncPos.SQL.Text := FuncArgsPosSQL; + qryCharSets.SQL.Text := CharSetSQL; + qryFunctions.ExecQuery; + while not qryFunctions.Eof do + begin + if First then + begin + FMEtaData.Add(Format('%s/* External Function declarations */%s', + [NEWLINE, NEWLINE])); + First := false; + end; //end_if + { Start new function declaration } + FMetaData.Add(Format('DECLARE EXTERNAL FUNCTION %s', + [qryFunctions.FieldByName('RDB$FUNCTION_NAME').AsString])); + Line := ''; + + FirstArg := true; + qryFuncArgs.Params.ByName('FUNCTION_NAME').AsString := + qryFunctions.FieldByName('RDB$FUNCTION_NAME').AsString; + + qryFuncArgs.ExecQuery; + while not qryFuncArgs.Eof do + begin + { Find parameter type } + i := 0; + FieldType := qryFuncArgs.FieldByName('RDB$FIELD_TYPE').AsInteger; + while FieldType <> ColumnTypes[i].SQLType do + Inc(i); + + { Print length where appropriate } + if FieldType in [ blr_text, blr_varying, blr_cstring] then + begin + DidCharset := false; + + qryCharSets.Params.ByName('CHARACTER_SET_ID').AsString := + qryFuncArgs.FieldByName('RDB$CHARACTER_SET_ID').AsString; + qryCharSets.ExecQuery; + while not qryCharSets.Eof do + begin + DidCharset := true; + TypeBuffer := Format('%s(%d) CHARACTER SET %s', + [ColumnTypes[i].TypeName, + qryFuncArgs.FieldByName('RDB$FIELD_LENGTH').AsInteger div + Max(1,qryCharSets.FieldByName('RDB$BYTES_PER_CHARACTER').AsInteger), + qryCharSets.FieldByName('RDB$CHARACTER_SET_NAME').AsString]); + qryCharSets.Next; + end; + qryCharSets.Close; + if not DidCharset then + TypeBuffer := Format('%s(%d)', [ColumnTypes[i].TypeName, + qryFuncArgs.FieldByName('RDB$FIELD_LENGTH').AsInteger]); + end //end_if + else + begin + PrecisionKnown := false; + if (FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10) and + (FieldType in [blr_short, blr_long, blr_int64]) then + begin + qryFuncPos.Params.ByName('RDB$FUNCTION_NAME').AsString := + qryFuncArgs.FieldByName('RDB$FUNCTION_NAME').AsString; + qryFuncPos.Params.ByName('RDB$ARGUMENT_POSITION').AsInteger := + qryFuncArgs.FieldByName('RDB$ARGUMENT_POSITION').AsInteger; + + qryFuncPos.ExecQuery; + while not qryFuncPos.Eof do + begin + { We are ODS >= 10 and could be any Dialect } + if not qryFuncPos.FieldByName('RDB$FIELD_PRECISION').IsNull then + begin + { We are Dialect >=3 since FIELD_PRECISION is non-NULL } + if (qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and + (qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then + begin + TypeBuffer := Format('%s(%d, %d)', + [IntegralSubtypes[qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger], + qryFuncPos.FieldByName('RDB$FIELD_PRECISION').AsInteger, + -qryFuncPos.FieldByName('RDB$FIELD_SCALE').AsInteger] ); + PrecisionKnown := true; + end; //end_if + end; { if field_precision is not null } + qryFuncPos.Next; + end; + qryFuncPos.Close; + end; { if major_ods >= ods_version10 && } + if not PrecisionKnown then + begin + { Take a stab at numerics and decimals } + if (FieldType = blr_short) and + (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + TypeBuffer := Format('NUMERIC(4, %d)', + [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger]) + else + if (FieldType = blr_long) and + (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + TypeBuffer := Format('NUMERIC(9, %d)', + [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger]) + else + if (FieldType = blr_double) and + (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + TypeBuffer := Format('NUMERIC(15, %d)', + [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger]) + else + TypeBuffer := ColumnTypes[i].TypeName; + end; { if not PrecisionKnown } + end; { if FCHAR or VARCHAR or CSTRING ... else } + + if qryFunctions.FieldByName('RDB$RETURN_ARGUMENT').AsInteger = + qryFuncArgs.FieldByName('RDB$ARGUMENT_POSITION').AsInteger then + begin + ReturnBuffer := 'RETURNS ' + TypeBuffer; + if qryFuncArgs.FieldByName('RDB$MECHANISM').AsInteger = 0 then + ReturnBuffer := ReturnBuffer + ' BY VALUE '; + if qryFuncArgs.FieldByName('RDB$MECHANISM').AsInteger < 0 then + ReturnBuffer := ReturnBuffer + ' FREE_IT'; + end + else + begin + { First arg needs no comma } + if FirstArg then + begin + Line := Line + TypeBuffer; + FirstArg := false; + end + else + Line := Line + ', ' + TypeBuffer; + end; //end_else + qryFuncArgs.Next; + end; + qryFuncArgs.Close; + + FMetaData.Add(Line); + FMetaData.Add(ReturnBuffer); + FMetaData.Add(Format('ENTRY_POINT ''%s'' MODULE_NAME ''%s''%s%s%s', + [qryFunctions.FieldByName('RDB$ENTRYPOINT').AsString, + qryFunctions.FieldByName('RDB$MODULE_NAME').AsString, + Term, NEWLINE, NEWLINE])); + + qryFunctions.Next; + end; + finally + qryFunctions.Free; + qryFuncArgs.Free; + qryCharSets.Free; + qryFuncPos.Free; + end; +end; + +{ ListGenerators + Functional description + Re create all non-system generators } + +procedure TIBExtract.ListGenerators(GeneratorName : String = ''); +const + GeneratorSQL = + 'SELECT RDB$GENERATOR_NAME ' + + 'FROM RDB$GENERATORS ' + + 'WHERE ' + + ' (RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG <> 1) ' + + 'ORDER BY RDB$GENERATOR_NAME'; + + GeneratorNameSQL = + 'SELECT RDB$GENERATOR_NAME ' + + 'FROM RDB$GENERATORS ' + + 'WHERE RDB$GENERATOR_NAME = :GeneratorName AND ' + + ' (RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG <> 1) ' + + 'ORDER BY RDB$GENERATOR_NAME'; + +var + qryGenerator : TIBSQL; + GenName : String; +begin + qryGenerator := TIBSQL.Create(FDatabase); + try + if GeneratorName = '' then + qryGenerator.SQL.Text := GeneratorSQL + else + begin + qryGenerator.SQL.Text := GeneratorNameSQL; + qryGenerator.Params.ByName('GeneratorName').AsString := GeneratorName; + end; + qryGenerator.ExecQuery; + FMetaData.Add(''); + while not qryGenerator.Eof do + begin + GenName := qryGenerator.FieldByName('RDB$GENERATOR_NAME').AsString; + if ((Pos('RDB$',GenName) = 1) and + (GenName[5] in ['0'..'9'])) or + ((Pos('SQL$',GenName) = 1) and + (GenName[5] in ['0'..'9'])) then + begin + qryGenerator.Next; + continue; + end; + FMetaData.Add(Format('CREATE GENERATOR %s%s', + [QuoteIdentifier(FDatabase.SQLDialect, GenName), + Term])); + qryGenerator.Next; + end; + finally + qryGenerator.Free; + end; +end; + +{ ListIndex + Functional description + Define all non-constraint indices + Use a static SQL query to get the info and print it. + + Uses get_index_segment to provide a key list for each index } + +procedure TIBExtract.ListIndex(ObjectName : String; ExtractType : TExtractType); +const + IndexSQL = + 'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' + + ' IDX.RDB$INDEX_TYPE ' + + 'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' + + ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' + + 'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' + + ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' + + ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' + + 'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME'; + + IndexNameSQL = + 'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' + + ' IDX.RDB$INDEX_TYPE ' + + 'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' + + ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' + + 'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' + + ' RELC.RDB$RELATION_NAME = :RelationName AND ' + + ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' + + ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' + + 'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME'; + + IndexByNameSQL = + 'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' + + ' IDX.RDB$INDEX_TYPE ' + + 'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' + + ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' + + 'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' + + ' IDX.RDB$INDEX_NAME = :IndexName AND ' + + ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' + + ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' + + 'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME'; + +var + qryIndex : TIBSQL; + First : Boolean; + Unique, IdxType, Line : String; +begin + First := true; + qryIndex := TIBSQL.Create(FDatabase); + try + if ObjectName = '' then + qryIndex.SQL.Text := IndexSQL + else + begin + if ExtractType = etTable then + begin + qryIndex.SQL.Text := IndexNameSQL; + qryIndex.Params.ByName('RelationName').AsString := ObjectName; + end + else + begin + qryIndex.SQL.Text := IndexByNameSQL; + qryIndex.Params.ByName('IndexName').AsString := ObjectName; + end; + end; + qryIndex.ExecQuery; + while not qryIndex.Eof do + begin + if First then + begin + if ObjectName = '' then + FMetaData.Add(NEWLINE + '/* Index definitions for all user tables */' + NEWLINE) + else + FMetaData.Add(NEWLINE + '/* Index definitions for ' + ObjectName + ' */' + NEWLINE); + First := false; + end; //end_if + + if qryIndex.FieldByName('RDB$UNIQUE_FLAG').AsInteger = 1 then + Unique := ' UNIQUE' + else + Unique := ''; + + if qryIndex.FieldByName('RDB$INDEX_TYPE').AsInteger = 1 then + IdxType := ' DESCENDING' + else + IdxType := ''; + + Line := Format('CREATE%s%s INDEX %s ON %s(', [Unique, IdxType, + QuoteIdentifier(FDataBase.SQLDialect, + qryIndex.FieldByName('RDB$INDEX_NAME').AsString), + QuoteIdentifier(FDataBase.SQLDialect, + qryIndex.FieldByName('RDB$RELATION_NAME').AsString)]); + + Line := Line + GetIndexSegments(qryIndex.FieldByName('RDB$INDEX_NAME').AsString) + + ')' + Term; + + FMetaData.Add(Line); + qryIndex.Next; + end; + finally + qryIndex.Free; + end; +end; + +{ ListViews + Functional description + Show text of views. + Use a SQL query to get the info and print it. + Note: This should also contain check option } + +procedure TIBExtract.ListViews(ViewName : String); +const + ViewSQL = + 'SELECT RDB$RELATION_NAME, RDB$OWNER_NAME, RDB$VIEW_SOURCE ' + + 'FROM RDB$RELATIONS ' + + 'WHERE ' + + ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + + ' NOT RDB$VIEW_BLR IS NULL AND ' + + ' RDB$FLAGS = 1 ' + + 'ORDER BY RDB$RELATION_ID'; + + ViewNameSQL = + 'SELECT RDB$RELATION_NAME, RDB$OWNER_NAME, RDB$VIEW_SOURCE ' + + 'FROM RDB$RELATIONS ' + + 'WHERE ' + + ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' + + ' NOT RDB$VIEW_BLR IS NULL AND ' + + ' RDB$FLAGS = 1 AND ' + + ' RDB$RELATION_NAME = :ViewName ' + + 'ORDER BY RDB$RELATION_ID'; + + ColumnSQL = + 'SELECT RDB$FIELD_NAME FROM RDB$RELATION_FIELDS ' + + 'WHERE ' + + ' RDB$RELATION_NAME = :RELATION_NAME ' + + 'ORDER BY RDB$FIELD_POSITION'; + +var + qryView, qryColumns : TIBSQL; + SList : TStrings; +begin + qryView := TIBSQL.Create(FDatabase); + qryColumns := TIBSQL.Create(FDatabase); + SList := TStringList.Create; + try + if ViewName = '' then + qryView.SQL.Text := ViewSQL + else + begin + qryView.SQL.Text := ViewNameSQL; + qryView.Params.ByName('ViewName').AsString := ViewName; + end; + qryColumns.SQL.Text := ColumnSQL; + qryView.ExecQuery; + while not qryView.Eof do + begin + SList.Add(Format('%s/* View: %s, Owner: %s */%s', + [NEWLINE, qryView.FieldByName('RDB$RELATION_NAME').AsString, + qryView.FieldByName('RDB$OWNER_NAME').AsString, NEWLINE])); + + SList.Add(Format('CREATE VIEW %s (', [QuoteIdentifier(FDatabase.SQLDialect, + qryView.FieldByName('RDB$RELATION_NAME').AsString)])); + + qryColumns.Params.ByName('RELATION_NAME').AsString := + qryView.FieldByName('RDB$RELATION_NAME').AsString; + qryColumns.ExecQuery; + while not qryColumns.Eof do + begin + SList.Add(' ' + QuoteIdentifier(FDatabase.SQLDialect, + qryColumns.FieldByName('RDB$FIELD_NAME').AsString)); + qryColumns.Next; + if not qryColumns.Eof then + SList.Strings[SList.Count - 1] := SList.Strings[SList.Count - 1] + ', '; + end; + qryColumns.Close; + SList.Text := SList.Text + Format(') AS%s', [NEWLINE]); + if not qryView.FieldByName('RDB$VIEW_SOURCE').IsNull then + SList.Text := SList.Text + qryView.FieldByName('RDB$VIEW_SOURCE').AsString; + SList.Text := SList.Text + Format('%s%s', [Term, NEWLINE]); + FMetaData.AddStrings(SList); + SList.Clear; + qryView.Next; + end; + finally + qryView.Free; + qryColumns.Free; + SList.Free; + end; +end; + +{ PrintSet + Functional description + print (using ISQL_printf) the word "SET" + if the first line of the ALTER DATABASE + settings options. Also, add trailing + comma for end of prior line if needed. + + uses Print_buffer, a global } + +function TIBExtract.PrintSet(var Used: Boolean) : String; +begin + if not Used then + begin + Result := ' SET '; + Used := true; + end + else + Result := Format(', %s ', [NEWLINE]); +end; + +{ + PrintValidation + Functional description + This does some minor syntax adjustmet for extracting + validation blobs and computed fields. + if it does not start with the word CHECK + if this is a computed field blob,look for () or insert them. + if flag = false, this is a validation clause, + if flag = true, this is a computed field } + +function TIBExtract.PrintValidation(ToValidate: String; + flag: Boolean): String; +var + IsSQL : Boolean; +begin + IsSql := false; + + Result := ''; + ToValidate := Trim(ToValidate); + + if flag then + begin + if ToValidate[1] = '(' then + IsSQL := true; + end + else + if (Pos(ToValidate, 'check') = 1) or (Pos(ToValidate, 'CHECK') = 1) then + IsSQL := TRUE; + + if not IsSQL then + begin + if Flag then + Result := Result + '/* ' + ToValidate + ' */' + else + Result := Result + '(' + ToValidate + ')'; + end + else + Result := ToValidate; +end; + +procedure TIBExtract.SetDatabase(const Value: TIBDatabase); +begin + if FDatabase <> Value then + begin + FDatabase := Value; + if (not Assigned(FTransaction)) and (FDatabase <> nil) then + Transaction := FDatabase.DefaultTransaction; + FDatabaseInfo.Database := FDatabase; + end; +end; + +procedure TIBExtract.SetTransaction(const Value: TIBTransaction); +begin + if FTransaction <> Value then + begin + FTransaction := Value; + if (not Assigned(FDatabase)) and (FTransaction <> nil) then + Database := FTransaction.DefaultDatabase; + end; +end; + +procedure TIBExtract.ExtractObject(ObjectType : TExtractObjectTypes; + ObjectName : String = ''; ExtractTypes : TExtractTypes = []); +var + DidActivate : Boolean; +begin + DidActivate := false; + if not FTransaction.Active then + begin + FTransaction.StartTransaction; + DidActivate := true; + end; + FMetaData.Clear; + case ObjectType of + eoDatabase : ExtractDDL(true, ''); + eoDomain : + if etTable in ExtractTypes then + ListDomains(ObjectName, etTable) + else + ListDomains(ObjectName); + eoTable : + begin + if ObjectName <> '' then + begin + if etDomain in ExtractTypes then + ListDomains(ObjectName, etTable); + ExtractListTable(ObjectName, '', false); + if etIndex in ExtractTypes then + ListIndex(ObjectName, etTable); + if etForeign in ExtractTypes then + ListForeign(ObjectName, etTable); + if etCheck in ExtractTypes then + ListCheck(ObjectName, etTable); + if etTrigger in ExtractTypes then + ListTriggers(ObjectName, etTable); + if etGrant in ExtractTypes then + ShowGrants(ObjectName, Term); + if etData in ExtractTypes then + ListData(ObjectName); + end + else + ListAllTables(true); + end; + eoView : ListViews(ObjectName); + eoProcedure : ListProcs(ObjectName); + eoFunction : ListFunctions(ObjectName); + eoGenerator : ListGenerators(ObjectName); + eoException : ListException(ObjectName); + eoBLOBFilter : ListFilters(ObjectName); + eoRole : ListRoles(ObjectName); + eoTrigger : + if etTable in ExtractTypes then + ListTriggers(ObjectName, etTable) + else + ListTriggers(ObjectName); + eoForeign : + if etTable in ExtractTypes then + ListForeign(ObjectName, etTable) + else + ListForeign(ObjectName); + eoIndexes : + if etTable in ExtractTypes then + ListIndex(ObjectName, etTable) + else + ListIndex(ObjectName); + eoChecks : + if etTable in ExtractTypes then + ListCheck(ObjectName, etTable) + else + ListCheck(ObjectName); + eoData : ListData(ObjectName); + end; + if DidActivate then + FTransaction.Commit; +end; + +function TIBExtract.GetFieldType(FieldType, FieldSubType, FieldScale, + FieldSize, FieldPrec, FieldLen: Integer): String; +var + i : Integer; + PrecisionKnown : Boolean; +begin + Result := ''; + for i := Low(ColumnTypes) to High(ColumnTypes) do + if FieldType = ColumnTypes[i].SQLType then + begin + PrecisionKnown := FALSE; + if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then + begin + if FieldType in [blr_short, blr_long, blr_int64] then + begin + { We are ODS >= 10 and could be any Dialect } + if (FDatabaseInfo.DBSQLDialect >= 3) and + (FieldPrec <> 0) and + (FieldSubType > 0) and + (FieldSubType <= MAX_INTSUBTYPES) then + begin + Result := Result + Format('%s(%d, %d)', [ + IntegralSubtypes [FieldSubType], + FieldPrec, + -1 * FieldScale]); + PrecisionKnown := true; + end; + end; + end; + if PrecisionKnown = false then + begin + { Take a stab at numerics and decimals } + if (FieldType = blr_short) and + (FieldScale < 0) then + Result := Result + Format('NUMERIC(4, %d)', + [-FieldScale] ) + else + if (FieldType = blr_long) and + (FieldScale < 0) then + Result := Result + Format('NUMERIC(9, %d)', + [-FieldScale] ) + else + if (FieldType = blr_double) and + (FieldScale < 0) then + Result := Result + Format('NUMERIC(15, %d)', + [-FieldScale] ) + else + Result := Result + ColumnTypes[i].TypeName; + end; + break; + end; + if (FieldType in [blr_text, blr_varying]) and + (FieldSize <> 0) then + Result := Result + Format('(%d)', [FieldSize]); +end; + +{ S H O W _ g r a n t s + Functional description + Show grants for given object name + This function is also called by extract for privileges. + It must extract granted privileges on tables/views to users, + - these may be compound, so put them on the same line. + Grant execute privilege on procedures to users + Grant various privilegs to procedures. + All privileges may have the with_grant option set. } + +procedure TIBExtract.ShowGrants(MetaObject, Terminator: String); +const + { This query only finds tables, eliminating owner privileges } + OwnerPrivSQL = + 'SELECT PRV.RDB$USER, PRV.RDB$GRANT_OPTION, PRV.RDB$FIELD_NAME, ' + + ' PRV.RDB$USER_TYPE, PRV.RDB$PRIVILEGE ' + + 'FROM RDB$USER_PRIVILEGES PRV, RDB$RELATIONS REL ' + + 'WHERE ' + + ' PRV.RDB$RELATION_NAME = :METAOBJECT AND ' + + ' REL.RDB$RELATION_NAME = :METAOBJECT AND ' + + ' PRV.RDB$PRIVILEGE <> ''M'' AND ' + + ' REL.RDB$OWNER_NAME <> PRV.RDB$USER ' + + 'ORDER BY PRV.RDB$USER, PRV.RDB$FIELD_NAME, PRV.RDB$GRANT_OPTION'; + + ProcPrivSQL = + 'SELECT PRV.RDB$USER, PRV.RDB$GRANT_OPTION, PRV.RDB$FIELD_NAME, ' + + ' PRV.RDB$USER_TYPE, PRV.RDB$PRIVILEGE, PRV.RDB$RELATION_NAME ' + + 'FROM RDB$USER_PRIVILEGES PRV, RDB$PROCEDURES PRC ' + + 'where ' + + ' PRV.RDB$OBJECT_TYPE = 5 AND ' + + ' PRV.RDB$RELATION_NAME = :METAOBJECT AND ' + + ' PRC.RDB$PROCEDURE_NAME = :METAOBJECT AND ' + + ' PRV.RDB$PRIVILEGE = ''X'' AND ' + + ' PRC.RDB$OWNER_NAME <> PRV.RDB$USER ' + + 'ORDER BY PRV.RDB$USER, PRV.RDB$FIELD_NAME, PRV.RDB$GRANT_OPTION'; + + RolePrivSQL = + 'SELECT * FROM RDB$USER_PRIVILEGES ' + + 'WHERE ' + + ' RDB$OBJECT_TYPE = 13 AND ' + + ' RDB$USER_TYPE = 8 AND ' + + ' RDB$RELATION_NAME = :METAOBJECT AND ' + + ' RDB$PRIVILEGE = ''M'' ' + + 'ORDER BY RDB$USER'; + +var + PrevUser, PrevField, WithOption, + PrivString, ColString, UserString, + FieldName, User : String; + c : Char; + PrevOption, PrivFlags, GrantOption : Integer; + First, PrevFieldNull : Boolean; + qryOwnerPriv : TIBSQL; + + { Given a bit-vector of privileges, turn it into a + string list. } + function MakePrivString(cflags : Integer) : String; + var + i : Integer; + begin + for i := Low(PrivTypes) to High(PrivTypes) do + begin + if (cflags and PrivTypes[i].PrivFlag) <> 0 then + begin + if Result <> '' then + Result := Result + ', '; + Result := Result + PrivTypes[i].PrivString; + end; //end_if + end; //end_for + end; //end_fcn MakePrivDtring + +begin + if MetaObject = '' then + exit; + + First := true; + PrevOption := -1; + PrevUser := ''; + PrivString := ''; + ColString := ''; + WithOption := ''; + PrivFlags := 0; + PrevFieldNull := false; + PrevField := ''; + + qryOwnerPriv := TIBSQL.Create(FDatabase); + try + qryOwnerPriv.SQL.Text := OwnerPrivSQL; + qryOwnerPriv.Params.ByName('metaobject').AsString := MetaObject; + qryOwnerPriv.ExecQuery; + while not qryOwnerPriv.Eof do + begin + { Sometimes grant options are null, sometimes 0. Both same } + if qryOwnerPriv.FieldByName('RDB$GRANT_OPTION').IsNull then + GrantOption := 0 + else + GrantOption := qryOwnerPriv.FieldByName('RDB$GRANT_OPTION').AsInteger; + + if qryOwnerPriv.FieldByName('RDB$FIELD_NAME').IsNull then + FieldName := '' + else + FieldName := qryOwnerPriv.FieldByName('RDB$FIELD_NAME').AsString; + + User := Trim(qryOwnerPriv.FieldByName('RDB$USER').AsString); + { Print a new grant statement for each new user or change of option } + + if ((PrevUser <> '') and (PrevUser <> User)) or + ((Not First) and + (PrevFieldNull <> qryOwnerPriv.FieldByName('RDB$FIELD_NAME').IsNull)) or + ((not PrevFieldNull) and (PrevField <> FieldName)) or + ((PrevOption <> -1) and (PrevOption <> GrantOption)) then + begin + PrivString := MakePrivString(PrivFlags); + + First := false; + FMetaData.Add(Format('GRANT %s%s ON %s TO %s%s%s', [PrivString, + ColString, QuoteIdentifier(FDatabase.SQLDialect, MetaObject), + UserString, WithOption, Terminator])); + { re-initialize strings } + + PrivString := ''; + WithOption := ''; + ColString := ''; + PrivFlags := 0; + end; //end_if + + PrevUser := User; + PrevOption := GrantOption; + PrevFieldNull := qryOwnerPriv.FieldByName('RDB$FIELD_NAME').IsNull; + PrevField := FieldName; + + case qryOwnerPriv.FieldByName('RDB$USER_TYPE').AsInteger of + obj_relation, + obj_view, + obj_trigger, + obj_procedure, + obj_sql_role: + UserString := QuoteIdentifier(FDatabase.SQLDialect, User); + else + UserString := User; + end; //end_case + + case qryOwnerPriv.FieldByName('RDB$USER_TYPE').AsInteger of + obj_view : + UserString := 'VIEW ' + UserString; + obj_trigger : + UserString := 'TRIGGER '+ UserString; + obj_procedure : + UserString := 'PROCEDURE ' + UserString; + end; //end_case + + c := qryOwnerPriv.FieldByName('RDB$PRIVILEGE').AsString[1]; + + case c of + 'S' : PrivFlags := PrivFlags or priv_SELECT; + 'I' : PrivFlags := PrivFlags or priv_INSERT; + 'U' : PrivFlags := PrivFlags or priv_UPDATE; + 'D' : PrivFlags := PrivFlags or priv_DELETE; + 'R' : PrivFlags := PrivFlags or priv_REFERENCES; + 'X' : ; + { Execute should not be here -- special handling below } + else + PrivFlags := PrivFlags or priv_UNKNOWN; + end; //end_switch + + { Column level privileges for update only } + + if FieldName = '' then + ColString := '' + else + ColString := Format(' (%s)', [QuoteIdentifier(FDatabase.SQLDialect, FieldName)]); + + if GrantOption <> 0 then + WithOption := ' WITH GRANT OPTION'; + + qryOwnerPriv.Next; + end; + { Print last case if there was anything to print } + if PrevOption <> -1 then + begin + PrivString := MakePrivString(PrivFlags); + First := false; + FMetaData.Add(Format('GRANT %s%s ON %s TO %s%s%s', [PrivString, + ColString, QuoteIdentifier(FDatabase.SQLDialect, MetaObject), + UserString, WithOption, Terminator])); + { re-initialize strings } + end; //end_if + qryOwnerPriv.Close; + + if First then + begin + { Part two is for stored procedures only } + qryOwnerPriv.SQL.Text := ProcPrivSQL; + qryOwnerPriv.Params.ByName('metaobject').AsString := MetaObject; + qryOwnerPriv.ExecQuery; + while not qryOwnerPriv.Eof do + begin + First := false; + User := Trim(qryOwnerPriv.FieldByName('RDB$USER').AsString); + + case qryOwnerPriv.FieldByName('RDB$USER_TYPE').AsInteger of + obj_relation, + obj_view, + obj_trigger, + obj_procedure, + obj_sql_role: + UserString := QuoteIdentifier(FDatabase.SQLDialect, User); + else + UserString := User; + end; //end_case + case qryOwnerPriv.FieldByName('RDB$USER_TYPE').AsInteger of + obj_view : + UserString := 'VIEW ' + UserString; + obj_trigger : + UserString := 'TRIGGER '+ UserString; + obj_procedure : + UserString := 'PROCEDURE ' + UserString; + end; //end_case + + if qryOwnerPriv.FieldByName('RDB$GRANT_OPTION').AsInteger = 1 then + WithOption := ' WITH GRANT OPTION' + else + WithOption := ''; + + FMetaData.Add(Format('GRANT EXECUTE ON PROCEDURE %s TO %s%s%s', + [QuoteIdentifier(FDatabase.SQLDialect, MetaObject), UserString, + WithOption, terminator])); + + qryOwnerPriv.Next; + end; + qryOwnerPriv.Close; + end; + if First then + begin + qryOwnerPriv.SQL.Text := RolePrivSQL; + qryOwnerPriv.Params.ByName('metaobject').AsString := MetaObject; + qryOwnerPriv.ExecQuery; + while not qryOwnerPriv.Eof do + begin + if qryOwnerPriv.FieldByName('RDB$GRANT_OPTION').AsInteger = 1 then + WithOption := ' WITH ADMIN OPTION' + else + WithOption := ''; + + FMetaData.Add(Format('GRANT %s TO %s%s%s', + [QuoteIdentifier(FDatabase.SQLDialect, qryOwnerPriv.FieldByName('RDB$RELATION_NAME').AsString), + qryOwnerPriv.FieldByName('RDB$USER_NAME').AsString, + WithOption, terminator])); + + qryOwnerPriv.Next; + end; + end; + qryOwnerPriv.Close; + finally + qryOwnerPriv.Free; + end; +end; + +{ ShowGrantRoles + Functional description + Show grants for given role name + This function is also called by extract for privileges. + All membership privilege may have the with_admin option set. } + +procedure TIBExtract.ShowGrantRoles(Terminator: String); +const + RoleSQL = + 'SELECT RDB$USER, RDB$GRANT_OPTION, RDB$RELATION_NAME ' + + 'FROM RDB$USER_PRIVILEGES ' + + 'WHERE ' + + ' RDB$OBJECT_TYPE = %d AND ' + + ' RDB$USER_TYPE = %d AND ' + + ' RDB$PRIVILEGE = ''M'' ' + + 'ORDER BY RDB$RELATION_NAME, RDB$USER'; + +var + WithOption, UserString : String; + qryRole : TIBSQL; + +begin + qryRole := TIBSQL.Create(FDatabase); + try + qryRole.SQL.Text := Format(RoleSQL, [obj_sql_role, obj_user]); + qryRole.ExecQuery; + while not qryRole.Eof do + begin + UserString := Trim(qryRole.FieldByName('RDB$USER').AsString); + + if (not qryRole.FieldByName('RDB$GRANT_OPTION').IsNull) and + (qryRole.FieldByName('RDB$GRANT_OPTION').AsInteger = 1) then + WithOption := ' WITH ADMIN OPTION' + else + WithOption := ''; + FMetaData.Add(Format('GRANT %s TO %s%s%s%s', + [ QuoteIdentifier(FDatabase.SQLDialect, qryRole.FieldByName('RDB$RELATION_NAME').AsString), + UserString, WithOption, Terminator, NEWLINE])); + + qryRole.Next; + end; + finally + qryRole.Free; + end; +end; + +{ GetProcedureArgs + Functional description + This function extract the procedure parameters and adds it to the + extract file } + +procedure TIBExtract.GetProcedureArgs(Proc: String); +const +{ query to retrieve the input parameters. } + ProcHeaderSQL = + 'SELECT * ' + + ' FROM RDB$PROCEDURE_PARAMETERS PRM JOIN RDB$FIELDS FLD ON ' + + ' PRM.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' + + 'WHERE ' + + ' PRM.RDB$PROCEDURE_NAME = :PROCNAME AND ' + + ' PRM.RDB$PARAMETER_TYPE = :Input ' + + 'ORDER BY PRM.RDB$PARAMETER_NUMBER'; + +var + FirstTime, PrecisionKnown : Boolean; + Line : String; + qryHeader : TIBSQL; + + function FormatParamStr : String; + var + i, CollationID, CharSetID : Integer; + begin + Result := Format(' %s ', [qryHeader.FieldByName('RDB$PARAMETER_NAME').AsString]); + for i := Low(ColumnTypes) to High(ColumnTypes) do + if qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = ColumnTypes[i].SQLType then + begin + PrecisionKnown := FALSE; + if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then + begin + if qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_short, blr_long, blr_int64] then + begin + { We are ODS >= 10 and could be any Dialect } + if (FDatabaseInfo.DBSQLDialect >= 3) and + (not qryHeader.FieldByName('RDB$FIELD_PRECISION').IsNull) and + (qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and + (qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then + begin + Result := Result + Format('%s(%d, %d)', [ + IntegralSubtypes [qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger], + qryHeader.FieldByName('RDB$FIELD_PRECISION').AsInteger, + -1 * qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger]); + PrecisionKnown := true; + end; + end; + end; + if PrecisionKnown = false then + begin + { Take a stab at numerics and decimals } + if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_short) and + (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + Result := Result + Format('NUMERIC(4, %d)', + [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] ) + else + if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_long) and + (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + Result := Result + Format('NUMERIC(9, %d)', + [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] ) + else + if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_double) and + (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then + Result := Result + Format('NUMERIC(15, %d)', + [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] ) + else + Result := Result + ColumnTypes[i].TypeName; + end; + break; + end; + if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying]) and + (not qryHeader.FieldByName('RDB$CHARACTER_LENGTH').IsNull) then + Result := Result + Format('(%d)', [qryHeader.FieldByName('RDB$FIELD_LENGTH').AsInteger]); + + { Show international character sets and collations } + + if (not qryHeader.FieldByName('RDB$COLLATION_ID').IsNull) or + (not qryHeader.FieldByName('RDB$CHARACTER_SET_ID').IsNull) then + begin + if qryHeader.FieldByName('RDB$COLLATION_ID').IsNull then + CollationId := 0 + else + CollationId := qryHeader.FieldByName('RDB$COLLATION_ID').AsInteger; + + if qryHeader.FieldByName('RDB$CHARACTER_SET_ID').IsNull then + CharSetId := 0 + else + CharSetId := qryHeader.FieldByName('RDB$CHARACTER_SET_ID').AsInteger; + + Result := Result + GetCharacterSets(CharSetId, CollationId, false); + end; + end; + +begin + FirstTime := true; + qryHeader := TIBSQL.Create(FDatabase); + try + qryHeader.SQL.Text := ProcHeaderSQL; + qryHeader.Params.ByName('procname').AsString := Proc; + qryHeader.Params.ByName('Input').AsInteger := 0; + qryHeader.ExecQuery; + while not qryHeader.Eof do + begin + if FirstTime then + begin + FirstTime := false; + FMetaData.Add('('); + end; + + Line := FormatParamStr; + + qryHeader.Next; + if not qryHeader.Eof then + Line := Line + ','; + FMetaData.Add(Line); + end; + + { If there was at least one param, close parens } + if not FirstTime then + begin + FMetaData.Add( ')'); + end; + + FirstTime := true; + qryHeader.Close; + qryHeader.Params.ByName('Input').AsInteger := 1; + qryHeader.ExecQuery; + + while not qryHeader.Eof do + begin + if FirstTime then + begin + FirstTime := false; + FMetaData.Add('RETURNS' + NEWLINE + '('); + end; + + Line := FormatParamStr; + + qryHeader.Next; + if not qryHeader.Eof then + Line := Line + ','; + FMetaData.Add(Line); + end; + + { If there was at least one param, close parens } + if not FirstTime then + begin + FMetaData.Add( ')'); + end; + + FMetaData.Add('AS'); + finally + qryHeader.Free; + end; +end; + +procedure TIBExtract.Notification(AComponent: TComponent; + Operation: TOperation); +begin + inherited; + if (AComponent = FDatabase) and (Operation = opRemove) then + FDatabase := nil; + if (AComponent = FTransaction) and (Operation = opRemove) then + FTransaction := nil; +end; + +procedure TIBExtract.ListData(ObjectName: String); +const + SelectSQL = 'SELECT * FROM %s'; +var + qrySelect : TIBSQL; + Line : String; + i : Integer; +begin + qrySelect := TIBSQL.Create(FDatabase); + try + qrySelect.SQL.Text := Format(SelectSQL, + [QuoteIdentifier(FDatabase.SQLDialect, ObjectName)]); + qrySelect.ExecQuery; + while not qrySelect.Eof do + begin + Line := 'INSERT INTO ' + QuoteIdentifier(FDatabase.SQLDialect, ObjectName) + ' ('; + for i := 0 to qrySelect.Current.Count - 1 do + if (qrySelect.Fields[i].SQLType <> SQL_ARRAY) and + (qrySelect.Fields[i].SQLType <> SQL_BLOB) then + begin + Line := Line + QuoteIdentifier(FDatabase.SQLDialect, qrySelect.Fields[i].Name); + if i <> (qrySelect.Current.Count - 1) then + Line := Line + ', '; + end; + Line := Line + ') VALUES ('; + for i := 0 to qrySelect.Current.Count - 1 do + begin + if qrySelect.Fields[i].IsNull and + (qrySelect.Fields[i].SQLType <> SQL_ARRAY) and + (qrySelect.Fields[i].SQLType <> SQL_BLOB) then + begin + Line := Line + 'NULL'; + if i <> (qrySelect.Current.Count - 1) then + Line := Line + ', '; + end + else + case qrySelect.Fields[i].SQLType of + SQL_TEXT, SQL_VARYING, SQL_TYPE_DATE, + SQL_TYPE_TIME, SQL_TIMESTAMP : + begin + Line := Line + QuotedStr(qrySelect.Fields[i].AsString); + if i <> (qrySelect.Current.Count - 1) then + Line := Line + ', '; + end; + SQL_SHORT, SQL_LONG, SQL_INT64, + SQL_DOUBLE, SQL_FLOAT, SQL_D_FLOAT: + begin + Line := Line + qrySelect.Fields[i].AsString; + if i <> (qrySelect.Current.Count - 1) then + Line := Line + ', '; + end; + SQL_ARRAY, SQL_BLOB : ; + else + IBError(ibxeInvalidDataConversion, [nil]); + end; + end; + Line := Line + ')' + Term; + FMetaData.Add(Line); + qrySelect.Next; + end; + finally + qrySelect.Free; + end; +end; + +procedure TIBExtract.ListRoles(ObjectName: String); +const + RolesSQL = + 'select * from RDB$ROLES ' + + 'order by RDB$ROLE_NAME'; + + RolesByNameSQL = + 'select * from RDB$ROLES ' + + 'WHERE RDB$ROLE_NAME = :RoleName ' + + 'order by RDB$ROLE_NAME'; + +var + qryRoles : TIBSQL; + PrevOwner, RoleName, OwnerName : String; +begin + {Process GRANT roles} + qryRoles := TIBSQL.Create(FDatabase); + try + if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION9 then + begin + PrevOwner := ''; + FMetaData.Add(''); + FMetaData.Add('/* Grant Roles for this database */'); + FMetaData.Add(''); + + if ObjectName = '' then + qryRoles.SQL.Text := RolesSQL + else + begin + qryRoles.SQL.Text := RolesByNameSQL; + qryRoles.Params.ByName('RoleName').AsString := ObjectName; + end; + qryRoles.ExecQuery; + try + while not qryRoles.Eof do + begin + RoleName := QuoteIdentifier(FDatabase.SQLDialect, + qryRoles.FieldByName('rdb$Role_Name').AsString); + OwnerName := Trim(qryRoles.FieldByName('rdb$Owner_Name').AsString); + if PrevOwner <> OwnerName then + begin + FMetaData.Add(''); + FMetaData.Add(Format('/* Role: %s, Owner: %s */', [RoleName, OwnerName])); + FMetaData.Add(''); + PrevOwner := OwnerName; + end; + FMetaData.Add('CREATE ROLE ' + RoleName + Term); + qryRoles.Next; + end; + finally + qryRoles.Close; + end; + end; + finally + qryRoles.Free; + end; +end; + +end. + +