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