ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBExtract.pas
Revision: 49
Committed: Thu Feb 2 16:20:12 2017 UTC (7 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 116220 byte(s)
Log Message:
Committing updates for Trunk

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