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

File Contents

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