ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBExtract.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 116129 byte(s)
Log Message:
Committing updates for Release R2-0-1

File Contents

# User Rev Content
1 tony 33 {************************************************************************}
2     { }
3     { The contents of this file are subject to the InterBase }
4     { Public License Version 1.0 (the "License"); you may not }
5     { use this file except in compliance with the License. You }
6     { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
7     { Software distributed under the License is distributed on }
8     { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
9     { express or implied. See the License for the specific language }
10     { governing rights and limitations under the License. }
11     { }
12     { The Original Code was created by Jeff Overcash. }
13     { Portions based upon code by Inprise Corporation are Copyright (C) }
14     { Inprise Corporation. All Rights Reserved. }
15     { }
16     { IBX Version 4.2 or higher required }
17     { Contributor(s): Jeff Overcash }
18     { }
19     { IBX For Lazarus (Firebird Express) }
20     { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
21     { Portions created by MWA Software are copyright McCallum Whyman }
22     { Associates Ltd 2011 }
23     { }
24     {************************************************************************}
25    
26 tony 47 { Syntax Enhancements Supported (by Firebird Version no.):
27 tony 45
28     Multi-action triggers (1.5)
29     CREATE SEQUENCE (2.0)
30     Database Triggers (2.1)
31     Global Temporary Tables (2.1)
32     Boolean Type (3.0)
33     Identity Column Type (3.0)
34     }
35    
36 tony 33 unit IBExtract;
37    
38     {$Mode Delphi}
39 tony 39 {$codepage UTF8}
40 tony 33
41     interface
42    
43     uses
44     {$IFDEF WINDOWS }
45     Windows,
46     {$ELSE}
47     unix,
48     {$ENDIF}
49     SysUtils, Classes, IBDatabase, IBDatabaseInfo,
50 tony 45 IBSQL, IBUtils, IBHeader, IB;
51 tony 33
52     type
53     TExtractObjectTypes =
54     (eoDatabase, eoDomain, eoTable, eoView, eoProcedure, eoFunction,
55     eoGenerator, eoException, eoBLOBFilter, eoRole, eoTrigger, eoForeign,
56     eoIndexes, eoChecks, eoData);
57    
58     TExtractType =
59     (etDomain, etTable, etRole, etTrigger, etForeign,
60     etIndex, etData, etGrant, etCheck);
61    
62     TExtractTypes = Set of TExtractType;
63    
64 tony 47 TProcDDLType = (pdCreateProc,pdCreateStub,pdAlterProc);
65    
66 tony 45 { TIBExtract }
67    
68 tony 33 TIBExtract = class(TComponent)
69     private
70     FDatabase : TIBDatabase;
71     FTransaction : TIBTransaction;
72     FMetaData: TStrings;
73     FDatabaseInfo: TIBDatabaseInfo;
74     FShowSystem: Boolean;
75     { Private declarations }
76 tony 47 procedure Add2MetaData(const Msg: string; IsError: boolean=true);
77 tony 33 function GetDatabase: TIBDatabase;
78     function GetIndexSegments ( indexname : String) : String;
79     function GetTransaction: TIBTransaction;
80 tony 45 function GetTriggerType(TypeID: integer): string;
81 tony 33 procedure SetDatabase(const Value: TIBDatabase);
82     procedure SetTransaction(const Value: TIBTransaction);
83     function PrintValidation(ToValidate : String; flag : Boolean) : String;
84     procedure ShowGrants(MetaObject: String; Terminator : String);
85 tony 47 procedure ShowGrantsTo(MetaObject: String; ObjectType: integer;
86     Terminator: String);
87 tony 33 procedure ShowGrantRoles(Terminator : String);
88     procedure GetProcedureArgs(Proc : String);
89     protected
90 tony 47 function ExtractDDL(Flag: Boolean; TableName: String; IncludeData: boolean =
91     false): Boolean;
92 tony 45 function ExtractListTable(RelationName, NewName: String; DomainFlag: Boolean): Boolean;
93 tony 33 procedure ExtractListView (ViewName : String);
94     procedure ListData(ObjectName : String);
95     procedure ListRoles(ObjectName : String = '');
96     procedure ListGrants;
97 tony 47 procedure ListProcs(ProcDDLType: TProcDDLType = pdCreateProc; ProcedureName : String = '';
98     IncludeGrants:boolean=false);
99 tony 33 procedure ListAllTables(flag : Boolean);
100 tony 47 procedure ListTriggers(ObjectName: String=''; ExtractTypes: TExtractTypes = [etTrigger]);
101 tony 33 procedure ListCheck(ObjectName : String = ''; ExtractType : TExtractType = etCheck);
102     function PrintSet(var Used : Boolean) : String;
103     procedure ListCreateDb(TargetDb : String = '');
104     procedure ListDomains(ObjectName : String = ''; ExtractType : TExtractType = etDomain);
105     procedure ListException(ExceptionName : String = '');
106     procedure ListFilters(FilterName : String = '');
107     procedure ListForeign(ObjectName : String = ''; ExtractType : TExtractType = etForeign);
108     procedure ListFunctions(FunctionName : String = '');
109 tony 47 procedure ListGenerators(GeneratorName : String = ''; ExtractTypes: TExtractTypes=[]);
110 tony 33 procedure ListIndex(ObjectName : String = ''; ExtractType : TExtractType = etIndex);
111     procedure ListViews(ViewName : String = '');
112 tony 47 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
113 tony 33
114     { Protected declarations }
115     public
116     { Public declarations }
117     constructor Create(AOwner : TComponent); override;
118     destructor Destroy; override;
119     function GetArrayField(FieldName : String) : String;
120     function GetFieldType(FieldType, FieldSubType, FieldScale, FieldSize,
121     FieldPrec, FieldLen : Integer) : String;
122     function GetCharacterSets(CharSetId, Collation : integer; CollateOnly : Boolean) : String;
123     procedure ExtractObject(ObjectType : TExtractObjectTypes; ObjectName : String = '';
124     ExtractTypes : TExtractTypes = []);
125     property DatabaseInfo : TIBDatabaseInfo read FDatabaseInfo;
126     property Items : TStrings read FMetaData;
127    
128     published
129     { Published declarations }
130     property Database : TIBDatabase read GetDatabase write SetDatabase;
131     property Transaction : TIBTransaction read GetTransaction write SetTransaction;
132     property ShowSystem: Boolean read FShowSystem write FShowSystem;
133     end;
134    
135     TSQLType = record
136     SqlType : Integer;
137     TypeName : String;
138     end;
139    
140     TPrivTypes = record
141     PrivFlag : Integer;
142     PrivString : String;
143     end;
144    
145 tony 45 TSQLTypes = Array[0..14] of TSQLType;
146 tony 33
147     const
148    
149     priv_UNKNOWN = 1;
150     priv_SELECT = 2;
151     priv_INSERT = 4;
152     priv_UPDATE = 8;
153     priv_DELETE = 16;
154     priv_EXECUTE = 32;
155     priv_REFERENCES = 64;
156 tony 47 priv_USAGE = 128;
157 tony 33
158 tony 47 PrivTypes : Array[0..6] of TPrivTypes = (
159 tony 33 (PrivFlag : priv_DELETE; PrivString : 'DELETE' ),
160     (PrivFlag : priv_EXECUTE; PrivString : 'EXECUTE' ),
161     (PrivFlag : priv_INSERT; PrivString : 'INSERT' ),
162     (PrivFlag : priv_SELECT; PrivString : 'SELECT' ),
163     (PrivFlag : priv_UPDATE; PrivString : 'UPDATE' ),
164 tony 47 (PrivFlag : priv_REFERENCES; PrivString : 'REFERENCES'),
165     (PrivFlag : priv_USAGE; PrivString : 'USAGE' ));
166 tony 33
167     ColumnTypes : TSQLTypes = (
168     (SqlType : blr_short; TypeName : 'SMALLINT'), { NTX: keyword }
169     (SqlType : blr_long; TypeName : 'INTEGER'), { NTX: keyword }
170     (SqlType : blr_quad; TypeName : 'QUAD'), { NTX: keyword }
171     (SqlType : blr_float; TypeName : 'FLOAT'), { NTX: keyword }
172     (SqlType : blr_text; TypeName : 'CHAR'), { NTX: keyword }
173     (SqlType : blr_double; TypeName : 'DOUBLE PRECISION'), { NTX: keyword }
174     (SqlType : blr_varying; TypeName : 'VARCHAR'), { NTX: keyword }
175     (SqlType : blr_cstring; TypeName : 'CSTRING'), { NTX: keyword }
176     (SqlType : blr_blob_id; TypeName : 'BLOB_ID'), { NTX: keyword }
177     (SqlType : blr_blob; TypeName : 'BLOB'), { NTX: keyword }
178     (SqlType : blr_sql_time; TypeName : 'TIME'), { NTX: keyword }
179     (SqlType : blr_sql_date; TypeName : 'DATE'), { NTX: keyword }
180     (SqlType : blr_timestamp; TypeName : 'TIMESTAMP'), { NTX: keyword }
181 tony 45 (SqlType : blr_int64; TypeName : 'INT64'),
182     (SqlType : blr_bool; TypeName : 'BOOLEAN'));
183 tony 33
184     SubTypes : Array[0..8] of String = (
185     'UNKNOWN', { NTX: keyword }
186     'TEXT', { NTX: keyword }
187     'BLR', { NTX: keyword }
188     'ACL', { NTX: keyword }
189     'RANGES', { NTX: keyword }
190     'SUMMARY', { NTX: keyword }
191     'FORMAT', { NTX: keyword }
192     'TRANSACTION_DESCRIPTION', { NTX: keyword }
193     'EXTERNAL_FILE_DESCRIPTION'); { NTX: keyword }
194    
195     IntegralSubtypes : Array[0..2] of String = (
196     'UNKNOWN', { Defined type, NTX: keyword }
197     'NUMERIC', { NUMERIC, NTX: keyword }
198     'DECIMAL'); { DECIMAL, NTX: keyword }
199    
200     ODS_VERSION6 = 6; { on-disk structure as of v3.0 }
201     ODS_VERSION7 = 7; { new on disk structure for fixing index bug }
202     ODS_VERSION8 = 8; { new btree structure to support pc semantics }
203     ODS_VERSION9 = 9; { btree leaf pages are always propogated up }
204     ODS_VERSION10 = 10; { V6.0 features. SQL delimited idetifier,
205     SQLDATE, and 64-bit exact numeric
206     type }
207 tony 47 ODS_VERSION12 = 12; {Firebird 3}
208 tony 33
209     { flags for RDB$FILE_FLAGS }
210     FILE_shadow = 1;
211     FILE_inactive = 2;
212     FILE_manual = 4;
213     FILE_cache = 8;
214     FILE_conditional = 16;
215    
216     { flags for RDB$LOG_FILES }
217     LOG_serial = 1;
218     LOG_default = 2;
219     LOG_raw = 4;
220     LOG_overflow = 8;
221    
222    
223    
224     MAX_INTSUBTYPES = 2;
225     MAXSUBTYPES = 8; { Top of subtypes array }
226    
227     { Object types used in RDB$DEPENDENCIES and RDB$USER_PRIVILEGES }
228    
229     obj_relation = 0;
230     obj_view = 1;
231     obj_trigger = 2;
232     obj_computed = 3;
233     obj_validation = 4;
234     obj_procedure = 5;
235     obj_expression_index = 6;
236     obj_exception = 7;
237     obj_user = 8;
238     obj_field = 9;
239     obj_index = 10;
240     obj_count = 11;
241     obj_user_group = 12;
242     obj_sql_role = 13;
243    
244     implementation
245    
246 tony 47 uses FBMessages, IBDataOutput;
247 tony 45
248 tony 33 const
249     TERM = ';';
250     ProcTerm = '^';
251    
252     CollationSQL =
253     'SELECT CST.RDB$CHARACTER_SET_NAME, COL.RDB$COLLATION_NAME, CST.RDB$DEFAULT_COLLATE_NAME ' +
254     'FROM RDB$COLLATIONS COL JOIN RDB$CHARACTER_SETS CST ON ' +
255     ' COL.RDB$CHARACTER_SET_ID = CST.RDB$CHARACTER_SET_ID ' +
256     'WHERE ' +
257     ' COL.RDB$COLLATION_ID = :COLLATION AND ' +
258     ' CST.RDB$CHARACTER_SET_ID = :CHAR_SET_ID ' +
259     'ORDER BY COL.RDB$COLLATION_NAME, CST.RDB$CHARACTER_SET_NAME';
260    
261     NonCollationSQL =
262     'SELECT CST.RDB$CHARACTER_SET_NAME ' +
263     'FROM RDB$CHARACTER_SETS CST ' +
264     'WHERE CST.RDB$CHARACTER_SET_ID = :CHARSETID ' +
265     'ORDER BY CST.RDB$CHARACTER_SET_NAME';
266    
267     PrecisionSQL =
268     'SELECT * FROM RDB$FIELDS ' +
269     'WHERE RDB$FIELD_NAME = :FIELDNAME';
270    
271     ArraySQL =
272     'SELECT * FROM RDB$FIELD_DIMENSIONS FDIM ' +
273     'WHERE ' +
274     ' FDIM.RDB$FIELD_NAME = :FIELDNAME ' +
275     'ORDER BY FDIM.RDB$DIMENSION';
276    
277     { TIBExtract }
278    
279     { ArrayDimensions
280     Functional description
281     Retrieves the dimensions of arrays and prints them.
282    
283     Parameters: fieldname -- the actual name of the array field }
284    
285     function TIBExtract.GetArrayField(FieldName: String): String;
286     var
287     qryArray : TIBSQL;
288     begin
289     qryArray := TIBSQL.Create(FDatabase);
290 tony 45 Result := '';
291 tony 33 qryArray.SQL.Add(ArraySQL);
292     qryArray.Params.ByName('FieldName').AsString := FieldName;
293     qryArray.ExecQuery;
294    
295     { Format is [lower:upper, lower:upper,..] }
296    
297 tony 45 if not qryArray.Eof then
298 tony 33 begin
299 tony 45 Result := '[';
300     while not qryArray.Eof do
301     begin
302     if (qryArray.FieldByName('RDB$DIMENSION').AsInteger > 0) then
303     Result := Result + ', ';
304     Result := Result + qryArray.FieldByName('RDB$LOWER_BOUND').AsString + ':' +
305     qryArray.FieldByName('RDB$UPPER_BOUND').AsString;
306     qryArray.Next;
307     end;
308     Result := Result + '] ';
309 tony 33 end;
310    
311     qryArray.Free;
312    
313     end;
314    
315     constructor TIBExtract.Create(AOwner: TComponent);
316     begin
317     inherited;
318     FMetaData := TStringList.Create;
319     FDatabaseInfo := TIBDatabaseInfo.Create(nil);
320     FDatabaseInfo.Database := FDatabase;
321     if AOwner is TIBDatabase then
322     Database := TIBDatabase(AOwner);
323     if AOwner is TIBTransaction then
324     Transaction := TIBTransaction(AOwner);
325     end;
326    
327     destructor TIBExtract.Destroy;
328     begin
329     FMetaData.Free;
330     FDatabasEInfo.Free;
331     inherited;
332     end;
333    
334 tony 47 function TIBExtract.ExtractDDL(Flag: Boolean; TableName: String; IncludeData: boolean = false) : Boolean;
335 tony 33 var
336     DidConnect : Boolean;
337     DidStart : Boolean;
338     begin
339     Result := true;
340     DidConnect := false;
341     DidStart := false;
342    
343     if not FDatabase.Connected then
344     begin
345     FDatabase.Connected := true;
346     didConnect := true;
347     end;
348    
349     FMetaData.Add(Format('SET SQL DIALECT %d;', [FDatabase.SQLDialect]));
350 tony 45 FMetaData.Add('SET AUTODDL ON;');
351 tony 33 FMetaData.Add('');
352    
353     if not FTransaction.Active then
354     begin
355     FTransaction.StartTransaction;
356     DidStart := true;
357     end;
358    
359     if TableName <> '' then
360     begin
361     if not ExtractListTable(TableName, '', true) then
362     Result := false;
363     end
364     else
365     begin
366     ListCreateDb;
367     ListFilters;
368     ListFunctions;
369     ListDomains;
370     ListAllTables(flag);
371 tony 47 if IncludeData then
372     ListData('');
373 tony 33 ListIndex;
374     ListForeign;
375 tony 47 if IncludeData then
376     ListGenerators('',[etData])
377     else
378     ListGenerators;
379 tony 33 ListViews;
380     ListCheck;
381     ListException;
382 tony 47 ListProcs(pdCreateStub);
383     ListTriggers;
384     ListProcs(pdAlterProc);
385 tony 33 ListGrants;
386     end;
387    
388     if DidStart then
389     FTransaction.Commit;
390    
391     if DidConnect then
392     FDatabase.Connected := false;
393     end;
394    
395     { ExtractListTable
396     Functional description
397     Shows columns, types, info for a given table name
398     and text of views.
399     If a new_name is passed, substitute it for relation_name
400    
401     relation_name -- Name of table to investigate
402     new_name -- Name of a new name for a replacement table
403     domain_flag -- extract needed domains before the table }
404    
405     function TIBExtract.ExtractListTable(RelationName, NewName: String;
406 tony 45 DomainFlag: Boolean): Boolean;
407 tony 33 const
408     TableListSQL =
409     'SELECT * FROM RDB$RELATIONS REL JOIN RDB$RELATION_FIELDS RFR ON ' + {Do Not Localize}
410     ' RFR.RDB$RELATION_NAME = REL.RDB$RELATION_NAME JOIN RDB$FIELDS FLD ON ' +
411     ' RFR.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' +
412     'WHERE REL.RDB$RELATION_NAME = :RelationName ' +
413     'ORDER BY RFR.RDB$FIELD_POSITION, RFR.RDB$FIELD_NAME';
414    
415     ConstraintSQL =
416     'SELECT RCO.RDB$CONSTRAINT_NAME, RDB$CONSTRAINT_TYPE, RDB$RELATION_NAME, ' +
417     'RDB$DEFERRABLE, RDB$INITIALLY_DEFERRED, RDB$INDEX_NAME, RDB$TRIGGER_NAME ' +
418     'FROM RDB$RELATION_CONSTRAINTS RCO, RDB$CHECK_CONSTRAINTS CON ' +
419     'WHERE ' +
420     ' CON.RDB$TRIGGER_NAME = :FIELDNAME AND ' +
421     ' CON.RDB$CONSTRAINT_NAME = RCO.RDB$CONSTRAINT_NAME AND ' +
422     ' RCO.RDB$CONSTRAINT_TYPE = ''NOT NULL'' AND ' +
423     ' RCO.RDB$RELATION_NAME = :RELATIONNAME';
424    
425     RelConstraintsSQL =
426     'SELECT * FROM RDB$RELATION_CONSTRAINTS RELC ' +
427     'WHERE ' +
428     ' (RELC.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'' OR ' +
429     ' RELC.RDB$CONSTRAINT_TYPE = ''UNIQUE'') AND ' +
430     ' RELC.RDB$RELATION_NAME = :RELATIONNAME ' +
431 tony 47 'ORDER BY RELC.RDB$CONSTRAINT_TYPE desc, RELC.RDB$CONSTRAINT_NAME';
432 tony 33
433 tony 45 GetGeneratorSQL =
434     'SELECT * FROM RDB$GENERATORS WHERE RDB$GENERATOR_NAME = :GENERATOR';
435    
436 tony 33 var
437     Collation, CharSetId : integer;
438     i : integer;
439     ColList, Column, Constraint : String;
440     SubType : integer;
441     IntChar : integer;
442 tony 45 qryTables, qryPrecision, qryConstraints, qryRelConstraints, qryGenerators : TIBSQL;
443 tony 33 PrecisionKnown, ValidRelation : Boolean;
444     FieldScale, FieldType : Integer;
445 tony 45 CreateTable: string;
446     TableType: integer;
447 tony 33 begin
448     Result := true;
449     ColList := '';
450     IntChar := 0;
451     ValidRelation := false;
452    
453     if DomainFlag then
454     ListDomains(RelationName);
455     qryTables := TIBSQL.Create(FDatabase);
456     qryPrecision := TIBSQL.Create(FDatabase);
457     qryConstraints := TIBSQL.Create(FDatabase);
458     qryRelConstraints := TIBSQL.Create(FDatabase);
459 tony 45 qryGenerators := TIBSQL.Create(FDatabase);
460 tony 33 try
461     qryTables.SQL.Add(TableListSQL);
462 tony 47 RelationName := trim(RelationName);
463 tony 33 qryTables.Params.ByName('RelationName').AsString := RelationName;
464     qryTables.ExecQuery;
465     qryPrecision.SQL.Add(PrecisionSQL);
466     qryConstraints.SQL.Add(ConstraintSQL);
467     qryRelConstraints.SQL.Add(RelConstraintsSQL);
468 tony 45 qryGenerators.SQL.Add(GetGeneratorSQL);
469 tony 33 if not qryTables.Eof then
470     begin
471     ValidRelation := true;
472 tony 45 TableType := qryTables.FieldByName('RDB$RELATION_TYPE').AsInteger;
473 tony 33 if (not qryTables.FieldByName('RDB$OWNER_NAME').IsNull) and
474     (Trim(qryTables.FieldByName('RDB$OWNER_NAME').AsString) <> '') then
475     FMetaData.Add(Format('%s/* Table: %s, Owner: %s */%s',
476 tony 47 [LineEnding, RelationName,
477     qryTables.FieldByName('RDB$OWNER_NAME').AsString, LineEnding]));
478 tony 45 if TableType > 3 then
479     CreateTable := 'CREATE GLOBAL TEMPORARY TABLE'
480     else
481     CreateTable := 'CREATE TABLE';
482 tony 33 if NewName <> '' then
483 tony 45 FMetaData.Add(Format('%s %s ', [CreateTable,QuoteIdentifier(FDatabase.SQLDialect,NewName)]))
484 tony 33 else
485 tony 45 FMetaData.Add(Format('%s %s ', [CreateTable,QuoteIdentifier(FDatabase.SQLDialect,RelationName)]));
486 tony 33 if not qryTables.FieldByName('RDB$EXTERNAL_FILE').IsNull then
487     FMetaData.Add(Format('EXTERNAL FILE %s ',
488     [QuotedStr(qryTables.FieldByName('RDB$EXTERNAL_FILE').AsString)]));
489     FMetaData.Add('(');
490     end;
491    
492     while not qryTables.Eof do
493     begin
494     Column := ' ' + QuoteIdentifier(FDatabase.SQLDialect, qryTables.FieldByName('RDB$FIELD_NAME').AsString) + TAB;
495    
496     { Check first for computed fields, then domains.
497     If this is a known domain, then just print the domain rather than type
498     Domains won't have length, array, or blob definitions, but they
499     may have not null, default and check overriding their definitions }
500    
501     if not qryTables.FieldByName('rdb$computed_blr').IsNull then
502     begin
503     Column := Column + ' COMPUTED BY ';
504     if not qryTables.FieldByName('RDB$COMPUTED_SOURCE').IsNull then
505     Column := Column + PrintValidation(qryTables.FieldByName('RDB$COMPUTED_SOURCE').AsString, true);
506     end
507     else
508     begin
509     FieldType := qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger;
510     FieldScale := qryTables.FieldByName('RDB$FIELD_SCALE').AsInteger;
511     if not ((Copy(qryTables.FieldByName('RDB$FIELD_NAME1').AsString, 1, 4) = 'RDB$') and
512     (qryTables.FieldByName('RDB$FIELD_NAME1').AsString[5] in ['0'..'9'])) and
513     (qryTables.FieldByName('RDB$SYSTEM_FLAG').AsInteger <> 1) then
514     begin
515 tony 47 Column := Column + QuoteIdentifier(FDatabase.SQLDialect, trim(qryTables.FieldByName('RDB$FIELD_NAME1').AsString));
516 tony 33 { International character sets }
517     if (qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying])
518     and (not qryTables.FieldByName('RDB$COLLATION_ID').IsNull)
519     and (qryTables.FieldByName('RDB$COLLATION_ID').AsInteger <> 0) then
520     begin
521     Collation := qryTables.FieldByName('RDB$COLLATION_ID').AsInteger;
522     Column := Column + GetCharacterSets(qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsShort,
523     Collation, true);
524     end;
525     end
526     else
527     begin
528     { Look through types array }
529     for i := Low(Columntypes) to High(ColumnTypes) do
530     begin
531     PrecisionKnown := false;
532     if qryTables.FieldByname('RDB$FIELD_TYPE').AsShort = ColumnTypes[i].SQLType then
533     begin
534    
535     if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then
536     begin
537     { Handle Integral subtypes NUMERIC and DECIMAL }
538     if qryTables.FieldByName('RDB$FIELD_TYPE').AsInteger in
539     [blr_short, blr_long, blr_int64] then
540     begin
541     qryPrecision.Params.ByName('FIELDNAME').AsString :=
542     qryTables.FieldByName('RDB$FIELD_NAME1').AsString;
543     qryPrecision.ExecQuery;
544    
545     { We are ODS >= 10 and could be any Dialect }
546     if not qryPrecision.FieldByName('RDB$FIELD_PRECISION').IsNull then
547     begin
548     { We are Dialect >=3 since FIELD_PRECISION is non-NULL }
549     if (qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and
550     (qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then
551     begin
552     Column := column + Format('%s(%d, %d)',
553     [IntegralSubtypes[qryPrecision.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger],
554     qryPrecision.FieldByName('RDB$FIELD_PRECISION').AsInteger,
555     -qryPrecision.FieldByName('RDB$FIELD_SCALE').AsInteger]);
556     PrecisionKnown := TRUE;
557     end;
558     end;
559     qryPrecision.Close;
560     end;
561     end;
562    
563     if PrecisionKnown = FALSE then
564     begin
565     { Take a stab at numerics and decimals }
566     if (FieldType = blr_short) and (FieldScale < 0) then
567     Column := Column + Format('NUMERIC(4, %d)', [-FieldScale])
568     else
569     if (FieldType = blr_long) and (FieldScale < 0) then
570     Column := Column + Format('NUMERIC(9, %d)', [-FieldScale])
571     else
572     if (FieldType = blr_double) and (FieldScale < 0) then
573     Column := Column + Format('NUMERIC(15, %d)', [-FieldScale])
574     else
575     Column := Column + ColumnTypes[i].TypeName;
576     end;
577     end;
578     end;
579     if FieldType in [blr_text, blr_varying] then
580     if qryTables.FieldByName('RDB$CHARACTER_LENGTH').IsNull then
581     Column := Column + Format('(%d)', [qryTables.FieldByName('RDB$FIELD_LENGTH').AsInteger])
582     else
583     Column := Column + Format('(%d)', [qryTables.FieldByName('RDB$CHARACTER_LENGTH').AsInteger]);
584    
585     { Catch arrays after printing the type }
586    
587 tony 45 if not qryTables.FieldByName('RDB$DIMENSIONS').IsNull and (qryTables.FieldByName('RDB$DIMENSIONS').AsInteger > 0) then
588     Column := column + GetArrayField(qryTables.FieldByName('RDB$FIELD_SOURCE').AsString);
589 tony 33
590     if FieldType = blr_blob then
591     begin
592     subtype := qryTables.FieldByName('RDB$FIELD_SUB_TYPE').AsShort;
593     Column := Column + ' SUB_TYPE ';
594     if (subtype > 0) and (subtype <= MAXSUBTYPES) then
595     Column := Column + SubTypes[subtype]
596     else
597     Column := Column + IntToStr(subtype);
598     column := Column + Format(' SEGMENT SIZE %d',
599     [qryTables.FieldByName('RDB$SEGMENT_LENGTH').AsInteger]);
600     end;
601    
602     { International character sets }
603     if ((FieldType in [blr_text, blr_varying]) or
604     (FieldType = blr_blob)) and
605     (not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull) and
606     (qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger <> 0) then
607     begin
608     { Override rdb$fields id with relation_fields if present }
609    
610     CharSetId := 0;
611     if not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull then
612     CharSetId := qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger;
613    
614     Column := Column + GetCharacterSets(CharSetId, 0, false);
615     intchar := 1;
616     end;
617     end;
618    
619 tony 45 {Firebird 3 introduces IDENTITY columns. We need to check for them here}
620     if qryTables.HasField('RDB$GENERATOR_NAME') then
621     begin
622     qryGenerators.ParamByName('GENERATOR').AsString := qryTables.FieldByName('RDB$GENERATOR_NAME').AsString;
623     qryGenerators.ExecQuery;
624     if not qryGenerators.Eof then
625     begin
626     Column := Column + Format(' GENERATED BY DEFAULT AS IDENTITY START WITH %d',
627     [qryGenerators.FieldByName('RDB$INITIAL_VALUE').AsInteger]);
628     end;
629     qryGenerators.Close;
630     end;
631    
632 tony 33 { Handle defaults for columns }
633     { Originally This called PrintMetadataTextBlob,
634     should no longer need }
635     if not qryTables.FieldByName('RDB$DEFAULT_SOURCE').IsNull then
636     Column := Column + ' ' + qryTables.FieldByName('RDB$DEFAULT_SOURCE').AsString;
637    
638    
639     { The null flag is either 1 or null (for nullable) . if there is
640     a constraint name, print that too. Domains cannot have named
641     constraints. The column name is in rdb$trigger_name in
642     rdb$check_constraints. We hope we get at most one row back. }
643    
644     if qryTables.FieldByName('RDB$NULL_FLAG').AsInteger = 1 then
645     begin
646     qryConstraints.Params.ByName('FIELDNAME').AsString := qryTables.FieldByName('RDB$FIELD_NAME').AsString;
647     qryConstraints.Params.ByName('RELATIONNAME').AsString := qryTables.FieldByName('RDB$RELATION_NAME').AsString;
648     qryConstraints.ExecQuery;
649    
650     while not qryConstraints.Eof do
651     begin
652     if Pos('INTEG', qryConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then
653     Column := Column + Format(' CONSTRAINT %s',
654     [ QuoteIdentifier( FDatabase.SQLDialect,
655     qryConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString)]);
656     qryConstraints.Next;
657     end;
658     qryConstraints.Close;
659     Column := Column + ' NOT NULL';
660     end;
661    
662     if ((FieldType in [blr_text, blr_varying]) or
663     (FieldType = blr_blob)) and
664     (not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull) and
665     (qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger <> 0) and
666     (intchar <> 0) then
667     begin
668     Collation := 0;
669     if not qryTables.FieldByName('RDB$COLLATION_ID1').IsNull then
670     Collation := qryTables.FieldByName('RDB$COLLATION_ID1').AsInteger
671     else
672     if not qryTables.FieldByName('RDB$COLLATION_ID').IsNull then
673     Collation := qryTables.FieldByName('RDB$COLLATION_ID').AsInteger;
674    
675     CharSetId := 0;
676     if not qryTables.FieldByName('RDB$CHARACTER_SET_ID').IsNull then
677     CharSetId := qryTables.FieldByName('RDB$CHARACTER_SET_ID').AsInteger;
678    
679     if Collation <> 0 then
680     Column := Column + GetCharacterSets(CharSetId, Collation, true);
681     end;
682     end;
683     qryTables.Next;
684     if not qryTables.Eof then
685     Column := Column + ',';
686     FMetaData.Add(Column);
687     end;
688    
689     { Do primary and unique keys only. references come later }
690    
691     qryRelConstraints.Params.ByName('relationname').AsString := RelationName;
692     qryRelConstraints.ExecQuery;
693     while not qryRelConstraints.Eof do
694     begin
695     Constraint := '';
696     FMetaData.Strings[FMetaData.Count - 1] := FMetaData.Strings[FMetaData.Count - 1] + ',';
697     { If the name of the constraint is not INTEG..., print it }
698     if Pos('INTEG', qryRelConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then
699     Constraint := Constraint + 'CONSTRAINT ' +
700     QuoteIdentifier(FDatabase.SQLDialect,
701     qryRelConstraints.FieldByName('RDB$CONSTRAINT_NAME').AsString);
702    
703    
704     if Pos('PRIMARY', qryRelConstraints.FieldByName('RDB$CONSTRAINT_TYPE').AsString) = 1 then
705     begin
706     FMetaData.Add(Constraint + Format(' PRIMARY KEY (%s)',
707     [GetIndexSegments(qryRelConstraints.FieldByName('RDB$INDEX_NAME').AsString)]));
708     end
709     else
710     if Pos('UNIQUE', qryRelConstraints.FieldByName('RDB$CONSTRAINT_TYPE').AsString) = 1 then
711     begin
712     FMetaData.Add(Constraint + Format(' UNIQUE (%s)',
713     [GetIndexSegments(qryRelConstraints.FieldByName('RDB$INDEX_NAME').AsString)]));
714     end;
715     qryRelConstraints.Next;
716     end;
717     if ValidRelation then
718 tony 45 begin
719     if TableType = 4 then
720 tony 47 FMetaData.Add(' ) ON COMMIT PRESERVE ROWS ' + TERM)
721     else
722     FMetaData.Add(')' + TERM);
723 tony 45 end;
724 tony 33 finally
725     qryTables.Free;
726     qryPrecision.Free;
727     qryConstraints.Free;
728     qryRelConstraints.Free;
729 tony 45 qryGenerators.Free;
730 tony 33 end;
731     end;
732    
733     { ExtractListView
734     Functional description
735     Show text of the specified view.
736     Use a SQL query to get the info and print it.
737     Note: This should also contain check option }
738    
739     procedure TIBExtract.ExtractListView(ViewName: String);
740     const
741     ViewsSQL = 'SELECT * FROM RDB$RELATIONS REL ' +
742     ' WHERE ' +
743     ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' +
744     ' NOT REL.RDB$VIEW_BLR IS NULL AND ' +
745     ' REL.RDB$RELATION_NAME = :VIEWNAME AND ' +
746     ' REL.RDB$FLAGS = 1 ' +
747     'ORDER BY REL.RDB$RELATION_ID ';
748    
749     ColumnsSQL = 'SELECT * FROM RDB$RELATION_FIELDS RFR ' +
750     'WHERE ' +
751     ' RFR.RDB$RELATION_NAME = :RELATIONNAME ' +
752     'ORDER BY RFR.RDB$FIELD_POSITION ';
753    
754     var
755     qryViews, qryColumns : TIBSQL;
756     RelationName, ColList : String;
757     begin
758     qryViews := TIBSQL.Create(FDatabase);
759     qryColumns := TIBSQL.Create(FDatabase);
760     try
761     qryViews.SQL.Add(ViewsSQL);
762     qryViews.Params.ByName('viewname').AsString := ViewName;
763     qryViews.ExecQuery;
764     while not qryViews.Eof do
765     begin
766     FMetaData.Add('');
767     RelationName := QuoteIdentifier(FDatabase.SQLDialect,
768     qryViews.FieldByName('RDB$RELATION_NAME').AsString);
769     FMetaData.Add(Format('%s/* View: %s, Owner: %s */%s', [
770     RelationName,
771     Trim(qryViews.FieldByName('RDB$OWNER_NAME').AsString)]));
772     FMetaData.Add('');
773     FMetaData.Add(Format('CREATE VIEW %s (', [RelationName]));
774    
775     { Get Column List}
776     qryColumns.SQL.Add(ColumnsSQL);
777     qryColumns.Params.ByName('relationname').AsString := RelationName;
778     qryColumns.ExecQuery;
779     while not qryColumns.Eof do
780     begin
781     ColList := ColList + QuoteIdentifier(FDatabase.SQLDialect,
782     qryColumns.FieldByName('RDB$FIELD_NAME').AsString);
783     qryColumns.Next;
784     if not qryColumns.Eof then
785     ColList := ColList + ', ';
786     end;
787     FMetaData.Add(ColList + ') AS');
788     FMetaData.Add(qryViews.FieldByName('RDB$VIEW_SOURCE').AsString + Term);
789     qryViews.Next;
790     end;
791     finally
792     qryViews.Free;
793     qryColumns.Free;
794     end;
795     end;
796    
797     function TIBExtract.GetCharacterSets(CharSetId, Collation: integer;
798     CollateOnly: Boolean): String;
799     var
800     CharSetSQL : TIBSQL;
801     DidActivate : Boolean;
802     begin
803 tony 45 Result := '';
804 tony 33 if not FTransaction.Active then
805     begin
806     FTransaction.StartTransaction;
807     DidActivate := true;
808     end
809     else
810     DidActivate := false;
811     CharSetSQL := TIBSQL.Create(FDatabase);
812     try
813     if Collation <> 0 then
814     begin
815     CharSetSQL.SQL.Add(CollationSQL);
816     CharSetSQL.Params.ByName('Char_Set_Id').AsInteger := CharSetId;
817     CharSetSQL.Params.ByName('Collation').AsInteger := Collation;
818     CharSetSQL.ExecQuery;
819    
820     { Is specified collation the default collation for character set? }
821     if (Trim(CharSetSQL.FieldByName('RDB$DEFAULT_COLLATE_NAME').AsString) =
822     Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString)) then
823     begin
824     if not CollateOnly then
825     Result := ' CHARACTER SET ' + Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString);
826     end
827     else
828     if CollateOnly then
829     Result := ' COLLATE ' + Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString)
830     else
831     Result := ' CHARACTER SET ' +
832     Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString) +
833     ' COLLATE ' +
834     Trim(CharSetSQL.FieldByName('RDB$COLLATION_NAME').AsString);
835     end
836     else
837     if CharSetId <> 0 then
838     begin
839     CharSetSQL.SQL.Add(NonCollationSQL);
840     CharSetSQL.Params.ByName('CharSetId').AsShort := CharSetId;
841     CharSetSQL.ExecQuery;
842     Result := ' CHARACTER SET ' + Trim(CharSetSQL.FieldByName('RDB$CHARACTER_SET_NAME').AsString);
843     end;
844     finally
845     CharSetSQL.Free;
846     end;
847     if DidActivate then
848     FTransaction.Commit;
849     end;
850    
851 tony 47 procedure TIBExtract.Add2MetaData(const Msg: string; IsError: boolean);
852     begin
853     FMetaData.Add(Msg);
854     end;
855    
856 tony 33 function TIBExtract.GetDatabase: TIBDatabase;
857     begin
858     result := FDatabase;
859     end;
860    
861     { GetIndexSegments
862     Functional description
863     returns the list of columns in an index. }
864    
865 tony 45 function TIBExtract.GetIndexSegments(indexname: String): String;
866 tony 33 const
867     IndexNamesSQL =
868     'SELECT * FROM RDB$INDEX_SEGMENTS SEG ' +
869     'WHERE SEG.RDB$INDEX_NAME = :INDEXNAME ' +
870     'ORDER BY SEG.RDB$FIELD_POSITION';
871    
872     var
873     qryColNames : TIBSQL;
874     begin
875     { Query to get column names }
876     Result := '';
877     qryColNames := TIBSQL.Create(FDatabase);
878     try
879     qryColNames.SQL.Add(IndexNamesSQL);
880     qryColNames.Params.ByName('IndexName').AsString := IndexName;
881     qryColNames.ExecQuery;
882     while not qryColNames.Eof do
883     begin
884     { Place a comma and a blank between each segment column name }
885    
886     Result := Result + QuoteIdentifier(FDatabase.SQLDialect,
887     qryColNames.FieldByName('RDB$FIELD_NAME').AsString);
888     qryColNames.Next;
889     if not qryColNames.Eof then
890     Result := Result + ', ';
891     end;
892     finally
893     qryColNames.Free;
894     end;
895     end;
896    
897     function TIBExtract.GetTransaction: TIBTransaction;
898     begin
899     Result := FTransaction;
900     end;
901    
902 tony 45 function TIBExtract.GetTriggerType(TypeID: integer): string;
903     var separator: string;
904     begin
905     if TypeID and $2000 <> 0 then
906     {database trigger}
907     begin
908     Result := 'ON ';
909     case TypeID of
910     $2000:
911 tony 47 Result += 'CONNECT';
912 tony 45 $2001:
913 tony 47 Result += 'DISCONNECT';
914 tony 45 $2002:
915 tony 47 Result +='TRANSACTION START';
916 tony 45 $2003:
917 tony 47 Result += 'TRANSACTION COMMIT';
918 tony 45 $2004:
919 tony 47 Result += 'TRANSACTION ROLLBACK';
920 tony 45 end;
921     end
922     else
923     begin
924     Inc(TypeID);
925     if TypeID and $01 <> 0 then
926     Result := 'AFTER '
927     else
928     Result := 'BEFORE ';
929     TypeID := TypeID shr 1;
930     separator := '';
931     repeat
932     Result += separator;
933     separator := ' or ';
934     case TypeID and $03 of
935     1:
936     Result += 'INSERT';
937     2:
938     Result += 'UPDATE';
939     3:
940     Result += 'DELETE';
941     end;
942     TypeID := TypeID shr 2;
943     until TypeID = 0;
944     end;
945     end;
946    
947 tony 33 { ListAllGrants
948     Functional description
949     Print the permissions on all user tables.
950     Get separate permissions on table/views and then procedures }
951    
952     procedure TIBExtract.ListGrants;
953     const
954     SecuritySQL = 'SELECT * FROM RDB$RELATIONS ' +
955     'WHERE ' +
956     ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' +
957     ' RDB$SECURITY_CLASS STARTING WITH ''SQL$'' ' +
958     'ORDER BY RDB$RELATION_NAME';
959    
960 tony 47 ProcedureSQL = 'select * from RDB$PROCEDURES '+
961     'Where RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL ' +
962 tony 33 'Order BY RDB$PROCEDURE_NAME';
963    
964 tony 47 ExceptionSQL = 'select * from RDB$EXCEPTIONS '+
965     'Where RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL ' +
966     'Order BY RDB$EXCEPTION_NAME';
967    
968     GeneratorSQL = 'select * from RDB$GENERATORS '+
969     'Where RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL ' +
970     'Order BY RDB$GENERATOR_NAME';
971    
972 tony 33 var
973     qryRoles : TIBSQL;
974     RelationName : String;
975     begin
976     ListRoles;
977     qryRoles := TIBSQL.Create(FDatabase);
978     try
979     { This version of cursor gets only sql tables identified by security class
980     and misses views, getting only null view_source }
981    
982     FMetaData.Add('');
983     FMetaData.Add('/* Grant permissions for this database */');
984     FMetaData.Add('');
985    
986     try
987     qryRoles.SQL.Text := SecuritySQL;
988     qryRoles.ExecQuery;
989     while not qryRoles.Eof do
990     begin
991     RelationName := Trim(qryRoles.FieldByName('rdb$relation_Name').AsString);
992     ShowGrants(RelationName, Term);
993     qryRoles.Next;
994     end;
995     finally
996     qryRoles.Close;
997     end;
998    
999     ShowGrantRoles(Term);
1000    
1001 tony 47 qryRoles.SQL.Text := ExceptionSQL;
1002     qryRoles.ExecQuery;
1003     try
1004     while not qryRoles.Eof do
1005     begin
1006     ShowGrants(Trim(qryRoles.FieldByName('RDB$EXCEPTION_NAME').AsString), Term);
1007     qryRoles.Next;
1008     end;
1009     finally
1010     qryRoles.Close;
1011     end;
1012    
1013     qryRoles.SQL.Text := GeneratorSQL;
1014     qryRoles.ExecQuery;
1015     try
1016     while not qryRoles.Eof do
1017     begin
1018     ShowGrants(Trim(qryRoles.FieldByName('RDB$GENERATOR_NAME').AsString), Term);
1019     qryRoles.Next;
1020     end;
1021     finally
1022     qryRoles.Close;
1023     end;
1024    
1025 tony 33 qryRoles.SQL.Text := ProcedureSQL;
1026     qryRoles.ExecQuery;
1027     try
1028     while not qryRoles.Eof do
1029     begin
1030     ShowGrants(Trim(qryRoles.FieldByName('RDB$PROCEDURE_NAME').AsString), Term);
1031     qryRoles.Next;
1032     end;
1033     finally
1034     qryRoles.Close;
1035     end;
1036     finally
1037     qryRoles.Free;
1038     end;
1039     end;
1040    
1041     { ListAllProcs
1042     Functional description
1043     Shows text of a stored procedure given a name.
1044     or lists procedures if no argument.
1045     Since procedures may reference each other, we will create all
1046     dummy procedures of the correct name, then alter these to their
1047     correct form.
1048     Add the parameter names when these procedures are created.
1049    
1050     procname -- Name of procedure to investigate }
1051    
1052 tony 47 procedure TIBExtract.ListProcs(ProcDDLType: TProcDDLType;
1053     ProcedureName: String; IncludeGrants: boolean);
1054 tony 33 const
1055     CreateProcedureStr1 = 'CREATE PROCEDURE %s ';
1056     CreateProcedureStr2 = 'BEGIN EXIT; END %s%s';
1057 tony 47 ProcedureSQL = {Order procedures by dependency order and then procedure name}
1058     'with recursive Procs as ( ' +
1059     'Select RDB$PROCEDURE_NAME, 1 as ProcLevel from RDB$PROCEDURES ' +
1060     'UNION ALL ' +
1061     'Select D.RDB$DEPENDED_ON_NAME, ProcLevel + 1 From RDB$DEPENDENCIES D ' +
1062     'JOIN Procs on Procs.RDB$PROCEDURE_NAME = D.RDB$DEPENDENT_NAME ' +
1063     ' and Procs.RDB$PROCEDURE_NAME <> D.RDB$DEPENDED_ON_NAME ' +
1064     'JOIN RDB$PROCEDURES P On P.RDB$PROCEDURE_NAME = D.RDB$DEPENDED_ON_NAME ' +
1065     ' ) ' +
1066     'SELECT * FROM RDB$PROCEDURES P ' +
1067     'JOIN ( ' +
1068     'Select RDB$PROCEDURE_NAME, max(ProcLevel) as ProcLevel From Procs ' +
1069     'Group By RDB$PROCEDURE_NAME) A On A.RDB$PROCEDURE_NAME = P.RDB$PROCEDURE_NAME ' +
1070     'Order by A.ProcLevel desc, P.RDB$PROCEDURE_NAME asc';
1071 tony 33
1072     ProcedureNameSQL =
1073     'SELECT * FROM RDB$PROCEDURES ' +
1074     'WHERE RDB$PROCEDURE_NAME = :ProcedureName ' +
1075     'ORDER BY RDB$PROCEDURE_NAME';
1076    
1077     var
1078     qryProcedures : TIBSQL;
1079     ProcName : String;
1080     SList : TStrings;
1081     Header : Boolean;
1082 tony 47
1083 tony 33 begin
1084    
1085     Header := true;
1086     qryProcedures := TIBSQL.Create(FDatabase);
1087     SList := TStringList.Create;
1088     try
1089     if ProcedureName = '' then
1090     qryProcedures.SQL.Text := ProcedureSQL
1091     else
1092     begin
1093     qryProcedures.SQL.Text := ProcedureNameSQL;
1094     qryProcedures.Params.ByName('ProcedureName').AsString := ProcedureName;
1095     end;
1096 tony 47
1097 tony 33 qryProcedures.ExecQuery;
1098     while not qryProcedures.Eof do
1099     begin
1100     if Header then
1101     begin
1102     FMetaData.Add('COMMIT WORK;');
1103     FMetaData.Add('SET AUTODDL OFF;');
1104     FMetaData.Add(Format('SET TERM %s %s', [ProcTerm, Term]));
1105 tony 47 FMetaData.Add(Format('%s/* Stored procedures */%s', [LineEnding, LineEnding]));
1106 tony 33 Header := false;
1107     end;
1108     ProcName := Trim(qryProcedures.FieldByName('RDB$PROCEDURE_NAME').AsString);
1109    
1110 tony 47 case ProcDDLType of
1111     pdCreateStub:
1112     begin
1113     FMetaData.Add(Format(CreateProcedureStr1, [QuoteIdentifier(FDatabase.SQLDialect,
1114     ProcName)]));
1115     GetProcedureArgs(ProcName);
1116     FMetaData.Add(Format(CreateProcedureStr2, [ProcTerm, LineEnding]));
1117     end;
1118 tony 33
1119 tony 47 pdCreateProc:
1120     begin
1121     FMetaData.Add(Format(CreateProcedureStr1, [QuoteIdentifier(FDatabase.SQLDialect,
1122     ProcName)]));
1123     GetProcedureArgs(ProcName);
1124     if not qryProcedures.FieldByName('RDB$PROCEDURE_SOURCE').IsNull then
1125     begin
1126     SList.Text := qryProcedures.FieldByName('RDB$PROCEDURE_SOURCE').AsString;
1127     SList.Add(Format(' %s%s', [ProcTerm, LineEnding]));
1128     FMetaData.AddStrings(SList);
1129     end
1130     else
1131     FMetaData.Add(Format(CreateProcedureStr2, [ProcTerm, LineEnding]));
1132     end;
1133    
1134     pdAlterProc:
1135     begin
1136     FMetaData.Add(Format('%sALTER PROCEDURE %s ', [LineEnding,
1137     QuoteIdentifier(FDatabase.SQLDialect, ProcName)]));
1138     GetProcedureArgs(ProcName);
1139    
1140     if not qryProcedures.FieldByName('RDB$PROCEDURE_SOURCE').IsNull then
1141     begin
1142     SList.Text := qryProcedures.FieldByName('RDB$PROCEDURE_SOURCE').AsString;
1143     SList.Add(Format(' %s%s', [ProcTerm, LineEnding]));
1144     FMetaData.AddStrings(SList);
1145     end
1146     else
1147     FMetaData.Add(Format(CreateProcedureStr2, [ProcTerm, LineEnding]));
1148     end;
1149     end;
1150     if IncludeGrants then
1151     ShowGrantsTo(ProcName,obj_procedure,ProcTerm);
1152 tony 33 qryProcedures.Next;
1153     end;
1154 tony 47 qryProcedures.Close;
1155 tony 33
1156     if not Header then
1157     begin
1158     FMetaData.Add(Format('SET TERM %s %s', [Term, ProcTerm]));
1159     FMetaData.Add('COMMIT WORK;');
1160     FMetaData.Add('SET AUTODDL ON;');
1161     end;
1162     finally
1163     qryProcedures.Free;
1164     SList.Free;
1165     end;
1166     end;
1167    
1168     { ListAllTables
1169     Functional description
1170     Extract the names of all user tables from
1171     rdb$relations. Filter SQL tables by
1172     security class after we fetch them
1173     Parameters: flag -- 0, get all tables }
1174    
1175     procedure TIBExtract.ListAllTables(flag: Boolean);
1176     const
1177     TableSQL =
1178     'SELECT * FROM RDB$RELATIONS ' +
1179     'WHERE ' +
1180     ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' +
1181     ' RDB$VIEW_BLR IS NULL ' +
1182     'ORDER BY RDB$RELATION_NAME';
1183    
1184     var
1185     qryTables : TIBSQL;
1186     begin
1187     { This version of cursor gets only sql tables identified by security class
1188     and misses views, getting only null view_source }
1189    
1190     qryTables := TIBSQL.Create(FDatabase);
1191     try
1192     qryTables.SQL.Text := TableSQL;
1193     qryTables.ExecQuery;
1194     while not qryTables.Eof do
1195     begin
1196     if ((qryTables.FieldByName('RDB$FLAGS').AsInteger <> 1) and
1197     (not Flag)) then
1198     continue;
1199     if flag or (Pos('SQL$', qryTables.FieldByName('RDB$SECURITY_CLASS').AsString) <> 1) then
1200     ExtractListTable(qryTables.FieldByName('RDB$RELATION_NAME').AsString,
1201     '', false);
1202    
1203     qryTables.Next;
1204     end;
1205     finally
1206     qryTables.Free;
1207     end;
1208     end;
1209    
1210     { ListAllTriggers
1211     Functional description
1212     Lists triggers in general on non-system
1213     tables with sql source only. }
1214    
1215 tony 47 procedure TIBExtract.ListTriggers(ObjectName: String; ExtractTypes: TExtractTypes
1216     );
1217 tony 33 const
1218     { Query gets the trigger info for non-system triggers with
1219     source that are not part of an SQL constraint }
1220    
1221     TriggerSQL =
1222 tony 47 'SELECT * FROM RDB$TRIGGERS TRG Left Outer JOIN RDB$RELATIONS REL ON ' +
1223 tony 33 ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' +
1224     'WHERE ' +
1225     ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' +
1226     ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' +
1227     ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' +
1228     'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' +
1229     ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME';
1230    
1231     TriggerNameSQL =
1232     'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$RELATIONS REL ON ' +
1233     ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' +
1234     'WHERE ' +
1235     ' REL.RDB$RELATION_NAME = :TableName AND ' +
1236     ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' +
1237     ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' +
1238     ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' +
1239     'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' +
1240     ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME';
1241    
1242     TriggerByNameSQL =
1243 tony 47 'SELECT * FROM RDB$TRIGGERS TRG Left Outer JOIN RDB$RELATIONS REL ON ' +
1244 tony 33 ' TRG.RDB$RELATION_NAME = REL.RDB$RELATION_NAME ' +
1245     'WHERE ' +
1246     ' TRG.RDB$TRIGGER_NAME = :TriggerName AND ' +
1247     ' (REL.RDB$SYSTEM_FLAG <> 1 OR REL.RDB$SYSTEM_FLAG IS NULL) AND ' +
1248     ' NOT EXISTS (SELECT * FROM RDB$CHECK_CONSTRAINTS CHK WHERE ' +
1249     ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME) ' +
1250     'ORDER BY TRG.RDB$RELATION_NAME, TRG.RDB$TRIGGER_TYPE, ' +
1251     ' TRG.RDB$TRIGGER_SEQUENCE, TRG.RDB$TRIGGER_NAME';
1252    
1253     var
1254     Header : Boolean;
1255     TriggerName, RelationName, InActive: String;
1256     qryTriggers : TIBSQL;
1257     SList : TStrings;
1258     begin
1259     Header := true;
1260     SList := TStringList.Create;
1261     qryTriggers := TIBSQL.Create(FDatabase);
1262     try
1263     if ObjectName = '' then
1264     qryTriggers.SQL.Text := TriggerSQL
1265     else
1266     begin
1267 tony 47 if etTable in ExtractTypes then
1268 tony 33 begin
1269     qryTriggers.SQL.Text := TriggerNameSQL;
1270     qryTriggers.Params.ByName('TableName').AsString := ObjectName;
1271     end
1272     else
1273     begin
1274     qryTriggers.SQL.Text := TriggerByNameSQL;
1275     qryTriggers.Params.ByName('TriggerName').AsString := ObjectName;
1276     end;
1277     end;
1278     qryTriggers.ExecQuery;
1279     while not qryTriggers.Eof do
1280     begin
1281     SList.Clear;
1282     if Header then
1283     begin
1284 tony 47 FMetaData.Add(Format('SET TERM %s %s%s', [Procterm, Term, LineEnding]));
1285 tony 33 FMetaData.Add(Format('%s/* Triggers only will work for SQL triggers */%s',
1286 tony 47 [LineEnding, LineEnding]));
1287 tony 33 Header := false;
1288     end;
1289     TriggerName := qryTriggers.FieldByName('RDB$TRIGGER_NAME').AsString;
1290     RelationName := qryTriggers.FieldByName('RDB$RELATION_NAME').AsString;
1291     if qryTriggers.FieldByName('RDB$TRIGGER_INACTIVE').IsNull then
1292     InActive := 'INACTIVE'
1293     else
1294     if qryTriggers.FieldByName('RDB$TRIGGER_INACTIVE').AsInteger = 1 then
1295     InActive := 'INACTIVE'
1296     else
1297     InActive := 'ACTIVE';
1298    
1299     if qryTriggers.FieldByName('RDB$FLAGS').AsInteger <> 1 then
1300     SList.Add('/* ');
1301    
1302 tony 47 {Database or Transaction trigger}
1303     SList.Add(Format('CREATE TRIGGER %s%s%s %s POSITION %d',
1304     [QuoteIdentifier(FDatabase.SQLDialect, TriggerName),
1305     LineEnding, InActive,
1306     GetTriggerType(qryTriggers.FieldByName('RDB$TRIGGER_TYPE').AsInteger),
1307     qryTriggers.FieldByName('RDB$TRIGGER_SEQUENCE').AsInteger]));
1308    
1309     if RelationName <> '' then
1310     SList.Add('ON ' + QuoteIdentifier(FDatabase.SQLDialect, RelationName));
1311    
1312     if not qryTriggers.FieldByName('RDB$TRIGGER_SOURCE').IsNull then
1313     SList.Add(qryTriggers.FieldByName('RDB$TRIGGER_SOURCE').AsString)
1314 tony 45 else
1315 tony 47 SList.Add('AS BEGIN EXIT; END');
1316     SList.Add(' ' + ProcTerm);
1317 tony 33 if qryTriggers.FieldByName('RDB$FLAGS').AsInteger <> 1 then
1318     SList.Add(' */');
1319     FMetaData.AddStrings(SList);
1320 tony 47 if etGrant in ExtractTypes then
1321     ShowGrantsTo(TriggerName,obj_trigger,ProcTerm);
1322 tony 33 qryTriggers.Next;
1323     end;
1324     if not Header then
1325     begin
1326     FMetaData.Add('COMMIT WORK ' + ProcTerm);
1327     FMetaData.Add('SET TERM ' + Term + ProcTerm);
1328     end;
1329     finally
1330     qryTriggers.Free;
1331     SList.Free;
1332     end;
1333     end;
1334    
1335     { ListCheck
1336     Functional description
1337     List check constraints for all objects to allow forward references }
1338    
1339     procedure TIBExtract.ListCheck(ObjectName : String; ExtractType : TExtractType);
1340     const
1341     { Query gets the check clauses for triggers stored for check constraints }
1342     CheckSQL =
1343     'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' +
1344     ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' +
1345     'WHERE ' +
1346     ' TRG.RDB$TRIGGER_TYPE = 1 AND ' +
1347     ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' +
1348     ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' +
1349     'ORDER BY CHK.RDB$CONSTRAINT_NAME';
1350    
1351     CheckNameSQL =
1352     'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' +
1353     ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' +
1354     'WHERE ' +
1355     ' TRG.RDB$RELATION_NAME = :TableName AND ' +
1356     ' TRG.RDB$TRIGGER_TYPE = 1 AND ' +
1357     ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' +
1358     ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' +
1359     'ORDER BY CHK.RDB$CONSTRAINT_NAME';
1360    
1361     CheckByNameSQL =
1362     'SELECT * FROM RDB$TRIGGERS TRG JOIN RDB$CHECK_CONSTRAINTS CHK ON ' +
1363     ' TRG.RDB$TRIGGER_NAME = CHK.RDB$TRIGGER_NAME ' +
1364     'WHERE ' +
1365     ' TRG.RDB$TRIGGER_NAME = :TriggerName AND ' +
1366     ' TRG.RDB$TRIGGER_TYPE = 1 AND ' +
1367     ' EXISTS (SELECT RDB$CONSTRAINT_NAME FROM RDB$RELATION_CONSTRAINTS RELC WHERE ' +
1368     ' CHK.RDB$CONSTRAINT_NAME = RELC.RDB$CONSTRAINT_NAME) ' +
1369     'ORDER BY CHK.RDB$CONSTRAINT_NAME';
1370    
1371     var
1372     qryChecks : TIBSQL;
1373     SList : TStrings;
1374     RelationName : String;
1375     begin
1376     qryChecks := TIBSQL.Create(FDatabase);
1377     SList := TStringList.Create;
1378     try
1379     if ObjectName = '' then
1380     qryChecks.SQL.Text := CheckSQL
1381     else
1382     if ExtractType = etTable then
1383     begin
1384     qryChecks.SQL.Text := CheckNameSQL;
1385     qryChecks.Params.ByName('TableName').AsString := ObjectName;
1386     end
1387     else
1388     begin
1389     qryChecks.SQL.Text := CheckByNameSQL;
1390     qryChecks.Params.ByName('TriggerName').AsString := ObjectName;
1391     end;
1392     qryChecks.ExecQuery;
1393     while not qryChecks.Eof do
1394     begin
1395     SList.Clear;
1396     RelationName := qryChecks.FieldByName('RDB$RELATION_NAME').AsString;
1397     SList.Add(Format('ALTER TABLE %s ADD',
1398     [QuoteIdentifier(FDatabase.SQLDialect, RelationName)]));
1399     if Pos('INTEG', qryChecks.FieldByName('RDB$CONSTRAINT_NAME').AsString) <> 1 then
1400     SList.Add(Format('%sCONSTRAINT %s ', [TAB,
1401     QuoteIdentifier(FDatabase.SQLDialect, qryChecks.FieldByName('RDB$CONSTRAINT_NAME').AsString)]));
1402    
1403     if not qryChecks.FieldByName('RDB$TRIGGER_SOURCE').IsNull then
1404     SList.Text := SList.Text + qryChecks.FieldByName('RDB$TRIGGER_SOURCE').AsString;
1405    
1406 tony 47 SList.Strings[SList.Count - 1] := SList.Strings[SList.Count - 1] + (Term) + LineEnding;
1407 tony 33 FMetaData.AddStrings(SList);
1408     qryChecks.Next;
1409     end;
1410     finally
1411     qryChecks.Free;
1412     SList.Free;
1413     end;
1414     end;
1415    
1416     { ListCreateDb
1417     Functional description
1418     Print the create database command if requested. At least put
1419     the page size in a comment with the extracted db name }
1420    
1421     procedure TIBExtract.ListCreateDb(TargetDb : String);
1422     const
1423     CharInfoSQL =
1424     'SELECT * FROM RDB$DATABASE DBP ' +
1425     'WHERE NOT DBP.RDB$CHARACTER_SET_NAME IS NULL ' +
1426 tony 45 ' AND DBP.RDB$CHARACTER_SET_NAME <> '' ''';
1427 tony 33
1428     FilesSQL =
1429     'select * from RDB$FILES ' +
1430     'order BY RDB$SHADOW_NUMBER, RDB$FILE_SEQUENCE';
1431    
1432     LogsSQL =
1433     'SELECT * FROM RDB$LOG_FILES ' +
1434     'ORDER BY RDB$FILE_FLAGS, RDB$FILE_SEQUENCE';
1435    
1436     var
1437     NoDb, First, FirstFile, HasWal, SetUsed : Boolean;
1438     Buffer : String;
1439     qryDB : TIBSQL;
1440     FileFlags, FileLength, FileSequence, FileStart : Integer;
1441    
1442     function GetLongDatabaseInfo(DatabaseInfoCommand: Integer): LongInt;
1443     begin
1444 tony 45 with Database.Attachment.GetDBInformation([DatabaseInfoCommand]) do
1445     if (Count > 0) and (Items[0].GetItemType = DatabaseInfoCommand) then
1446     Result := Items[0].AsInteger
1447     else
1448     IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
1449 tony 33 end;
1450    
1451     begin
1452 tony 45 NoDb := FALSE;
1453 tony 33 First := TRUE;
1454     FirstFile := TRUE;
1455     HasWal := FALSE;
1456     SetUsed := FALSE;
1457     Buffer := '';
1458     if TargetDb = '' then
1459     begin
1460     Buffer := '/* ';
1461     TargetDb := FDatabase.DatabaseName;
1462     NoDb := true;
1463     end;
1464     Buffer := Buffer + 'CREATE DATABASE ' + QuotedStr(TargetDb) + ' PAGE_SIZE ' +
1465 tony 47 IntToStr(FDatabaseInfo.PageSize) + LineEnding;
1466 tony 33 FMetaData.Add(Buffer);
1467     Buffer := '';
1468    
1469     qryDB := TIBSQL.Create(FDatabase);
1470     try
1471     qryDB.SQL.Text := CharInfoSQL;
1472     qryDB.ExecQuery;
1473    
1474 tony 45 if not qryDB.EOF then
1475     Buffer := Format(' DEFAULT CHARACTER SET %s',
1476 tony 47 [trim(qryDB.FieldByName('RDB$CHARACTER_SET_NAME').AsString)]);
1477 tony 33 if NoDB then
1478 tony 45 Buffer := Buffer + Term + ' */'
1479 tony 33 else
1480     Buffer := Buffer + Term;
1481     FMetaData.Add(Buffer);
1482     qryDB.Close;
1483     {List secondary files and shadows as
1484     alter db and create shadow in comment}
1485     qryDB.SQL.Text := FilesSQL;
1486     qryDB.ExecQuery;
1487     while not qryDB.Eof do
1488     begin
1489     if First then
1490     begin
1491 tony 47 FMetaData.Add(LineEnding + '/* Add secondary files in comments ');
1492 tony 33 First := false;
1493     end; //end_if
1494    
1495     if qryDB.FieldByName('RDB$FILE_FLAGS').IsNull then
1496     FileFlags := 0
1497     else
1498     FileFlags := qryDB.FieldByName('RDB$FILE_FLAGS').AsInteger;
1499     if qryDB.FieldByName('RDB$FILE_LENGTH').IsNull then
1500     FileLength := 0
1501     else
1502     FileLength := qryDB.FieldByName('RDB$FILE_LENGTH').AsInteger;
1503     if qryDB.FieldByName('RDB$FILE_SEQUENCE').IsNull then
1504     FileSequence := 0
1505     else
1506     FileSequence := qryDB.FieldByName('RDB$FILE_SEQUENCE').AsInteger;
1507     if qryDB.FieldByName('RDB$FILE_START').IsNull then
1508     FileStart := 0
1509     else
1510     FileStart := qryDB.FieldByName('RDB$FILE_START').AsInteger;
1511    
1512     { Pure secondary files }
1513     if FileFlags = 0 then
1514     begin
1515     Buffer := Format('%sALTER DATABASE ADD FILE ''%s''',
1516 tony 47 [LineEnding, qryDB.FieldByName('RDB$FILE_NAME').AsString]);
1517 tony 33 if FileStart <> 0 then
1518     Buffer := Buffer + Format(' STARTING %d', [FileStart]);
1519     if FileLength <> 0 then
1520     Buffer := Buffer + Format(' LENGTH %d', [FileLength]);
1521     FMetaData.Add(Buffer);
1522     end; //end_if
1523     if (FileFlags and FILE_cache) <> 0 then
1524     FMetaData.Add(Format('%sALTER DATABASE ADD CACHE ''%s'' LENGTH %d',
1525 tony 47 [LineEnding, qryDB.FieldByName('RDB$FILE_NAME').AsString, FileLength]));
1526 tony 33
1527     Buffer := '';
1528     if (FileFlags and FILE_shadow) <> 0 then
1529     begin
1530     if FileSequence <> 0 then
1531     Buffer := Format('%sFILE ''%s''',
1532     [TAB, qryDB.FieldByName('RDB$FILE_NAME').AsString])
1533     else
1534     begin
1535     Buffer := Format('%sCREATE SHADOW %d ''%s'' ',
1536 tony 47 [LineEnding, qryDB.FieldByName('RDB$SHADOW_NUMBER').AsInteger,
1537 tony 33 qryDB.FieldByName('RDB$FILE_NAME').AsString]);
1538     if (FileFlags and FILE_inactive) <> 0 then
1539     Buffer := Buffer + 'INACTIVE ';
1540     if (FileFlags and FILE_manual) <> 0 then
1541     Buffer := Buffer + 'MANUAL '
1542     else
1543     Buffer := Buffer + 'AUTO ';
1544     if (FileFlags and FILE_conditional) <> 0 then
1545     Buffer := Buffer + 'CONDITIONAL ';
1546     end; //end_else
1547     if FileLength <> 0 then
1548     Buffer := Buffer + Format('LENGTH %d ', [FileLength]);
1549     if FileStart <> 0 then
1550     Buffer := Buffer + Format('STARTING %d ', [FileStart]);
1551     FMetaData.Add(Buffer);
1552     end; //end_if
1553     qryDB.Next;
1554     end;
1555     qryDB.Close;
1556    
1557     qryDB.SQL.Text := LogsSQL;
1558     qryDB.ExecQuery;
1559     while not qryDB.Eof do
1560     begin
1561    
1562     if qryDB.FieldByName('RDB$FILE_FLAGS').IsNull then
1563     FileFlags := 0
1564     else
1565     FileFlags := qryDB.FieldByName('RDB$FILE_FLAGS').AsInteger;
1566     if qryDB.FieldByName('RDB$FILE_LENGTH').IsNull then
1567     FileLength := 0
1568     else
1569     FileLength := qryDB.FieldByName('RDB$FILE_LENGTH').AsInteger;
1570    
1571     Buffer := '';
1572     HasWal := true;
1573     if First then
1574     begin
1575     if NoDB then
1576     Buffer := '/* ';
1577 tony 47 Buffer := Buffer + LineEnding + 'ALTER DATABASE ADD ';
1578 tony 33 First := false;
1579     end; //end_if
1580     if FirstFile then
1581     Buffer := Buffer + 'LOGFILE ';
1582     { Overflow files also have the serial bit set }
1583     if (FileFlags and LOG_default) = 0 then
1584     begin
1585     if (FileFlags and LOG_overflow) <> 0 then
1586     Buffer := Buffer + Format(')%s OVERFLOW ''%s''',
1587 tony 47 [LineEnding, qryDB.FieldByName('RDB$FILE_NAME').AsString])
1588 tony 33 else
1589     if (FileFlags and LOG_serial) <> 0 then
1590     Buffer := Buffer + Format('%s BASE_NAME ''%s''',
1591 tony 47 [LineEnding, qryDB.FieldByName('RDB$FILE_NAME').AsString])
1592 tony 33 { Since we are fetching order by FILE_FLAGS, the LOG_0verflow will
1593     be last. It will only appear if there were named round robin,
1594     so we must close the parens first }
1595    
1596     { We have round robin and overflow file specifications }
1597     else
1598     begin
1599     if FirstFile then
1600     Buffer := Buffer + '('
1601     else
1602 tony 47 Buffer := Buffer + Format(',%s ', [LineEnding]);
1603 tony 33 FirstFile := false;
1604    
1605     Buffer := Buffer + Format('''%s''', [qryDB.FieldByName('RDB$FILE_NAME').AsString]);
1606     end; //end_else
1607     end;
1608     { Any file can have a length }
1609     if FileLength <> 0 then
1610     Buffer := Buffer + Format(' SIZE %d ', [FileLength]);
1611     FMetaData.Add(Buffer);
1612     qryDB.Next;
1613     end;
1614     qryDB.Close;
1615     Buffer := '';
1616     if HasWal then
1617     begin
1618     Buffer := Buffer + PrintSet(SetUsed);
1619     Buffer := Buffer + Format('NUM_LOG_BUFFERS = %d',
1620     [GetLongDatabaseInfo(isc_info_num_wal_buffers)]);
1621     Buffer := Buffer + PrintSet(SetUsed);
1622     Buffer := Buffer + Format('LOG_BUFFER_SIZE = %d',
1623     [GetLongDatabaseInfo(isc_info_wal_buffer_size)]);
1624     Buffer := Buffer + PrintSet(SetUsed);
1625     Buffer := Buffer + Format('GROUP_COMMIT_WAIT_TIME = %d',
1626     [GetLongDatabaseInfo(isc_info_wal_grpc_wait_usecs)]);
1627     Buffer := Buffer + PrintSet(SetUsed);
1628     Buffer := Buffer + Format('CHECK_POINT_LENGTH = %d',
1629     [GetLongDatabaseInfo(isc_info_wal_ckpt_length)]);
1630     FMetaData.Add(Buffer);
1631    
1632     end;
1633     if not First then
1634     begin
1635     if NoDB then
1636 tony 47 FMetaData.Add(Format('%s */%s', [LineEnding, LineEnding]))
1637 tony 33 else
1638 tony 47 FMetaData.Add(Format('%s%s%s', [Term, LineEnding, LineEnding]));
1639 tony 33 end;
1640     finally
1641     qryDB.Free;
1642     end;
1643    
1644     (*
1645     *)
1646     end;
1647    
1648     { ListDomainTable
1649     Functional description
1650     List domains as identified by fields with any constraints on them
1651     for the named table
1652    
1653     Parameters: table_name == only extract domains for this table }
1654    
1655     procedure TIBExtract.ListDomains(ObjectName: String; ExtractType : TExtractType);
1656     const
1657     DomainSQL =
1658     'SELECT distinct fld.* FROM RDB$FIELDS FLD JOIN RDB$RELATION_FIELDS RFR ON ' +
1659     ' RFR.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' +
1660     'WHERE RFR.RDB$RELATION_NAME = :TABLE_NAME ' +
1661     'ORDER BY FLD.RDB$FIELD_NAME';
1662    
1663     DomainByNameSQL =
1664     'SELECT * FROM RDB$FIELDS FLD ' +
1665     'WHERE FLD.RDB$FIELD_NAME = :DomainName ' +
1666     'ORDER BY FLD.RDB$FIELD_NAME';
1667    
1668     AllDomainSQL =
1669     'select * from RDB$FIELDS ' +
1670     'where RDB$SYSTEM_FLAG <> 1 ' +
1671     'order BY RDB$FIELD_NAME';
1672    
1673     var
1674     First : Boolean;
1675     qryDomains : TIBSQL;
1676     FieldName, Line : String;
1677    
1678     function FormatDomainStr : String;
1679     var
1680     i, SubType : Integer;
1681     PrecisionKnown : Boolean;
1682     begin
1683     Result := '';
1684     for i := Low(ColumnTypes) to High(ColumnTypes) do
1685     if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = ColumnTypes[i].SQLType then
1686     begin
1687     PrecisionKnown := FALSE;
1688     if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then
1689     begin
1690     if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_short, blr_long, blr_int64] then
1691     begin
1692     { We are ODS >= 10 and could be any Dialect }
1693     if (FDatabaseInfo.DBSQLDialect >= 3) and
1694     (not qryDomains.FieldByName('RDB$FIELD_PRECISION').IsNull) and
1695     (qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and
1696     (qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then
1697     begin
1698     Result := Result + Format('%s(%d, %d)', [
1699     IntegralSubtypes [qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger],
1700     qryDomains.FieldByName('RDB$FIELD_PRECISION').AsInteger,
1701     -1 * qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger]);
1702     PrecisionKnown := true;
1703     end;
1704     end;
1705     end;
1706     if PrecisionKnown = false then
1707     begin
1708     { Take a stab at numerics and decimals }
1709     if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_short) and
1710     (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
1711     Result := Result + Format('NUMERIC(4, %d)',
1712     [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] )
1713     else
1714     if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_long) and
1715     (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
1716     Result := Result + Format('NUMERIC(9, %d)',
1717     [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] )
1718     else
1719     if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_double) and
1720     (qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
1721     Result := Result + Format('NUMERIC(15, %d)',
1722     [-qryDomains.FieldByName('RDB$FIELD_SCALE').AsInteger] )
1723     else
1724     Result := Result + ColumnTypes[i].TypeName;
1725     end;
1726     break;
1727     end;
1728    
1729     if qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_blob then
1730     begin
1731     subtype := qryDomains.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger;
1732     Result := Result + ' SUB_TYPE ';
1733     if (subtype > 0) and (subtype <= MAXSUBTYPES) then
1734     Result := Result + SubTypes[subtype]
1735     else
1736     Result := Result + Format('%d', [subtype]);
1737     Result := Result + Format(' SEGMENT SIZE %d', [qryDomains.FieldByName('RDB$SEGMENT_LENGTH').AsInteger]);
1738     end //end_if
1739     else
1740 tony 47 if (qryDomains.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying]) then
1741     begin
1742     if not qryDomains.FieldByName('RDB$CHARACTER_LENGTH').IsNull then
1743     Result := Result + Format('(%d)', [qryDomains.FieldByName('RDB$CHARACTER_LENGTH').AsInteger])
1744     else
1745     Result := Result + Format('(%d)', [qryDomains.FieldByName('RDB$FIELD_LENGTH').AsInteger]);
1746     end;
1747 tony 33
1748     { since the character set is part of the field type, display that
1749     information now. }
1750     if not qryDomains.FieldByName('RDB$CHARACTER_SET_ID').IsNull then
1751     Result := Result + GetCharacterSets(qryDomains.FieldByName('RDB$CHARACTER_SET_ID').AsInteger,
1752     0, FALSE);
1753     if not qryDomains.FieldByName('RDB$DIMENSIONS').IsNull then
1754 tony 45 Result := GetArrayField(qryDomains.FieldByName('RDB$FIELD_SOURCE').AsString);
1755 tony 33
1756     if not qryDomains.FieldByName('RDB$DEFAULT_SOURCE').IsNull then
1757 tony 47 Result := Result + Format('%s%s %s', [LineEnding, TAB,
1758 tony 33 qryDomains.FieldByName('RDB$DEFAULT_SOURCE').AsString]);
1759    
1760     if not qryDomains.FieldByName('RDB$VALIDATION_SOURCE').IsNull then
1761     if Pos('CHECK', AnsiUpperCase(qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString)) = 1 then
1762 tony 47 Result := Result + Format('%s%s %s', [LineEnding, TAB,
1763 tony 33 qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString])
1764     else
1765 tony 47 Result := Result + Format('%s%s /* %s */', [LineEnding, TAB,
1766 tony 33 qryDomains.FieldByName('RDB$VALIDATION_SOURCE').AsString]);
1767    
1768     if qryDomains.FieldByName('RDB$NULL_FLAG').AsInteger = 1 then
1769     Result := Result + ' NOT NULL';
1770    
1771     { Show the collation order if one has been specified. If the collation
1772     order is the default for the character set being used, then no collation
1773     order will be shown ( because it isn't needed ).
1774    
1775     If the collation id is 0, then the default for the character set is
1776     being used so there is no need to retrieve the collation information.}
1777    
1778     if (not qryDomains.FieldByName('RDB$COLLATION_ID').IsNull) and
1779     (qryDomains.FieldByName('RDB$COLLATION_ID').AsInteger <> 0) then
1780     Result := Result + GetCharacterSets(qryDomains.FieldByName('RDB$CHARACTER_SET_ID').AsInteger,
1781     qryDomains.FieldByName('RDB$COLLATION_ID').AsInteger, true);
1782     end;
1783    
1784     begin
1785     First := true;
1786     qryDomains := TIBSQL.Create(FDatabase);
1787     try
1788     if ObjectName <> '' then
1789     begin
1790     if ExtractType = etTable then
1791     begin
1792     qryDomains.SQL.Text := DomainSQL;
1793     qryDomains.Params.ByName('table_name').AsString := ObjectName;
1794     end
1795     else
1796     begin
1797     qryDomains.SQL.Text := DomainByNameSQL;
1798     qryDomains.Params.ByName('DomainName').AsString := ObjectName;
1799     end;
1800     end
1801     else
1802     qryDomains.SQL.Text := AllDomainSQL;
1803    
1804     qryDomains.ExecQuery;
1805     while not qryDomains.Eof do
1806     begin
1807     FieldName := qryDomains.FieldByName('RDB$FIELD_NAME').AsString;
1808     { Skip over artifical domains }
1809     if (Pos('RDB$',FieldName) = 1) and
1810     (FieldName[5] in ['0'..'9']) and
1811     (qryDomains.FieldByName('RDB$SYSTEM_FLAG').AsInteger <> 1) then
1812     begin
1813     qryDomains.Next;
1814     continue;
1815     end;
1816    
1817     if First then
1818     begin
1819     FMetaData.Add('/* Domain definitions */');
1820     First := false;
1821     end;
1822    
1823     Line := Format('CREATE DOMAIN %s AS ', [FieldName]);
1824     Line := Line + FormatDomainStr + Term;
1825     FMetaData.Add(Line);
1826     qryDomains.Next;
1827     end;
1828     finally
1829     qryDomains.Free;
1830     end;
1831     end;
1832    
1833     { ListException
1834     Functional description
1835     List all exceptions defined in the database
1836    
1837     Parameters: none }
1838    
1839     procedure TIBExtract.ListException(ExceptionName : String = '');
1840     const
1841     ExceptionSQL =
1842     'select * from RDB$EXCEPTIONS ' +
1843     'ORDER BY RDB$EXCEPTION_NAME';
1844    
1845     ExceptionNameSQL =
1846     'select * from RDB$EXCEPTIONS ' +
1847     'WHERE RDB$EXCEPTION_NAME = :ExceptionName ' +
1848     'ORDER BY RDB$EXCEPTION_NAME';
1849    
1850     var
1851     First : Boolean;
1852     qryException : TIBSQL;
1853     begin
1854     First := true;
1855     qryException := TIBSQL.Create(FDatabase);
1856     try
1857     if ExceptionName = '' then
1858     qryException.SQL.Text := ExceptionSQL
1859     else
1860     begin
1861     qryException.SQL.Text := ExceptionNameSQL;
1862     qryException.Params.ByName('ExceptionName').AsString := ExceptionName;
1863     end;
1864    
1865     qryException.ExecQuery;
1866     while not qryException.Eof do
1867     begin
1868     if First then
1869     begin
1870     FMetaData.Add('');
1871     FMetaData.Add('/* Exceptions */');
1872     FMetaData.Add('');
1873     First := false;
1874     end; //end_if
1875    
1876     FMetaData.Add(Format('CREATE EXCEPTION %s %s%s',
1877     [QuoteIdentifier(FDatabase.SQLDialect, qryException.FieldByName('RDB$EXCEPTION_NAME').AsString),
1878     QuotedStr(qryException.FieldByName('RDB$MESSAGE').AsString), Term]));
1879     qryException.Next;
1880     end;
1881     finally
1882     qryException.Free;
1883     end;
1884     end;
1885    
1886     { ListFilters
1887    
1888     Functional description
1889     List all blob filters
1890    
1891     Parameters: none
1892     Results in
1893     DECLARE FILTER <fname> INPUT_TYPE <blob_sub_type> OUTPUT_TYPE <blob_subtype>
1894     ENTRY_POINT <string> MODULE_NAME <string> }
1895    
1896     procedure TIBExtract.ListFilters(FilterName : String = '');
1897     const
1898     FiltersSQL =
1899     'SELECT * FROM RDB$FILTERS ' +
1900     'ORDER BY RDB$FUNCTION_NAME';
1901     FilterNameSQL =
1902     'SELECT * FROM RDB$FILTERS ' +
1903     'WHERE RDB$FUNCTION_NAME = :FunctionName ' +
1904     'ORDER BY RDB$FUNCTION_NAME';
1905    
1906     var
1907     First : Boolean;
1908     qryFilters : TIBSQL;
1909     begin
1910     First := true;
1911     qryFilters := TIBSQL.Create(FDatabase);
1912     try
1913     if FilterName = '' then
1914     qryFilters.SQL.Text := FiltersSQL
1915     else
1916     begin
1917     qryFilters.SQL.Text := FilterNameSQL;
1918     qryFilters.Params.ByName('FunctionName').AsString := FilterName;
1919     end;
1920     qryFilters.ExecQuery;
1921     while not qryFilters.Eof do
1922     begin
1923     if First then
1924     begin
1925     FMetaData.Add('');
1926     FMetaData.Add('/* BLOB Filter declarations */');
1927     FMetaData.Add('');
1928     First := false;
1929     end; //end_if
1930    
1931     FMetaData.Add(Format('DECLARE FILTER %s INPUT_TYPE %d OUTPUT_TYPE %d',
1932     [qryFilters.FieldByName('RDB$FUNCTION_NAME').AsString,
1933     qryFilters.FieldByName('RDB$INPUT_SUB_TYPE').AsInteger,
1934     qryFilters.FieldByName('RDB$OUTPUT_SUB_TYPE').AsInteger]));
1935     FMetaData.Add(Format('%sENTRY_POINT ''%s'' MODULE_NAME ''%s''%s%',
1936     [TAB, qryFilters.FieldByName('RDB$ENTRYPOINT').AsString,
1937     qryFilters.FieldByName('RDB$MODULE_NAME').AsString, Term]));
1938     FMetaData.Add('');
1939    
1940     qryFilters.Next;
1941     end;
1942    
1943     finally
1944     qryFilters.Free;
1945     end;
1946     end;
1947    
1948     { ListForeign
1949     Functional description
1950     List all foreign key constraints and alter the tables }
1951    
1952     procedure TIBExtract.ListForeign(ObjectName : String; ExtractType : TExtractType);
1953     const
1954     { Static queries for obtaining foreign constraints, where RELC1 is the
1955     foreign key constraints, RELC2 is the primary key lookup and REFC
1956     is the join table }
1957     ForeignSQL =
1958     'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' +
1959     ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' +
1960     ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' +
1961     ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' +
1962     'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' +
1963     ' RDB$RELATION_CONSTRAINTS RELC2 ' +
1964     'WHERE ' +
1965     ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' +
1966     ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' +
1967     ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' +
1968     ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' +
1969     ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' +
1970     'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME';
1971    
1972     ForeignNameSQL =
1973     'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' +
1974     ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' +
1975     ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' +
1976     ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' +
1977     'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' +
1978     ' RDB$RELATION_CONSTRAINTS RELC2 ' +
1979     'WHERE ' +
1980     ' RELC1.RDB$RELATION_NAME = :TableName AND ' +
1981     ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' +
1982     ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' +
1983     ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' +
1984     ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' +
1985     ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' +
1986     'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME';
1987    
1988     ForeignByNameSQL =
1989     'SELECT REFC.RDB$UPDATE_RULE REFC_UPDATE_RULE, REFC.RDB$DELETE_RULE REFC_DELETE_RULE, ' +
1990     ' RELC1.RDB$RELATION_NAME RELC1_RELATION_NAME, RELC2.RDB$RELATION_NAME RELC2_RELATION_NAME, ' +
1991     ' RELC1.RDB$INDEX_NAME RELC1_INDEX_NAME, RELC1.RDB$CONSTRAINT_NAME RELC1_CONSTRAINT_NAME, ' +
1992     ' RELC2.RDB$INDEX_NAME RELC2_INDEX_NAME ' +
1993     'FROM RDB$REF_CONSTRAINTS REFC, RDB$RELATION_CONSTRAINTS RELC1, ' +
1994     ' RDB$RELATION_CONSTRAINTS RELC2 ' +
1995     'WHERE ' +
1996     ' RELC1.RDB$CONSTRAINT_NAME = :ConstraintName AND ' +
1997     ' RELC1.RDB$CONSTRAINT_TYPE = ''FOREIGN KEY'' AND ' +
1998     ' REFC.RDB$CONST_NAME_UQ = RELC2.RDB$CONSTRAINT_NAME AND ' +
1999     ' REFC.RDB$CONSTRAINT_NAME = RELC1.RDB$CONSTRAINT_NAME AND ' +
2000     ' (RELC2.RDB$CONSTRAINT_TYPE = ''UNIQUE'' OR ' +
2001     ' RELC2.RDB$CONSTRAINT_TYPE = ''PRIMARY KEY'') ' +
2002     'ORDER BY RELC1.RDB$RELATION_NAME, RELC1.RDB$CONSTRAINT_NAME';
2003    
2004     var
2005     qryForeign : TIBSQL;
2006     Line : String;
2007    
2008     begin
2009     qryForeign := TIBSQL.Create(FDatabase);
2010     try
2011     if ObjectName = '' then
2012     qryForeign.SQL.Text := ForeignSQL
2013     else
2014     begin
2015     if ExtractType = etTable then
2016     begin
2017     qryForeign.SQL.Text := ForeignNameSQL;
2018     qryForeign.Params.ByName('TableName').AsString := ObjectName;
2019     end
2020     else
2021     begin
2022     qryForeign.SQL.Text := ForeignByNameSQL;
2023     qryForeign.Params.ByName('ConstraintName').AsString := ObjectName;
2024     end;
2025     end;
2026     qryForeign.ExecQuery;
2027     while not qryForeign.Eof do
2028     begin
2029     Line := Format('ALTER TABLE %s ADD ', [QuoteIdentifier(FDatabase.SQLDialect,
2030     qryForeign.FieldByName('RELC1_RELATION_NAME').AsString)]);
2031    
2032     { If the name of the constraint is not INTEG..., print it.
2033     INTEG... are internally generated names. }
2034     if (not qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').IsNull) and
2035     ( Pos('INTEG', qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').AsString) <> 1) then
2036     Line := Line + Format('CONSTRAINT %s ', [QuoteIdentifier(FDatabase.SQLDialect,
2037     Trim(qryForeign.FieldByName('RELC1_CONSTRAINT_NAME').AsString))]);
2038    
2039     Line := Line + Format('FOREIGN KEY (%s) REFERENCES %s ', [
2040     GetIndexSegments(qryForeign.FieldByName('RELC1_INDEX_NAME').AsString),
2041     Trim(qryForeign.FieldByName('RELC2_RELATION_NAME').AsString)]);
2042    
2043     Line := Line + Format('(%s)',
2044     [GetIndexSegments(qryForeign.FieldByName('RELC2_INDEX_NAME').AsString)]);
2045    
2046     { Add the referential actions, if any }
2047     if (not qryForeign.FieldByName('REFC_UPDATE_RULE').IsNull) and
2048     (Trim(qryForeign.FieldByName('REFC_UPDATE_RULE').AsString) <> 'RESTRICT') then
2049     Line := Line + Format(' ON UPDATE %s',
2050     [Trim(qryForeign.FieldByName('REFC_UPDATE_RULE').AsString)]);
2051    
2052     if (not qryForeign.FieldByName('REFC_DELETE_RULE').IsNull) and
2053     (Trim(qryForeign.FieldByName('REFC_DELETE_RULE').AsString) <> 'RESTRICT') then
2054     Line := Line + Format(' ON DELETE %s',
2055     [Trim(qryForeign.FieldByName('REFC_DELETE_RULE').AsString)]);
2056    
2057     Line := Line + Term;
2058     FMetaData.Add(Line);
2059     qryForeign.Next;
2060     end;
2061     finally
2062     qryForeign.Free;
2063     end;
2064     end;
2065    
2066     { ListFunctions
2067    
2068     Functional description
2069     List all external functions
2070    
2071     Parameters: none
2072     Results in
2073     DECLARE EXTERNAL FUNCTION function_name
2074     CHAR [256] , INTEGER, ....
2075     RETURNS INTEGER BY VALUE
2076     ENTRY_POINT entrypoint MODULE_NAME module; }
2077    
2078     procedure TIBExtract.ListFunctions(FunctionName : String = '');
2079     const
2080     FunctionSQL =
2081 tony 45 'SELECT * FROM RDB$FUNCTIONS WHERE RDB$SYSTEM_FLAG = 0 ' +
2082 tony 33 'ORDER BY RDB$FUNCTION_NAME';
2083    
2084     FunctionNameSQL =
2085     'SELECT * FROM RDB$FUNCTIONS ' +
2086     'WHERE RDB$FUNCTION_NAME = :FunctionName ' +
2087     'ORDER BY RDB$FUNCTION_NAME';
2088    
2089     FunctionArgsSQL =
2090     'SELECT * FROM RDB$FUNCTION_ARGUMENTS ' +
2091     'WHERE ' +
2092     ' :FUNCTION_NAME = RDB$FUNCTION_NAME ' +
2093     'ORDER BY RDB$ARGUMENT_POSITION';
2094    
2095     FuncArgsPosSQL =
2096     'SELECT * FROM RDB$FUNCTION_ARGUMENTS ' +
2097     'WHERE ' +
2098     ' RDB$FUNCTION_NAME = :RDB$FUNCTION_NAME AND ' +
2099     ' RDB$ARGUMENT_POSITION = :RDB$ARGUMENT_POSITION';
2100    
2101     CharSetSQL =
2102     'SELECT * FROM RDB$CHARACTER_SETS ' +
2103     'WHERE ' +
2104     ' RDB$CHARACTER_SET_ID = :CHARACTER_SET_ID';
2105    
2106     var
2107     qryFunctions, qryFuncArgs, qryCharSets, qryFuncPos : TIBSQL;
2108     First, FirstArg, DidCharset, PrecisionKnown : Boolean;
2109     ReturnBuffer, TypeBuffer, Line : String;
2110     i, FieldType : Integer;
2111     begin
2112     First := true;
2113     qryFunctions := TIBSQL.Create(FDatabase);
2114     qryFuncArgs := TIBSQL.Create(FDatabase);
2115     qryFuncPos := TIBSQL.Create(FDatabase);
2116     qryCharSets := TIBSQL.Create(FDatabase);
2117     try
2118     if FunctionName = '' then
2119     qryFunctions.SQL.Text := FunctionSQL
2120     else
2121     begin
2122     qryFunctions.SQL.Text := FunctionNameSQL;
2123     qryFunctions.Params.ByName('FunctionName').AsString := FunctionName;
2124     end;
2125     qryFuncArgs.SQL.Text := FunctionArgsSQL;
2126     qryFuncPos.SQL.Text := FuncArgsPosSQL;
2127     qryCharSets.SQL.Text := CharSetSQL;
2128     qryFunctions.ExecQuery;
2129     while not qryFunctions.Eof do
2130     begin
2131     if First then
2132     begin
2133     FMEtaData.Add(Format('%s/* External Function declarations */%s',
2134 tony 47 [LineEnding, LineEnding]));
2135 tony 33 First := false;
2136     end; //end_if
2137     { Start new function declaration }
2138     FMetaData.Add(Format('DECLARE EXTERNAL FUNCTION %s',
2139     [qryFunctions.FieldByName('RDB$FUNCTION_NAME').AsString]));
2140     Line := '';
2141    
2142     FirstArg := true;
2143     qryFuncArgs.Params.ByName('FUNCTION_NAME').AsString :=
2144     qryFunctions.FieldByName('RDB$FUNCTION_NAME').AsString;
2145    
2146     qryFuncArgs.ExecQuery;
2147     while not qryFuncArgs.Eof do
2148     begin
2149     { Find parameter type }
2150     i := 0;
2151     FieldType := qryFuncArgs.FieldByName('RDB$FIELD_TYPE').AsInteger;
2152     while FieldType <> ColumnTypes[i].SQLType do
2153     Inc(i);
2154    
2155     { Print length where appropriate }
2156     if FieldType in [ blr_text, blr_varying, blr_cstring] then
2157     begin
2158     DidCharset := false;
2159    
2160     qryCharSets.Params.ByName('CHARACTER_SET_ID').AsString :=
2161     qryFuncArgs.FieldByName('RDB$CHARACTER_SET_ID').AsString;
2162     qryCharSets.ExecQuery;
2163     while not qryCharSets.Eof do
2164     begin
2165     DidCharset := true;
2166     TypeBuffer := Format('%s(%d) CHARACTER SET %s',
2167     [ColumnTypes[i].TypeName,
2168     qryFuncArgs.FieldByName('RDB$FIELD_LENGTH').AsInteger div
2169     Max(1,qryCharSets.FieldByName('RDB$BYTES_PER_CHARACTER').AsInteger),
2170     qryCharSets.FieldByName('RDB$CHARACTER_SET_NAME').AsString]);
2171     qryCharSets.Next;
2172     end;
2173     qryCharSets.Close;
2174     if not DidCharset then
2175     TypeBuffer := Format('%s(%d)', [ColumnTypes[i].TypeName,
2176     qryFuncArgs.FieldByName('RDB$FIELD_LENGTH').AsInteger]);
2177     end //end_if
2178     else
2179     begin
2180     PrecisionKnown := false;
2181     if (FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10) and
2182     (FieldType in [blr_short, blr_long, blr_int64]) then
2183     begin
2184     qryFuncPos.Params.ByName('RDB$FUNCTION_NAME').AsString :=
2185     qryFuncArgs.FieldByName('RDB$FUNCTION_NAME').AsString;
2186     qryFuncPos.Params.ByName('RDB$ARGUMENT_POSITION').AsInteger :=
2187     qryFuncArgs.FieldByName('RDB$ARGUMENT_POSITION').AsInteger;
2188    
2189     qryFuncPos.ExecQuery;
2190     while not qryFuncPos.Eof do
2191     begin
2192     { We are ODS >= 10 and could be any Dialect }
2193     if not qryFuncPos.FieldByName('RDB$FIELD_PRECISION').IsNull then
2194     begin
2195     { We are Dialect >=3 since FIELD_PRECISION is non-NULL }
2196     if (qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and
2197     (qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then
2198     begin
2199     TypeBuffer := Format('%s(%d, %d)',
2200     [IntegralSubtypes[qryFuncPos.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger],
2201     qryFuncPos.FieldByName('RDB$FIELD_PRECISION').AsInteger,
2202     -qryFuncPos.FieldByName('RDB$FIELD_SCALE').AsInteger] );
2203     PrecisionKnown := true;
2204     end; //end_if
2205     end; { if field_precision is not null }
2206     qryFuncPos.Next;
2207     end;
2208     qryFuncPos.Close;
2209     end; { if major_ods >= ods_version10 && }
2210     if not PrecisionKnown then
2211     begin
2212     { Take a stab at numerics and decimals }
2213     if (FieldType = blr_short) and
2214     (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
2215     TypeBuffer := Format('NUMERIC(4, %d)',
2216     [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger])
2217     else
2218     if (FieldType = blr_long) and
2219     (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
2220     TypeBuffer := Format('NUMERIC(9, %d)',
2221     [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger])
2222     else
2223     if (FieldType = blr_double) and
2224     (qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
2225     TypeBuffer := Format('NUMERIC(15, %d)',
2226     [-qryFuncArgs.FieldByName('RDB$FIELD_SCALE').AsInteger])
2227     else
2228     TypeBuffer := ColumnTypes[i].TypeName;
2229     end; { if not PrecisionKnown }
2230     end; { if FCHAR or VARCHAR or CSTRING ... else }
2231    
2232     if qryFunctions.FieldByName('RDB$RETURN_ARGUMENT').AsInteger =
2233     qryFuncArgs.FieldByName('RDB$ARGUMENT_POSITION').AsInteger then
2234     begin
2235     ReturnBuffer := 'RETURNS ' + TypeBuffer;
2236     if qryFuncArgs.FieldByName('RDB$MECHANISM').AsInteger = 0 then
2237     ReturnBuffer := ReturnBuffer + ' BY VALUE ';
2238     if qryFuncArgs.FieldByName('RDB$MECHANISM').AsInteger < 0 then
2239     ReturnBuffer := ReturnBuffer + ' FREE_IT';
2240     end
2241     else
2242     begin
2243     { First arg needs no comma }
2244     if FirstArg then
2245     begin
2246     Line := Line + TypeBuffer;
2247     FirstArg := false;
2248     end
2249     else
2250     Line := Line + ', ' + TypeBuffer;
2251     end; //end_else
2252     qryFuncArgs.Next;
2253     end;
2254     qryFuncArgs.Close;
2255    
2256     FMetaData.Add(Line);
2257     FMetaData.Add(ReturnBuffer);
2258     FMetaData.Add(Format('ENTRY_POINT ''%s'' MODULE_NAME ''%s''%s%s%s',
2259     [qryFunctions.FieldByName('RDB$ENTRYPOINT').AsString,
2260     qryFunctions.FieldByName('RDB$MODULE_NAME').AsString,
2261 tony 47 Term, LineEnding, LineEnding]));
2262 tony 33
2263     qryFunctions.Next;
2264     end;
2265     finally
2266     qryFunctions.Free;
2267     qryFuncArgs.Free;
2268     qryCharSets.Free;
2269     qryFuncPos.Free;
2270     end;
2271     end;
2272    
2273     { ListGenerators
2274     Functional description
2275     Re create all non-system generators }
2276    
2277 tony 47 procedure TIBExtract.ListGenerators(GeneratorName: String;
2278     ExtractTypes: TExtractTypes);
2279 tony 33 const
2280     GeneratorSQL =
2281     'SELECT RDB$GENERATOR_NAME ' +
2282     'FROM RDB$GENERATORS ' +
2283     'WHERE ' +
2284     ' (RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG <> 1) ' +
2285     'ORDER BY RDB$GENERATOR_NAME';
2286    
2287     GeneratorNameSQL =
2288     'SELECT RDB$GENERATOR_NAME ' +
2289     'FROM RDB$GENERATORS ' +
2290     'WHERE RDB$GENERATOR_NAME = :GeneratorName AND ' +
2291     ' (RDB$SYSTEM_FLAG IS NULL OR RDB$SYSTEM_FLAG <> 1) ' +
2292     'ORDER BY RDB$GENERATOR_NAME';
2293    
2294 tony 47 GeneratorValueSQL =
2295     'SELECT GEN_ID(%s,0) as GENERATORVALUE From RDB$Database';
2296    
2297 tony 33 var
2298     qryGenerator : TIBSQL;
2299 tony 47 qryValue: TIBSQL;
2300 tony 33 GenName : String;
2301     begin
2302     qryGenerator := TIBSQL.Create(FDatabase);
2303 tony 47 qryValue := TIBSQL.Create(FDatabase);
2304 tony 33 try
2305     if GeneratorName = '' then
2306     qryGenerator.SQL.Text := GeneratorSQL
2307     else
2308     begin
2309     qryGenerator.SQL.Text := GeneratorNameSQL;
2310     qryGenerator.Params.ByName('GeneratorName').AsString := GeneratorName;
2311     end;
2312     qryGenerator.ExecQuery;
2313     FMetaData.Add('');
2314     while not qryGenerator.Eof do
2315     begin
2316     GenName := qryGenerator.FieldByName('RDB$GENERATOR_NAME').AsString;
2317     if ((Pos('RDB$',GenName) = 1) and
2318     (GenName[5] in ['0'..'9'])) or
2319     ((Pos('SQL$',GenName) = 1) and
2320     (GenName[5] in ['0'..'9'])) then
2321     begin
2322     qryGenerator.Next;
2323     continue;
2324     end;
2325 tony 45 FMetaData.Add(Format('CREATE SEQUENCE %s%s',
2326 tony 33 [QuoteIdentifier(FDatabase.SQLDialect, GenName),
2327     Term]));
2328 tony 47 if etData in ExtractTypes then
2329     begin
2330     qryValue.SQL.Text := Format(GeneratorValueSQL,[GenName]);
2331     qryValue.ExecQuery;
2332     try
2333     if not qryValue.EOF then
2334     FMetaData.Add(Format('ALTER SEQUENCE %s RESTART WITH %d;',
2335     [QuoteIdentifier(FDatabase.SQLDialect, GenName),
2336     qryValue.FieldByName('GENERATORVALUE').AsInteger]));
2337     finally
2338     qryValue.Close;
2339     end;
2340     end;
2341 tony 33 qryGenerator.Next;
2342     end;
2343     finally
2344     qryGenerator.Free;
2345 tony 47 qryValue.Free;
2346 tony 33 end;
2347     end;
2348    
2349     { ListIndex
2350     Functional description
2351     Define all non-constraint indices
2352     Use a static SQL query to get the info and print it.
2353    
2354     Uses get_index_segment to provide a key list for each index }
2355    
2356     procedure TIBExtract.ListIndex(ObjectName : String; ExtractType : TExtractType);
2357     const
2358     IndexSQL =
2359     'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' +
2360     ' IDX.RDB$INDEX_TYPE ' +
2361     'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' +
2362     ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' +
2363     'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' +
2364     ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' +
2365     ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' +
2366     'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME';
2367    
2368     IndexNameSQL =
2369     'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' +
2370     ' IDX.RDB$INDEX_TYPE ' +
2371     'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' +
2372     ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' +
2373     'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' +
2374     ' RELC.RDB$RELATION_NAME = :RelationName AND ' +
2375     ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' +
2376     ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' +
2377     'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME';
2378    
2379     IndexByNameSQL =
2380     'SELECT IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME, IDX.RDB$UNIQUE_FLAG, ' +
2381     ' IDX.RDB$INDEX_TYPE ' +
2382     'FROM RDB$INDICES IDX JOIN RDB$RELATIONS RELC ON ' +
2383     ' IDX.RDB$RELATION_NAME = RELC.RDB$RELATION_NAME ' +
2384     'WHERE (RELC.RDB$SYSTEM_FLAG <> 1 OR RELC.RDB$SYSTEM_FLAG IS NULL) AND ' +
2385     ' IDX.RDB$INDEX_NAME = :IndexName AND ' +
2386     ' NOT EXISTS (SELECT * FROM RDB$RELATION_CONSTRAINTS RC ' +
2387     ' WHERE RC.RDB$INDEX_NAME = IDX.RDB$INDEX_NAME) ' +
2388     'ORDER BY IDX.RDB$RELATION_NAME, IDX.RDB$INDEX_NAME';
2389    
2390     var
2391     qryIndex : TIBSQL;
2392     First : Boolean;
2393     Unique, IdxType, Line : String;
2394     begin
2395     First := true;
2396     qryIndex := TIBSQL.Create(FDatabase);
2397     try
2398     if ObjectName = '' then
2399     qryIndex.SQL.Text := IndexSQL
2400     else
2401     begin
2402     if ExtractType = etTable then
2403     begin
2404     qryIndex.SQL.Text := IndexNameSQL;
2405     qryIndex.Params.ByName('RelationName').AsString := ObjectName;
2406     end
2407     else
2408     begin
2409     qryIndex.SQL.Text := IndexByNameSQL;
2410     qryIndex.Params.ByName('IndexName').AsString := ObjectName;
2411     end;
2412     end;
2413     qryIndex.ExecQuery;
2414     while not qryIndex.Eof do
2415     begin
2416     if First then
2417     begin
2418     if ObjectName = '' then
2419 tony 47 FMetaData.Add(LineEnding + '/* Index definitions for all user tables */' + LineEnding)
2420 tony 33 else
2421 tony 47 FMetaData.Add(LineEnding + '/* Index definitions for ' + ObjectName + ' */' + LineEnding);
2422 tony 33 First := false;
2423     end; //end_if
2424    
2425     if qryIndex.FieldByName('RDB$UNIQUE_FLAG').AsInteger = 1 then
2426     Unique := ' UNIQUE'
2427     else
2428     Unique := '';
2429    
2430     if qryIndex.FieldByName('RDB$INDEX_TYPE').AsInteger = 1 then
2431     IdxType := ' DESCENDING'
2432     else
2433     IdxType := '';
2434    
2435     Line := Format('CREATE%s%s INDEX %s ON %s(', [Unique, IdxType,
2436     QuoteIdentifier(FDataBase.SQLDialect,
2437     qryIndex.FieldByName('RDB$INDEX_NAME').AsString),
2438     QuoteIdentifier(FDataBase.SQLDialect,
2439     qryIndex.FieldByName('RDB$RELATION_NAME').AsString)]);
2440    
2441     Line := Line + GetIndexSegments(qryIndex.FieldByName('RDB$INDEX_NAME').AsString) +
2442     ')' + Term;
2443    
2444     FMetaData.Add(Line);
2445     qryIndex.Next;
2446     end;
2447     finally
2448     qryIndex.Free;
2449     end;
2450     end;
2451    
2452     { ListViews
2453     Functional description
2454     Show text of views.
2455     Use a SQL query to get the info and print it.
2456     Note: This should also contain check option }
2457    
2458     procedure TIBExtract.ListViews(ViewName : String);
2459     const
2460     ViewSQL =
2461 tony 47 'with recursive Views as ( ' +
2462     ' Select RDB$RELATION_NAME, 1 as ViewLevel from RDB$RELATIONS ' +
2463     ' Where RDB$RELATION_TYPE = 1 and RDB$SYSTEM_FLAG = 0 '+
2464     ' UNION ALL ' +
2465     ' Select D.RDB$DEPENDED_ON_NAME, ViewLevel + 1 From RDB$DEPENDENCIES D ' +
2466     ' JOIN Views on Views.RDB$RELATION_NAME = D.RDB$DEPENDENT_NAME ' +
2467     ' and Views.RDB$RELATION_NAME <> D.RDB$DEPENDED_ON_NAME ' +
2468     ' JOIN RDB$RELATIONS R On R.RDB$RELATION_NAME = D.RDB$DEPENDED_ON_NAME ' +
2469     ')' +
2470     'SELECT R.RDB$RELATION_NAME, R.RDB$OWNER_NAME, R.RDB$VIEW_SOURCE FROM RDB$RELATIONS R ' +
2471     'JOIN ( ' +
2472     'Select RDB$RELATION_NAME, max(ViewLevel) as ViewLevel From Views ' +
2473     'Group By RDB$RELATION_NAME) A On A.RDB$RELATION_NAME = R.RDB$RELATION_NAME ' +
2474     'Where R.RDB$RELATION_TYPE = 1 and R.RDB$SYSTEM_FLAG = 0 '+
2475     'Order by A.ViewLevel desc, R.RDB$RELATION_NAME asc';
2476    
2477     {
2478 tony 33 'SELECT RDB$RELATION_NAME, RDB$OWNER_NAME, RDB$VIEW_SOURCE ' +
2479     'FROM RDB$RELATIONS ' +
2480     'WHERE ' +
2481     ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' +
2482     ' NOT RDB$VIEW_BLR IS NULL AND ' +
2483     ' RDB$FLAGS = 1 ' +
2484 tony 47 'ORDER BY RDB$RELATION_ID'; }
2485 tony 33
2486     ViewNameSQL =
2487     'SELECT RDB$RELATION_NAME, RDB$OWNER_NAME, RDB$VIEW_SOURCE ' +
2488     'FROM RDB$RELATIONS ' +
2489     'WHERE ' +
2490     ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' +
2491     ' NOT RDB$VIEW_BLR IS NULL AND ' +
2492     ' RDB$FLAGS = 1 AND ' +
2493     ' RDB$RELATION_NAME = :ViewName ' +
2494     'ORDER BY RDB$RELATION_ID';
2495    
2496     ColumnSQL =
2497     'SELECT RDB$FIELD_NAME FROM RDB$RELATION_FIELDS ' +
2498     'WHERE ' +
2499     ' RDB$RELATION_NAME = :RELATION_NAME ' +
2500     'ORDER BY RDB$FIELD_POSITION';
2501    
2502     var
2503     qryView, qryColumns : TIBSQL;
2504     SList : TStrings;
2505     begin
2506     qryView := TIBSQL.Create(FDatabase);
2507     qryColumns := TIBSQL.Create(FDatabase);
2508     SList := TStringList.Create;
2509     try
2510     if ViewName = '' then
2511     qryView.SQL.Text := ViewSQL
2512     else
2513     begin
2514     qryView.SQL.Text := ViewNameSQL;
2515     qryView.Params.ByName('ViewName').AsString := ViewName;
2516     end;
2517     qryColumns.SQL.Text := ColumnSQL;
2518     qryView.ExecQuery;
2519     while not qryView.Eof do
2520     begin
2521     SList.Add(Format('%s/* View: %s, Owner: %s */%s',
2522 tony 47 [LineEnding, qryView.FieldByName('RDB$RELATION_NAME').AsString,
2523     qryView.FieldByName('RDB$OWNER_NAME').AsString, LineEnding]));
2524 tony 33
2525     SList.Add(Format('CREATE VIEW %s (', [QuoteIdentifier(FDatabase.SQLDialect,
2526     qryView.FieldByName('RDB$RELATION_NAME').AsString)]));
2527    
2528     qryColumns.Params.ByName('RELATION_NAME').AsString :=
2529     qryView.FieldByName('RDB$RELATION_NAME').AsString;
2530     qryColumns.ExecQuery;
2531     while not qryColumns.Eof do
2532     begin
2533     SList.Add(' ' + QuoteIdentifier(FDatabase.SQLDialect,
2534     qryColumns.FieldByName('RDB$FIELD_NAME').AsString));
2535     qryColumns.Next;
2536     if not qryColumns.Eof then
2537     SList.Strings[SList.Count - 1] := SList.Strings[SList.Count - 1] + ', ';
2538     end;
2539     qryColumns.Close;
2540 tony 47 SList.Text := SList.Text + Format(') AS%s', [LineEnding]);
2541 tony 33 if not qryView.FieldByName('RDB$VIEW_SOURCE').IsNull then
2542     SList.Text := SList.Text + qryView.FieldByName('RDB$VIEW_SOURCE').AsString;
2543 tony 47 SList.Text := SList.Text + Format('%s%s', [Term, LineEnding]);
2544 tony 33 FMetaData.AddStrings(SList);
2545     SList.Clear;
2546     qryView.Next;
2547     end;
2548     finally
2549     qryView.Free;
2550     qryColumns.Free;
2551     SList.Free;
2552     end;
2553     end;
2554    
2555     { PrintSet
2556     Functional description
2557     print (using ISQL_printf) the word "SET"
2558     if the first line of the ALTER DATABASE
2559     settings options. Also, add trailing
2560     comma for end of prior line if needed.
2561    
2562     uses Print_buffer, a global }
2563    
2564     function TIBExtract.PrintSet(var Used: Boolean) : String;
2565     begin
2566     if not Used then
2567     begin
2568     Result := ' SET ';
2569     Used := true;
2570     end
2571     else
2572 tony 47 Result := Format(', %s ', [LineEnding]);
2573 tony 33 end;
2574    
2575     {
2576     PrintValidation
2577     Functional description
2578     This does some minor syntax adjustmet for extracting
2579     validation blobs and computed fields.
2580     if it does not start with the word CHECK
2581     if this is a computed field blob,look for () or insert them.
2582     if flag = false, this is a validation clause,
2583     if flag = true, this is a computed field }
2584    
2585     function TIBExtract.PrintValidation(ToValidate: String;
2586     flag: Boolean): String;
2587     var
2588     IsSQL : Boolean;
2589     begin
2590     IsSql := false;
2591    
2592     Result := '';
2593     ToValidate := Trim(ToValidate);
2594    
2595     if flag then
2596     begin
2597     if ToValidate[1] = '(' then
2598     IsSQL := true;
2599     end
2600     else
2601     if (Pos(ToValidate, 'check') = 1) or (Pos(ToValidate, 'CHECK') = 1) then
2602     IsSQL := TRUE;
2603    
2604     if not IsSQL then
2605     begin
2606     if Flag then
2607     Result := Result + '/* ' + ToValidate + ' */'
2608     else
2609     Result := Result + '(' + ToValidate + ')';
2610     end
2611     else
2612     Result := ToValidate;
2613     end;
2614    
2615     procedure TIBExtract.SetDatabase(const Value: TIBDatabase);
2616     begin
2617     if FDatabase <> Value then
2618     begin
2619     FDatabase := Value;
2620     if (not Assigned(FTransaction)) and (FDatabase <> nil) then
2621     Transaction := FDatabase.DefaultTransaction;
2622     FDatabaseInfo.Database := FDatabase;
2623     end;
2624     end;
2625    
2626     procedure TIBExtract.SetTransaction(const Value: TIBTransaction);
2627     begin
2628     if FTransaction <> Value then
2629     begin
2630     FTransaction := Value;
2631     if (not Assigned(FDatabase)) and (FTransaction <> nil) then
2632     Database := FTransaction.DefaultDatabase;
2633     end;
2634     end;
2635    
2636     procedure TIBExtract.ExtractObject(ObjectType : TExtractObjectTypes;
2637     ObjectName : String = ''; ExtractTypes : TExtractTypes = []);
2638     var
2639     DidActivate : Boolean;
2640     begin
2641     DidActivate := false;
2642     if not FTransaction.Active then
2643     begin
2644     FTransaction.StartTransaction;
2645     DidActivate := true;
2646     end;
2647     FMetaData.Clear;
2648     case ObjectType of
2649 tony 47 eoDatabase : ExtractDDL(true, '', etData in ExtractTypes);
2650 tony 33 eoDomain :
2651     if etTable in ExtractTypes then
2652     ListDomains(ObjectName, etTable)
2653     else
2654     ListDomains(ObjectName);
2655     eoTable :
2656     begin
2657     if ObjectName <> '' then
2658     begin
2659     if etDomain in ExtractTypes then
2660     ListDomains(ObjectName, etTable);
2661     ExtractListTable(ObjectName, '', false);
2662     if etIndex in ExtractTypes then
2663     ListIndex(ObjectName, etTable);
2664     if etForeign in ExtractTypes then
2665     ListForeign(ObjectName, etTable);
2666     if etCheck in ExtractTypes then
2667     ListCheck(ObjectName, etTable);
2668     if etTrigger in ExtractTypes then
2669 tony 47 begin
2670     if etGrant in ExtractTypes then
2671     ListTriggers(ObjectName, [etTable,etGrant])
2672     else
2673     ListTriggers(ObjectName, [etTable]);
2674     end;
2675 tony 33 if etGrant in ExtractTypes then
2676     ShowGrants(ObjectName, Term);
2677     if etData in ExtractTypes then
2678     ListData(ObjectName);
2679     end
2680     else
2681     ListAllTables(true);
2682     end;
2683 tony 45 eoView :
2684     begin
2685     ListViews(ObjectName);
2686     if ObjectName <> '' then
2687     begin
2688     if etTrigger in ExtractTypes then
2689 tony 47 begin
2690     if etGrant in ExtractTypes then
2691     ListTriggers(ObjectName, [etTable,etGrant])
2692     else
2693     ListTriggers(ObjectName, [etTable]);
2694     end;
2695     if etGrant in ExtractTypes then
2696     ShowGrants(ObjectName, Term);
2697 tony 45 end;
2698     end;
2699 tony 47 eoProcedure :
2700     begin
2701     ListProcs(pdCreateProc,ObjectName,etGrant in ExtractTypes);
2702     if (ObjectName <> '' ) and (etGrant in ExtractTypes) then
2703     ShowGrants(ObjectName, Term);
2704     end;
2705 tony 33 eoFunction : ListFunctions(ObjectName);
2706 tony 47 eoGenerator : ListGenerators(ObjectName,ExtractTypes);
2707 tony 33 eoException : ListException(ObjectName);
2708     eoBLOBFilter : ListFilters(ObjectName);
2709     eoRole : ListRoles(ObjectName);
2710     eoTrigger :
2711     if etTable in ExtractTypes then
2712 tony 47 begin
2713     if etGrant in ExtractTypes then
2714     ListTriggers(ObjectName, [etTable,etGrant])
2715     else
2716     ListTriggers(ObjectName, [etTable])
2717     end
2718 tony 33 else
2719 tony 47 if etGrant in ExtractTypes then
2720     ListTriggers(ObjectName,[etTrigger,etGrant])
2721     else
2722     ListTriggers(ObjectName);
2723 tony 33 eoForeign :
2724     if etTable in ExtractTypes then
2725     ListForeign(ObjectName, etTable)
2726     else
2727     ListForeign(ObjectName);
2728     eoIndexes :
2729     if etTable in ExtractTypes then
2730     ListIndex(ObjectName, etTable)
2731     else
2732     ListIndex(ObjectName);
2733     eoChecks :
2734     if etTable in ExtractTypes then
2735     ListCheck(ObjectName, etTable)
2736     else
2737     ListCheck(ObjectName);
2738     eoData : ListData(ObjectName);
2739     end;
2740     if DidActivate then
2741     FTransaction.Commit;
2742     end;
2743    
2744     function TIBExtract.GetFieldType(FieldType, FieldSubType, FieldScale,
2745     FieldSize, FieldPrec, FieldLen: Integer): String;
2746     var
2747     i : Integer;
2748     PrecisionKnown : Boolean;
2749     begin
2750     Result := '';
2751     for i := Low(ColumnTypes) to High(ColumnTypes) do
2752     if FieldType = ColumnTypes[i].SQLType then
2753     begin
2754     PrecisionKnown := FALSE;
2755     if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then
2756     begin
2757     if FieldType in [blr_short, blr_long, blr_int64] then
2758     begin
2759     { We are ODS >= 10 and could be any Dialect }
2760     if (FDatabaseInfo.DBSQLDialect >= 3) and
2761     (FieldPrec <> 0) and
2762     (FieldSubType > 0) and
2763     (FieldSubType <= MAX_INTSUBTYPES) then
2764     begin
2765     Result := Result + Format('%s(%d, %d)', [
2766     IntegralSubtypes [FieldSubType],
2767     FieldPrec,
2768     -1 * FieldScale]);
2769     PrecisionKnown := true;
2770     end;
2771     end;
2772     end;
2773     if PrecisionKnown = false then
2774     begin
2775     { Take a stab at numerics and decimals }
2776     if (FieldType = blr_short) and
2777     (FieldScale < 0) then
2778     Result := Result + Format('NUMERIC(4, %d)',
2779     [-FieldScale] )
2780     else
2781     if (FieldType = blr_long) and
2782     (FieldScale < 0) then
2783     Result := Result + Format('NUMERIC(9, %d)',
2784     [-FieldScale] )
2785     else
2786     if (FieldType = blr_double) and
2787     (FieldScale < 0) then
2788     Result := Result + Format('NUMERIC(15, %d)',
2789     [-FieldScale] )
2790     else
2791     Result := Result + ColumnTypes[i].TypeName;
2792     end;
2793     break;
2794     end;
2795     if (FieldType in [blr_text, blr_varying]) and
2796     (FieldSize <> 0) then
2797     Result := Result + Format('(%d)', [FieldSize]);
2798     end;
2799    
2800     { S H O W _ g r a n t s
2801     Functional description
2802     Show grants for given object name
2803     This function is also called by extract for privileges.
2804     It must extract granted privileges on tables/views to users,
2805     - these may be compound, so put them on the same line.
2806     Grant execute privilege on procedures to users
2807 tony 45 Grant various privileges to procedures.
2808 tony 33 All privileges may have the with_grant option set. }
2809    
2810 tony 45 procedure TIBExtract.ShowGrants(MetaObject: String; Terminator: String);
2811 tony 33 const
2812 tony 47 GrantsBaseSelect =
2813     'Select Trim(RDB$USER) as RDB$USER,List("Privileges") as Privileges, '+
2814     'coalesce(RDB$GRANT_OPTION,0) as RDB$GRANT_OPTION,METAOBJECTNAME, '+
2815     'RDB$USER_TYPE, RDB$OBJECT_TYPE, '+
2816     'case RDB$OBJECT_TYPE '+
2817     'When 0 then ''TABLE'' '+
2818     'When 5 then ''PROCEDURE'' '+
2819     'When 7 then ''EXCEPTION'' '+
2820     'When 11 then ''CHARACTER SET'' '+
2821     'When 14 then ''GENERATOR'' '+
2822     'ELSE NULL END as OBJECT_TYPE_NAME, '+
2823     'case RDB$USER_TYPE '+
2824     'When 5 then ''PROCEDURE'' '+
2825     'When 2 then ''TRIGGER'' '+
2826     'When 8 then ''USER'' '+
2827     'When 13 then ''ROLE'' '+
2828     'ELSE NULL END as USER_TYPE_NAME, '+
2829     'case '+
2830     'When coalesce(RDB$GRANT_OPTION,0) <> 0 and RDB$USER_TYPE = 13 then '' WITH ADMIN OPTION'' '+
2831     'When coalesce(RDB$GRANT_OPTION,0) <> 0 and RDB$USER_TYPE <> 13 then '' WITH GRANT OPTION'' '+
2832     'ELSE '''' End as GRANTOPTION '+
2833     'From ( '+
2834     'Select PR.RDB$USER,PR.RDB$RELATION_NAME as METAOBJECTNAME, LIST(DISTINCT Trim(Case PR.RDB$PRIVILEGE '+
2835     'When ''X'' then ''EXECUTE'' '+
2836     'When ''S'' then ''SELECT'' '+
2837     'When ''U'' then ''UPDATE'' '+
2838     'When ''D'' then ''DELETE'' '+
2839     'When ''R'' then ''REFERENCES'' '+
2840     'When ''G'' then ''USAGE'' '+
2841     'When ''I'' then ''INSERT'' end )) as "Privileges", '+
2842     'PR.RDB$GRANT_OPTION, PR.RDB$USER_TYPE, PR.RDB$OBJECT_TYPE,OW.RDB$OWNER_NAME '+
2843     'FROM RDB$USER_PRIVILEGES PR '+
2844     'JOIN ObjectOwners OW On OW.METAOBJECTNAME = PR.RDB$RELATION_NAME and OW.ObjectType = PR.RDB$OBJECT_TYPE '+
2845     'Where PR.RDB$PRIVILEGE <> ''M'' and (PR.RDB$PRIVILEGE <> ''U'' or PR.RDB$FIELD_NAME is null) '+
2846     'Group By PR.RDB$USER,PR.RDB$RELATION_NAME,PR.RDB$GRANT_OPTION, PR.RDB$USER_TYPE, PR.RDB$OBJECT_TYPE,OW.RDB$OWNER_NAME '+
2847     'UNION '+
2848     'Select PR.RDB$USER,PR.RDB$RELATION_NAME, ''Update('' || List(Trim(PR.RDB$FIELD_NAME)) || '')'', '+
2849     'PR.RDB$GRANT_OPTION, PR.RDB$USER_TYPE, PR.RDB$OBJECT_TYPE, OW.RDB$OWNER_NAME '+
2850     'FROM RDB$USER_PRIVILEGES PR '+
2851     'JOIN ObjectOwners OW On OW.METAOBJECTNAME = PR.RDB$RELATION_NAME and OW.ObjectType = PR.RDB$OBJECT_TYPE '+
2852     'Where PR.RDB$PRIVILEGE = ''U'' and PR.RDB$FIELD_NAME is not null '+
2853     'Group By PR.RDB$USER,PR.RDB$RELATION_NAME,PR.RDB$GRANT_OPTION, PR.RDB$USER_TYPE, PR.RDB$OBJECT_TYPE, OW.RDB$OWNER_NAME) '+
2854     'Where METAOBJECTNAME = :METAOBJECTNAME and RDB$USER <> RDB$OWNER_NAME '+
2855     'Group By RDB$USER,RDB$GRANT_OPTION, RDB$USER_TYPE, RDB$OBJECT_TYPE,METAOBJECTNAME '+
2856     'ORDER BY RDB$USER, RDB$OBJECT_TYPE';
2857 tony 33
2858 tony 47 GrantsSQL12 =
2859     'with ObjectOwners As ( '+
2860     'Select RDB$RELATION_NAME as METAOBJECTNAME, RDB$OWNER_NAME, 0 as ObjectType '+
2861     'From RDB$RELATIONS '+
2862     'UNION '+
2863     'Select RDB$PROCEDURE_NAME as METAOBJECTNAME, RDB$OWNER_NAME, 5 as ObjectType '+
2864     'From RDB$PROCEDURES '+
2865     'UNION '+
2866     'Select RDB$EXCEPTION_NAME as METAOBJECTNAME, RDB$OWNER_NAME, 7 as ObjectType '+
2867     'From RDB$EXCEPTIONS '+
2868     'UNION '+
2869     'Select RDB$GENERATOR_NAME as METAOBJECTNAME, RDB$OWNER_NAME, 14 as ObjectType '+
2870     'From RDB$GENERATORS '+
2871     'UNION '+
2872     'Select RDB$CHARACTER_SET_NAME as METAOBJECTNAME, RDB$OWNER_NAME, 11 as ObjectType '+
2873     'From RDB$CHARACTER_SETS '+
2874     ') '+ GrantsBaseSelect;
2875 tony 33
2876 tony 47 GrantsSQL =
2877     'with ObjectOwners As ( '+
2878     'Select RDB$RELATION_NAME as METAOBJECTNAME, RDB$OWNER_NAME, 0 as ObjectType '+
2879     'From RDB$RELATIONS '+
2880     'UNION '+
2881     'Select RDB$PROCEDURE_NAME as METAOBJECTNAME, RDB$OWNER_NAME, 5 as ObjectType '+
2882     'From RDB$PROCEDURES '+
2883     'UNION '+
2884     'Select RDB$EXCEPTION_NAME as METAOBJECTNAME, ''SYSDBA'', 7 as ObjectType '+
2885     'From RDB$EXCEPTIONS '+
2886     'UNION '+
2887     'Select RDB$GENERATOR_NAME as METAOBJECTNAME, ''SYSDBA'', 14 as ObjectType '+
2888     'From RDB$GENERATORS '+
2889     'UNION '+
2890     'Select RDB$CHARACTER_SET_NAME as METAOBJECTNAME, ''SYSDBA'', 11 as ObjectType '+
2891     'From RDB$CHARACTER_SETS '+
2892     ') '+ GrantsBaseSelect;
2893 tony 33
2894 tony 47 var qryOwnerPriv : TIBSQL;
2895 tony 33
2896     begin
2897     if MetaObject = '' then
2898     exit;
2899    
2900     qryOwnerPriv := TIBSQL.Create(FDatabase);
2901     try
2902 tony 47 if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION12 then
2903     qryOwnerPriv.SQL.Text := GrantsSQL12
2904     else
2905     qryOwnerPriv.SQL.Text := GrantsSQL;
2906     qryOwnerPriv.Params.ByName('METAOBJECTNAME').AsString := MetaObject;
2907 tony 33 qryOwnerPriv.ExecQuery;
2908     while not qryOwnerPriv.Eof do
2909     begin
2910 tony 47 FMetaData.Add(Format('GRANT %s ON %s "%s" TO %s "%s" %s%s', [
2911     qryOwnerPriv.FieldByName('Privileges').AsString,
2912     qryOwnerPriv.FieldByName('OBJECT_TYPE_NAME').AsString,
2913     qryOwnerPriv.FieldByName('METAOBJECTNAME').AsString,
2914     qryOwnerPriv.FieldByName('USER_TYPE_NAME').AsString,
2915     qryOwnerPriv.FieldByName('RDB$USER').AsString,
2916     qryOwnerPriv.FieldByName('GRANTOPTION').AsString,
2917     Terminator]));
2918 tony 33 qryOwnerPriv.Next;
2919     end;
2920     qryOwnerPriv.Close;
2921 tony 47 finally
2922     qryOwnerPriv.Free;
2923     end;
2924     end;
2925 tony 33
2926 tony 47 procedure TIBExtract.ShowGrantsTo(MetaObject: String; ObjectType: integer; Terminator: String);
2927     const
2928     GrantsSQL =
2929     'Select Trim(RDB$USER) as RDB$USER,List("Privileges") as Privileges, '+
2930     'coalesce(RDB$GRANT_OPTION,0) as RDB$GRANT_OPTION,METAOBJECTNAME, '+
2931     'RDB$USER_TYPE, RDB$OBJECT_TYPE, '+
2932     'case RDB$OBJECT_TYPE '+
2933     'When 0 then ''TABLE'' '+
2934     'When 5 then ''PROCEDURE'' '+
2935     'When 7 then ''EXCEPTION'' '+
2936     'When 11 then ''CHARACTER SET'' '+
2937     'ELSE NULL END as OBJECT_TYPE_NAME, '+
2938     'case RDB$USER_TYPE '+
2939     'When 5 then ''PROCEDURE'' '+
2940     'When 2 then ''TRIGGER'' '+
2941     'When 8 then ''USER'' '+
2942     'When 13 then ''ROLE'' '+
2943     'ELSE NULL END as USER_TYPE_NAME, '+
2944     'case '+
2945     'When coalesce(RDB$GRANT_OPTION,0) <> 0 and RDB$USER_TYPE = 13 then '' WITH ADMIN OPTION'' '+
2946     'When coalesce(RDB$GRANT_OPTION,0) <> 0 and RDB$USER_TYPE <> 13 then '' WITH GRANT OPTION'' '+
2947     'ELSE '''' End as GRANTOPTION '+
2948     'From ( '+
2949     'Select PR.RDB$USER,PR.RDB$RELATION_NAME as METAOBJECTNAME, LIST(DISTINCT Trim(Case PR.RDB$PRIVILEGE '+
2950     'When ''X'' then ''EXECUTE'' '+
2951     'When ''S'' then ''SELECT'' '+
2952     'When ''U'' then ''UPDATE'' '+
2953     'When ''D'' then ''DELETE'' '+
2954     'When ''R'' then ''REFERENCES'' '+
2955     'When ''G'' then ''USAGE'' '+
2956     'When ''I'' then ''INSERT'' end )) as "Privileges", '+
2957     'PR.RDB$GRANT_OPTION, PR.RDB$USER_TYPE, PR.RDB$OBJECT_TYPE '+
2958     'FROM RDB$USER_PRIVILEGES PR '+
2959     'Where PR.RDB$PRIVILEGE <> ''M'' and (PR.RDB$PRIVILEGE <> ''U'' or PR.RDB$FIELD_NAME is null) '+
2960     'Group By PR.RDB$USER,PR.RDB$RELATION_NAME,PR.RDB$GRANT_OPTION, PR.RDB$USER_TYPE, PR.RDB$OBJECT_TYPE '+
2961     'UNION '+
2962     'Select PR.RDB$USER,PR.RDB$RELATION_NAME, ''Update('' || List(Trim(PR.RDB$FIELD_NAME)) || '')'', '+
2963     'PR.RDB$GRANT_OPTION, PR.RDB$USER_TYPE, PR.RDB$OBJECT_TYPE '+
2964     'FROM RDB$USER_PRIVILEGES PR '+
2965     'Where PR.RDB$PRIVILEGE = ''U'' and PR.RDB$FIELD_NAME is not null '+
2966     'Group By PR.RDB$USER,PR.RDB$RELATION_NAME,PR.RDB$GRANT_OPTION, PR.RDB$USER_TYPE, PR.RDB$OBJECT_TYPE) '+
2967     'Where RDB$USER = :METAOBJECTNAME and RDB$USER_TYPE = :USERTYPE '+
2968     'Group By RDB$USER,RDB$GRANT_OPTION, RDB$USER_TYPE, RDB$OBJECT_TYPE, METAOBJECTNAME '+
2969     'ORDER BY METAOBJECTNAME';
2970 tony 33
2971 tony 47 var qryOwnerPriv : TIBSQL;
2972 tony 33
2973 tony 47 begin
2974     if MetaObject = '' then
2975     exit;
2976 tony 33
2977 tony 47 qryOwnerPriv := TIBSQL.Create(FDatabase);
2978     try
2979     qryOwnerPriv.SQL.Text := GrantsSQL;
2980     qryOwnerPriv.Params.ByName('METAOBJECTNAME').AsString := MetaObject;
2981     qryOwnerPriv.Params.ByName('USERTYPE').AsInteger := ObjectType;
2982     qryOwnerPriv.ExecQuery;
2983     while not qryOwnerPriv.Eof do
2984 tony 33 begin
2985 tony 47 FMetaData.Add(Format('GRANT %s ON %s "%s" TO %s "%s" %s%s', [
2986     qryOwnerPriv.FieldByName('Privileges').AsString,
2987     qryOwnerPriv.FieldByName('OBJECT_TYPE_NAME').AsString,
2988     qryOwnerPriv.FieldByName('METAOBJECTNAME').AsString,
2989     qryOwnerPriv.FieldByName('USER_TYPE_NAME').AsString,
2990     qryOwnerPriv.FieldByName('RDB$USER').AsString,
2991     qryOwnerPriv.FieldByName('GRANTOPTION').AsString,
2992     Terminator]));
2993     qryOwnerPriv.Next;
2994 tony 33 end;
2995     qryOwnerPriv.Close;
2996     finally
2997     qryOwnerPriv.Free;
2998     end;
2999 tony 47 FMetaData.Add('');
3000 tony 33 end;
3001    
3002     { ShowGrantRoles
3003     Functional description
3004     Show grants for given role name
3005     This function is also called by extract for privileges.
3006     All membership privilege may have the with_admin option set. }
3007    
3008     procedure TIBExtract.ShowGrantRoles(Terminator: String);
3009     const
3010     RoleSQL =
3011     'SELECT RDB$USER, RDB$GRANT_OPTION, RDB$RELATION_NAME ' +
3012     'FROM RDB$USER_PRIVILEGES ' +
3013     'WHERE ' +
3014     ' RDB$OBJECT_TYPE = %d AND ' +
3015     ' RDB$USER_TYPE = %d AND ' +
3016     ' RDB$PRIVILEGE = ''M'' ' +
3017     'ORDER BY RDB$RELATION_NAME, RDB$USER';
3018    
3019     var
3020     WithOption, UserString : String;
3021     qryRole : TIBSQL;
3022    
3023     begin
3024     qryRole := TIBSQL.Create(FDatabase);
3025     try
3026     qryRole.SQL.Text := Format(RoleSQL, [obj_sql_role, obj_user]);
3027     qryRole.ExecQuery;
3028     while not qryRole.Eof do
3029     begin
3030     UserString := Trim(qryRole.FieldByName('RDB$USER').AsString);
3031    
3032     if (not qryRole.FieldByName('RDB$GRANT_OPTION').IsNull) and
3033     (qryRole.FieldByName('RDB$GRANT_OPTION').AsInteger = 1) then
3034     WithOption := ' WITH ADMIN OPTION'
3035     else
3036     WithOption := '';
3037     FMetaData.Add(Format('GRANT %s TO %s%s%s%s',
3038     [ QuoteIdentifier(FDatabase.SQLDialect, qryRole.FieldByName('RDB$RELATION_NAME').AsString),
3039 tony 47 UserString, WithOption, Terminator, LineEnding]));
3040 tony 33
3041     qryRole.Next;
3042     end;
3043     finally
3044     qryRole.Free;
3045     end;
3046     end;
3047    
3048     { GetProcedureArgs
3049     Functional description
3050     This function extract the procedure parameters and adds it to the
3051     extract file }
3052    
3053     procedure TIBExtract.GetProcedureArgs(Proc: String);
3054     const
3055     { query to retrieve the input parameters. }
3056     ProcHeaderSQL =
3057     'SELECT * ' +
3058     ' FROM RDB$PROCEDURE_PARAMETERS PRM JOIN RDB$FIELDS FLD ON ' +
3059     ' PRM.RDB$FIELD_SOURCE = FLD.RDB$FIELD_NAME ' +
3060     'WHERE ' +
3061     ' PRM.RDB$PROCEDURE_NAME = :PROCNAME AND ' +
3062     ' PRM.RDB$PARAMETER_TYPE = :Input ' +
3063     'ORDER BY PRM.RDB$PARAMETER_NUMBER';
3064    
3065     var
3066     FirstTime, PrecisionKnown : Boolean;
3067     Line : String;
3068     qryHeader : TIBSQL;
3069    
3070     function FormatParamStr : String;
3071     var
3072     i, CollationID, CharSetID : Integer;
3073     begin
3074     Result := Format(' %s ', [qryHeader.FieldByName('RDB$PARAMETER_NAME').AsString]);
3075     for i := Low(ColumnTypes) to High(ColumnTypes) do
3076     if qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = ColumnTypes[i].SQLType then
3077     begin
3078     PrecisionKnown := FALSE;
3079     if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION10 then
3080     begin
3081     if qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_short, blr_long, blr_int64] then
3082     begin
3083     { We are ODS >= 10 and could be any Dialect }
3084     if (FDatabaseInfo.DBSQLDialect >= 3) and
3085     (not qryHeader.FieldByName('RDB$FIELD_PRECISION').IsNull) and
3086     (qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger > 0) and
3087     (qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger <= MAX_INTSUBTYPES) then
3088     begin
3089     Result := Result + Format('%s(%d, %d)', [
3090     IntegralSubtypes [qryHeader.FieldByName('RDB$FIELD_SUB_TYPE').AsInteger],
3091     qryHeader.FieldByName('RDB$FIELD_PRECISION').AsInteger,
3092     -1 * qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger]);
3093     PrecisionKnown := true;
3094     end;
3095     end;
3096     end;
3097     if PrecisionKnown = false then
3098     begin
3099     { Take a stab at numerics and decimals }
3100     if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_short) and
3101     (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
3102     Result := Result + Format('NUMERIC(4, %d)',
3103     [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] )
3104     else
3105     if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_long) and
3106     (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
3107     Result := Result + Format('NUMERIC(9, %d)',
3108     [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] )
3109     else
3110     if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger = blr_double) and
3111     (qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger < 0) then
3112     Result := Result + Format('NUMERIC(15, %d)',
3113     [-qryHeader.FieldByName('RDB$FIELD_SCALE').AsInteger] )
3114     else
3115     Result := Result + ColumnTypes[i].TypeName;
3116     end;
3117     break;
3118     end;
3119 tony 47 if (qryHeader.FieldByName('RDB$FIELD_TYPE').AsInteger in [blr_text, blr_varying]) then
3120     begin
3121     if not qryHeader.FieldByName('RDB$CHARACTER_LENGTH').IsNull then
3122     Result := Result + Format('(%d)', [qryHeader.FieldByName('RDB$CHARACTER_LENGTH').AsInteger])
3123     else
3124     Result := Result + Format('(%d)', [qryHeader.FieldByName('RDB$FIELD_LENGTH').AsInteger]);
3125     end;
3126 tony 33
3127     { Show international character sets and collations }
3128    
3129     if (not qryHeader.FieldByName('RDB$COLLATION_ID').IsNull) or
3130     (not qryHeader.FieldByName('RDB$CHARACTER_SET_ID').IsNull) then
3131     begin
3132     if qryHeader.FieldByName('RDB$COLLATION_ID').IsNull then
3133     CollationId := 0
3134     else
3135     CollationId := qryHeader.FieldByName('RDB$COLLATION_ID').AsInteger;
3136    
3137     if qryHeader.FieldByName('RDB$CHARACTER_SET_ID').IsNull then
3138     CharSetId := 0
3139     else
3140     CharSetId := qryHeader.FieldByName('RDB$CHARACTER_SET_ID').AsInteger;
3141    
3142     Result := Result + GetCharacterSets(CharSetId, CollationId, false);
3143     end;
3144     end;
3145    
3146     begin
3147     FirstTime := true;
3148     qryHeader := TIBSQL.Create(FDatabase);
3149     try
3150     qryHeader.SQL.Text := ProcHeaderSQL;
3151     qryHeader.Params.ByName('procname').AsString := Proc;
3152     qryHeader.Params.ByName('Input').AsInteger := 0;
3153     qryHeader.ExecQuery;
3154     while not qryHeader.Eof do
3155     begin
3156     if FirstTime then
3157     begin
3158     FirstTime := false;
3159     FMetaData.Add('(');
3160     end;
3161    
3162     Line := FormatParamStr;
3163    
3164     qryHeader.Next;
3165     if not qryHeader.Eof then
3166     Line := Line + ',';
3167     FMetaData.Add(Line);
3168     end;
3169    
3170     { If there was at least one param, close parens }
3171     if not FirstTime then
3172     begin
3173     FMetaData.Add( ')');
3174     end;
3175    
3176     FirstTime := true;
3177     qryHeader.Close;
3178     qryHeader.Params.ByName('Input').AsInteger := 1;
3179     qryHeader.ExecQuery;
3180    
3181     while not qryHeader.Eof do
3182     begin
3183     if FirstTime then
3184     begin
3185     FirstTime := false;
3186 tony 47 FMetaData.Add('RETURNS' + LineEnding + '(');
3187 tony 33 end;
3188    
3189     Line := FormatParamStr;
3190    
3191     qryHeader.Next;
3192     if not qryHeader.Eof then
3193     Line := Line + ',';
3194     FMetaData.Add(Line);
3195     end;
3196    
3197     { If there was at least one param, close parens }
3198     if not FirstTime then
3199     begin
3200     FMetaData.Add( ')');
3201     end;
3202    
3203     FMetaData.Add('AS');
3204     finally
3205     qryHeader.Free;
3206     end;
3207     end;
3208    
3209     procedure TIBExtract.Notification(AComponent: TComponent;
3210     Operation: TOperation);
3211     begin
3212     inherited;
3213     if (AComponent = FDatabase) and (Operation = opRemove) then
3214     FDatabase := nil;
3215     if (AComponent = FTransaction) and (Operation = opRemove) then
3216     FTransaction := nil;
3217     end;
3218    
3219     procedure TIBExtract.ListData(ObjectName: String);
3220     const
3221 tony 47 SelectFieldListSQL = 'Select List(RDB$FIELD_NAME) From ( '+
3222     'Select RF.RDB$FIELD_NAME From RDB$RELATION_FIELDS RF '+
3223     'JOIN RDB$FIELDS F On F.RDB$FIELD_NAME = RF.RDB$FIELD_SOURCE '+
3224     'Where F.RDB$COMPUTED_BLR is NULL and RF.RDB$RELATION_NAME = Upper(:Relation) '+
3225     'Order by RF.RDB$FIELD_POSITION asc)';
3226    
3227     TableSQL =
3228     'SELECT * FROM RDB$RELATIONS ' +
3229     'WHERE ' +
3230     ' (RDB$SYSTEM_FLAG <> 1 OR RDB$SYSTEM_FLAG IS NULL) AND ' +
3231     ' RDB$VIEW_BLR IS NULL ' +
3232     'ORDER BY RDB$RELATION_NAME';
3233    
3234     var FieldList: string;
3235    
3236 tony 33 begin
3237 tony 47 if ObjectName = '' then {List all}
3238     begin
3239     with TIBSQL.Create(self) do
3240     try
3241     Database := FDatabase;
3242     SQL.Text := TableSQL;
3243     ExecQuery;
3244     while not EOF do
3245 tony 33 begin
3246 tony 47 ListData(Trim(FieldByName('RDB$RELATION_NAME').AsString));
3247     Next;
3248 tony 33 end;
3249 tony 47 finally
3250     Free;
3251 tony 33 end;
3252 tony 47 end
3253     else
3254     begin
3255     FieldList := '*';
3256     with TIBSQL.Create(self) do
3257     try
3258     Database := FDatabase;
3259     SQL.Text := SelectFieldListSQL;
3260     Params[0].AsString := ObjectName;
3261     ExecQuery;
3262     try
3263     if not EOF then
3264     FieldList := Fields[0].AsString;
3265     finally
3266     Close;
3267     end;
3268     finally
3269     Free
3270     end;
3271    
3272     with TIBInsertStmtsOut.Create(self) do
3273     try
3274     Database := FDatabase;
3275     DataOut(Format('Select %s From %s',[FieldList,QuoteIdentifier(FDatabase.SQLDialect, ObjectName)]),
3276     Add2MetaData);
3277     FMetaData.Add('COMMIT;');
3278     finally
3279     Free
3280     end;
3281 tony 33 end;
3282     end;
3283    
3284     procedure TIBExtract.ListRoles(ObjectName: String);
3285     const
3286     RolesSQL =
3287 tony 45 'select * from RDB$ROLES WHERE RDB$SYSTEM_FLAG = 0 ' +
3288 tony 33 'order by RDB$ROLE_NAME';
3289    
3290     RolesByNameSQL =
3291     'select * from RDB$ROLES ' +
3292     'WHERE RDB$ROLE_NAME = :RoleName ' +
3293     'order by RDB$ROLE_NAME';
3294    
3295     var
3296     qryRoles : TIBSQL;
3297     PrevOwner, RoleName, OwnerName : String;
3298     begin
3299     {Process GRANT roles}
3300     qryRoles := TIBSQL.Create(FDatabase);
3301     try
3302     if FDatabaseInfo.ODSMajorVersion >= ODS_VERSION9 then
3303     begin
3304     PrevOwner := '';
3305     FMetaData.Add('');
3306     FMetaData.Add('/* Grant Roles for this database */');
3307     FMetaData.Add('');
3308    
3309     if ObjectName = '' then
3310     qryRoles.SQL.Text := RolesSQL
3311     else
3312     begin
3313     qryRoles.SQL.Text := RolesByNameSQL;
3314     qryRoles.Params.ByName('RoleName').AsString := ObjectName;
3315     end;
3316     qryRoles.ExecQuery;
3317     try
3318     while not qryRoles.Eof do
3319     begin
3320     RoleName := QuoteIdentifier(FDatabase.SQLDialect,
3321     qryRoles.FieldByName('rdb$Role_Name').AsString);
3322     OwnerName := Trim(qryRoles.FieldByName('rdb$Owner_Name').AsString);
3323     if PrevOwner <> OwnerName then
3324     begin
3325     FMetaData.Add('');
3326     FMetaData.Add(Format('/* Role: %s, Owner: %s */', [RoleName, OwnerName]));
3327     FMetaData.Add('');
3328     PrevOwner := OwnerName;
3329     end;
3330     FMetaData.Add('CREATE ROLE ' + RoleName + Term);
3331     qryRoles.Next;
3332     end;
3333     finally
3334     qryRoles.Close;
3335     end;
3336     end;
3337     finally
3338     qryRoles.Free;
3339     end;
3340     end;
3341    
3342     end.
3343    
3344