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