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