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