ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/DBAdmin/DataModule.pas
Revision: 210
Committed: Wed Mar 14 15:03:38 2018 UTC (2 years, 7 months ago) by tony
File size: 45111 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 IBValidationService1 do
663 begin
664 Options := [IBXServices.KillShadows];
665 Execute(nil);
666 MessageDlg('All Unavailable Shadows killed',mtInformation,[mbOK],0);
667 end;
668 end;
669
670 begin
671 Disconnect;
672 repeat
673 try
674 IBDatabase1.Connected := true;
675 except
676 on E:EIBClientError do
677 begin
678 Exit
679 end;
680 On E: EIBInterBaseError do
681 begin
682 if E.IBErrorCode = isc_io_error then
683 begin
684 FDBPassword := '';
685 if MessageDlg('I/O Error reported on database file. If this is a shadow file, do you want '+
686 'to kill all unavailable shadow sets?. The original message is ' + E.Message,
687 mtInformation,[mbYes,mbNo],0) = mrYes then
688 try KillShadows except end
689 else
690 continue;
691 end
692 else
693 ReportException(E);
694 end;
695 On E:Exception do
696 ReportException(E);
697 end;
698 until IBDatabase1.Connected;
699
700 if assigned(FAfterDBConnect) then
701 AfterDBConnect(self);
702 end;
703
704 procedure TDatabaseData.Disconnect;
705 begin
706 FDBUserName := '';
707 FDBPassword := '';
708 FLocalConnect := false;
709 IBDatabase1.Connected := false;
710 IBXServicesConnection1.Connected := false;
711 FDBHeaderScanned := false;
712 end;
713
714 procedure TDatabaseData.DropDatabase;
715 begin
716 IBDatabase1.DropDatabase;
717 Disconnect;
718 end;
719
720 procedure TDatabaseData.BackupDatabase;
721 begin
722 BackupDlg.ShowModal;
723 end;
724
725 procedure TDatabaseData.RestoreDatabase;
726 var DefaultPageSize: integer;
727 DefaultNumBuffers: integer;
728 begin
729 DefaultPageSize := DatabaseQuery.FieldByName('MON$PAGE_SIZE').AsInteger;
730 DefaultNumBuffers := DatabaseQuery.FieldByName('MON$PAGE_BUFFERS').AsInteger;
731 IBDatabase1.Connected := false;
732 try
733 RestoreDlg.ShowModal(DefaultPageSize,DefaultNumBuffers);
734 finally
735 IBDatabase1.Connected := true;
736 end;
737 end;
738
739 procedure TDatabaseData.BringDatabaseOnline;
740 begin
741 if IsDatabaseOnline then
742 MessageDlg('Database is already online!',mtInformation,[mbOK],0)
743 else
744 begin
745 IBDatabase1.Connected := false;
746 try
747 IBConfigService1.BringDatabaseOnline;
748 finally
749 IBDatabase1.Connected := true;
750 end;
751 if IsDatabaseOnline then
752 MessageDlg('Database is back online',mtInformation,[mbOK],0)
753 else
754 MessageDlg('Database is still shutdown!',mtError,[mbOK],0);
755 end;
756 end;
757
758 procedure TDatabaseData.ShutDown(aShutDownmode: TDBShutdownMode; aDelay: integer
759 );
760 begin
761 IBDatabase1.Connected := false;
762 try
763 ShutdownDatabaseDlg.Shutdown(DatabaseName, aShutDownmode, aDelay);
764 finally
765 IBDatabase1.Connected := true;
766 end;
767 end;
768
769 procedure TDatabaseData.DatabaseRepair(Options: TValidateOptions; ReportLines: TStrings);
770
771 procedure ReportOptions;
772 var Line: string;
773 begin
774 Line := 'With Options: [';
775 if (ValidateDB in Options) then Line += 'ValidateDB ';
776 if (SweepDB in Options) then Line += 'SweepDB ';
777 if (KillShadows in Options) then Line += 'KillShadows ';
778 if (ValidateFull in Options) then Line += 'ValidateFull ';
779 if (CheckDB in Options) then Line += 'CheckDB ';
780 if (IgnoreChecksum in Options) then Line +='IgnoreChecksum ';
781 if (MendDB in Options) then Line +='MendDB ';
782 Line +=']';
783 ReportLines.Add(Line);
784 end;
785
786 begin
787 ReportLines.Add(Format('Validation of %s started',[IBValidationService1.DatabaseName]));
788 ReportOptions;
789 IBDatabase1.Connected := false;
790 with IBValidationService1 do
791 try
792 Execute(ReportLines);
793 ReportLines.Add('Operation Completed');
794 MessageDlg('Operation Completed',mtInformation,[mbOK],0);
795 finally
796 IBDatabase1.Connected := true;
797 end;
798 end;
799
800 procedure TDatabaseData.OnlineValidation(ReportLines: TStrings;
801 SelectedTablesOnly: boolean);
802 var TableNames: string;
803 Separator: string;
804 begin
805 if IBDatabaseInfo.ODSMajorVersion < 12 then
806 raise Exception.Create('Online Validation is not supported');
807 with IBOnlineValidationService1 do
808 begin
809 if SelectedTablesOnly then
810 begin
811 TableNames := '';
812 with DBTables do
813 if Active then
814 begin
815 DisableControls;
816 try
817 Separator := '';
818 First;
819 while not EOF do
820 begin
821 if FieldByName('Selected').AsInteger <> 0 then
822 begin
823 TableNames += Separator + FieldByName('RDB$RELATION_NAME').AsString;
824 Separator := '|';
825 end;
826 Next;
827 end;
828 finally
829 EnableControls;
830 end;
831 end;
832 IncludeTables := TableNames;
833 end
834 else
835 IncludeTables := '';
836 ReportLines.Add(Format('Online Validation of %s started',[IBOnlineValidationService1.DatabaseName]));
837 Execute(ReportLines);
838 ReportLines.Add('Online Validation Completed');
839 MessageDlg('Online Validation Completed',mtInformation,[mbOK],0);
840 end;
841 end;
842
843 procedure TDatabaseData.LimboResolution(ActionID: TTransactionGlobalAction;
844 Report: TStrings);
845 begin
846 if not InLimboList.Active then
847 raise Exception.Create('Limbo Transactions List not available');
848
849 with InLimboList do
850 if State = dsEdit then Post;
851 Report.Clear;
852 Report.Add('Starting Limbo transaction resolution');
853 InLimboList.FixErrors(ActionID,Report);
854 Report.Add('Limbo Transaction resolution complete');
855 CurrentTransaction.Commit;
856 end;
857
858 function TDatabaseData.GetLingerDelay: string;
859 var Linger: TField;
860 begin
861 Result := 'n/a';
862 if not DatabaseQuery.Active then exit;
863 Linger := DatabaseQuery.FindField('RDB$LINGER');
864 if Linger <> nil then
865 begin
866 if Linger.IsNull then
867 Result := '0'
868 else
869 Result := Linger.AsString;
870 end;
871 end;
872
873 function TDatabaseData.GetNoReserve: boolean;
874 begin
875 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$RESERVE_SPACE').AsInteger <> 0);
876 end;
877
878 function TDatabaseData.GetPageBuffers: integer;
879 begin
880 Result := IBDatabaseInfo.NumBuffers;
881 end;
882
883 function TDatabaseData.GetRoleName: string;
884 begin
885 Result := Trim(AttmtQuery.FieldByName('MON$ROLE').AsString);
886 end;
887
888 function TDatabaseData.GetSecurityDatabase: string;
889 var SecPlugin: TField;
890 begin
891 SecPlugin := DatabaseQuery.FindField('MON$SEC_DATABASE');
892 if SecPlugin = nil then
893 Result := 'Legacy'
894 else
895 Result := Trim(SecPlugin.AsString);
896 end;
897
898 function TDatabaseData.GetSweepInterval: integer;
899 begin
900 if DatabaseQuery.Active then
901 Result := DatabaseQuery.FieldByName('MON$SWEEP_INTERVAL').AsInteger
902 else
903 Result := 0;
904 end;
905
906 function TDatabaseData.GetUserAdminPrivilege: boolean;
907 begin
908 Result := false;
909 {For ODS 12 use SEC$USERS table}
910 if IBDatabaseInfo.ODSMajorVersion >= 12 then
911 with AdminUserQuery do
912 begin
913 ExecQuery;
914 try
915 Result := not EOF and FieldByName('SEC$ADMIN').AsBoolean;
916 finally
917 Close;
918 end;
919 end
920 {if need to know for ODS 11.2 then will have to use Service API}
921 else
922 begin
923 with IBSecurityService1 do
924 begin
925 DisplayUser(DBUserName);
926 Result := (UserInfoCount > 0) and UserInfo[0].AdminRole;
927 end;
928 end;
929 end;
930
931 procedure TDatabaseData.SetAutoAdmin(AValue: boolean);
932 begin
933 IBSecurityService1.SetAutoAdmin(AValue);
934 CurrentTransaction.Commit;
935 end;
936
937 procedure TDatabaseData.SetDBReadOnly(AValue: boolean);
938 begin
939 IBDatabase1.Connected := false;
940 try
941 IBConfigService1.SetReadOnly(AValue);
942 finally
943 IBDatabase1.Connected := true;
944 end;
945 end;
946
947 procedure TDatabaseData.SetDBSQLDialect(AValue: integer);
948 begin
949 IBDatabase1.Connected := false;
950 try
951 IBConfigService1.SetDBSqlDialect(AValue);
952 finally
953 IBDatabase1.Connected := true;
954 end;
955 end;
956
957 procedure TDatabaseData.SetForcedWrites(AValue: boolean);
958 begin
959 IBConfigService1.SetAsyncMode(not AValue);
960 end;
961
962 function TDatabaseData.IsDatabaseOnline: boolean;
963 begin
964 Result := DatabaseQuery.Active and (DatabaseQuery.FieldByName('MON$SHUTDOWN_MODE').AsInteger = 0);
965 end;
966
967 function TDatabaseData.IsShadowDatabase: boolean;
968 begin
969 GetDBFlags;
970 Result := FIsShadowDatabase;
971 end;
972
973 procedure TDatabaseData.ActivateShadow;
974 begin
975 IBConfigService1.ActivateShadow;
976 MessageDlg('Shadow Database activated. You should now rename the file or change the database alias name to point to the shadow',
977 mtInformation,[mbOK],0);
978 end;
979
980 procedure TDatabaseData.AddSecondaryFile(aFileName: string; StartAt,
981 FileLength: integer);
982 var SQLText: string;
983 begin
984 if FileLength <> -1 then
985 SQLText := Format(sAddSecondarySQL2,[aFileName,StartAt,FileLength])
986 else
987 SQLText := Format(sAddSecondarySQL,[aFileName,StartAt]);
988 ExecDDL.SQL.Text := SQLText;
989 ExecDDL.ExecQuery;
990 CurrentTransaction.Commit;
991 end;
992
993 procedure TDatabaseData.AddShadowSet;
994 var CurrentLocation: TBookmark;
995 ShadowSet: integer;
996 begin
997 if ShadowFiles.RecordCount = 0 then
998 ShadowSet := 1
999 else
1000 with ShadowFiles do
1001 begin
1002 CurrentLocation := Bookmark;
1003 DisableControls;
1004 try
1005 Last;
1006 ShadowSet := FieldByName('RDB$Shadow_Number').AsInteger + 1;
1007 finally
1008 Bookmark := CurrentLocation;
1009 EnableControls
1010 end
1011 end;
1012 AddShadowSetDlg.ShowModal(ShadowSet);
1013 CurrentTransaction.Active := true;
1014 end;
1015
1016 procedure TDatabaseData.RemoveShadowSet(ShadowSet: integer);
1017 begin
1018 if IBDatabaseInfo.ODSMajorVersion < 12 then
1019 begin
1020 if MessageDlg(Format(sRemoveShadow,[ShadowSet]),mtConfirmation,[mbYes,mbNo],0) = mrYes then
1021 ExecDDL.SQL.Text := Format(sRemoveShadow,[ShadowSet]);
1022 end
1023 else
1024 case MessageDlg(Format(sPreserveShadowFiles,[ShadowSet]),mtConfirmation,[mbYes,mbNo,mbCancel],0) of
1025 mrNo:
1026 ExecDDL.SQL.Text :=Format(sRemoveShadow12,[ShadowSet]);
1027 mrYes:
1028 ExecDDL.SQL.Text := Format(sPreserveShadow,[ShadowSet]);
1029 mrCancel:
1030 Exit;
1031 end;
1032 ExecDDL.ExecQuery;
1033 CurrentTransaction.Commit;
1034 end;
1035
1036 procedure TDatabaseData.LoadPerformanceStatistics(Lines: TStrings);
1037
1038 procedure AddPerfStats(Heading: string; stats: TStrings);
1039 var i: integer;
1040 begin
1041 with Lines do
1042 begin
1043 if stats.count = 0 then exit;
1044 Add('');
1045 Add(Heading);
1046 for i := 0 to stats.Count - 1 do
1047 begin
1048 if TableNameLookup.Locate('RDB$RELATION_ID',stats.Names[i],[]) then
1049 Add(' ' + TableNameLookup.FieldByName('RDB$RELATION_NAME').AsString + ' = ' + stats.ValueFromIndex[i]);
1050 end;
1051 end;
1052 end;
1053
1054 begin
1055 TableNameLookup.Active := true;
1056 with IBDatabaseInfo, Lines do
1057 begin
1058 Add(Format('Number of reads from the memory buffer cache = %d',[Fetches]));
1059 Add(Format('Number of writes to the memory buffer cache = %d',[Marks]));
1060 Add(Format('Number of page reads = %d',[Reads]));
1061 Add(Format('Number of page writes = %d',[Writes]));
1062 Add('');
1063 Add('Since Database last attached:');
1064 AddPerfStats('Number of removals of a version of a record',BackoutCount);
1065 AddPerfStats('Number of database deletes',DeleteCount);
1066 AddPerfStats('Number of removals of a committed record',ExpungeCount);
1067 AddPerfStats('Number of inserts',InsertCount);
1068 AddPerfStats('Number of removals of old versions of fully mature records',PurgeCount);
1069 AddPerfStats('Number of reads done via an index',ReadIdxCount);
1070 AddPerfStats('Number of sequential table scans',ReadSeqCount);
1071 AddPerfStats('Number of database updates',UpdateCount);
1072 end;
1073 end;
1074
1075 procedure TDatabaseData.LoadDatabaseStatistics(OptionID: integer; Lines: TStrings);
1076 begin
1077 if OptionID = 1 then
1078 LoadPerformanceStatistics(Lines)
1079 else
1080 with IBStatisticalService1 do
1081 begin
1082 case OptionID of
1083 0: Options := [HeaderPages];
1084 2: options := [DataPages];
1085 3: Options := [IndexPages];
1086 4: Options := [SystemRelations]
1087 end;
1088 Execute(Lines);
1089 end;
1090 end;
1091
1092 procedure TDatabaseData.LoadServerProperties(Lines: TStrings);
1093 var i: integer;
1094 begin
1095 Lines.Clear;
1096 with IBServerProperties1 do
1097 begin
1098 Lines.Add('Server Version = ' + VersionInfo.ServerVersion);
1099 Lines.Add('Server Implementation = ' + VersionInfo.ServerImplementation);
1100 Lines.Add('Service Version = ' + IntToStr(VersionInfo.ServiceVersion));
1101 with ServicesConnection do
1102 Lines.Add(Format('Firebird Release = %d.%d.%d (Build no. %d)',[ServerVersionNo[1],
1103 ServerVersionNo[2],
1104 ServerVersionNo[3],
1105 ServerVersionNo[4]]));
1106 Lines.Add('No. of attachments = ' + IntToStr(DatabaseInfo.NoOfAttachments));
1107 Lines.Add('No. of databases = ' + IntToStr(DatabaseInfo.NoOfDatabases));
1108 for i := 0 to DatabaseInfo.NoOfDatabases - 1 do
1109 Lines.Add(Format('DB Name (%d) = %s',[i+1, DatabaseInfo.DbName[i]]));
1110 Lines.Add('Base Location = ' + ConfigParams.BaseLocation);
1111 Lines.Add('Lock File Location = ' + ConfigParams.LockFileLocation);
1112 Lines.Add('Security Database Location = ' + ConfigParams.SecurityDatabaseLocation);
1113 Lines.Add('Message File Location = ' + ConfigParams.MessageFileLocation);
1114 end;
1115 end;
1116
1117 procedure TDatabaseData.LoadServerLog(Lines: TStrings);
1118 begin
1119 Lines.Clear;
1120 if IBLogService1.ServicesConnection.ServiceIntf.getProtocol = Local then
1121 Lines.Add('Server Log not available with embedded server')
1122 else
1123 IBLogService1.Execute(Lines);
1124 end;
1125
1126 procedure TDatabaseData.RevokeAll;
1127 begin
1128 with SubjectAccessRights do
1129 if Active then
1130 begin
1131 DisableControls;
1132 try
1133 First;
1134 while not EOF do
1135 begin
1136 if FieldByName('OBJECT_TYPE').AsInteger = 0 {relation} then
1137 ExecDDL.SQL.Text := Format('Revoke All on %s from %s',[
1138 Trim(FieldByName('OBJECT_NAME').AsString),
1139 Trim(FieldByName('SUBJECT_NAME').AsString)])
1140 else
1141 if FieldByName('OBJECT_TYPE').AsInteger = 13 {role} then
1142 ExecDDL.SQL.Text := Format('Revoke %s from %s',[
1143 Trim(FieldByName('OBJECT_NAME').AsString),
1144 Trim(FieldByName('SUBJECT_NAME').AsString)])
1145 else
1146 ExecDDL.SQL.Text := Format('Revoke All on %s %s from %s',[
1147 Trim(FieldByName('OBJECT_TYPE_NAME').AsString),
1148 Trim(FieldByName('OBJECT_NAME').AsString),
1149 Trim(FieldByName('SUBJECT_NAME').AsString)]);
1150 ExecDDL.ExecQuery;
1151 Next;
1152 end;
1153 finally
1154 EnableControls;
1155 end;
1156 CurrentTransaction.Commit;
1157 end;
1158 end;
1159
1160 procedure TDatabaseData.SyncSubjectAccessRights(ID: string);
1161 begin
1162 if (FSubjectAccessRightsID = ID) and SubjectAccessRights.Active then Exit;
1163 SubjectAccessRights.Active := false;
1164 FSubjectAccessRightsID := ID;
1165 SubjectAccessRights.Active := true;
1166 end;
1167
1168 procedure TDatabaseData.IBDatabase1Login(Database: TIBDatabase;
1169 LoginParams: TStrings);
1170 var aDatabaseName: string;
1171 aUserName: string;
1172 aPassword: string;
1173 aCreateIfNotExist: boolean;
1174 begin
1175 if FLocalConnect or (FDBPassword <> '') {reconnect} then
1176 begin
1177 LoginParams.Values['user_name'] := FDBUserName;
1178 LoginParams.Values['password'] := FDBPassword;
1179 exit;
1180 end;
1181
1182 aDatabaseName := Database.DatabaseName;
1183 aUserName := LoginParams.Values['user_name'];
1184 aPassword := '';
1185 aCreateIfNotExist := false;
1186 if DBLoginDlg.ShowModal(aDatabaseName, aUserName, aPassword, aCreateIfNotExist) = mrOK then
1187 begin
1188 FDBPassword := aPassword; {remember for reconnect}
1189 Database.DatabaseName := aDatabaseName;
1190 LoginParams.Values['user_name'] := aUserName;
1191 LoginParams.Values['password'] := aPassword;
1192 FDBUserName := aUserName;
1193 FDBPassword := aPassword;
1194 Database.CreateIfNotExists := aCreateIfNotExist;
1195 ParseConnectString(aDatabaseName,FServerName,FDatabasePathName,FProtocol,FPortNo);
1196 end
1197 else
1198 IBError(ibxeOperationCancelled, [nil]);
1199 end;
1200
1201 procedure TDatabaseData.AttUpdateApplyUpdates(Sender: TObject;
1202 UpdateKind: TUpdateKind; Params: ISQLParams);
1203 begin
1204 if UpdateKind = ukDelete then
1205 begin
1206 ExecDDL.SQL.Text := 'Delete from MON$ATTACHMENTS Where MON$ATTACHMENT_ID =' +
1207 Params.ByName('MON$ATTACHMENT_ID').Asstring;
1208 ExecDDL.ExecQuery;
1209 end;
1210 end;
1211
1212 procedure TDatabaseData.DBTablesUpdateApplyUpdates(Sender: TObject;
1213 UpdateKind: TUpdateKind; Params: ISQLParams);
1214 begin
1215 // Do nothing
1216 end;
1217
1218 procedure TDatabaseData.IBValidationService1GetNextLine(Sender: TObject;
1219 var Line: string);
1220 begin
1221 Application.ProcessMessages;
1222 end;
1223
1224 procedure TDatabaseData.IBXServicesConnection1Login(
1225 Service: TIBXServicesConnection; var aServerName: string; LoginParams: TStrings);
1226 begin
1227 LoginParams.Values['user_name'] := FDBUserName;
1228 LoginParams.Values['password'] := FDBPassword;
1229 end;
1230
1231 procedure TDatabaseData.LegacyUserListAfterOpen(DataSet: TDataSet);
1232 begin
1233 UserListSource.DataSet := LegacyUserList;
1234 CurrentTransaction.Active := true;
1235 RoleNameList.Active := true;
1236 end;
1237
1238 procedure TDatabaseData.LegacyUserListAfterPost(DataSet: TDataSet);
1239 begin
1240 RoleNameList.Active := true;
1241 end;
1242
1243 procedure TDatabaseData.LegacyUserListBeforeClose(DataSet: TDataSet);
1244 begin
1245 RoleNameList.Active := false;
1246 end;
1247
1248 procedure TDatabaseData.ShadowFilesCalcFields(DataSet: TDataSet);
1249 var Flags: integer;
1250 begin
1251 Flags := DataSet.FieldByName('RDB$FILE_FLAGS').AsInteger;
1252 if Flags and $10 <> 0 then
1253 DataSet.FieldByName('FileMode').AsString := 'C'
1254 else
1255 if Flags and $04 <> 0 then
1256 DataSet.FieldByName('FileMode').AsString := 'M'
1257 else
1258 if Flags and $01 <> 0 then
1259 if DataSet.FieldByName('RDB$FILE_SEQUENCE').AsInteger = 0 then
1260 DataSet.FieldByName('FileMode').AsString := 'A'
1261 else
1262 DataSet.FieldByName('FileMode').AsString := '+'
1263 else
1264 DataSet.FieldByName('FileMode').AsString := ''
1265 end;
1266
1267 procedure TDatabaseData.SubjectAccessRightsBeforeOpen(DataSet: TDataSet);
1268 begin
1269 SubjectAccessRights.ParamByName('ID').AsString := FSubjectAccessRightsID;
1270 end;
1271
1272 procedure TDatabaseData.TagsUpdateApplyUpdates(Sender: TObject;
1273 UpdateKind: TUpdateKind; Params: ISQLParams);
1274 var sql: string;
1275 begin
1276 sql := '';
1277 case UpdateKind of
1278 ukInsert,
1279 ukModify:
1280 begin
1281 sql := 'ALTER USER ' + Trim(Params.ByName('SEC$USER_NAME').AsString)
1282 + ' TAGS (' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('SEC$KEY').AsString)
1283 + '=''' + SQLSafeString(Params.ByName('SEC$VALUE').AsString) + '''';
1284 if Params.ByName('SEC$KEY').AsString <> Params.ByName('OLD_SEC$KEY').AsString then
1285 sql += ', DROP ' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('OLD_SEC$KEY').AsString);
1286 sql +=')'
1287 end;
1288
1289 ukDelete:
1290 sql := 'ALTER USER ' + Trim(Params.ByName('SEC$USER_NAME').AsString)
1291 + ' TAGS (DROP ' + QuoteIdentifierIfNeeded(IBDatabase1.SQLDialect,Params.ByName('SEC$KEY').AsString) + ')';
1292 end;
1293 ExecDDL.SQL.Text := sql;
1294 ExecDDL.ExecQuery;
1295 end;
1296
1297 procedure TDatabaseData.IBDatabase1AfterConnect(Sender: TObject);
1298 begin
1299 {Virtual tables did not exist prior to Firebird 2.1 - so don't bother with old version}
1300 with IBDatabaseInfo do
1301 if (ODSMajorVersion < 11) or ((ODSMajorVersion = 11) and (ODSMinorVersion < 1)) then
1302 begin
1303 IBDatabase1.Connected := false;
1304 raise Exception.Create('This application requires Firebird 2.1 or later');
1305 end
1306 else
1307 if ODSMajorVersion < 12 then
1308 {Don't expect to be able to find these fields}
1309 begin
1310 AttachmentsMONCLIENT_VERSION.FieldKind := fkCalculated;
1311 AttachmentsMONREMOTE_VERSION.FieldKind := fkCalculated;
1312 AttachmentsMONREMOTE_HOST.FieldKind := fkCalculated;
1313 AttachmentsMONREMOTE_OS_USER.FieldKind := fkCalculated;
1314 AttachmentsMONAUTH_METHOD.FieldKind := fkCalculated;
1315 AttachmentsMONSYSTEM_FLAG.FieldKind := fkCalculated;
1316 AttachmentsRDBSECURITY_CLASS.FieldKind := fkCalculated;
1317 AttachmentsRDBOWNER_NAME.FieldKind := fkCalculated;
1318 end
1319 else
1320 begin
1321 AttachmentsMONCLIENT_VERSION.FieldKind := fkData;
1322 AttachmentsMONREMOTE_VERSION.FieldKind := fkData;
1323 AttachmentsMONREMOTE_HOST.FieldKind := fkData;
1324 AttachmentsMONREMOTE_OS_USER.FieldKind := fkData;
1325 AttachmentsMONAUTH_METHOD.FieldKind := fkData;
1326 AttachmentsMONSYSTEM_FLAG.FieldKind := fkData;
1327 AttachmentsRDBSECURITY_CLASS.FieldKind := fkData;
1328 AttachmentsRDBOWNER_NAME.FieldKind := fkData;
1329 end;
1330
1331 FLocalConnect := FProtocol = Local;
1332 ConnectServicesAPI;
1333 ReloadData;
1334 end;
1335
1336 procedure TDatabaseData.IBDatabase1AfterDisconnect(Sender: TObject);
1337 begin
1338 FDisconnecting := false;
1339 end;
1340
1341 procedure TDatabaseData.IBDatabase1BeforeDisconnect(Sender: TObject);
1342 begin
1343 FDisconnecting := true;
1344 end;
1345
1346 procedure TDatabaseData.DatabaseQueryAfterOpen(DataSet: TDataSet);
1347 begin
1348 DBCharSet.Active := true;
1349 end;
1350
1351 procedure TDatabaseData.CurrentTransactionAfterTransactionEnd(Sender: TObject);
1352 begin
1353 if not Disconnecting and not (csDestroying in ComponentState) then
1354 Application.QueueAsyncCall(@ReloadData,0);
1355 end;
1356
1357 procedure TDatabaseData.ApplicationProperties1Exception(Sender: TObject;
1358 E: Exception);
1359 begin
1360 if E is EIBInterBaseError then
1361 begin
1362 if RoleNameList.State in [dsInsert,dsEdit] then
1363 RoleNameList.Cancel;
1364 if UserList.State in [dsInsert,dsEdit] then
1365 UserList.Cancel;
1366 end;
1367 MessageDlg(E.Message,mtError,[mbOK],0);
1368 if CurrentTransaction.Active then
1369 CurrentTransaction.Rollback;
1370 end;
1371
1372 procedure TDatabaseData.AccessRightsCalcFields(DataSet: TDataSet);
1373 begin
1374 AccessRightsDisplayName.AsString := AccessRightsSUBJECT_NAME.AsString;
1375 if AccessRightsSUBJECT_TYPE.AsInteger = 8 then
1376 begin
1377 if (AccessRightsSUBJECT_NAME.AsString <> 'PUBLIC') and UserListSource.DataSet.Active and
1378 not UserListSource.DataSet.Locate('SEC$USER_NAME',AccessRightsSUBJECT_NAME.AsString,[]) then
1379 begin
1380 AccessRightsImageIndex.AsInteger := 4;
1381 AccessRightsDisplayName.AsString := AccessRightsSUBJECT_NAME.AsString + ' (stale)';
1382 end
1383 else
1384 AccessRightsImageIndex.AsInteger := -1
1385 end
1386 else
1387 AccessRightsImageIndex.AsInteger := -1;
1388 end;
1389
1390 procedure TDatabaseData.AttachmentsAfterDelete(DataSet: TDataSet);
1391 begin
1392 CurrentTransaction.Commit;
1393 end;
1394
1395 procedure TDatabaseData.AttachmentsAfterOpen(DataSet: TDataSet);
1396 begin
1397 Attachments.Locate('MON$ATTACHMENT_ID',AttmtQuery.FieldByName('MON$ATTACHMENT_ID').AsInteger,[]);
1398 end;
1399
1400 procedure TDatabaseData.AttachmentsBeforeOpen(DataSet: TDataSet);
1401 begin
1402 if IBDatabaseInfo.ODSMajorVersion >= 12 then
1403 (DataSet as TIBQuery).Parser.Add2WhereClause('r.MON$SYSTEM_FLAG = 0');
1404 end;
1405
1406 procedure TDatabaseData.DatabaseQueryBeforeClose(DataSet: TDataSet);
1407 begin
1408 DBCharSet.Active := false;
1409 end;
1410
1411 procedure TDatabaseData.DBCharSetAfterClose(DataSet: TDataSet);
1412 begin
1413 CharSetLookup.Active := false;
1414 end;
1415
1416 procedure TDatabaseData.DBCharSetBeforeOpen(DataSet: TDataSet);
1417 begin
1418 CharSetLookup.Active := true;
1419 end;
1420
1421 end.
1422