ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBExtract.pas
Revision: 39
Committed: Tue May 17 08:14:52 2016 UTC (8 years, 6 months ago) by tony
Content type: text/x-pascal
File size: 107867 byte(s)
Log Message: 
Committing updates for Release R1-4-1

File Contents

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