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