ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/DBAdmin/DataModule.pas
Revision: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (17 months, 2 weeks ago) by tony
File size: 50515 byte(s)
Log Message:
Updated for IBX 4 release
Line File contents
1 (*
2 * DataModule.pas
3 * Copyright (C) 2018 Tony Whyman <tony@mwasoftware.co.uk>
4 *
5 * DBAdmin is free software: you can redistribute it and/or modify it
6 * under the terms of the GNU General Public License as published by the
7 * Free Software Foundation, either version 3 of the License, or
8 * (at your option) any later version.
9 *
10 * DBAdmin is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13 * See the GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License along
16 * with this program. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 unit DataModule;
19
20 {$mode objfpc}{$H+}
21
22 interface
23
24 uses
25 Classes, SysUtils, FileUtil, db, memds, IBDatabase, IBSQL, IBQuery,
26 IBCustomDataSet, IBUpdate, IBDatabaseInfo, IBXServices, IB,
27 Dialogs, Controls, Forms;
28
29 type
30
31 { TDBDataModule }
32
33 TDBDataModule = class(TDataModule)
34 AccessRightsCHILDCOUNT: TIBIntegerField;
35 AccessRightsDisplayName: TStringField;
36 AccessRightsID: TIBStringField;
37 AccessRightsImageIndex: TLongintField;
38 AccessRightsPARENT: TIBStringField;
39 AccessRightsSUBJECT_NAME: TIBStringField;
40 AccessRightsSUBJECT_TYPE: TIBSmallintField;
41 ApplicationProperties1: TApplicationProperties;
42 AttachmentsMONATTACHMENT_ID: TIBLargeIntField;
43 AttachmentsMONATTACHMENT_NAME: TIBStringField;
44 AttachmentsMONAUTH_METHOD: TIBStringField;
45 AttachmentsMONCHARACTER_SET_ID: TIBSmallintField;
46 AttachmentsMONCLIENT_VERSION: TIBStringField;
47 AttachmentsMONGARBAGE_COLLECTION: TIBSmallintField;
48 AttachmentsMONREMOTE_ADDRESS: TIBStringField;
49 AttachmentsMONREMOTE_HOST: TIBStringField;
50 AttachmentsMONREMOTE_OS_USER: TIBStringField;
51 AttachmentsMONREMOTE_PID: TIBIntegerField;
52 AttachmentsMONREMOTE_PROCESS: TIBStringField;
53 AttachmentsMONREMOTE_PROTOCOL: TIBStringField;
54 AttachmentsMONREMOTE_VERSION: TIBStringField;
55 AttachmentsMONROLE: TIBStringField;
56 AttachmentsMONSERVER_PID: TIBIntegerField;
57 AttachmentsMONSTATE: TIBSmallintField;
58 AttachmentsMONSTAT_ID: TIBIntegerField;
59 AttachmentsMONSYSTEM_FLAG: TIBSmallintField;
60 AttachmentsMONTIMESTAMP: TDateTimeField;
61 AttachmentsMONUSER: TIBStringField;
62 AttachmentsRDBBYTES_PER_CHARACTER: TIBSmallintField;
63 AttachmentsRDBCHARACTER_SET_ID: TIBSmallintField;
64 AttachmentsRDBCHARACTER_SET_NAME: TIBStringField;
65 AttachmentsRDBDEFAULT_COLLATE_NAME: TIBStringField;
66 AttachmentsRDBDESCRIPTION: TIBMemoField;
67 AttachmentsRDBFORM_OF_USE: TIBStringField;
68 AttachmentsRDBFUNCTION_NAME: TIBStringField;
69 AttachmentsRDBNUMBER_OF_CHARACTERS: TIBIntegerField;
70 AttachmentsRDBOWNER_NAME: TIBStringField;
71 AttachmentsRDBSECURITY_CLASS: TIBStringField;
72 AttachmentsRDBSYSTEM_FLAG: TIBSmallintField;
73 CharSetLookup: TIBQuery;
74 ConfigDataset: TMemDataset;
75 CurrentTransaction: TIBTransaction;
76 DatabaseQuery: TIBQuery;
77 Attachments: TIBQuery;
78 DBTables: TIBQuery;
79 AuthMappings: TIBQuery;
80 AccessRights: TIBQuery;
81 IBConfigService1: TIBXConfigService;
82 IBServerProperties1: TIBXServerProperties;
83 IBLogService1: TIBXLogService;
84 IBSecurityService1: TIBXSecurityService;
85 IBOnlineValidationService1: TIBXOnlineValidationService;
86
87 IBLimboTrans: TIBXLimboTransactionResolutionService;
88 IBXServicesConnection1: TIBXServicesConnection;
89 IBStatisticalService1: TIBXStatisticalService;
90 IBValidationService1: TIBXValidationService;
91 InLimboList: TIBXServicesLimboTransactionsList;
92 LegacyUserList: TIBXServicesUserList;
93 SubjectAccessRights: TIBQuery;
94 AttUpdate: TIBUpdate;
95 AdminUserQuery: TIBSQL;
96 DBTablesUpdate: TIBUpdate;
97 UserListGROUPID: TLongintField;
98 UserListSECPASSWORD: TIBStringField;
99 UserListSECUSER_NAME: TIBStringField;
100 UserListSource: TDataSource;
101 DBCharSet: TIBQuery;
102 DBSecFiles: TIBQuery;
103 ExecDDL: TIBSQL;
104 IBDatabase1: TIBDatabase;
105 IBDatabaseInfo: TIBDatabaseInfo;
106 AttmtQuery: TIBQuery;
107 RoleNameList: TIBQuery;
108 TableNameLookup: TIBQuery;
109 TagsUpdate: TIBUpdate;
110 UpdateCharSet: TIBUpdate;
111 SecGlobalAuth: TIBQuery;
112 ShadowFiles: TIBQuery;
113 ShadowFilesFileMode: TStringField;
114 ShadowFilesRDBFILE_FLAGS: TSmallintField;
115 ShadowFilesRDBFILE_LENGTH: TIntegerField;
116 ShadowFilesRDBFILE_NAME: TIBStringField;
117 ShadowFilesRDBFILE_SEQUENCE: TSmallintField;
118 ShadowFilesRDBFILE_START: TIntegerField;
119 ShadowFilesRDBSHADOW_NUMBER: TSmallintField;
120 UpdateUserRoles: TIBUpdate;
121 UpdateUsers: TIBUpdate;
122 UserList: TIBQuery;
123 UserListCURRENT_CONNECTION: TIBLargeIntField;
124 UserListDBCREATOR: TBooleanField;
125 UserListLOGGEDIN: TBooleanField;
126 UserListSECACTIVE: TBooleanField;
127 UserListSECADMIN: TBooleanField;
128 UserListSECFIRST_NAME: TIBStringField;
129 UserListSECLAST_NAME: TIBStringField;
130 UserListSECMIDDLE_NAME: TIBStringField;
131 UserListSECPLUGIN: TIBStringField;
132 UserListUSERID: TLongintField;
133 UserTags: TIBQuery;
134 procedure AccessRightsCalcFields(DataSet: TDataSet);
135 procedure ApplicationProperties1Exception(Sender: TObject; E: Exception);
136 procedure AttachmentsAfterDelete(DataSet: TDataSet);
137 procedure AttachmentsAfterOpen(DataSet: TDataSet);
138 procedure AttachmentsBeforeOpen(DataSet: TDataSet);
139 procedure ConfigDatasetAfterClose(DataSet: TDataSet);
140 procedure CurrentTransactionAfterTransactionEnd(Sender: TObject);
141 procedure DatabaseQueryAfterOpen(DataSet: TDataSet);
142 procedure DatabaseQueryBeforeClose(DataSet: TDataSet);
143 procedure DBCharSetAfterClose(DataSet: TDataSet);
144 procedure DBCharSetBeforeOpen(DataSet: TDataSet);
145 procedure IBDatabase1AfterConnect(Sender: TObject);
146 procedure IBDatabase1AfterDisconnect(Sender: TObject);
147 procedure IBDatabase1BeforeDisconnect(Sender: TObject);
148 procedure IBDatabase1Login(Database: TIBDatabase; LoginParams: TStrings);
149 procedure AttUpdateApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
150 Params: ISQLParams);
151 procedure DBTablesUpdateApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
152 Params: ISQLParams);
153 procedure IBValidationService1GetNextLine(Sender: TObject; var Line: string
154 );
155 procedure IBXServicesConnection1AfterConnect(Sender: TObject);
156 procedure IBXServicesConnection1Login(Service: TIBXServicesConnection;
157 var aServerName: string; LoginParams: TStrings);
158 procedure LegacyUserListAfterOpen(DataSet: TDataSet);
159 procedure LegacyUserListAfterPost(DataSet: TDataSet);
160 procedure LegacyUserListBeforeClose(DataSet: TDataSet);
161 procedure ShadowFilesCalcFields(DataSet: TDataSet);
162 procedure SubjectAccessRightsBeforeOpen(DataSet: TDataSet);
163 procedure TagsUpdateApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
164 Params: ISQLParams);
165 procedure UpdateCharSetApplyUpdates(Sender: TObject;
166 UpdateKind: TUpdateKind; Params: ISQLParams);
167 procedure UpdateUserRolesApplyUpdates(Sender: TObject;
168 UpdateKind: TUpdateKind; Params: ISQLParams);
169 procedure UpdateUsersApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
170 Params: ISQLParams);
171 procedure UserListAfterInsert(DataSet: TDataSet);
172 procedure UserListAfterOpen(DataSet: TDataSet);
173 procedure UserListAfterPost(DataSet: TDataSet);
174 procedure UserListAfterScroll(DataSet: TDataSet);
175 procedure UserListBeforeClose(DataSet: TDataSet);
176 procedure UserTagsAfterInsert(DataSet: TDataSet);
177 private
178 FAfterDataReload: TNotifyEvent;
179 FAfterDBConnect: TNotifyEvent;
180 FDBHeaderScanned: boolean;
181 FDisconnecting: boolean;
182 FISShadowDatabase: boolean;
183 FDBUserName: string;
184 FDBPassword: string;
185 FLocalConnect: boolean;
186 FSubjectAccessRightsID: string;
187 {Parsed results of connectstring;}
188 FServerName: string;
189 FPortNo: string;
190 FProtocol: TProtocolAll;
191 FDatabasePathName: string;
192 FHasUserAdminPrivilege: boolean;
193 function GetAuthMethod: string;
194 function GetAutoAdmin: boolean;
195 function GetDatabaseName: string;
196 function GetDBDateCreated: string;
197 procedure GetDBFlags;
198 function GetDBOwner: string;
199 function GetDBReadOnly: boolean;
200 function GetDBSQLDialect: integer;
201 function GetDBUserName: string;
202 function GetDescription: string;
203 function GetForcedWrites: boolean;
204 function GetLingerDelay: string;
205 function GetNoReserve: boolean;
206 function GetPageBuffers: integer;
207 function GetRoleName: string;
208 function GetSecurityDatabase: string;
209 function GetServerName: string;
210 function GetSweepInterval: integer;
211 function GetUserAdminPrivilege: boolean;
212 procedure SetAutoAdmin(AValue: boolean);
213 procedure SetDBReadOnly(AValue: boolean);
214 procedure SetDBSQLDialect(AValue: integer);
215 procedure SetDescription(AValue: string);
216 procedure SetForcedWrites(AValue: boolean);
217 procedure SetLingerDelay(AValue: string);
218 procedure SetNoReserve(AValue: boolean);
219 procedure SetPageBuffers(AValue: integer);
220 procedure SetSweepInterval(AValue: integer);
221 procedure ReloadData(Data: PtrInt=0);
222 protected
223 FServiceUserName: string;
224 function GetEmbeddedMode: boolean; virtual;
225 procedure ConnectServicesAPI; virtual;
226 function CallLoginDlg(var aDatabaseName, aUserName, aPassword: string;
227 var aCreateIfNotExist: boolean): TModalResult; virtual;
228 public
229 destructor Destroy; override;
230 function Connect: boolean; virtual;
231 procedure Disconnect; virtual;
232 procedure DropDatabase;
233 procedure BackupDatabase;
234 procedure RestoreDatabase;
235 procedure BringDatabaseOnline;
236 procedure ShutDown(aShutDownmode: TDBShutdownMode; aDelay: integer);
237 procedure DatabaseRepair(Options: TValidateOptions; ReportLines: TStrings);
238 procedure OnlineValidation(ReportLines: TStrings; SelectedTablesOnly: boolean);
239 procedure LimboResolution(ActionID: TTransactionGlobalAction; Report: TStrings);
240 function IsDatabaseOnline: boolean;
241 function IsShadowDatabase: boolean;
242 procedure ActivateShadow;
243 procedure AddSecondaryFile(aFileName: string; StartAt,FileLength: integer);
244 procedure AddShadowSet;
245 procedure RemoveShadowSet(ShadowSet: integer);
246 procedure LoadPerformanceStatistics(Lines: TStrings);
247 procedure LoadDatabaseStatistics(OptionID: integer; Lines: TStrings);
248 function LoadConfigData(ConfigFileData: TConfigFileData): boolean;
249 procedure LoadServerProperties(Lines: TStrings);
250 procedure LoadServerLog(Lines: TStrings);
251 procedure RevokeAll;
252 procedure SyncSubjectAccessRights(ID: string);
253 property AutoAdmin: boolean read GetAutoAdmin write SetAutoAdmin;
254 property Description: string read GetDescription write SetDescription;
255 property Disconnecting: boolean read FDisconnecting;
256 property ForcedWrites: boolean read GetForcedWrites write SetForcedWrites;
257 property LingerDelay: string read GetLingerDelay write SetLingerDelay;
258 property DBReadOnly: boolean read GetDBReadOnly write SetDBReadOnly;
259 property NoReserve: boolean read GetNoReserve write SetNoReserve;
260 property PageBuffers: integer read GetPageBuffers write SetPageBuffers;
261 property SweepInterval: integer read GetSweepInterval write SetSweepInterval;
262 property DatabaseName: string read GetDatabaseName;
263 property SecurityDatabase: string read GetSecurityDatabase;
264 property AuthMethod: string read GetAuthMethod;
265 property EmbeddedMode: boolean read GetEmbeddedMode;
266 property DBUserName: string read GetDBUserName;
267 property RoleName: string read GetRoleName;
268 property DBOwner: string read GetDBOwner;
269 property DBSQLDialect: integer read GetDBSQLDialect write SetDBSQLDialect;
270 property DBDateCreated: string read GetDBDateCreated;
271 property ServerName: string read GetServerName;
272 property ServiceUserName: string read FServiceUserName;
273 property HasUserAdminPrivilege: boolean read FHasUserAdminPrivilege;
274 property AfterDBConnect: TNotifyEvent read FAfterDBConnect write FAfterDBConnect;
275 property AfterDataReload: TNotifyEvent read FAfterDataReload write FAfterDataReload;
276 end;
277
278 var
279 DBDataModule: TDBDataModule;
280
281 implementation
282
283 {$R *.lfm}
284
285 uses DBLoginDlgUnit, IBUtils, IBMessages, ShutdownDatabaseDlgUnit,
286 BackupDlgUnit, RestoreDlgUnit, AddShadowSetDlgUnit, IBErrorCodes;
287
288 const
289 sAddSecondarySQL = 'Alter Database Add File ''%s'' Starting at %d';
290 sAddSecondarySQL2 = 'Alter Database Add File ''%s'' Starting at %d Length %d';
291 sRemoveShadow = 'Drop Shadow %d';
292 sRemoveShadow12 = 'Drop Shadow %d DELETE FILE';
293 sPreserveShadow = 'Drop Shadow %d PRESERVE FILE';
294
295 resourcestring
296 sPreserveShadowFiles = 'Preserve Shadow Set Files after drop?';
297
298 { TDBDataModule }
299
300 procedure TDBDataModule.UpdateCharSetApplyUpdates(Sender: TObject;
301 UpdateKind: TUpdateKind; Params: ISQLParams);
302 begin
303 if UpdateKind = ukModify then
304 begin
305 ExecDDL.SQL.Text := 'ALTER DATABASE SET DEFAULT CHARACTER SET ' +
306 Params.ByName('RDB$CHARACTER_SET_NAME').AsString;
307 ExecDDL.ExecQuery;
308 end;
309 end;
310
311 procedure TDBDataModule.UpdateUserRolesApplyUpdates(Sender: TObject;
312 UpdateKind: TUpdateKind; Params: ISQLParams);
313
314 procedure Grant(Params: ISQLParams);
315 begin
316 ExecDDL.SQL.Text := 'Grant ' + trim(Params.ByName('RDB$ROLE_NAME').AsString) + ' to ' + Params.ByName('SEC$USER_NAME').AsString;
317 ExecDDL.ExecQuery;
318 end;
319
320 procedure Revoke(Params: ISQLParams);
321 begin
322 ExecDDL.SQL.Text := 'Revoke ' + trim(Params.ByName('RDB$ROLE_NAME').AsString) + ' from ' + Params.ByName('SEC$USER_NAME').AsString;
323 ExecDDL.ExecQuery;
324 end;
325
326 begin
327 if UpdateKind = ukModify then
328 begin
329 if Params.ByName('GRANTED').AsInteger = 0 then
330 Revoke(Params)
331 else
332 Grant(Params);
333 end;
334 end;
335
336 procedure TDBDataModule.UpdateUsersApplyUpdates(Sender: TObject;
337 UpdateKind: TUpdateKind; Params: ISQLParams);
338
339 var UserName: string;
340
341 function FormatStmtOptions: string;
342 var Param: ISQLParam;
343 begin
344 Result := UserName;
345 Param := Params.ByName('SEC$PASSWORD');
346 if (Param <> nil) and not Param.IsNull then
347 Result += ' PASSWORD ''' + SQLSafeString(Param.AsString) + '''';
348 Param := Params.ByName('SEC$FIRST_NAME');
349 if Param <> nil then
350 Result += ' FIRSTNAME ''' + SQLSafeString(Param.AsString) + '''';
351 Param := Params.ByName('SEC$MIDDLE_NAME');
352 if Param <> nil then
353 Result += ' MIDDLENAME ''' + SQLSafeString(Param.AsString) + '''';
354 Param := Params.ByName('SEC$LAST_NAME');
355 if Param <> nil then
356 Result += ' LASTNAME ''' + SQLSafeString(Param.AsString) + '''';
357 Param := Params.ByName('SEC$ACTIVE');
358 if Param <> nil then
359 begin
360 if Param.AsBoolean then
361 Result += ' ACTIVE'
362 else
363 Result += ' INACTIVE';
364 end;
365 Param := Params.ByName('SEC$PLUGIN');
366 if Param <> nil then
367 Result += ' USING PLUGIN ' + QuoteIdentifierIfNeeded((Sender as TIBUpdate).DataSet.Database.SQLDialect,Param.AsString);
368 end;
369
370 function GetAlterPasswordStmt: string;
371 var Param: ISQLParam;
372 begin
373 Result := '';
374 Param := Params.ByName('SEC$PASSWORD');
375 if (UpdateKind = ukModify) and not Param.IsNull then
376 begin
377 Result := 'ALTER USER ' + UserName +
378 ' PASSWORD ''' + SQLSafeString(Param.AsString) + '''';
379 Param := Params.ByName('SEC$PLUGIN');
380 if Param <> nil then
381 Result += ' USING PLUGIN ' + QuoteIdentifierIfNeeded((Sender as TIBUpdate).DataSet.Database.SQLDialect,Param.AsString);
382 end;
383 end;
384
385 begin
386 UserName := Trim(Params.ByName('SEC$USER_NAME').AsString);
387 {non SYSDBA user not an RDB$ADMIN can only change their password}
388 if (DBUserName <> 'SYSDBA') and (RoleName <> 'RDB$ADMIN') then
389 begin
390 ExecDDL.SQL.Text := GetAlterPasswordStmt;
391 if ExecDDL.SQL.Text <> '' then
392 ExecDDL.ExecQuery;
393 Exit;
394 end;
395
396 case UpdateKind of
397 ukInsert:
398 ExecDDL.SQL.Text := 'CREATE USER ' + FormatStmtOptions;
399 ukModify:
400 ExecDDL.SQL.Text := 'ALTER USER ' + FormatStmtOptions;
401 ukDelete:
402 ExecDDL.SQL.Text := 'DROP USER ' + UserName;
403 end;
404 ExecDDL.ExecQuery;
405
406 if UpdateKind = ukInsert then
407 begin
408 {if new user is also given the admin role then we need to add this}
409 if Params.ByName('SEC$ADMIN').AsBoolean then
410 begin
411 ExecDDL.SQL.Text := 'ALTER USER ' + UserName + ' GRANT ADMIN ROLE';
412 ExecDDL.ExecQuery;
413 end;
414 end
415 else
416 if UpdateKind = ukModify then
417 {Update Admin Role if allowed}
418 begin
419 if Params.ByName('SEC$ADMIN').AsBoolean and not Params.ByName('OLD_SEC$ADMIN').AsBoolean then
420 begin
421 ExecDDL.SQL.Text := 'ALTER USER ' + UserName + ' GRANT ADMIN ROLE';
422 ExecDDL.ExecQuery;
423 end
424 else
425 if not Params.ByName('SEC$ADMIN').AsBoolean and Params.ByName('OLD_SEC$ADMIN').AsBoolean then
426 begin
427 ExecDDL.SQL.Text := 'ALTER USER ' + UserName + ' REVOKE ADMIN ROLE';
428 ExecDDL.ExecQuery;
429 end
430 end;
431
432 {Update DB Creator Role}
433 if Params.ByName('DBCreator').AsBoolean and not Params.ByName('OLD_DBCreator').AsBoolean then
434 begin
435 ExecDDL.SQL.Text := 'GRANT CREATE DATABASE TO USER ' + UserName;
436 ExecDDL.ExecQuery;
437 end
438 else
439 if not Params.ByName('DBCreator').AsBoolean and Params.ByName('OLD_DBCreator').AsBoolean then
440 begin
441 ExecDDL.SQL.Text := 'REVOKE CREATE DATABASE FROM USER ' + UserName;
442 ExecDDL.ExecQuery;
443 end
444 end;
445
446 procedure TDBDataModule.UserListAfterInsert(DataSet: TDataSet);
447 begin
448 DataSet.FieldByName('SEC$ADMIN').AsBoolean := false;
449 DataSet.FieldByName('SEC$ACTIVE').AsBoolean := false;
450 DataSet.FieldByName('DBCreator').AsBoolean := false;
451 DataSet.FieldByName('SEC$PLUGIN').AsString := 'Srp';
452 // DataSet.FieldByName('UserID').AsInteger := 0;
453 // DataSet.FieldByName('GroupID').AsInteger := 0;
454 DataSet.FieldByName('SEC$PASSWORD').Clear;
455 RoleNameList.Active := false; {Prevent role assignments until saved}
456 UserTags.Active := false; {ditto}
457 end;
458
459 procedure TDBDataModule.UserListAfterOpen(DataSet: TDataSet);
460 begin
461 if UserListSource.DataSet <> DataSet then
462 UserListSource.DataSet := DataSet;
463 RoleNameList.Active := true;
464 UserTags.Active := true;
465 end;
466
467 procedure TDBDataModule.UserListAfterPost(DataSet: TDataSet);
468 begin
469 CurrentTransaction.Commit;
470 end;
471
472 procedure TDBDataModule.UserListAfterScroll(DataSet: TDataSet);
473 begin
474 UserList.FieldByName('SEC$PLUGIN').ReadOnly := UserList.State <> dsInsert;
475 end;
476
477 procedure TDBDataModule.UserListBeforeClose(DataSet: TDataSet);
478 begin
479 RoleNameList.Active := false;
480 UserTags.Active := false;
481 end;
482
483 procedure TDBDataModule.UserTagsAfterInsert(DataSet: TDataSet);
484 begin
485 DataSet.FieldByName('SEC$USER_NAME').AsString := DataSet.DataSource.DataSet.FieldByName('SEC$USER_NAME').AsString;
486 end;
487
488 procedure TDBDataModule.ConnectServicesAPI;
489 begin
490 if IBXServicesConnection1.Connected then Exit;
491 try
492 IBXServicesConnection1.ConnectUsing(IBDatabase1);
493 except on E: Exception do
494 begin
495 Application.ShowException(E);
496 IBDatabase1.Connected := false;
497 FDBPassword := '';
498 Exit;
499 end;
500 end;
501 end;
502
503 function TDBDataModule.CallLoginDlg(var aDatabaseName, aUserName,
504 aPassword: string; var aCreateIfNotExist: boolean): TModalResult;
505 begin
506 Result := DBLoginDlg.ShowModal(aDatabaseName, aUserName, aPassword, aCreateIfNotExist);
507 end;
508
509 procedure TDBDataModule.GetDBFlags;
510 var Lines: TStringList;
511 i: integer;
512 line: string;
513 begin
514 if FDBHeaderScanned or not DatabaseQuery.Active or not AttmtQuery.Active then Exit;
515 FIsShadowDatabase := false;
516
517 try
518 with IBStatisticalService1 do
519 begin
520 Options := [HeaderPages];
521 Lines := TStringList.Create;
522 try
523 Execute(Lines);
524 for i := 0 to Lines.Count - 1 do
525 begin
526 line := Lines[i];
527 if (Pos('Attributes',Line) <> 0) and (Pos('shadow',Line) <> 0) then
528 begin
529 FIsShadowDatabase := true;
530 break;
531 end;
532 end;
533 finally
534 Lines.Free;
535 end;
536 FDBHeaderScanned := true;
537 end;
538 except on E: Exception do
539 MessageDlg('Error getting DB Header Page: ' + E.Message,mtError,[mbOK],0);
540 end;
541 end;
542
543 function TDBDataModule.GetDBOwner: string;
544 var DBOField: TField;
545 begin
546 DBOField := DatabaseQuery.FindField('MON$OWNER');
547 if DBOField <> nil then
548 Result := Trim(DBOField.AsString)
549 else
550 Result := 'n/a';
551 end;
552
553 function TDBDataModule.GetAutoAdmin: boolean;
554 begin
555 Result := false;
556 if not CurrentTransaction.Active then Exit;
557 SecGlobalAuth.Active := true; {sets AutoAdmin}
558 try
559 Result := SecGlobalAuth.FieldByName('Mappings').AsInteger > 0;
560 finally
561 SecGlobalAuth.Active := false;
562 end;
563 end;
564
565 function TDBDataModule.GetDatabaseName: string;
566 begin
567 if DatabaseQuery.Active and not DatabaseQuery.FieldByName('MON$DATABASE_NAME').IsNull then
568 Result := DatabaseQuery.FieldByName('MON$DATABASE_NAME').AsString
569 else
570 Result := FDatabasePathName;
571 end;
572
573 function TDBDataModule.GetDBDateCreated: string;
574 begin
575 with DefaultFormatSettings do
576 try
577 Result := FormatDateTime(LongDateFormat + ' ' + LongTimeFormat,DatabaseQuery.FieldByName('MON$CREATION_DATE').AsDateTime);
578 except
579 Result := 'unknown';
580 end;
581 end;
582
583 function TDBDataModule.GetDBReadOnly: boolean;
584 begin
585 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$READ_ONLY').AsInteger <> 0);
586 end;
587
588 function TDBDataModule.GetDBSQLDialect: integer;
589 begin
590 Result := IBDatabaseInfo.DBSQLDialect;
591 end;
592
593 function TDBDataModule.GetDBUserName: string;
594 var DPB: IDPB;
595 info: IDPBItem;
596 begin
597 Result := '';
598 if AttmtQuery.Active then
599 Result := Trim(AttmtQuery.FieldByName('MON$USER').AsString)
600 else
601 if IBDatabase1.Connected then
602 begin
603 DPB := IBDatabase1.Attachment.getDPB;
604 info := DPB.Find(isc_dpb_user_name);
605 if info <> nil then
606 Result := info.AsString;
607 end
608 end;
609
610 function TDBDataModule.GetDescription: string;
611 begin
612 if DatabaseQuery.Active then
613 Result := DatabaseQuery.FieldByName('RDB$DESCRIPTION').AsString
614 else
615 Result := '';
616 end;
617
618 function TDBDataModule.GetEmbeddedMode: boolean;
619 begin
620 Result := AttmtQuery.Active and AttmtQuery.FieldByName('MON$REMOTE_PROTOCOL').IsNull;
621 end;
622
623 function TDBDataModule.GetForcedWrites: boolean;
624 begin
625 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$FORCED_WRITES').AsInteger <> 0);
626 end;
627
628 procedure TDBDataModule.SetLingerDelay(AValue: string);
629 begin
630 if (StrToInt(AValue) = DatabaseQuery.FieldByName('RDB$LINGER').AsInteger) then Exit;
631
632 if (AValue = '') or (StrToInt(AValue) = 0) then
633 begin
634 if MessageDlg('Turn off Linger Permanently?',mtConfirmation,[mbYes,mbNo],0) = mrNo then
635 begin
636 IBConfigService1.SetNoLinger;
637 CurrentTransaction.Commit; {Refresh}
638 Exit;
639 end;
640 ExecDDL.SQL.Text := 'ALTER DATABASE DROP LINGER'
641 end
642 else
643 ExecDDL.SQL.Text := 'ALTER DATABASE SET LINGER TO ' + AValue;
644 with ExecDDL do
645 begin
646 Transaction.Active := true;
647 ExecQuery;
648 Transaction.Commit;
649 end;
650 end;
651
652
653 function TDBDataModule.GetAuthMethod: string;
654 var AuthMeth: TField;
655 begin
656 AuthMeth := AttmtQuery.FindField('MON$AUTH_METHOD');
657 if AuthMeth = nil then
658 Result := 'Legacy_auth'
659 else
660 Result := AuthMeth.AsString;
661 end;
662
663 procedure TDBDataModule.SetNoReserve(AValue: boolean);
664 begin
665 IBConfigService1.SetReserveSpace(AValue);
666 end;
667
668 procedure TDBDataModule.SetPageBuffers(AValue: integer);
669 begin
670 IBDatabase1.Connected := false;
671 try
672 IBConfigService1.SetPageBuffers(AValue);
673 finally
674 IBDatabase1.Connected := true;
675 end;
676 end;
677
678 procedure TDBDataModule.SetSweepInterval(AValue: integer);
679 begin
680 IBDatabase1.Connected := false;
681 try
682 IBConfigService1.SetSweepInterval(AValue);
683 finally
684 IBDatabase1.Connected := true;
685 end;
686 end;
687
688 procedure TDBDataModule.ReloadData(Data: PtrInt);
689 begin
690 if csDestroying in ComponentState then Exit;
691 CurrentTransaction.Active := true;
692 DataBaseQuery.Active := true;
693 AttmtQuery.Active := true;
694 if LegacyUserList.Active then
695 RoleNameList.Active := true;
696 if assigned(FAfterDataReload) then
697 AfterDataReload(self);
698 end;
699
700 destructor TDBDataModule.Destroy;
701 begin
702 Application.RemoveAsyncCalls(self);
703 inherited Destroy;
704 end;
705
706 function TDBDataModule.Connect: boolean;
707
708 procedure ReportException(E: Exception);
709 begin
710 MessageDlg(E.Message,mtError,[mbOK],0);
711 FDBPassword := '';
712 end;
713
714 procedure KillShadows;
715 begin
716 with IBXServicesConnection1 do
717 begin
718 ServerName := FServerName;
719 Protocol := FProtocol;
720 PortNo := FPortNo;
721 Connected := true;
722 end;
723 try
724 with IBValidationService1 do
725 begin
726 DatabaseName := FDatabasePathName;
727 Options := [IBXServices.KillShadows];
728 Execute(nil);
729 MessageDlg('All Unavailable Shadows killed',mtInformation,[mbOK],0);
730 end;
731 finally
732 IBXServicesConnection1.Connected := false;
733 end;
734 end;
735
736 var KillDone: boolean;
737 begin
738 KillDone := false;
739 Result := false;
740 Disconnect;
741 repeat
742 try
743 IBDatabase1.Connected := true;
744 except
745 on E:EIBClientError do
746 begin
747 Exit
748 end;
749 On E: EIBInterBaseError do
750 begin
751 FDBPassword := '';
752 if (E.IBErrorCode = isc_io_error) and not KillDone then
753 begin
754 if MessageDlg('I/O Error reported on database file. If this is a shadow file, do you want '+
755 'to kill all unavailable shadow sets?. The original message is ' + E.Message,
756 mtInformation,[mbYes,mbNo],0) = mrNo then
757 continue;
758 try KillShadows except end;
759 KillDone := true;
760 end
761 else
762 ReportException(E);
763 end;
764 On E:Exception do
765 ReportException(E);
766 end;
767 until IBDatabase1.Connected;
768
769 if assigned(FAfterDBConnect) then
770 AfterDBConnect(self);
771 Result := IBDatabase1.Connected;
772 end;
773
774 procedure TDBDataModule.Disconnect;
775 begin
776 FDBUserName := '';
777 FDBPassword := '';
778 FServiceUserName := '';
779 FLocalConnect := false;
780 IBDatabase1.Connected := false;
781 IBXServicesConnection1.Connected := false;
782 FDBHeaderScanned := false;
783 end;
784
785 procedure TDBDataModule.DropDatabase;
786 begin
787 IBDatabase1.DropDatabase;
788 Disconnect;
789 end;
790
791 procedure TDBDataModule.BackupDatabase;
792 begin
793 BackupDlg.ShowModal;
794 end;
795
796 procedure TDBDataModule.RestoreDatabase;
797 var DefaultPageSize: integer;
798 DefaultNumBuffers: integer;
799 begin
800 DefaultPageSize := DatabaseQuery.FieldByName('MON$PAGE_SIZE').AsInteger;
801 DefaultNumBuffers := DatabaseQuery.FieldByName('MON$PAGE_BUFFERS').AsInteger;
802 IBDatabase1.Connected := false;
803 try
804 RestoreDlg.ShowModal(DefaultPageSize,DefaultNumBuffers);
805 finally
806 IBDatabase1.Connected := true;
807 end;
808 end;
809
810 procedure TDBDataModule.BringDatabaseOnline;
811 begin
812 if IsDatabaseOnline then
813 MessageDlg('Database is already online!',mtInformation,[mbOK],0)
814 else
815 begin
816 IBDatabase1.Connected := false;
817 try
818 IBConfigService1.BringDatabaseOnline;
819 finally
820 IBDatabase1.Connected := true;
821 end;
822 if IsDatabaseOnline then
823 MessageDlg('Database is back online',mtInformation,[mbOK],0)
824 else
825 MessageDlg('Database is still shutdown!',mtError,[mbOK],0);
826 end;
827 end;
828
829 procedure TDBDataModule.ShutDown(aShutDownmode: TDBShutdownMode; aDelay: integer
830 );
831 begin
832 IBDatabase1.Connected := false;
833 try
834 ShutdownDatabaseDlg.Shutdown(aShutDownmode, aDelay);
835 finally
836 IBDatabase1.Connected := true;
837 end;
838 end;
839
840 procedure TDBDataModule.DatabaseRepair(Options: TValidateOptions; ReportLines: TStrings);
841
842 procedure ReportOptions;
843 var Line: string;
844 begin
845 Line := 'With Options: [';
846 if (ValidateDB in Options) then Line += 'ValidateDB ';
847 if (SweepDB in Options) then Line += 'SweepDB ';
848 if (KillShadows in Options) then Line += 'KillShadows ';
849 if (ValidateFull in Options) then Line += 'ValidateFull ';
850 if (CheckDB in Options) then Line += 'CheckDB ';
851 if (IgnoreChecksum in Options) then Line +='IgnoreChecksum ';
852 if (MendDB in Options) then Line +='MendDB ';
853 Line +=']';
854 ReportLines.Add(Line);
855 end;
856
857 begin
858 ReportLines.Add(Format('Validation of %s started',[IBValidationService1.DatabaseName]));
859 ReportOptions;
860 IBDatabase1.Connected := false;
861 with IBValidationService1 do
862 try
863 Execute(ReportLines);
864 ReportLines.Add('Operation Completed');
865 MessageDlg('Operation Completed',mtInformation,[mbOK],0);
866 finally
867 IBDatabase1.Connected := true;
868 end;
869 end;
870
871 procedure TDBDataModule.OnlineValidation(ReportLines: TStrings;
872 SelectedTablesOnly: boolean);
873 var TableNames: string;
874 Separator: string;
875 begin
876 if IBDatabaseInfo.ODSMajorVersion < 12 then
877 raise Exception.Create('Online Validation is not supported');
878 with IBOnlineValidationService1 do
879 begin
880 if SelectedTablesOnly then
881 begin
882 TableNames := '';
883 with DBTables do
884 if Active then
885 begin
886 DisableControls;
887 try
888 Separator := '';
889 First;
890 while not EOF do
891 begin
892 if FieldByName('Selected').AsInteger <> 0 then
893 begin
894 TableNames += Separator + FieldByName('RDB$RELATION_NAME').AsString;
895 Separator := '|';
896 end;
897 Next;
898 end;
899 finally
900 EnableControls;
901 end;
902 end;
903 IncludeTables := TableNames;
904 end
905 else
906 IncludeTables := '';
907 ReportLines.Add(Format('Online Validation of %s started',[IBOnlineValidationService1.DatabaseName]));
908 Execute(ReportLines);
909 ReportLines.Add('Online Validation Completed');
910 MessageDlg('Online Validation Completed',mtInformation,[mbOK],0);
911 end;
912 end;
913
914 procedure TDBDataModule.LimboResolution(ActionID: TTransactionGlobalAction;
915 Report: TStrings);
916 begin
917 if not InLimboList.Active then
918 raise Exception.Create('Limbo Transactions List not available');
919
920 with InLimboList do
921 if State = dsEdit then Post;
922 Report.Clear;
923 Report.Add('Starting Limbo transaction resolution');
924 InLimboList.FixErrors(ActionID,Report);
925 Report.Add('Limbo Transaction resolution complete');
926 CurrentTransaction.Commit;
927 end;
928
929 function TDBDataModule.GetLingerDelay: string;
930 var Linger: TField;
931 begin
932 Result := 'n/a';
933 if not DatabaseQuery.Active then exit;
934 Linger := DatabaseQuery.FindField('RDB$LINGER');
935 if Linger <> nil then
936 begin
937 if Linger.IsNull then
938 Result := '0'
939 else
940 Result := Linger.AsString;
941 end;
942 end;
943
944 function TDBDataModule.GetNoReserve: boolean;
945 begin
946 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$RESERVE_SPACE').AsInteger <> 0);
947 end;
948
949 function TDBDataModule.GetPageBuffers: integer;
950 begin
951 Result := IBDatabaseInfo.NumBuffers;
952 end;
953
954 function TDBDataModule.GetRoleName: string;
955 begin
956 Result := Trim(AttmtQuery.FieldByName('MON$ROLE').AsString);
957 end;
958
959 function TDBDataModule.GetSecurityDatabase: string;
960 var SecPlugin: TField;
961 begin
962 SecPlugin := DatabaseQuery.FindField('MON$SEC_DATABASE');
963 if SecPlugin = nil then
964 Result := 'Legacy'
965 else
966 Result := Trim(SecPlugin.AsString);
967 end;
968
969 function TDBDataModule.GetServerName: string;
970 begin
971 Result := IBXServicesConnection1.ServerName;
972 end;
973
974 function TDBDataModule.GetSweepInterval: integer;
975 begin
976 if DatabaseQuery.Active then
977 Result := DatabaseQuery.FieldByName('MON$SWEEP_INTERVAL').AsInteger
978 else
979 Result := 0;
980 end;
981
982 function TDBDataModule.GetUserAdminPrivilege: boolean;
983 begin
984 Result := false;
985 {For ODS 12 use SEC$USERS table}
986 if IBDatabase1.Connected and (IBDatabaseInfo.ODSMajorVersion >= 12) then
987 with AdminUserQuery do
988 begin
989 ExecQuery;
990 try
991 Result := not EOF and FieldByName('SEC$ADMIN').AsBoolean;
992 finally
993 Close;
994 end;
995 end
996 {if need to know for ODS 11.2 then will have to use Service API}
997 else
998 begin
999 with IBSecurityService1 do
1000 begin
1001 DisplayUser(ServiceUserName);
1002 Result := (UserInfoCount > 0) and UserInfo[0].AdminRole;
1003 end;
1004 end;
1005 end;
1006
1007 procedure TDBDataModule.SetAutoAdmin(AValue: boolean);
1008 begin
1009 IBSecurityService1.SetAutoAdmin(AValue);
1010 CurrentTransaction.Commit;
1011 end;
1012
1013 procedure TDBDataModule.SetDBReadOnly(AValue: boolean);
1014 begin
1015 IBDatabase1.Connected := false;
1016 try
1017 IBConfigService1.SetReadOnly(AValue);
1018 finally
1019 IBDatabase1.Connected := true;
1020 end;
1021 end;
1022
1023 procedure TDBDataModule.SetDBSQLDialect(AValue: integer);
1024 begin
1025 IBDatabase1.Connected := false;
1026 try
1027 IBConfigService1.SetDBSqlDialect(AValue);
1028 finally
1029 IBDatabase1.Connected := true;
1030 end;
1031 end;
1032
1033 procedure TDBDataModule.SetDescription(AValue: string);
1034 begin
1035 with TIBSQL.Create(IBDatabase1) do
1036 try
1037 SQL.Text := 'Comment on Database is ''' + SQLSafeString(AValue) + '''';
1038 Transaction.Active := true;
1039 ExecQuery;
1040 finally
1041 Free;
1042 end;
1043 CurrentTransaction.Commit;
1044 end;
1045
1046 procedure TDBDataModule.SetForcedWrites(AValue: boolean);
1047 begin
1048 IBConfigService1.SetAsyncMode(not AValue);
1049 end;
1050
1051 function TDBDataModule.IsDatabaseOnline: boolean;
1052 begin
1053 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$SHUTDOWN_MODE').AsInteger = 0);
1054 end;
1055
1056 function TDBDataModule.IsShadowDatabase: boolean;
1057 begin
1058 GetDBFlags;
1059 Result := FIsShadowDatabase;
1060 end;
1061
1062 procedure TDBDataModule.ActivateShadow;
1063 var DBConnected: boolean;
1064 begin
1065 DBConnected := IBDatabase1.Connected;
1066 IBDatabase1.Connected := false;
1067 try
1068 IBConfigService1.ActivateShadow;
1069 finally
1070 IBDatabase1.Connected := DBConnected;
1071 end;
1072 MessageDlg('Shadow Database activated. You should now rename the file or change the database alias name to point to the shadow',
1073 mtInformation,[mbOK],0);
1074 end;
1075
1076 procedure TDBDataModule.AddSecondaryFile(aFileName: string; StartAt,
1077 FileLength: integer);
1078 var SQLText: string;
1079 begin
1080 if FileLength <> -1 then
1081 SQLText := Format(sAddSecondarySQL2,[aFileName,StartAt,FileLength])
1082 else
1083 SQLText := Format(sAddSecondarySQL,[aFileName,StartAt]);
1084 ExecDDL.SQL.Text := SQLText;
1085 ExecDDL.ExecQuery;
1086 CurrentTransaction.Commit;
1087 end;
1088
1089 procedure TDBDataModule.AddShadowSet;
1090 var CurrentLocation: TBookmark;
1091 ShadowSet: integer;
1092 begin
1093 if ShadowFiles.RecordCount = 0 then
1094 ShadowSet := 1
1095 else
1096 with ShadowFiles do
1097 begin
1098 CurrentLocation := Bookmark;
1099 DisableControls;
1100 try
1101 Last;
1102 ShadowSet := FieldByName('RDB$Shadow_Number').AsInteger + 1;
1103 finally
1104 Bookmark := CurrentLocation;
1105 EnableControls
1106 end
1107 end;
1108 AddShadowSetDlg.ShowModal(ShadowSet);
1109 CurrentTransaction.Active := true;
1110 end;
1111
1112 procedure TDBDataModule.RemoveShadowSet(ShadowSet: integer);
1113 begin
1114 if IBDatabaseInfo.ODSMajorVersion < 12 then
1115 begin
1116 if MessageDlg(Format(sRemoveShadow,[ShadowSet]),mtConfirmation,[mbYes,mbNo],0) = mrYes then
1117 ExecDDL.SQL.Text := Format(sRemoveShadow,[ShadowSet]);
1118 end
1119 else
1120 case MessageDlg(Format(sPreserveShadowFiles,[ShadowSet]),mtConfirmation,[mbYes,mbNo,mbCancel],0) of
1121 mrNo:
1122 ExecDDL.SQL.Text :=Format(sRemoveShadow12,[ShadowSet]);
1123 mrYes:
1124 ExecDDL.SQL.Text := Format(sPreserveShadow,[ShadowSet]);
1125 mrCancel:
1126 Exit;
1127 end;
1128 ExecDDL.ExecQuery;
1129 CurrentTransaction.Commit;
1130 end;
1131
1132 procedure TDBDataModule.LoadPerformanceStatistics(Lines: TStrings);
1133
1134 procedure AddPerfStats(Heading: string; stats: TStrings);
1135 var i: integer;
1136 begin
1137 with Lines do
1138 begin
1139 if stats.count = 0 then exit;
1140 Add('');
1141 Add(Heading);
1142 for i := 0 to stats.Count - 1 do
1143 begin
1144 if TableNameLookup.Locate('RDB$RELATION_ID',stats.Names[i],[]) then
1145 Add(' ' + TableNameLookup.FieldByName('RDB$RELATION_NAME').AsString + ' = ' + stats.ValueFromIndex[i]);
1146 end;
1147 end;
1148 end;
1149
1150 begin
1151 TableNameLookup.Active := true;
1152 with IBDatabaseInfo, Lines do
1153 begin
1154 Add(Format('Number of reads from the memory buffer cache = %d',[Fetches]));
1155 Add(Format('Number of writes to the memory buffer cache = %d',[Marks]));
1156 Add(Format('Number of page reads = %d',[Reads]));
1157 Add(Format('Number of page writes = %d',[Writes]));
1158 Add('');
1159 Add('Since Database last attached:');
1160 AddPerfStats('Number of removals of a version of a record',BackoutCount);
1161 AddPerfStats('Number of database deletes',DeleteCount);
1162 AddPerfStats('Number of removals of a committed record',ExpungeCount);
1163 AddPerfStats('Number of inserts',InsertCount);
1164 AddPerfStats('Number of removals of old versions of fully mature records',PurgeCount);
1165 AddPerfStats('Number of reads done via an index',ReadIdxCount);
1166 AddPerfStats('Number of sequential table scans',ReadSeqCount);
1167 AddPerfStats('Number of database updates',UpdateCount);
1168 end;
1169 end;
1170
1171 procedure TDBDataModule.LoadDatabaseStatistics(OptionID: integer; Lines: TStrings);
1172 begin
1173 if OptionID = 1 then
1174 LoadPerformanceStatistics(Lines)
1175 else
1176 with IBStatisticalService1 do
1177 begin
1178 case OptionID of
1179 0: Options := [HeaderPages];
1180 2: options := [DataPages];
1181 3: Options := [IndexPages];
1182 4: Options := [SystemRelations]
1183 end;
1184 Execute(Lines);
1185 end;
1186 end;
1187
1188 function TDBDataModule.LoadConfigData(ConfigFileData: TConfigFileData): boolean;
1189 var i: integer;
1190 aValue: integer;
1191 begin
1192 ConfigDataset.Active := true;
1193 ConfigDataset.Clear(false);
1194 for i := 0 to Length(ConfigFileData.ConfigFileKey) - 1 do
1195 begin
1196 aValue := ConfigFileData.ConfigFileValue[i] ;
1197 with ConfigDataset do
1198 case ConfigFileData.ConfigFileKey[i] of
1199 ISCCFG_LOCKMEM_KEY:
1200 AppendRecord(['Lock mem', aValue]);
1201 ISCCFG_LOCKSEM_KEY:
1202 AppendRecord(['Lock Semaphores', aValue]);
1203 ISCCFG_LOCKSIG_KEY:
1204 AppendRecord(['Lock sig', aValue]);
1205 ISCCFG_EVNTMEM_KEY:
1206 AppendRecord(['Event mem', aValue]);
1207 ISCCFG_PRIORITY_KEY:
1208 AppendRecord(['Priority', aValue]);
1209 ISCCFG_MEMMIN_KEY:
1210 AppendRecord(['Min memory', aValue]);
1211 ISCCFG_MEMMAX_KEY:
1212 AppendRecord(['Max Memory', aValue]);
1213 ISCCFG_LOCKORDER_KEY:
1214 AppendRecord(['Lock order', aValue]);
1215 ISCCFG_ANYLOCKMEM_KEY:
1216 AppendRecord(['Any lock mem', aValue]);
1217 ISCCFG_ANYLOCKSEM_KEY:
1218 AppendRecord(['Any lock semaphore',aValue]);
1219 ISCCFG_ANYLOCKSIG_KEY:
1220 AppendRecord(['any lock sig', aValue]);
1221 ISCCFG_ANYEVNTMEM_KEY:
1222 AppendRecord(['any event mem', aValue]);
1223 ISCCFG_LOCKHASH_KEY:
1224 AppendRecord(['Lock hash', aValue]);
1225 ISCCFG_DEADLOCK_KEY:
1226 AppendRecord(['Deadlock', aValue]);
1227 ISCCFG_LOCKSPIN_KEY:
1228 AppendRecord(['Lock spin', aValue]);
1229 ISCCFG_CONN_TIMEOUT_KEY:
1230 AppendRecord(['Conn timeout', aValue]);
1231 ISCCFG_DUMMY_INTRVL_KEY:
1232 AppendRecord(['Dummy interval', aValue]);
1233 ISCCFG_IPCMAP_KEY:
1234 AppendRecord(['Map size', aValue]);
1235 ISCCFG_DBCACHE_KEY:
1236 AppendRecord(['Cache size', aValue]);
1237 end;
1238 end;
1239 Result := ConfigDataset.Active and (ConfigDataset.RecordCount > 0);
1240 end;
1241
1242 procedure TDBDataModule.LoadServerProperties(Lines: TStrings);
1243 var i: integer;
1244 begin
1245 Lines.Clear;
1246 with IBServerProperties1 do
1247 begin
1248 Lines.Add('Server Version = ' + VersionInfo.ServerVersion);
1249 Lines.Add('Server Implementation = ' + VersionInfo.ServerImplementation);
1250 Lines.Add('Service Version = ' + IntToStr(VersionInfo.ServiceVersion));
1251 with ServicesConnection do
1252 Lines.Add(Format('Firebird Release = %d.%d.%d (Build no. %d)',[ServerVersionNo[1],
1253 ServerVersionNo[2],
1254 ServerVersionNo[3],
1255 ServerVersionNo[4]]));
1256 Lines.Add('No. of attachments = ' + IntToStr(DatabaseInfo.NoOfAttachments));
1257 Lines.Add('No. of databases = ' + IntToStr(DatabaseInfo.NoOfDatabases));
1258 for i := 0 to length(DatabaseInfo.DbName) - 1 do
1259 Lines.Add(Format('DB Name (%d) = %s',[i+1, DatabaseInfo.DbName[i]]));
1260 Lines.Add('Base Location = ' + ConfigParams.BaseLocation);
1261 Lines.Add('Lock File Location = ' + ConfigParams.LockFileLocation);
1262 Lines.Add('Security Database Location = ' + ConfigParams.SecurityDatabaseLocation);
1263 Lines.Add('Message File Location = ' + ConfigParams.MessageFileLocation);
1264 end;
1265 end;
1266
1267 procedure TDBDataModule.LoadServerLog(Lines: TStrings);
1268 begin
1269 Lines.Clear;
1270 if IBLogService1.ServicesConnection.ServiceIntf.getProtocol = Local then
1271 Lines.Add('Server Log not available with embedded server')
1272 else
1273 IBLogService1.Execute(Lines);
1274 end;
1275
1276 procedure TDBDataModule.RevokeAll;
1277 begin
1278 with SubjectAccessRights do
1279 if Active then
1280 begin
1281 DisableControls;
1282 try
1283 First;
1284 while not EOF do
1285 begin
1286 if FieldByName('OBJECT_TYPE').AsInteger = 0 {relation} then
1287 ExecDDL.SQL.Text := Format('Revoke All on %s from %s',[
1288 Trim(FieldByName('OBJECT_NAME').AsString),
1289 Trim(FieldByName('SUBJECT_NAME').AsString)])
1290 else
1291 if FieldByName('OBJECT_TYPE').AsInteger = 13 {role} then
1292 ExecDDL.SQL.Text := Format('Revoke %s from %s',[
1293 Trim(FieldByName('OBJECT_NAME').AsString),
1294 Trim(FieldByName('SUBJECT_NAME').AsString)])
1295 else
1296 ExecDDL.SQL.Text := Format('Revoke All on %s %s from %s',[
1297 Trim(FieldByName('OBJECT_TYPE_NAME').AsString),
1298 Trim(FieldByName('OBJECT_NAME').AsString),
1299 Trim(FieldByName('SUBJECT_NAME').AsString)]);
1300 ExecDDL.ExecQuery;
1301 Next;
1302 end;
1303 finally
1304 EnableControls;
1305 end;
1306 CurrentTransaction.Commit;
1307 end;
1308 end;
1309
1310 procedure TDBDataModule.SyncSubjectAccessRights(ID: string);
1311 begin
1312 if (FSubjectAccessRightsID = ID) and SubjectAccessRights.Active then Exit;
1313 SubjectAccessRights.Active := false;
1314 FSubjectAccessRightsID := ID;
1315 SubjectAccessRights.Active := true;
1316 end;
1317
1318 procedure TDBDataModule.IBDatabase1Login(Database: TIBDatabase;
1319 LoginParams: TStrings);
1320 var aDatabaseName: string;
1321 aUserName: string;
1322 aPassword: string;
1323 aCreateIfNotExist: boolean;
1324 begin
1325 if FLocalConnect or (FDBPassword <> '') {reconnect} then
1326 begin
1327 LoginParams.Values['user_name'] := FDBUserName;
1328 LoginParams.Values['password'] := FDBPassword;
1329 exit;
1330 end;
1331
1332 aDatabaseName := Database.DatabaseName;
1333 aUserName := LoginParams.Values['user_name'];
1334 aPassword := '';
1335 aCreateIfNotExist := false;
1336 if CallLoginDlg(aDatabaseName, aUserName, aPassword, aCreateIfNotExist) = mrOK then
1337 begin
1338 FDBPassword := aPassword; {remember for reconnect}
1339 Database.DatabaseName := aDatabaseName;
1340 LoginParams.Values['user_name'] := aUserName;
1341 LoginParams.Values['password'] := aPassword;
1342 FDBUserName := aUserName;
1343 FDBPassword := aPassword;
1344 Database.CreateIfNotExists := aCreateIfNotExist;
1345 ParseConnectString(aDatabaseName,FServerName,FDatabasePathName,FProtocol,FPortNo);
1346 end
1347 else
1348 IBError(ibxeOperationCancelled, [nil]);
1349 end;
1350
1351 procedure TDBDataModule.AttUpdateApplyUpdates(Sender: TObject;
1352 UpdateKind: TUpdateKind; Params: ISQLParams);
1353 begin
1354 if UpdateKind = ukDelete then
1355 begin
1356 ExecDDL.SQL.Text := 'Delete from MON$ATTACHMENTS Where MON$ATTACHMENT_ID =' +
1357 Params.ByName('MON$ATTACHMENT_ID').Asstring;
1358 ExecDDL.ExecQuery;
1359 end;
1360 end;
1361
1362 procedure TDBDataModule.DBTablesUpdateApplyUpdates(Sender: TObject;
1363 UpdateKind: TUpdateKind; Params: ISQLParams);
1364 begin
1365 // Do nothing
1366 end;
1367
1368 procedure TDBDataModule.IBValidationService1GetNextLine(Sender: TObject;
1369 var Line: string);
1370 begin
1371 Application.ProcessMessages;
1372 end;
1373
1374 procedure TDBDataModule.IBXServicesConnection1AfterConnect(Sender: TObject);
1375 var UN: ISPBItem;
1376 begin
1377 UN := IBXServicesConnection1.ServiceIntf.getSPB.Find(isc_spb_user_name);
1378 if UN <> nil then
1379 FServiceUserName := UN.AsString;
1380 end;
1381
1382 procedure TDBDataModule.IBXServicesConnection1Login(
1383 Service: TIBXServicesConnection; var aServerName: string; LoginParams: TStrings);
1384 begin
1385 LoginParams.Values['user_name'] := FDBUserName;
1386 LoginParams.Values['password'] := FDBPassword;
1387 end;
1388
1389 procedure TDBDataModule.LegacyUserListAfterOpen(DataSet: TDataSet);
1390 begin
1391 if UserListSource.DataSet <> LegacyUserList then
1392 UserListSource.DataSet := LegacyUserList;
1393 if IBDatabase1.Connected then
1394 begin
1395 CurrentTransaction.Active := true;
1396 RoleNameList.Active := true;
1397 end;
1398 end;
1399
1400 procedure TDBDataModule.LegacyUserListAfterPost(DataSet: TDataSet);
1401 begin
1402 if IBDatabase1.Connected then
1403 RoleNameList.Active := true;
1404 end;
1405
1406 procedure TDBDataModule.LegacyUserListBeforeClose(DataSet: TDataSet);
1407 begin
1408 RoleNameList.Active := false;
1409 end;
1410
1411 procedure TDBDataModule.ShadowFilesCalcFields(DataSet: TDataSet);
1412 var Flags: integer;
1413 begin
1414 Flags := DataSet.FieldByName('RDB$FILE_FLAGS').AsInteger;
1415 if Flags and $10 <> 0 then
1416 DataSet.FieldByName('FileMode').AsString := 'C'
1417 else
1418 if Flags and $04 <> 0 then
1419 DataSet.FieldByName('FileMode').AsString := 'M'
1420 else
1421 if Flags and $01 <> 0 then
1422 if DataSet.FieldByName('RDB$FILE_SEQUENCE').AsInteger = 0 then
1423 DataSet.FieldByName('FileMode').AsString := 'A'
1424 else
1425 DataSet.FieldByName('FileMode').AsString := '+'
1426 else
1427 DataSet.FieldByName('FileMode').AsString := ''
1428 end;
1429
1430 procedure TDBDataModule.SubjectAccessRightsBeforeOpen(DataSet: TDataSet);
1431 begin
1432 SubjectAccessRights.ParamByName('ID').AsString := FSubjectAccessRightsID;
1433 end;
1434
1435 procedure TDBDataModule.TagsUpdateApplyUpdates(Sender: TObject;
1436 UpdateKind: TUpdateKind; Params: ISQLParams);
1437 var sql: string;
1438 begin
1439 sql := '';
1440 case UpdateKind of
1441 ukInsert,
1442 ukModify:
1443 begin
1444 sql := 'ALTER USER ' + Trim(Params.ByName('SEC$USER_NAME').AsString)
1445 + ' TAGS (' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('SEC$KEY').AsString)
1446 + '=''' + SQLSafeString(Params.ByName('SEC$VALUE').AsString) + '''';
1447 if Params.ByName('SEC$KEY').AsString <> Params.ByName('OLD_SEC$KEY').AsString then
1448 sql += ', DROP ' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('OLD_SEC$KEY').AsString);
1449 sql +=')'
1450 end;
1451
1452 ukDelete:
1453 sql := 'ALTER USER ' + Trim(Params.ByName('SEC$USER_NAME').AsString)
1454 + ' TAGS (DROP ' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('SEC$KEY').AsString) + ')';
1455 end;
1456 ExecDDL.SQL.Text := sql;
1457 ExecDDL.ExecQuery;
1458 end;
1459
1460 procedure TDBDataModule.IBDatabase1AfterConnect(Sender: TObject);
1461 begin
1462 {Virtual tables did not exist prior to Firebird 2.1 - so don't bother with old version}
1463 with IBDatabaseInfo do
1464 if (ODSMajorVersion < 11) or ((ODSMajorVersion = 11) and (ODSMinorVersion < 1)) then
1465 begin
1466 IBDatabase1.Connected := false;
1467 raise Exception.Create('This application requires Firebird 2.1 or later');
1468 end
1469 else
1470 if ODSMajorVersion < 12 then
1471 {Don't expect to be able to find these fields}
1472 begin
1473 AttachmentsMONCLIENT_VERSION.FieldKind := fkCalculated;
1474 AttachmentsMONREMOTE_VERSION.FieldKind := fkCalculated;
1475 AttachmentsMONREMOTE_HOST.FieldKind := fkCalculated;
1476 AttachmentsMONREMOTE_OS_USER.FieldKind := fkCalculated;
1477 AttachmentsMONAUTH_METHOD.FieldKind := fkCalculated;
1478 AttachmentsMONSYSTEM_FLAG.FieldKind := fkCalculated;
1479 AttachmentsRDBSECURITY_CLASS.FieldKind := fkCalculated;
1480 AttachmentsRDBOWNER_NAME.FieldKind := fkCalculated;
1481 end
1482 else
1483 begin
1484 AttachmentsMONCLIENT_VERSION.FieldKind := fkData;
1485 AttachmentsMONREMOTE_VERSION.FieldKind := fkData;
1486 AttachmentsMONREMOTE_HOST.FieldKind := fkData;
1487 AttachmentsMONREMOTE_OS_USER.FieldKind := fkData;
1488 AttachmentsMONAUTH_METHOD.FieldKind := fkData;
1489 AttachmentsMONSYSTEM_FLAG.FieldKind := fkData;
1490 AttachmentsRDBSECURITY_CLASS.FieldKind := fkData;
1491 AttachmentsRDBOWNER_NAME.FieldKind := fkData;
1492 end;
1493
1494 FLocalConnect := FProtocol = Local;
1495 ConnectServicesAPI;
1496 CurrentTransaction.Active := true;
1497 FHasUserAdminPrivilege := GetUserAdminPrivilege;
1498 ReloadData;
1499 end;
1500
1501 procedure TDBDataModule.IBDatabase1AfterDisconnect(Sender: TObject);
1502 begin
1503 FDisconnecting := false;
1504 end;
1505
1506 procedure TDBDataModule.IBDatabase1BeforeDisconnect(Sender: TObject);
1507 begin
1508 FDBHeaderScanned := false;
1509 FDisconnecting := true;
1510 end;
1511
1512 procedure TDBDataModule.DatabaseQueryAfterOpen(DataSet: TDataSet);
1513 begin
1514 DBCharSet.Active := true;
1515 end;
1516
1517 procedure TDBDataModule.CurrentTransactionAfterTransactionEnd(Sender: TObject);
1518 begin
1519 if not Disconnecting and not (csDestroying in ComponentState) then
1520 begin
1521 CurrentTransaction.Active := true;
1522 Application.QueueAsyncCall(@ReloadData,0);
1523 end;
1524 end;
1525
1526 procedure TDBDataModule.ApplicationProperties1Exception(Sender: TObject;
1527 E: Exception);
1528 begin
1529 if E is EIBInterBaseError then
1530 begin
1531 if RoleNameList.State in [dsInsert,dsEdit] then
1532 RoleNameList.Cancel;
1533 if UserList.State in [dsInsert,dsEdit] then
1534 UserList.Cancel;
1535 end;
1536 MessageDlg(E.Message,mtError,[mbOK],0);
1537 if CurrentTransaction.Active then
1538 CurrentTransaction.Rollback;
1539 end;
1540
1541 procedure TDBDataModule.AccessRightsCalcFields(DataSet: TDataSet);
1542 begin
1543 AccessRightsDisplayName.AsString := AccessRightsSUBJECT_NAME.AsString;
1544 if AccessRightsSUBJECT_TYPE.AsInteger = 8 then
1545 begin
1546 if (AccessRightsSUBJECT_NAME.AsString <> 'PUBLIC') and UserListSource.DataSet.Active and
1547 not UserListSource.DataSet.Locate('SEC$USER_NAME',AccessRightsSUBJECT_NAME.AsString,[]) then
1548 begin
1549 AccessRightsImageIndex.AsInteger := 4;
1550 AccessRightsDisplayName.AsString := AccessRightsSUBJECT_NAME.AsString + ' (stale)';
1551 end
1552 else
1553 AccessRightsImageIndex.AsInteger := -1
1554 end
1555 else
1556 AccessRightsImageIndex.AsInteger := -1;
1557 end;
1558
1559 procedure TDBDataModule.AttachmentsAfterDelete(DataSet: TDataSet);
1560 begin
1561 CurrentTransaction.Commit;
1562 end;
1563
1564 procedure TDBDataModule.AttachmentsAfterOpen(DataSet: TDataSet);
1565 begin
1566 Attachments.Locate('MON$ATTACHMENT_ID',AttmtQuery.FieldByName('MON$ATTACHMENT_ID').AsInteger,[]);
1567 end;
1568
1569 procedure TDBDataModule.AttachmentsBeforeOpen(DataSet: TDataSet);
1570 begin
1571 if IBDatabaseInfo.ODSMajorVersion >= 12 then
1572 (DataSet as TIBQuery).Parser.Add2WhereClause('r.MON$SYSTEM_FLAG = 0');
1573 end;
1574
1575 procedure TDBDataModule.ConfigDatasetAfterClose(DataSet: TDataSet);
1576 begin
1577 ConfigDataset.Clear(false);
1578 end;
1579
1580 procedure TDBDataModule.DatabaseQueryBeforeClose(DataSet: TDataSet);
1581 begin
1582 DBCharSet.Active := false;
1583 end;
1584
1585 procedure TDBDataModule.DBCharSetAfterClose(DataSet: TDataSet);
1586 begin
1587 CharSetLookup.Active := false;
1588 end;
1589
1590 procedure TDBDataModule.DBCharSetBeforeOpen(DataSet: TDataSet);
1591 begin
1592 CharSetLookup.Active := true;
1593 end;
1594
1595 end.
1596