ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBExtract.pas
Revision: 17
Committed: Sat Dec 28 19:22:24 2013 UTC (10 years, 11 months ago) by tony
Content type: text/x-pascal
File size: 110938 byte(s)
Log Message: 
Committing updates for Release R1-0-5

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