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