ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/DBAdmin/DataModule.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 44942 byte(s)
Log Message:
Fixes Merged

File Contents

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