ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/DBAdmin/DataModule.pas
Revision: 158
Committed: Thu Mar 1 11:23:33 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 55196 byte(s)
Log Message:
Repository resync

File Contents

# Content
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, IBServices, IB, Dialogs, Controls,
27 Forms;
28
29 type
30
31 { TDatabaseData }
32
33 TDatabaseData = class(TDataModule)
34 AccessRightsCHILDCOUNT: TIBLargeIntField;
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 CurrentTransaction: TIBTransaction;
75 DatabaseQuery: TIBQuery;
76 Attachments: TIBQuery;
77 IBOnlineValidationService1: TIBOnlineValidationService;
78 DBTables: TIBQuery;
79 AuthMappings: TIBQuery;
80 AccessRights: TIBQuery;
81 SubjectAccessRights: TIBQuery;
82 IBSecurityService1: TIBSecurityService;
83 AttUpdate: TIBUpdate;
84 AdminUserQuery: TIBSQL;
85 DBTablesUpdate: TIBUpdate;
86 IBValidationService1: TIBValidationService;
87 InLimboList: TMemDataset;
88 LegacyUserList: TMemDataset;
89 UserListGROUPID: TLongintField;
90 UserListSource: TDataSource;
91 DBCharSet: TIBQuery;
92 DBSecFiles: TIBQuery;
93 ExecDDL: TIBSQL;
94 IBConfigService1: TIBConfigService;
95 IBDatabase1: TIBDatabase;
96 IBDatabaseInfo: TIBDatabaseInfo;
97 AttmtQuery: TIBQuery;
98 IBLogService1: TIBLogService;
99 IBServerProperties1: TIBServerProperties;
100 IBStatisticalService1: TIBStatisticalService;
101 RoleNameList: TIBQuery;
102 TableNameLookup: TIBQuery;
103 TagsUpdate: TIBUpdate;
104 UpdateCharSet: TIBUpdate;
105 SecGlobalAuth: TIBQuery;
106 ShadowFiles: TIBQuery;
107 ShadowFilesFileMode: TStringField;
108 ShadowFilesRDBFILE_FLAGS: TSmallintField;
109 ShadowFilesRDBFILE_LENGTH: TIntegerField;
110 ShadowFilesRDBFILE_NAME: TIBStringField;
111 ShadowFilesRDBFILE_SEQUENCE: TSmallintField;
112 ShadowFilesRDBFILE_START: TIntegerField;
113 ShadowFilesRDBSHADOW_NUMBER: TSmallintField;
114 UpdateUserRoles: TIBUpdate;
115 UpdateUsers: TIBUpdate;
116 UserList: TIBQuery;
117 UserListCURRENT_CONNECTION: TIBLargeIntField;
118 UserListDBCREATOR: TBooleanField;
119 UserListLOGGEDIN: TBooleanField;
120 UserListSECACTIVE: TBooleanField;
121 UserListSECADMIN: TBooleanField;
122 UserListSECFIRST_NAME: TIBStringField;
123 UserListSECLAST_NAME: TIBStringField;
124 UserListSECMIDDLE_NAME: TIBStringField;
125 UserListSECPLUGIN: TIBStringField;
126 UserListUSERID: TLongintField;
127 UserListUSERNAME: TIBStringField;
128 UserListUSERPASSWORD: TIBStringField;
129 UserTags: TIBQuery;
130 procedure AccessRightsCalcFields(DataSet: TDataSet);
131 procedure ApplicationProperties1Exception(Sender: TObject; E: Exception);
132 procedure AttachmentsAfterDelete(DataSet: TDataSet);
133 procedure AttachmentsAfterOpen(DataSet: TDataSet);
134 procedure AttachmentsBeforeOpen(DataSet: TDataSet);
135 procedure CurrentTransactionAfterTransactionEnd(Sender: TObject);
136 procedure DatabaseQueryAfterOpen(DataSet: TDataSet);
137 procedure DatabaseQueryBeforeClose(DataSet: TDataSet);
138 procedure DBCharSetAfterClose(DataSet: TDataSet);
139 procedure DBCharSetBeforeOpen(DataSet: TDataSet);
140 procedure IBDatabase1AfterConnect(Sender: TObject);
141 procedure IBDatabase1AfterDisconnect(Sender: TObject);
142 procedure IBDatabase1BeforeDisconnect(Sender: TObject);
143 procedure IBDatabase1Login(Database: TIBDatabase; LoginParams: TStrings);
144 procedure AttUpdateApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
145 Params: ISQLParams);
146 procedure DBTablesUpdateApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
147 Params: ISQLParams);
148 procedure InLimboListAfterOpen(DataSet: TDataSet);
149 procedure InLimboListBeforeClose(DataSet: TDataSet);
150 procedure InLimboListBeforePost(DataSet: TDataSet);
151 procedure LegacyUserListAfterOpen(DataSet: TDataSet);
152 procedure LegacyUserListBeforeClose(DataSet: TDataSet);
153 procedure LegacyUserListBeforeDelete(DataSet: TDataSet);
154 procedure LegacyUserListBeforePost(DataSet: TDataSet);
155 procedure ShadowFilesCalcFields(DataSet: TDataSet);
156 procedure SubjectAccessRightsBeforeOpen(DataSet: TDataSet);
157 procedure TagsUpdateApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
158 Params: ISQLParams);
159 procedure UpdateCharSetApplyUpdates(Sender: TObject;
160 UpdateKind: TUpdateKind; Params: ISQLParams);
161 procedure UpdateUserRolesApplyUpdates(Sender: TObject;
162 UpdateKind: TUpdateKind; Params: ISQLParams);
163 procedure UpdateUsersApplyUpdates(Sender: TObject; UpdateKind: TUpdateKind;
164 Params: ISQLParams);
165 procedure UserListAfterInsert(DataSet: TDataSet);
166 procedure UserListAfterOpen(DataSet: TDataSet);
167 procedure UserListAfterPost(DataSet: TDataSet);
168 procedure UserListAfterScroll(DataSet: TDataSet);
169 procedure UserListBeforeClose(DataSet: TDataSet);
170 procedure UserTagsAfterInsert(DataSet: TDataSet);
171 private
172 FAfterDataReload: TNotifyEvent;
173 FAfterDBConnect: TNotifyEvent;
174 FDBHeaderScanned: boolean;
175 FDisconnecting: boolean;
176 FISShadowDatabase: boolean;
177 FDBUserName: string;
178 FDBPassword: string;
179 FLocalConnect: boolean;
180 FUsersLoading: boolean;
181 FLoadingLimboTr: boolean;
182 FSubjectAccessRightsID: string;
183 {Parsed results of connectstring;}
184 FServerName: string;
185 FPortNo: string;
186 FProtocol: TProtocolAll;
187 FDatabasePathName: string;
188 procedure ActivateService(aService: TIBCustomService);
189 function GetAuthMethod: string;
190 function GetAutoAdmin: boolean;
191 function GetDatabaseName: string;
192 procedure GetDBFlags;
193 function GetDBOwner: string;
194 function GetDBReadOnly: boolean;
195 function GetDBSQLDialect: integer;
196 function GetDBUserName: string;
197 function GetEmbeddedMode: boolean;
198 function GetForcedWrites: boolean;
199 function GetLingerDelay: string;
200 function GetNoReserve: boolean;
201 function GetPageBuffers: integer;
202 function GetRoleName: string;
203 function GetSecurityDatabase: string;
204 function GetSweepInterval: integer;
205 function GetUserAdminPrivilege: boolean;
206 procedure SetAutoAdmin(AValue: boolean);
207 procedure SetDBReadOnly(AValue: boolean);
208 procedure SetDBSQLDialect(AValue: integer);
209 procedure SetForcedWrites(AValue: boolean);
210 procedure SetLingerDelay(AValue: string);
211 procedure SetNoReserve(AValue: boolean);
212 procedure SetPageBuffers(AValue: integer);
213 procedure SetSweepInterval(AValue: integer);
214 procedure ReloadData(Data: PtrInt=0);
215 public
216 destructor Destroy; override;
217 procedure Connect;
218 procedure Disconnect;
219 procedure DropDatabase;
220 procedure BackupDatabase;
221 procedure RestoreDatabase;
222 procedure BringDatabaseOnline;
223 procedure ShutDown(aShutDownmode: TShutdownMode; aDelay: integer);
224 procedure DatabaseRepair(Options: TValidateOptions; ReportLines: TStrings);
225 procedure OnlineValidation(ReportLines: TStrings; SelectedTablesOnly: boolean);
226 procedure LimboResolution(ActionID: TTransactionGlobalAction; Report: TStrings);
227 function IsDatabaseOnline: boolean;
228 function IsShadowDatabase: boolean;
229 procedure ActivateShadow;
230 procedure AddSecondaryFile(aFileName: string; StartAt,FileLength: integer);
231 procedure AddShadowSet;
232 procedure RemoveShadowSet(ShadowSet: integer);
233 procedure LoadPerformanceStatistics(Lines: TStrings);
234 procedure LoadDatabaseStatistics(OptionID: integer; Lines: TStrings);
235 procedure LoadServerProperties(Lines: TStrings);
236 procedure LoadServerLog(Lines: TStrings);
237 procedure RevokeAll;
238 procedure SyncSubjectAccessRights(ID: string);
239 property AutoAdmin: boolean read GetAutoAdmin write SetAutoAdmin;
240 property Disconnecting: boolean read FDisconnecting;
241 property ForcedWrites: boolean read GetForcedWrites write SetForcedWrites;
242 property LingerDelay: string read GetLingerDelay write SetLingerDelay;
243 property DBReadOnly: boolean read GetDBReadOnly write SetDBReadOnly;
244 property NoReserve: boolean read GetNoReserve write SetNoReserve;
245 property PageBuffers: integer read GetPageBuffers write SetPageBuffers;
246 property SweepInterval: integer read GetSweepInterval write SetSweepInterval;
247 property DatabaseName: string read GetDatabaseName;
248 property SecurityDatabase: string read GetSecurityDatabase;
249 property AuthMethod: string read GetAuthMethod;
250 property EmbeddedMode: boolean read GetEmbeddedMode;
251 property DBUserName: string read GetDBUserName;
252 property RoleName: string read GetRoleName;
253 property DBOwner: string read GetDBOwner;
254 property DBSQLDialect: integer read GetDBSQLDialect write SetDBSQLDialect;
255 property HasUserAdminPrivilege: boolean read GetUserAdminPrivilege;
256 property AfterDBConnect: TNotifyEvent read FAfterDBConnect write FAfterDBConnect;
257 property AfterDataReload: TNotifyEvent read FAfterDataReload write FAfterDataReload;
258 end;
259
260 var
261 DatabaseData: TDatabaseData;
262
263 implementation
264
265 {$R *.lfm}
266
267 uses DBLoginDlgUnit, IBUtils, FBMessages, ShutdownDatabaseDlgUnit,
268 BackupDlgUnit, RestoreDlgUnit, AddShadowSetDlgUnit, IBErrorCodes;
269
270 const
271 sAddSecondarySQL = 'Alter Database Add File ''%s'' Starting at %d';
272 sAddSecondarySQL2 = 'Alter Database Add File ''%s'' Starting at %d Length %d';
273 sRemoveShadow = 'Drop Shadow %d';
274 sRemoveShadow12 = 'Drop Shadow %d DELETE FILE';
275 sPreserveShadow = 'Drop Shadow %d PRESERVE FILE';
276
277 resourcestring
278 sPreserveShadowFiles = 'Preserve Shadow Set Files after drop?';
279
280 { TDatabaseData }
281
282 procedure TDatabaseData.UpdateCharSetApplyUpdates(Sender: TObject;
283 UpdateKind: TUpdateKind; Params: ISQLParams);
284 begin
285 if UpdateKind = ukModify then
286 begin
287 ExecDDL.SQL.Text := 'ALTER DATABASE SET DEFAULT CHARACTER SET ' +
288 Params.ByName('RDB$CHARACTER_SET_NAME').AsString;
289 ExecDDL.ExecQuery;
290 end;
291 end;
292
293 procedure TDatabaseData.UpdateUserRolesApplyUpdates(Sender: TObject;
294 UpdateKind: TUpdateKind; Params: ISQLParams);
295
296 procedure Grant(Params: ISQLParams);
297 begin
298 ExecDDL.SQL.Text := 'Grant ' + trim(Params.ByName('RDB$ROLE_NAME').AsString) + ' to ' + Params.ByName('USERNAME').AsString;
299 ExecDDL.ExecQuery;
300 end;
301
302 procedure Revoke(Params: ISQLParams);
303 begin
304 ExecDDL.SQL.Text := 'Revoke ' + trim(Params.ByName('RDB$ROLE_NAME').AsString) + ' from ' + Params.ByName('USERNAME').AsString;
305 ExecDDL.ExecQuery;
306 end;
307
308 begin
309 if UpdateKind = ukModify then
310 begin
311 if Params.ByName('GRANTED').AsInteger = 0 then
312 Revoke(Params)
313 else
314 Grant(Params);
315 end;
316 end;
317
318 procedure TDatabaseData.UpdateUsersApplyUpdates(Sender: TObject;
319 UpdateKind: TUpdateKind; Params: ISQLParams);
320
321 function FormatStmtOptions: string;
322 var Param: ISQLParam;
323 begin
324 Result := Trim(Params.ByName('UserName').AsString);
325 Param := Params.ByName('USERPASSWORD');
326 if (Param <> nil) and not Param.IsNull then
327 Result += ' PASSWORD ''' + SQLSafeString(Param.AsString) + '''';
328 Param := Params.ByName('SEC$FIRST_NAME');
329 if Param <> nil then
330 Result += ' FIRSTNAME ''' + SQLSafeString(Param.AsString) + '''';
331 Param := Params.ByName('SEC$MIDDLE_NAME');
332 if Param <> nil then
333 Result += ' MIDDLENAME ''' + SQLSafeString(Param.AsString) + '''';
334 Param := Params.ByName('SEC$LAST_NAME');
335 if Param <> nil then
336 Result += ' LASTNAME ''' + SQLSafeString(Param.AsString) + '''';
337 Param := Params.ByName('SEC$ACTIVE');
338 if Param <> nil then
339 begin
340 if Param.AsBoolean then
341 Result += ' ACTIVE'
342 else
343 Result += ' INACTIVE';
344 end;
345 Param := Params.ByName('SEC$PLUGIN');
346 if Param <> nil then
347 Result += ' USING PLUGIN ' + QuoteIdentifierIfNeeded((Sender as TIBUpdate).DataSet.Database.SQLDialect,Param.AsString);
348 end;
349
350 function GetAlterPasswordStmt: string;
351 var Param: ISQLParam;
352 begin
353 Result := '';
354 Param := Params.ByName('USERPASSWORD');
355 if (UpdateKind = ukModify) and not Param.IsNull then
356 begin
357 Result := 'ALTER USER ' + Trim(Params.ByName('UserName').AsString) +
358 ' PASSWORD ''' + SQLSafeString(Param.AsString) + '''';
359 Param := Params.ByName('SEC$PLUGIN');
360 if Param <> nil then
361 Result += ' USING PLUGIN ' + QuoteIdentifierIfNeeded((Sender as TIBUpdate).DataSet.Database.SQLDialect,Param.AsString);
362 end;
363 end;
364
365 begin
366 {non SYSDBA user not an RDB$ADMIN can only change their password}
367 if (DBUserName <> 'SYSDBA') and (RoleName <> 'RDB$ADMIN') then
368 begin
369 ExecDDL.SQL.Text := GetAlterPasswordStmt;
370 if ExecDDL.SQL.Text <> '' then
371 ExecDDL.ExecQuery;
372 Exit;
373 end;
374
375 case UpdateKind of
376 ukInsert:
377 ExecDDL.SQL.Text := 'CREATE USER ' + FormatStmtOptions;
378 ukModify:
379 ExecDDL.SQL.Text := 'ALTER USER ' + FormatStmtOptions;
380 ukDelete:
381 ExecDDL.SQL.Text := 'DROP USER ' + Trim(Params.ByName('UserName').AsString);
382 end;
383 ExecDDL.ExecQuery;
384
385 if UpdateKind = ukInsert then
386 begin
387 {if new user is also given the admin role then we need to add this}
388 if Params.ByName('SEC$ADMIN').AsBoolean then
389 begin
390 ExecDDL.SQL.Text := 'ALTER USER ' + Trim(Params.ByName('UserName').AsString) + ' GRANT ADMIN ROLE';
391 ExecDDL.ExecQuery;
392 end;
393 end
394 else
395 if UpdateKind = ukModify then
396 {Update Admin Role if allowed}
397 begin
398 if Params.ByName('SEC$ADMIN').AsBoolean and not Params.ByName('OLD_SEC$ADMIN').AsBoolean then
399 begin
400 ExecDDL.SQL.Text := 'ALTER USER ' + Trim(Params.ByName('UserName').AsString) + ' GRANT ADMIN ROLE';
401 ExecDDL.ExecQuery;
402 end
403 else
404 if not Params.ByName('SEC$ADMIN').AsBoolean and Params.ByName('OLD_SEC$ADMIN').AsBoolean then
405 begin
406 ExecDDL.SQL.Text := 'ALTER USER ' + Trim(Params.ByName('UserName').AsString) + ' REVOKE ADMIN ROLE';
407 ExecDDL.ExecQuery;
408 end
409 end;
410
411 {Update DB Creator Role}
412 if Params.ByName('DBCreator').AsBoolean and not Params.ByName('OLD_DBCreator').AsBoolean then
413 begin
414 ExecDDL.SQL.Text := 'GRANT CREATE DATABASE TO USER ' + Trim(Params.ByName('UserName').AsString);
415 ExecDDL.ExecQuery;
416 end
417 else
418 if not Params.ByName('DBCreator').AsBoolean and Params.ByName('OLD_DBCreator').AsBoolean then
419 begin
420 ExecDDL.SQL.Text := 'REVOKE CREATE DATABASE FROM USER ' + Trim(Params.ByName('UserName').AsString);
421 ExecDDL.ExecQuery;
422 end
423 end;
424
425 procedure TDatabaseData.UserListAfterInsert(DataSet: TDataSet);
426 begin
427 DataSet.FieldByName('SEC$ADMIN').AsBoolean := false;
428 DataSet.FieldByName('SEC$ACTIVE').AsBoolean := false;
429 DataSet.FieldByName('DBCreator').AsBoolean := false;
430 DataSet.FieldByName('SEC$PLUGIN').AsString := 'Srp';
431 DataSet.FieldByName('UserID').AsInteger := 0;
432 DataSet.FieldByName('GroupID').AsInteger := 0;
433 DataSet.FieldByName('UserPassword').Clear;
434 RoleNameList.Active := false; {Prevent role assignments until saved}
435 UserTags.Active := false; {ditto}
436 end;
437
438 procedure TDatabaseData.UserListAfterOpen(DataSet: TDataSet);
439 begin
440 UserListSource.DataSet := UserList;
441 RoleNameList.Active := true;
442 UserTags.Active := true;
443 end;
444
445 procedure TDatabaseData.UserListAfterPost(DataSet: TDataSet);
446 begin
447 CurrentTransaction.Commit;
448 end;
449
450 procedure TDatabaseData.UserListAfterScroll(DataSet: TDataSet);
451 begin
452 UserList.FieldByName('SEC$PLUGIN').ReadOnly := UserList.State <> dsInsert;
453 end;
454
455 procedure TDatabaseData.UserListBeforeClose(DataSet: TDataSet);
456 begin
457 RoleNameList.Active := false;
458 UserTags.Active := false;
459 end;
460
461 procedure TDatabaseData.UserTagsAfterInsert(DataSet: TDataSet);
462 begin
463 DataSet.FieldByName('SEC$USER_NAME').AsString := DataSet.DataSource.DataSet.FieldByName('UserName').AsString;
464 end;
465
466 procedure TDatabaseData.GetDBFlags;
467 var Line: string;
468 begin
469 if FDBHeaderScanned or not DatabaseQuery.Active or not AttmtQuery.Active then Exit;
470 FIsShadowDatabase := false;
471
472 try
473 ActivateService(IBStatisticalService1);
474
475 with IBStatisticalService1 do
476 begin
477 try
478 Options := [HeaderPages];
479 ServiceStart;
480 while not Eof do
481 begin
482 Line := GetNextLine;
483 if (Pos('Attributes',Line) <> 0) and (Pos('shadow',Line) <> 0) then
484 FIsShadowDatabase := true;
485
486 end
487 finally
488 Active := False;
489 end
490 end;
491 except on E: Exception do
492 MessageDlg('Error getting DB Header Page: ' + E.Message,mtError,[mbOK],0);
493 end;
494 end;
495
496 function TDatabaseData.GetDBOwner: string;
497 var DBOField: TField;
498 begin
499 DBOField := DatabaseQuery.FindField('MON$OWNER');
500 if DBOField <> nil then
501 Result := Trim(DBOField.AsString)
502 else
503 Result := 'n/a';
504 end;
505
506 function TDatabaseData.GetAutoAdmin: boolean;
507 begin
508 Result := false;
509 if not CurrentTransaction.Active then Exit;
510 SecGlobalAuth.Active := true; {sets AutoAdmin}
511 try
512 Result := SecGlobalAuth.FieldByName('Mappings').AsInteger > 0;
513 finally
514 SecGlobalAuth.Active := false;
515 end;
516 end;
517
518 function TDatabaseData.GetDatabaseName: string;
519 begin
520 if DatabaseQuery.Active and not DatabaseQuery.FieldByName('MON$DATABASE_NAME').IsNull then
521 Result := DatabaseQuery.FieldByName('MON$DATABASE_NAME').AsString
522 else
523 Result := FDatabasePathName;
524 end;
525
526 function TDatabaseData.GetDBReadOnly: boolean;
527 begin
528 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$READ_ONLY').AsInteger <> 0);
529 end;
530
531 function TDatabaseData.GetDBSQLDialect: integer;
532 begin
533 Result := IBDatabaseInfo.DBSQLDialect;
534 end;
535
536 function TDatabaseData.GetDBUserName: string;
537 begin
538 Result := Trim(AttmtQuery.FieldByName('MON$USER').AsString);
539 end;
540
541 function TDatabaseData.GetEmbeddedMode: boolean;
542 begin
543 Result := AttmtQuery.FieldByName('MON$REMOTE_PROTOCOL').IsNull;
544 end;
545
546 function TDatabaseData.GetForcedWrites: boolean;
547 begin
548 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$FORCED_WRITES').AsInteger <> 0);
549 end;
550
551 procedure TDatabaseData.SetLingerDelay(AValue: string);
552 begin
553 if (StrToInt(AValue) = DatabaseQuery.FieldByName('RDB$LINGER').AsInteger) then Exit;
554
555 if (AValue = '') or (StrToInt(AValue) = 0) then
556 begin
557 if MessageDlg('Turn off Linger Permanently?',mtConfirmation,[mbYes,mbNo],0) = mrNo then
558 begin
559 ActivateService(IBConfigService1);
560 IBConfigService1.SetNoLinger;
561 CurrentTransaction.Commit; {Refresh}
562 Exit;
563 end;
564 ExecDDL.SQL.Text := 'ALTER DATABASE DROP LINGER'
565 end
566 else
567 ExecDDL.SQL.Text := 'ALTER DATABASE SET LINGER TO ' + AValue;
568 with ExecDDL do
569 begin
570 Transaction.Active := true;
571 ExecQuery;
572 Transaction.Commit;
573 end;
574 end;
575
576 procedure TDatabaseData.ActivateService(aService: TIBCustomService);
577
578 procedure AssignDatabase(IBService: TIBCustomService; DBName: string);
579 begin
580 if IBService is TIBValidationService then
581 TIBValidationService(IBService).DatabaseName := DBName
582 else
583 if IBService is TIBOnlineValidationService then
584 TIBOnlineValidationService(IBService).DatabaseName := DBName
585 else
586 if IBService is TIBStatisticalService then
587 TIBStatisticalService(IBService).DatabaseName := DBName
588 else
589 if IBService is TIBConfigService then
590 TIBConfigService(IBService).DatabaseName := DBName
591 else
592 if IBService is TIBBackupService then
593 TIBBackupService(IBService).DatabaseName := DBName
594 else
595 if IBService is TIBRestoreService then
596 begin
597 TIBRestoreService(IBService).DatabaseName.Clear;
598 TIBRestoreService(IBService).DatabaseName.Add(DBName);
599 end;
600 end;
601
602 procedure SetupParams(IBService: TIBCustomService; UseDefaultSecDatabase: boolean; DBName: string);
603 var index: integer;
604 begin
605 with IBService do
606 begin
607 Active := false;
608 {Use database login user name and password}
609 Params.Values['user_name'] := FDBUserName;
610 Params.Values['password'] := FDBPassword;
611 Params.Values['sql_role_name'] := 'RDB$ADMIN';
612
613 if FProtocol <> unknownProtocol then
614 Protocol := FProtocol
615 else
616 Protocol := Local;
617 PortNo := FPortNo;
618 if Protocol = Local then
619 begin
620 {If Local we must specify the server as the Localhost}
621 ServerName := 'Localhost';
622 if AttmtQuery.Active then
623 begin
624 if not AttmtQuery.FieldByName('MON$REMOTE_PROTOCOL').IsNull then
625 Protocol := TCP; {Use loopback if database does not use embedded server}
626 end
627 else {Special case - database not open}
628 if not FileExists(DBName) or FileIsReadOnly(DBName) then
629 Protocol := TCP; {Use loopback if database does not use embedded server}
630 end
631 else
632 ServerName := FServername;
633 end;
634 AssignDatabase(IBService,DBName);
635
636 {Are we using a different security database?}
637
638 if not UseDefaultSecDatabase then
639 IBService.Params.Values['expected_db'] := DBName
640 else
641 begin
642 index := IBService.Params.IndexOfName('expected_db');
643 if index <> -1 then IBService.Params.Delete(index);
644 end;
645 end;
646
647 var SecPlugin: TField;
648 UsingDefaultSecDatabase: boolean;
649 begin
650 {Are we using a different security database?}
651
652 SecPlugin := DatabaseQuery.FindField('MON$SEC_DATABASE');
653 UsingDefaultSecDatabase := (SecPlugin = nil) or (Trim(SecPlugin.AsString) = 'Default');
654
655 {The server properties service is the base service holding the service interface}
656 if not IBServerProperties1.Active then
657 begin
658 SetupParams(IBServerProperties1,UsingDefaultSecDatabase,
659 {note that on a local server, the following always gives us the actual path}
660 GetDatabaseName);
661 with IBServerProperties1 do
662 begin
663 LoginPrompt := (Protocol <> Local) and (FDBPassword = ''); {Does this ever occur?}
664 repeat
665 try
666 Active := true;
667 LoginPrompt := false;
668 except
669 on E:EIBClientError do {Typically Login cancelled}
670 begin
671 MessageDlg(E.Message,mtError,[mbOK],0);
672 Exit;
673 end;
674 on E:Exception do
675 begin
676 MessageDlg(E.Message,mtError,[mbOK],0);
677 LoginPrompt := true;
678 end;
679 end;
680 until Active;
681 end;
682 end;
683
684 if aService = IBServerProperties1 then
685 Exit;
686
687 aService.Assign(IBServerProperties1);
688 AssignDatabase(aService,FDatabasePathName);
689 end;
690
691 function TDatabaseData.GetAuthMethod: string;
692 var AuthMeth: TField;
693 begin
694 AuthMeth := AttmtQuery.FindField('MON$AUTH_METHOD');
695 if AuthMeth = nil then
696 Result := 'Legacy_auth'
697 else
698 Result := AuthMeth.AsString;
699 end;
700
701 procedure TDatabaseData.SetNoReserve(AValue: boolean);
702 begin
703 ActivateService(IBConfigService1);
704 IBConfigService1.SetReserveSpace(AValue);
705 while IBConfigService1.IsServiceRunning do;
706 end;
707
708 procedure TDatabaseData.SetPageBuffers(AValue: integer);
709 begin
710 ActivateService(IBConfigService1);
711 IBDatabase1.Connected := false;
712 try
713 IBConfigService1.SetPageBuffers(AValue);
714 while IBConfigService1.IsServiceRunning do;
715 finally
716 IBDatabase1.Connected := true;
717 end;
718 end;
719
720 procedure TDatabaseData.SetSweepInterval(AValue: integer);
721 begin
722 ActivateService(IBConfigService1);
723 IBDatabase1.Connected := false;
724 try
725 IBConfigService1.SetSweepInterval(AValue);
726 while IBConfigService1.IsServiceRunning do;
727 finally
728 IBDatabase1.Connected := true;
729 end;
730 end;
731
732 procedure TDatabaseData.ReloadData(Data: PtrInt);
733 begin
734 if csDestroying in ComponentState then Exit;
735 CurrentTransaction.Active := true;
736 DataBaseQuery.Active := true;
737 AttmtQuery.Active := true;
738 if assigned(FAfterDataReload) then
739 AfterDataReload(self);
740 if LegacyUserList.Active then
741 RoleNameList.Active := true;
742 end;
743
744 destructor TDatabaseData.Destroy;
745 begin
746 Application.RemoveAsyncCalls(self);
747 inherited Destroy;
748 end;
749
750 procedure TDatabaseData.Connect;
751
752 procedure ReportException(E: Exception);
753 begin
754 MessageDlg(E.Message,mtError,[mbOK],0);
755 FDBPassword := '';
756 end;
757
758 procedure KillShadows;
759 begin
760 ActivateService(IBValidationService1);
761 with IBValidationService1 do
762 begin
763 Options := [IBServices.KillShadows];
764 try
765 try
766 ServiceStart;
767 except end;
768 While not Eof do
769 GetNextLine;
770 finally
771 while IsServiceRunning do;
772 end;
773 MessageDlg('All Unavailable Shadows killed',mtInformation,[mbOK],0);
774 end;
775 end;
776
777 begin
778 Disconnect;
779 repeat
780 try
781 IBDatabase1.Connected := true;
782 except
783 on E:EIBClientError do
784 begin
785 Exit
786 end;
787 On E: EIBInterBaseError do
788 begin
789 if E.IBErrorCode = isc_io_error then
790 begin
791 FDBPassword := '';
792 if MessageDlg('I/O Error reported on database file. If this is a shadow file, do you want '+
793 'to kill all unavailable shadow sets?. The original message is ' + E.Message,
794 mtInformation,[mbYes,mbNo],0) = mrYes then
795 try KillShadows except end
796 else
797 continue;
798 end
799 else
800 ReportException(E);
801 end;
802 On E:Exception do
803 ReportException(E);
804 end;
805 until IBDatabase1.Connected;
806
807 if assigned(FAfterDBConnect) then
808 AfterDBConnect(self);
809 end;
810
811 procedure TDatabaseData.Disconnect;
812 begin
813 FDBUserName := '';
814 FDBPassword := '';
815 FLocalConnect := false;
816 IBDatabase1.Connected := false;
817 IBConfigService1.Active := false;
818 IBStatisticalService1.Active := false;
819 IBServerProperties1.Active := false;
820 IBValidationService1.Active := false;
821 IBLogService1.Active := false;
822 IBSecurityService1.Active := false;
823 end;
824
825 procedure TDatabaseData.DropDatabase;
826 begin
827 IBDatabase1.DropDatabase;
828 Disconnect;
829 end;
830
831 procedure TDatabaseData.BackupDatabase;
832 begin
833 with BackupDlg do
834 begin
835 ActivateService(IBBackupService1);
836 ShowModal;
837 end;
838 end;
839
840 procedure TDatabaseData.RestoreDatabase;
841 var DefaultPageSize: integer;
842 DefaultNumBuffers: integer;
843 begin
844 DefaultPageSize := DatabaseQuery.FieldByName('MON$PAGE_SIZE').AsInteger;
845 DefaultNumBuffers := DatabaseQuery.FieldByName('MON$PAGE_BUFFERS').AsInteger;
846 ActivateService(RestoreDlg.IBRestoreService1);
847 IBDatabase1.Connected := false;
848 try
849 RestoreDlg.ShowModal(DefaultPageSize,DefaultNumBuffers);
850 finally
851 IBDatabase1.Connected := true;
852 end;
853 end;
854
855 procedure TDatabaseData.BringDatabaseOnline;
856 begin
857 if IsDatabaseOnline then
858 MessageDlg('Database is already online!',mtInformation,[mbOK],0)
859 else
860 begin
861 ActivateService(IBConfigService1);
862 IBDatabase1.Connected := false;
863 try
864 IBConfigService1.BringDatabaseOnline;
865 while IBConfigService1.IsServiceRunning do;
866 finally
867 IBDatabase1.Connected := true;
868 end;
869 if IsDatabaseOnline then
870 MessageDlg('Database is back online',mtInformation,[mbOK],0)
871 else
872 MessageDlg('Database is still shutdown!',mtError,[mbOK],0);
873 end;
874 end;
875
876 procedure TDatabaseData.ShutDown(aShutDownmode: TShutdownMode; aDelay: integer);
877 begin
878 ActivateService(IBConfigService1);
879 IBDatabase1.Connected := false;
880 try
881 ShutdownDatabaseDlg.Shutdown(IBConfigService1, aShutDownmode, aDelay);
882 finally
883 IBDatabase1.Connected := true;
884 end;
885 end;
886
887 procedure TDatabaseData.DatabaseRepair(Options: TValidateOptions; ReportLines: TStrings);
888
889 procedure ReportOptions;
890 var Line: string;
891 begin
892 Line := 'With Options: [';
893 if (ValidateDB in Options) then Line += 'ValidateDB ';
894 if (SweepDB in Options) then Line += 'SweepDB ';
895 if (KillShadows in Options) then Line += 'KillShadows ';
896 if (ValidateFull in Options) then Line += 'ValidateFull ';
897 if (CheckDB in Options) then Line += 'CheckDB ';
898 if (IgnoreChecksum in Options) then Line +='IgnoreChecksum ';
899 if (MendDB in Options) then Line +='MendDB ';
900 Line +=']';
901 ReportLines.Add(Line);
902 end;
903
904 begin
905 ActivateService(IBValidationService1);
906 ReportLines.Add(Format('Validation of %s started',[IBValidationService1.DatabaseName]));
907 ReportOptions;
908 IBDatabase1.Connected := false;
909 with IBValidationService1 do
910 try
911 try
912 ServiceStart;
913 while not Eof do
914 begin
915 Application.ProcessMessages;
916 ReportLines.Add(GetNextLine);
917 end;
918 finally
919 while IsServiceRunning do;
920 end;
921 ReportLines.Add('Operation Completed');
922 MessageDlg('Operation Completed',mtInformation,[mbOK],0);
923 finally
924 IBDatabase1.Connected := true;
925 end;
926 end;
927
928 procedure TDatabaseData.OnlineValidation(ReportLines: TStrings;
929 SelectedTablesOnly: boolean);
930 var TableNames: string;
931 Separator: string;
932 begin
933 if IBDatabaseInfo.ODSMajorVersion < 12 then
934 raise Exception.Create('Online Validation is not supported');
935 ActivateService(IBOnlineValidationService1);
936 with IBOnlineValidationService1 do
937 begin
938 if SelectedTablesOnly then
939 begin
940 TableNames := '';
941 with DBTables do
942 if Active then
943 begin
944 DisableControls;
945 try
946 Separator := '';
947 First;
948 while not EOF do
949 begin
950 if FieldByName('Selected').AsInteger <> 0 then
951 begin
952 TableNames += Separator + FieldByName('RDB$RELATION_NAME').AsString;
953 Separator := '|';
954 end;
955 Next;
956 end;
957 finally
958 EnableControls;
959 end;
960 end;
961 IncludeTables := TableNames;
962 end
963 else
964 IncludeTables := '';
965 ReportLines.Add(Format('Online Validation of %s started',[IBOnlineValidationService1.DatabaseName]));
966 try
967 ServiceStart;
968 while not Eof do
969 begin
970 Application.ProcessMessages;
971 ReportLines.Add(GetNextLine);
972 end;
973 finally
974 while IsServiceRunning do;
975 end;
976 ReportLines.Add('Online Validation Completed');
977 MessageDlg('Online Validation Completed',mtInformation,[mbOK],0);
978 end;
979 end;
980
981 procedure TDatabaseData.LimboResolution(ActionID: TTransactionGlobalAction;
982 Report: TStrings);
983 begin
984 if not InLimboList.Active then
985 raise Exception.Create('Limbo Transactions List not available');
986
987 with InLimboList do
988 if State = dsEdit then Post;
989 Report.Clear;
990 ActivateService(IBValidationService1);
991 with IBValidationService1 do
992 begin
993 GlobalAction := ActionID;
994 Report.Add('Starting Limbo transaction resolution');
995 FixLimboTransactionErrors;
996 while not Eof do
997 begin
998 Application.ProcessMessages;
999 Report.Add(GetNextLine);
1000 end;
1001 Report.Add('Limbo Transaction resolution complete');
1002 CurrentTransaction.Commit;
1003 InLimboList.Active := false;
1004 InLimboList.Active := true;
1005 end;
1006 end;
1007
1008 function TDatabaseData.GetLingerDelay: string;
1009 var Linger: TField;
1010 begin
1011 Result := 'n/a';
1012 if not DatabaseQuery.Active then exit;
1013 Linger := DatabaseQuery.FindField('RDB$LINGER');
1014 if Linger <> nil then
1015 begin
1016 if Linger.IsNull then
1017 Result := '0'
1018 else
1019 Result := Linger.AsString;
1020 end;
1021 end;
1022
1023 function TDatabaseData.GetNoReserve: boolean;
1024 begin
1025 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$RESERVE_SPACE').AsInteger <> 0);
1026 end;
1027
1028 function TDatabaseData.GetPageBuffers: integer;
1029 begin
1030 Result := IBDatabaseInfo.NumBuffers;
1031 end;
1032
1033 function TDatabaseData.GetRoleName: string;
1034 begin
1035 Result := Trim(AttmtQuery.FieldByName('MON$ROLE').AsString);
1036 end;
1037
1038 function TDatabaseData.GetSecurityDatabase: string;
1039 var SecPlugin: TField;
1040 begin
1041 SecPlugin := DatabaseQuery.FindField('MON$SEC_DATABASE');
1042 if SecPlugin = nil then
1043 Result := 'Legacy'
1044 else
1045 Result := Trim(SecPlugin.AsString);
1046 end;
1047
1048 function TDatabaseData.GetSweepInterval: integer;
1049 begin
1050 if DatabaseQuery.Active then
1051 Result := DatabaseQuery.FieldByName('MON$SWEEP_INTERVAL').AsInteger
1052 else
1053 Result := 0;
1054 end;
1055
1056 function TDatabaseData.GetUserAdminPrivilege: boolean;
1057 begin
1058 Result := false;
1059 {For ODS 12 use SEC$USERS table}
1060 if IBDatabaseInfo.ODSMajorVersion >= 12 then
1061 with AdminUserQuery do
1062 begin
1063 ExecQuery;
1064 try
1065 Result := not EOF and FieldByName('SEC$ADMIN').AsBoolean;
1066 finally
1067 Close;
1068 end;
1069 end
1070 {if need to know for ODS 11.2 then will have to use Service API}
1071 else
1072 begin
1073 ActivateService(IBSecurityService1);
1074 with IBSecurityService1 do
1075 begin
1076 DisplayUser(DBUserName);
1077 Result := (UserInfoCount > 0) and UserInfo[0].AdminRole;
1078 end;
1079 end;
1080 end;
1081
1082 procedure TDatabaseData.SetAutoAdmin(AValue: boolean);
1083 begin
1084 ActivateService(IBConfigService1);
1085 IBConfigService1.SetAutoAdmin(AValue);
1086 while IBConfigService1.IsServiceRunning do;
1087 CurrentTransaction.Commit;
1088 end;
1089
1090 procedure TDatabaseData.SetDBReadOnly(AValue: boolean);
1091 begin
1092 ActivateService(IBConfigService1);
1093 IBDatabase1.Connected := false;
1094 try
1095 IBConfigService1.SetReadOnly(AValue);
1096 while IBConfigService1.IsServiceRunning do;
1097 finally
1098 IBDatabase1.Connected := true;
1099 end;
1100 end;
1101
1102 procedure TDatabaseData.SetDBSQLDialect(AValue: integer);
1103 begin
1104 ActivateService(IBConfigService1);
1105 IBDatabase1.Connected := false;
1106 try
1107 IBConfigService1.SetDBSqlDialect(AValue);
1108 while IBConfigService1.IsServiceRunning do;
1109 finally
1110 IBDatabase1.Connected := true;
1111 end;
1112 end;
1113
1114 procedure TDatabaseData.SetForcedWrites(AValue: boolean);
1115 begin
1116 ActivateService(IBConfigService1);
1117 IBConfigService1.SetAsyncMode(not AValue);
1118 while IBConfigService1.IsServiceRunning do;
1119 end;
1120
1121 function TDatabaseData.IsDatabaseOnline: boolean;
1122 begin
1123 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$SHUTDOWN_MODE').AsInteger = 0);
1124 end;
1125
1126 function TDatabaseData.IsShadowDatabase: boolean;
1127 begin
1128 GetDBFlags;
1129 Result := FIsShadowDatabase;
1130 end;
1131
1132 procedure TDatabaseData.ActivateShadow;
1133 begin
1134 ActivateService(IBConfigService1);
1135 IBConfigService1.ActivateShadow;
1136 while IBConfigService1.IsServiceRunning do;
1137 MessageDlg('Shadow Database activated. You should now rename the file or change the database alias name to point to the shadow',
1138 mtInformation,[mbOK],0);
1139 end;
1140
1141 procedure TDatabaseData.AddSecondaryFile(aFileName: string; StartAt,
1142 FileLength: integer);
1143 var SQLText: string;
1144 begin
1145 if FileLength <> -1 then
1146 SQLText := Format(sAddSecondarySQL2,[aFileName,StartAt,FileLength])
1147 else
1148 SQLText := Format(sAddSecondarySQL,[aFileName,StartAt]);
1149 ExecDDL.SQL.Text := SQLText;
1150 ExecDDL.ExecQuery;
1151 CurrentTransaction.Commit;
1152 end;
1153
1154 procedure TDatabaseData.AddShadowSet;
1155 var CurrentLocation: TBookmark;
1156 ShadowSet: integer;
1157 begin
1158 if ShadowFiles.RecordCount = 0 then
1159 ShadowSet := 1
1160 else
1161 with ShadowFiles do
1162 begin
1163 CurrentLocation := Bookmark;
1164 DisableControls;
1165 try
1166 Last;
1167 ShadowSet := FieldByName('RDB$Shadow_Number').AsInteger + 1;
1168 finally
1169 Bookmark := CurrentLocation;
1170 EnableControls
1171 end
1172 end;
1173 AddShadowSetDlg.ShowModal(ShadowSet);
1174 CurrentTransaction.Active := true;
1175 end;
1176
1177 procedure TDatabaseData.RemoveShadowSet(ShadowSet: integer);
1178 begin
1179 if IBDatabaseInfo.ODSMajorVersion < 12 then
1180 begin
1181 if MessageDlg(Format(sRemoveShadow,[ShadowSet]),mtConfirmation,[mbYes,mbNo],0) = mrYes then
1182 ExecDDL.SQL.Text := Format(sRemoveShadow,[ShadowSet]);
1183 end
1184 else
1185 case MessageDlg(Format(sPreserveShadowFiles,[ShadowSet]),mtConfirmation,[mbYes,mbNo,mbCancel],0) of
1186 mrNo:
1187 ExecDDL.SQL.Text :=Format(sRemoveShadow12,[ShadowSet]);
1188 mrYes:
1189 ExecDDL.SQL.Text := Format(sPreserveShadow,[ShadowSet]);
1190 mrCancel:
1191 Exit;
1192 end;
1193 ExecDDL.ExecQuery;
1194 CurrentTransaction.Commit;
1195 end;
1196
1197 procedure TDatabaseData.LoadPerformanceStatistics(Lines: TStrings);
1198
1199 procedure AddPerfStats(Heading: string; stats: TStrings);
1200 var i: integer;
1201 begin
1202 with Lines do
1203 begin
1204 if stats.count = 0 then exit;
1205 Add('');
1206 Add(Heading);
1207 for i := 0 to stats.Count - 1 do
1208 begin
1209 if TableNameLookup.Locate('RDB$RELATION_ID',stats.Names[i],[]) then
1210 Add(' ' + TableNameLookup.FieldByName('RDB$RELATION_NAME').AsString + ' = ' + stats.ValueFromIndex[i]);
1211 end;
1212 end;
1213 end;
1214
1215 begin
1216 TableNameLookup.Active := true;
1217 with IBDatabaseInfo, Lines do
1218 begin
1219 Add(Format('Number of reads from the memory buffer cache = %d',[Fetches]));
1220 Add(Format('Number of writes to the memory buffer cache = %d',[Marks]));
1221 Add(Format('Number of page reads = %d',[Reads]));
1222 Add(Format('Number of page writes = %d',[Writes]));
1223 Add('');
1224 Add('Since Database last attached:');
1225 AddPerfStats('Number of removals of a version of a record',BackoutCount);
1226 AddPerfStats('Number of database deletes',DeleteCount);
1227 AddPerfStats('Number of removals of a committed record',ExpungeCount);
1228 AddPerfStats('Number of inserts',InsertCount);
1229 AddPerfStats('Number of removals of old versions of fully mature records',PurgeCount);
1230 AddPerfStats('Number of reads done via an index',ReadIdxCount);
1231 AddPerfStats('Number of sequential table scans',ReadSeqCount);
1232 AddPerfStats('Number of database updates',UpdateCount);
1233 end;
1234 end;
1235
1236 procedure TDatabaseData.LoadDatabaseStatistics(OptionID: integer; Lines: TStrings);
1237 begin
1238 ActivateService(IBStatisticalService1);
1239 if OptionID = 1 then
1240 LoadPerformanceStatistics(Lines)
1241 else
1242 with IBStatisticalService1 do
1243 begin
1244 case OptionID of
1245 0: Options := [HeaderPages];
1246 2: options := [DataPages];
1247 3: Options := [IndexPages];
1248 4: Options := [SystemRelations]
1249 end;
1250 Active := true;
1251 ServiceStart;
1252 while not Eof do
1253 Lines.Add(GetNextLine);
1254 end;
1255 end;
1256
1257 procedure TDatabaseData.LoadServerProperties(Lines: TStrings);
1258 var i: integer;
1259 begin
1260 Lines.Clear;
1261 ActivateService(IBServerProperties1);
1262 with IBServerProperties1 do
1263 begin
1264 FetchVersionInfo;
1265 Lines.Add('Server Version = ' + VersionInfo.ServerVersion);
1266 Lines.Add('Server Implementation = ' + VersionInfo.ServerImplementation);
1267 Lines.Add('Service Version = ' + IntToStr(VersionInfo.ServiceVersion));
1268 Lines.Add(Format('Firebird Release = %d.%d.%d (Build no. %d)',[ServerVersionNo[1],
1269 ServerVersionNo[2],
1270 ServerVersionNo[3],
1271 ServerVersionNo[4]]));
1272 FetchDatabaseInfo;
1273 Lines.Add('No. of attachments = ' + IntToStr(DatabaseInfo.NoOfAttachments));
1274 Lines.Add('No. of databases = ' + IntToStr(DatabaseInfo.NoOfDatabases));
1275 for i := 0 to DatabaseInfo.NoOfDatabases - 1 do
1276 Lines.Add(Format('DB Name (%d) = %s',[i+1, DatabaseInfo.DbName[i]]));
1277 FetchConfigParams;
1278 Lines.Add('Base Location = ' + ConfigParams.BaseLocation);
1279 Lines.Add('Lock File Location = ' + ConfigParams.LockFileLocation);
1280 Lines.Add('Security Database Location = ' + ConfigParams.SecurityDatabaseLocation);
1281 Lines.Add('Message File Location = ' + ConfigParams.MessageFileLocation);
1282 end;
1283 end;
1284
1285 procedure TDatabaseData.LoadServerLog(Lines: TStrings);
1286 begin
1287 Lines.Clear;
1288 ActivateService(IBLogService1);
1289 if IBLogService1.Protocol = Local then
1290 Lines.Add('Server Log not available with embedded server')
1291 else
1292 with IBLogService1 do
1293 begin
1294 ServiceStart;
1295 while not Eof do
1296 Lines.Add(GetNextLine);
1297 end;
1298 end;
1299
1300 procedure TDatabaseData.RevokeAll;
1301 begin
1302 with SubjectAccessRights do
1303 if Active then
1304 begin
1305 DisableControls;
1306 try
1307 First;
1308 while not EOF do
1309 begin
1310 if FieldByName('OBJECT_TYPE').AsInteger = 0 {relation} then
1311 ExecDDL.SQL.Text := Format('Revoke All on %s from %s',[
1312 Trim(FieldByName('OBJECT_NAME').AsString),
1313 Trim(FieldByName('SUBJECT_NAME').AsString)])
1314 else
1315 if FieldByName('OBJECT_TYPE').AsInteger = 13 {role} then
1316 ExecDDL.SQL.Text := Format('Revoke %s from %s',[
1317 Trim(FieldByName('OBJECT_NAME').AsString),
1318 Trim(FieldByName('SUBJECT_NAME').AsString)])
1319 else
1320 ExecDDL.SQL.Text := Format('Revoke All on %s %s from %s',[
1321 Trim(FieldByName('OBJECT_TYPE_NAME').AsString),
1322 Trim(FieldByName('OBJECT_NAME').AsString),
1323 Trim(FieldByName('SUBJECT_NAME').AsString)]);
1324 ExecDDL.ExecQuery;
1325 Next;
1326 end;
1327 finally
1328 EnableControls;
1329 end;
1330 CurrentTransaction.Commit;
1331 end;
1332 end;
1333
1334 procedure TDatabaseData.SyncSubjectAccessRights(ID: string);
1335 begin
1336 if (FSubjectAccessRightsID = ID) and SubjectAccessRights.Active then Exit;
1337 SubjectAccessRights.Active := false;
1338 FSubjectAccessRightsID := ID;
1339 SubjectAccessRights.Active := true;
1340 end;
1341
1342 procedure TDatabaseData.IBDatabase1Login(Database: TIBDatabase;
1343 LoginParams: TStrings);
1344 var aDatabaseName: string;
1345 aUserName: string;
1346 aPassword: string;
1347 aCreateIfNotExist: boolean;
1348 begin
1349 if FLocalConnect or (FDBPassword <> '') {reconnect} then
1350 begin
1351 LoginParams.Values['user_name'] := FDBUserName;
1352 LoginParams.Values['password'] := FDBPassword;
1353 exit;
1354 end;
1355
1356 aDatabaseName := Database.DatabaseName;
1357 aUserName := LoginParams.Values['user_name'];
1358 aPassword := '';
1359 aCreateIfNotExist := false;
1360 if DBLoginDlg.ShowModal(aDatabaseName, aUserName, aPassword, aCreateIfNotExist) = mrOK then
1361 begin
1362 FDBPassword := aPassword; {remember for reconnect}
1363 Database.DatabaseName := aDatabaseName;
1364 LoginParams.Values['user_name'] := aUserName;
1365 LoginParams.Values['password'] := aPassword;
1366 FDBUserName := aUserName;
1367 FDBPassword := aPassword;
1368 Database.CreateIfNotExists := aCreateIfNotExist;
1369 ParseConnectString(aDatabaseName,FServerName,FDatabasePathName,FProtocol,FPortNo);
1370 end
1371 else
1372 IBError(ibxeOperationCancelled, [nil]);
1373 end;
1374
1375 procedure TDatabaseData.AttUpdateApplyUpdates(Sender: TObject;
1376 UpdateKind: TUpdateKind; Params: ISQLParams);
1377 begin
1378 if UpdateKind = ukDelete then
1379 begin
1380 ExecDDL.SQL.Text := 'Delete from MON$ATTACHMENTS Where MON$ATTACHMENT_ID =' +
1381 Params.ByName('MON$ATTACHMENT_ID').Asstring;
1382 ExecDDL.ExecQuery;
1383 end;
1384 end;
1385
1386 procedure TDatabaseData.DBTablesUpdateApplyUpdates(Sender: TObject;
1387 UpdateKind: TUpdateKind; Params: ISQLParams);
1388 begin
1389 // Do nothing
1390 end;
1391
1392 procedure TDatabaseData.InLimboListAfterOpen(DataSet: TDataSet);
1393
1394 function TypeToStr(MultiDatabase: boolean): string;
1395 begin
1396 if MultiDatabase then
1397 Result := 'Multi DB'
1398 else
1399 Result := 'Single DB';
1400 end;
1401
1402 function StateToStr(State: TTransactionState): string;
1403 begin
1404 case State of
1405 LimboState:
1406 Result := 'Limbo';
1407 CommitState:
1408 Result := 'Commit';
1409 RollbackState:
1410 Result := 'Rollback';
1411 else
1412 Result := 'Unknown';
1413 end;
1414 end;
1415
1416 function AdviseToStr(Advise: TTransactionAdvise): string;
1417 begin
1418 case Advise of
1419 CommitAdvise:
1420 Result := 'Commit';
1421 RollbackAdvise:
1422 Result := 'Rollback';
1423 else
1424 Result := 'Unknown';
1425 end;
1426 end;
1427
1428 function ActionToStr(anAction: IBServices.TTransactionAction): string;
1429 begin
1430 case anAction of
1431 CommitAction:
1432 Result := 'Commit';
1433 RollbackAction:
1434 Result := 'Rollback';
1435 end;
1436 end;
1437
1438 var i: integer;
1439 begin
1440 if FLoadingLimboTr then Exit;
1441 FLoadingLimboTr := true;
1442 with IBValidationService1 do
1443 try
1444 ActivateService(IBValidationService1);
1445 Options := [LimboTransactions];
1446 ServiceStart;
1447 FetchLimboTransactionInfo;
1448 for i := 0 to LimboTransactionInfoCount - 1 do
1449 with LimboTransactionInfo[i] do
1450 begin
1451 InLimboList.Append;
1452 InLimboList.FieldByName('TransactionID').AsInteger := ID;
1453 InLimboList.FieldByName('TransactionType').AsString := TypeToStr(MultiDatabase);
1454 InLimboList.FieldByName('HostSite').AsString := HostSite;
1455 InLimboList.FieldByName('RemoteSite').AsString := RemoteSite;
1456 InLimboList.FieldByName('DatabasePath').AsString := RemoteDatabasePath;
1457 InLimboList.FieldByName('State').AsString := StateToStr(State);
1458 InLimboList.FieldByName('RecommendedAction').AsString := AdviseToStr(Advise);
1459 InLimboList.FieldByName('RequestedAction').AsString := ActionToStr(Action);
1460 InLimboList.Post;
1461 end;
1462 finally
1463 FLoadingLimboTr := false;
1464 end;
1465 end;
1466
1467 procedure TDatabaseData.InLimboListBeforeClose(DataSet: TDataSet);
1468 begin
1469 InLimboList.Clear(false);
1470 end;
1471
1472 procedure TDatabaseData.InLimboListBeforePost(DataSet: TDataSet);
1473 var i: integer;
1474 begin
1475 if FLoadingLimboTr then Exit;
1476 with IBValidationService1 do
1477 for i := 0 to LimboTransactionInfoCount - 1 do
1478 with LimboTransactionInfo[i] do
1479 begin
1480 if ID = InLimboList.FieldByName('TransactionID').AsInteger then
1481 begin
1482 if InLimboList.FieldByName('RequestedAction').AsString = 'Commit' then
1483 Action := CommitAction
1484 else
1485 if InLimboList.FieldByName('RequestedAction').AsString = 'Rollback' then
1486 Action := RollbackAction;
1487 break;
1488 end;
1489 end;
1490 end;
1491
1492 procedure TDatabaseData.LegacyUserListAfterOpen(DataSet: TDataSet);
1493 var i: integer;
1494 begin
1495 ActivateService(IBSecurityService1);
1496 with IBSecurityService1 do
1497 begin
1498 DisplayUsers;
1499 FUsersLoading := true;
1500 try
1501 for i := 0 to UserInfoCount - 1 do
1502 with UserInfo[i],LegacyUserList do
1503 begin
1504 Append;
1505 FieldByName('UserID').AsInteger := UserID;
1506 FieldByName('GroupID').AsInteger := GroupID;
1507 FieldByName('UserName').AsString := Trim(UserName);
1508 FieldByName('SEC$FIRST_NAME').AsString := FirstName;
1509 FieldByName('SEC$MIDDLE_NAME').AsString := MiddleName;
1510 FieldByName('SEC$LAST_NAME').AsString := LastName;
1511 FieldByName('UserPassword').Clear;
1512 FieldByName('SEC$ADMIN').AsBoolean := AdminRole;
1513 Post;
1514 end;
1515 finally
1516 FUsersLoading := false;
1517 end;
1518 end;
1519 UserListSource.DataSet := LegacyUserList;
1520 CurrentTransaction.Active := true;
1521 RoleNameList.Active := true;
1522 end;
1523
1524 procedure TDatabaseData.LegacyUserListBeforeClose(DataSet: TDataSet);
1525 begin
1526 RoleNameList.Active := false;
1527 with LegacyUserList do
1528 begin
1529 if State in [dsEdit,dsInsert] then Post;
1530 Clear(false);
1531 end;
1532 end;
1533
1534 procedure TDatabaseData.LegacyUserListBeforeDelete(DataSet: TDataSet);
1535 begin
1536 ActivateService(IBSecurityService1);
1537 with IBSecurityService1 do
1538 begin
1539 UserName := DataSet.FieldByName('UserName').AsString;
1540 DeleteUser;
1541 while IsServiceRunning do;
1542 end;
1543 end;
1544
1545 procedure TDatabaseData.LegacyUserListBeforePost(DataSet: TDataSet);
1546
1547 procedure SetParams;
1548 begin
1549 with LegacyUserList, IBSecurityService1 do
1550 begin
1551 UserID := FieldByName('UserID').AsInteger;
1552 GroupID := FieldByName('GroupID').AsInteger;
1553 UserName := FieldByName('UserName').AsString;
1554 FirstName := FieldByName('SEC$FIRST_NAME').AsString;
1555 MiddleName := FieldByName('SEC$MIDDLE_NAME').AsString;
1556 LastName := FieldByName('SEC$LAST_NAME').AsString;
1557 if not FieldByName('UserPassword').IsNull then
1558 Password := FieldByName('UserPassword').AsString;
1559 AdminRole := FieldByName('SEC$ADMIN').AsBoolean;
1560 end;
1561 end;
1562
1563 begin
1564 if FUsersLoading then Exit;
1565 ActivateService(IBSecurityService1);
1566 case LegacyUserList.State of
1567 dsEdit:
1568 begin
1569 SetParams;
1570 IBSecurityService1.ModifyUser;
1571 end;
1572 dsInsert:
1573 begin
1574 SetParams;
1575 IBSecurityService1.AddUser;
1576 end;
1577 end;
1578 while IBSecurityService1.IsServiceRunning do;
1579 end;
1580
1581 procedure TDatabaseData.ShadowFilesCalcFields(DataSet: TDataSet);
1582 var Flags: integer;
1583 begin
1584 Flags := DataSet.FieldByName('RDB$FILE_FLAGS').AsInteger;
1585 if Flags and $10 <> 0 then
1586 DataSet.FieldByName('FileMode').AsString := 'C'
1587 else
1588 if Flags and $04 <> 0 then
1589 DataSet.FieldByName('FileMode').AsString := 'M'
1590 else
1591 if Flags and $01 <> 0 then
1592 if DataSet.FieldByName('RDB$FILE_SEQUENCE').AsInteger = 0 then
1593 DataSet.FieldByName('FileMode').AsString := 'A'
1594 else
1595 DataSet.FieldByName('FileMode').AsString := '+'
1596 else
1597 DataSet.FieldByName('FileMode').AsString := ''
1598 end;
1599
1600 procedure TDatabaseData.SubjectAccessRightsBeforeOpen(DataSet: TDataSet);
1601 begin
1602 SubjectAccessRights.ParamByName('ID').AsString := FSubjectAccessRightsID;
1603 end;
1604
1605 procedure TDatabaseData.TagsUpdateApplyUpdates(Sender: TObject;
1606 UpdateKind: TUpdateKind; Params: ISQLParams);
1607 var sql: string;
1608 begin
1609 sql := '';
1610 case UpdateKind of
1611 ukInsert,
1612 ukModify:
1613 begin
1614 sql := 'ALTER USER ' + Trim(Params.ByName('SEC$USER_NAME').AsString)
1615 + ' TAGS (' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('SEC$KEY').AsString)
1616 + '=''' + SQLSafeString(Params.ByName('SEC$VALUE').AsString) + '''';
1617 if Params.ByName('SEC$KEY').AsString <> Params.ByName('OLD_SEC$KEY').AsString then
1618 sql += ', DROP ' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('OLD_SEC$KEY').AsString);
1619 sql +=')'
1620 end;
1621
1622 ukDelete:
1623 sql := 'ALTER USER ' + Trim(Params.ByName('SEC$USER_NAME').AsString)
1624 + ' TAGS (DROP ' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('SEC$KEY').AsString) + ')';
1625 end;
1626 ExecDDL.SQL.Text := sql;
1627 ExecDDL.ExecQuery;
1628 end;
1629
1630 procedure TDatabaseData.IBDatabase1AfterConnect(Sender: TObject);
1631 begin
1632 {Virtual tables did not exist prior to Firebird 2.1 - so don't bother with old version}
1633 with IBDatabaseInfo do
1634 if (ODSMajorVersion < 11) or ((ODSMajorVersion = 11) and (ODSMinorVersion < 1)) then
1635 begin
1636 IBDatabase1.Connected := false;
1637 raise Exception.Create('This application requires Firebird 2.1 or later');
1638 end
1639 else
1640 if ODSMajorVersion < 12 then
1641 {Don't expect to be able to find these fields}
1642 begin
1643 AttachmentsMONCLIENT_VERSION.FieldKind := fkCalculated;
1644 AttachmentsMONREMOTE_VERSION.FieldKind := fkCalculated;
1645 AttachmentsMONREMOTE_HOST.FieldKind := fkCalculated;
1646 AttachmentsMONREMOTE_OS_USER.FieldKind := fkCalculated;
1647 AttachmentsMONAUTH_METHOD.FieldKind := fkCalculated;
1648 AttachmentsMONSYSTEM_FLAG.FieldKind := fkCalculated;
1649 AttachmentsRDBSECURITY_CLASS.FieldKind := fkCalculated;
1650 AttachmentsRDBOWNER_NAME.FieldKind := fkCalculated;
1651 end
1652 else
1653 begin
1654 AttachmentsMONCLIENT_VERSION.FieldKind := fkData;
1655 AttachmentsMONREMOTE_VERSION.FieldKind := fkData;
1656 AttachmentsMONREMOTE_HOST.FieldKind := fkData;
1657 AttachmentsMONREMOTE_OS_USER.FieldKind := fkData;
1658 AttachmentsMONAUTH_METHOD.FieldKind := fkData;
1659 AttachmentsMONSYSTEM_FLAG.FieldKind := fkData;
1660 AttachmentsRDBSECURITY_CLASS.FieldKind := fkData;
1661 AttachmentsRDBOWNER_NAME.FieldKind := fkData;
1662 end;
1663
1664 FLocalConnect := FProtocol = Local;
1665 ReloadData;
1666 end;
1667
1668 procedure TDatabaseData.IBDatabase1AfterDisconnect(Sender: TObject);
1669 begin
1670 FDisconnecting := false;
1671 end;
1672
1673 procedure TDatabaseData.IBDatabase1BeforeDisconnect(Sender: TObject);
1674 begin
1675 FDisconnecting := true;
1676 end;
1677
1678 procedure TDatabaseData.DatabaseQueryAfterOpen(DataSet: TDataSet);
1679 begin
1680 DBCharSet.Active := true;
1681 end;
1682
1683 procedure TDatabaseData.CurrentTransactionAfterTransactionEnd(Sender: TObject);
1684 begin
1685 if not Disconnecting and not (csDestroying in ComponentState) then
1686 Application.QueueAsyncCall(@ReloadData,0);
1687 end;
1688
1689 procedure TDatabaseData.ApplicationProperties1Exception(Sender: TObject;
1690 E: Exception);
1691 begin
1692 if E is EIBInterBaseError then
1693 begin
1694 if RoleNameList.State in [dsInsert,dsEdit] then
1695 RoleNameList.Cancel;
1696 if UserList.State in [dsInsert,dsEdit] then
1697 UserList.Cancel;
1698 end;
1699 MessageDlg(E.Message,mtError,[mbOK],0);
1700 if CurrentTransaction.Active then
1701 CurrentTransaction.Rollback;
1702 end;
1703
1704 procedure TDatabaseData.AccessRightsCalcFields(DataSet: TDataSet);
1705 begin
1706 AccessRightsDisplayName.AsString := AccessRightsSUBJECT_NAME.AsString;
1707 if AccessRightsSUBJECT_TYPE.AsInteger = 8 then
1708 begin
1709 if (AccessRightsSUBJECT_NAME.AsString <> 'PUBLIC') and UserListSource.DataSet.Active and
1710 not UserListSource.DataSet.Locate('USERNAME',AccessRightsSUBJECT_NAME.AsString,[]) then
1711 begin
1712 AccessRightsImageIndex.AsInteger := 4;
1713 AccessRightsDisplayName.AsString := AccessRightsSUBJECT_NAME.AsString + ' (stale)';
1714 end
1715 else
1716 AccessRightsImageIndex.AsInteger := -1
1717 end
1718 else
1719 AccessRightsImageIndex.AsInteger := -1;
1720 end;
1721
1722 procedure TDatabaseData.AttachmentsAfterDelete(DataSet: TDataSet);
1723 begin
1724 CurrentTransaction.Commit;
1725 end;
1726
1727 procedure TDatabaseData.AttachmentsAfterOpen(DataSet: TDataSet);
1728 begin
1729 Attachments.Locate('MON$ATTACHMENT_ID',AttmtQuery.FieldByName('MON$ATTACHMENT_ID').AsInteger,[]);
1730 end;
1731
1732 procedure TDatabaseData.AttachmentsBeforeOpen(DataSet: TDataSet);
1733 begin
1734 if IBDatabaseInfo.ODSMajorVersion >= 12 then
1735 (DataSet as TIBQuery).Parser.Add2WhereClause('r.MON$SYSTEM_FLAG = 0');
1736 end;
1737
1738 procedure TDatabaseData.DatabaseQueryBeforeClose(DataSet: TDataSet);
1739 begin
1740 DBCharSet.Active := false;
1741 end;
1742
1743 procedure TDatabaseData.DBCharSetAfterClose(DataSet: TDataSet);
1744 begin
1745 CharSetLookup.Active := false;
1746 end;
1747
1748 procedure TDatabaseData.DBCharSetBeforeOpen(DataSet: TDataSet);
1749 begin
1750 CharSetLookup.Active := true;
1751 end;
1752
1753 end.
1754