ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBExtract.pas
Revision: 311
Committed: Mon Aug 24 09:32:58 2020 UTC (3 years, 7 months ago) by tony
Content type: text/x-pascal
File size: 142547 byte(s)
Log Message:
Fixes merged

File Contents

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