ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/runtime/IBDatabaseInfo.pas

Comparing ibx/trunk/runtime/IBDatabaseInfo.pas (file contents):
Revision 17 by tony, Sat Dec 28 19:22:24 2013 UTC vs.
Revision 143 by tony, Fri Feb 23 12:11:21 2018 UTC

#	Line 1 | Line 1
1	<	{************************************************************************}
2	<	{                                                                        }
3	<	{       Borland Delphi Visual Component Library                          }
4	<	{       InterBase Express core components                                }
5	<	{                                                                        }
6	<	{       Copyright (c) 1998-2000 Inprise Corporation                      }
7	<	{                                                                        }
8	<	{    InterBase Express is based in part on the product                   }
9	<	{    Free IB Components, written by Gregory H. Deatz for                 }
10	<	{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
11	<	{    Free IB Components is used under license.                           }
12	<	{                                                                        }
13	<	{    The contents of this file are subject to the InterBase              }
14	<	{    Public License Version 1.0 (the "License"); you may not             }
15	<	{    use this file except in compliance with the License. You            }
16	<	{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	<	{    Software distributed under the License is distributed on            }
18	<	{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
19	<	{    express or implied. See the License for the specific language       }
20	<	{    governing rights and limitations under the License.                 }
21	<	{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
22	<	{       Corporation. All Rights Reserved.                                }
23	<	{    Contributor(s): Jeff Overcash                                       }
24	<	{                                                                        }
25	<	{    IBX For Lazarus (Firebird Express)                                  }
26	<	{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
27	<	{    Portions created by MWA Software are copyright McCallum Whyman      }
28	<	{    Associates Ltd 2011                                                 }
29	<	{                                                                        }
30	<	{************************************************************************}
31	<
32	<	unit IBDatabaseInfo;
33	<
34	<	{$Mode Delphi}
35	<
36	<	interface
37	<
38	<	uses
39	<	SysUtils, Classes, IBHeader, IBExternals, IB, IBDatabase;
40	<
41	<	type
42	<
43	<	TIBDatabaseInfo = class(TComponent)
44	<	protected
45	<	FIBLoaded: Boolean;
46	<	FDatabase: TIBDatabase;
47	<	FUserNames   : TStringList;
48	<	FBackoutCount: TStringList;
49	<	FDeleteCount: TStringList;
50	<	FExpungeCount: TStringList;
51	<	FInsertCount: TStringList;
52	<	FPurgeCount: TStringList;
53	<	FReadIdxCount: TStringList;
54	<	FReadSeqCount: TStringList;
55	<	FUpdateCount: TStringList;
56	<	function GetAllocation: Long;
57	<	function GetBaseLevel: Long;
58	<	function GetDBFileName: String;
59	<	function GetDBSiteName: String;
60	<	function GetDBImplementationNo: Long;
61	<	function GetDBImplementationClass: Long;
62	<	function GetNoReserve: Long;
63	<	function GetODSMinorVersion: Long;
64	<	function GetODSMajorVersion: Long;
65	<	function GetPageSize: Long;
66	<	function GetVersion: String;
67	<	function GetCurrentMemory: Long;
68	<	function GetForcedWrites: Long;
69	<	function GetMaxMemory: Long;
70	<	function GetNumBuffers: Long;
71	<	function GetSweepInterval: Long;
72	<	function GetUserNames: TStringList;
73	<	function GetFetches: Long;
74	<	function GetMarks: Long;
75	<	function GetReads: Long;
76	<	function GetWrites: Long;
77	<	function GetBackoutCount: TStringList;
78	<	function GetDeleteCount: TStringList;
79	<	function GetExpungeCount: TStringList;
80	<	function GetInsertCount: TStringList;
81	<	function GetPurgeCount: TStringList;
82	<	function GetReadIdxCount: TStringList;
83	<	function GetReadSeqCount: TStringList;
84	<	function GetUpdateCount: TStringList;
85	<	function GetOperationCounts(DBInfoCommand: Integer; FOperation: TStringList): TStringList;
86	<	function GetReadOnly: Long;
87	<	function GetStringDatabaseInfo(DatabaseInfoCommand: Integer): String;
88	<	function GetDBSQLDialect: Long;
89	<	public
90	<	constructor Create(AOwner: TComponent); override;
91	<	destructor Destroy; override;
92	<	function Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
93	<	function GetLongDatabaseInfo(DatabaseInfoCommand: Integer): Long;
94	<	property Allocation: Long read GetAllocation;
95	<	property BaseLevel: Long read GetBaseLevel;
96	<	property DBFileName: String read GetDBFileName;
97	<	property DBSiteName: String read GetDBSiteName;
98	<	property DBImplementationNo: Long read GetDBImplementationNo;
99	<	property DBImplementationClass: Long read GetDBImplementationClass;
100	<	property NoReserve: Long read GetNoReserve;
101	<	property ODSMinorVersion: Long read GetODSMinorVersion;
102	<	property ODSMajorVersion: Long read GetODSMajorVersion;
103	<	property PageSize: Long read GetPageSize;
104	<	property Version: String read GetVersion;
105	<	property CurrentMemory: Long read GetCurrentMemory;
106	<	property ForcedWrites: Long read GetForcedWrites;
107	<	property MaxMemory: Long read GetMaxMemory;
108	<	property NumBuffers: Long read GetNumBuffers;
109	<	property SweepInterval: Long read GetSweepInterval;
110	<	property UserNames: TStringList read GetUserNames;
111	<	property Fetches: Long read GetFetches;
112	<	property Marks: Long read GetMarks;
113	<	property Reads: Long read GetReads;
114	<	property Writes: Long read GetWrites;
115	<	property BackoutCount: TStringList read GetBackoutCount;
116	<	property DeleteCount: TStringList read GetDeleteCount;
117	<	property ExpungeCount: TStringList read GetExpungeCount;
118	<	property InsertCount: TStringList read GetInsertCount;
119	<	property PurgeCount: TStringList read GetPurgeCount;
120	<	property ReadIdxCount: TStringList read GetReadIdxCount;
121	<	property ReadSeqCount: TStringList read GetReadSeqCount;
122	<	property UpdateCount: TStringList read GetUpdateCount;
123	<	property DBSQLDialect : Long read GetDBSQLDialect;
124	<	property ReadOnly: Long read GetReadOnly;
125	<	published
126	<	property Database: TIBDatabase read FDatabase write FDatabase;
127	<	end;
128	<
129	<	implementation
130	<
131	<	uses
132	<	IBIntf;
133	<
134	<	{ TIBDatabaseInfo }
135	<
136	<	constructor TIBDatabaseInfo.Create(AOwner: TComponent);
137	<	begin
138	<	inherited Create(AOwner);
139	<	FIBLoaded := False;
140	<	CheckIBLoaded;
141	<	FIBLoaded := True;
142	<	FUserNames := TStringList.Create;
143	<	FBackoutCount                        := nil;
144	<	FDeleteCount                         := nil;
145	<	FExpungeCount                        := nil;
146	<	FInsertCount                         := nil;
147	<	FPurgeCount                          := nil;
148	<	FReadIdxCount                        := nil;
149	<	FReadSeqCount                        := nil;
150	<	FUpdateCount                         := nil;
151	<	end;
152	<
153	<	destructor TIBDatabaseInfo.Destroy;
154	<	begin
155	<	if FIBLoaded then
156	<	begin
157	<	FUserNames.Free;
158	<	FBackoutCount.Free;
159	<	FDeleteCount.Free;
160	<	FExpungeCount.Free;
161	<	FInsertCount.Free;
162	<	FPurgeCount.Free;
163	<	FReadIdxCount.Free;
164	<	FReadSeqCount.Free;
165	<	FUpdateCount.Free;
166	<	end;
167	<	inherited Destroy;
168	<	end;
169	<
170	<
171	<	function TIBDatabaseInfo.Call(ErrCode: ISC_STATUS;
172	<	RaiseError: Boolean): ISC_STATUS;
173	<	begin
174	<	result := ErrCode;
175	<	if RaiseError and (ErrCode > 0) then
176	<	IBDataBaseError;
177	<	end;
178	<	function TIBDatabaseInfo.GetAllocation: Long;
179	<	begin
180	<	result := GetLongDatabaseInfo(isc_info_allocation);
181	<	end;
182	<
183	<	function TIBDatabaseInfo.GetBaseLevel: Long;
184	<	var
185	<	local_buffer: array[0..IBLocalBufferLength - 1] of Char;
186	<	DatabaseInfoCommand: Char;
187	<	begin
188	<	DatabaseInfoCommand := Char(isc_info_base_level);
189	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
190	<	IBLocalBufferLength, local_buffer), True);
191	<	result := isc_vax_integer(@local_buffer[4], 1);
192	<	end;
193	<
194	<	function TIBDatabaseInfo.GetDBFileName: String;
195	<	var
196	<	local_buffer: array[0..IBLocalBufferLength - 1] of Char;
197	<	DatabaseInfoCommand: Char;
198	<	begin
199	<	DatabaseInfoCommand := Char(isc_info_db_id);
200	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
201	<	IBLocalBufferLength, local_buffer), True);
202	<	local_buffer[5 + Int(local_buffer[4])] := #0;
203	<	result := String(PChar(@local_buffer[5]));
204	<	end;
205	<
206	<	function TIBDatabaseInfo.GetDBSiteName: String;
207	<	var
208	<	local_buffer: array[0..IBBigLocalBufferLength - 1] of Char;
209	<	p: PChar;
210	<	DatabaseInfoCommand: Char;
211	<	begin
212	<	DatabaseInfoCommand := Char(isc_info_db_id);
213	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
214	<	IBLocalBufferLength, local_buffer), True);
215	<	p := @local_buffer[5 + Int(local_buffer[4])]; { DBSiteName Length }
216	<	p := p + Int(p^) + 1;                         { End of DBSiteName }
217	<	p^ := #0;                                     { Null it }
218	<	result := String(PChar(@local_buffer[6 + Int(local_buffer[4])]));
219	<	end;
220	<
221	<	function TIBDatabaseInfo.GetDBImplementationNo: Long;
222	<	var
223	<	local_buffer: array[0..IBLocalBufferLength - 1] of Char;
224	<	DatabaseInfoCommand: Char;
225	<	begin
226	<	DatabaseInfoCommand := Char(isc_info_implementation);
227	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
228	<	IBLocalBufferLength, local_buffer), True);
229	<	result := isc_vax_integer(@local_buffer[3], 1);
230	<	end;
231	<
232	<	function TIBDatabaseInfo.GetDBImplementationClass: Long;
233	<	var
234	<	local_buffer: array[0..IBLocalBufferLength - 1] of Char;
235	<	DatabaseInfoCommand: Char;
236	<	begin
237	<	DatabaseInfoCommand := Char(isc_info_implementation);
238	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
239	<	IBLocalBufferLength, local_buffer), True);
240	<	result := isc_vax_integer(@local_buffer[4], 1);
241	<	end;
242	<
243	<	function TIBDatabaseInfo.GetNoReserve: Long;
244	<	begin
245	<	result := GetLongDatabaseInfo(isc_info_no_reserve);
246	<	end;
247	<
248	<	function TIBDatabaseInfo.GetODSMinorVersion: Long;
249	<	begin
250	<	result := GetLongDatabaseInfo(isc_info_ods_minor_version);
251	<	end;
252	<
253	<	function TIBDatabaseInfo.GetODSMajorVersion: Long;
254	<	begin
255	<	result := GetLongDatabaseInfo(isc_info_ods_version);
256	<	end;
257	<
258	<	function TIBDatabaseInfo.GetPageSize: Long;
259	<	begin
260	<	result := GetLongDatabaseInfo(isc_info_page_size);
261	<	end;
262	<
263	<	function TIBDatabaseInfo.GetVersion: String;
264	<	var
265	<	local_buffer: array[0..IBBigLocalBufferLength - 1] of Char;
266	<	DatabaseInfoCommand: Char;
267	<	begin
268	<	DatabaseInfoCommand := Char(isc_info_version);
269	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
270	<	IBBigLocalBufferLength, local_buffer), True);
271	<	local_buffer[5 + Int(local_buffer[4])] := #0;
272	<	result := String(PChar(@local_buffer[5]));
273	<	end;
274	<
275	<	function TIBDatabaseInfo.GetCurrentMemory: Long;
276	<	begin
277	<	result := GetLongDatabaseInfo(isc_info_current_memory);
278	<	end;
279	<
280	<	function TIBDatabaseInfo.GetForcedWrites: Long;
281	<	begin
282	<	result := GetLongDatabaseInfo(isc_info_forced_writes);
283	<	end;
284	<
285	<	function TIBDatabaseInfo.GetMaxMemory: Long;
286	<	begin
287	<	result := GetLongDatabaseInfo(isc_info_max_memory);
288	<	end;
289	<
290	<	function TIBDatabaseInfo.GetNumBuffers: Long;
291	<	begin
292	<	result := GetLongDatabaseInfo(isc_info_num_buffers);
293	<	end;
294	<
295	<	function TIBDatabaseInfo.GetSweepInterval: Long;
296	<	begin
297	<	result := GetLongDatabaseInfo(isc_info_sweep_interval);
298	<	end;
299	<
300	<	function TIBDatabaseInfo.GetUserNames: TStringList;
301	<	var
302	<	local_buffer: array[0..IBHugeLocalBufferLength - 1] of Char;
303	<	temp_buffer: array[0..IBLocalBufferLength - 2] of Char;
304	<	DatabaseInfoCommand: Char;
305	<	i, user_length: Integer;
306	<	begin
307	<	result := FUserNames;
308	<	DatabaseInfoCommand := Char(isc_info_user_names);
309	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
310	<	IBHugeLocalBufferLength, local_buffer), True);
311	<	FUserNames.Clear;
312	<	i := 0;
313	<	while local_buffer[i] = Char(isc_info_user_names) do
314	<	begin
315	<	Inc(i, 3); { skip "isc_info_user_names byte" & two unknown bytes of structure (see below) }
316	<	user_length := Long(local_buffer[i]);
317	<	Inc(i,1);
318	<	Move(local_buffer[i], temp_buffer[0], user_length);
319	<	Inc(i, user_length);
320	<	temp_buffer[user_length] := #0;
321	<	FUserNames.Add(String(temp_buffer));
322	<	end;
323	<	end;
324	<
325	<	function TIBDatabaseInfo.GetFetches: Long;
326	<	begin
327	<	result := GetLongDatabaseInfo(isc_info_fetches);
328	<	end;
329	<
330	<	function TIBDatabaseInfo.GetMarks: Long;
331	<	begin
332	<	result := GetLongDatabaseInfo(isc_info_marks);
333	<	end;
334	<
335	<	function TIBDatabaseInfo.GetReads: Long;
336	<	begin
337	<	result := GetLongDatabaseInfo(isc_info_reads);
338	<	end;
339	<
340	<	function TIBDatabaseInfo.GetWrites: Long;
341	<	begin
342	<	result := GetLongDatabaseInfo(isc_info_writes);
343	<	end;
344	<
345	<	function TIBDatabaseInfo.GetOperationCounts(DBInfoCommand: Integer; FOperation: TStringList): TStringList;
346	<	var
347	<	local_buffer: array[0..IBHugeLocalBufferLength - 1] of Char;
348	<	DatabaseInfoCommand: Char;
349	<	i, qtd_tables, id_table, qtd_operations: Integer;
350	<	begin
351	<	if FOperation = nil then FOperation := TStringList.Create;
352	<	result := FOperation;
353	<	DatabaseInfoCommand := Char(DBInfoCommand);
354	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
355	<	IBHugeLocalBufferLength, local_buffer), True);
356	<	FOperation.Clear;
357	<	{ 1. 1 byte specifying the item type requested (e.g., isc_info_insert_count).
358	<	2. 2 bytes telling how many bytes compose the subsequent value pairs.
359	<	3. A pair of values for each table in the database on wich the requested
360	<	type of operation has occurred since the database was last attached.
361	<	Each pair consists of:
362	<	1. 2 bytes specifying the table ID.
363	<	2. 4 bytes listing the number of operations (e.g., inserts) done on that table.
364	<	}
365	<	qtd_tables := trunc(isc_vax_integer(@local_buffer[1],2)/6);
366	<	for i := 0 to qtd_tables - 1 do
367	<	begin
368	<	id_table := isc_vax_integer(@local_buffer[3+(i*6)],2);
369	<	qtd_operations := isc_vax_integer(@local_buffer[5+(i*6)],4);
370	<	FOperation.Add(IntToStr(id_table)+'='+IntToStr(qtd_operations));
371	<	end;
372	<	end;
373	<
374	<	function TIBDatabaseInfo.GetBackoutCount: TStringList;
375	<	begin
376	<	result := GetOperationCounts(isc_info_backout_count,FBackoutCount);
377	<	end;
378	<
379	<	function TIBDatabaseInfo.GetDeleteCount: TStringList;
380	<	begin
381	<	result := GetOperationCounts(isc_info_delete_count,FDeleteCount);
382	<	end;
383	<
384	<	function TIBDatabaseInfo.GetExpungeCount: TStringList;
385	<	begin
386	<	result := GetOperationCounts(isc_info_expunge_count,FExpungeCount);
387	<	end;
388	<
389	<	function TIBDatabaseInfo.GetInsertCount: TStringList;
390	<	begin
391	<	result := GetOperationCounts(isc_info_insert_count,FInsertCount);
392	<	end;
393	<
394	<	function TIBDatabaseInfo.GetPurgeCount: TStringList;
395	<	begin
396	<	result := GetOperationCounts(isc_info_purge_count,FPurgeCount);
397	<	end;
398	<
399	<	function TIBDatabaseInfo.GetReadIdxCount: TStringList;
400	<	begin
401	<	result := GetOperationCounts(isc_info_read_idx_count,FReadIdxCount);
402	<	end;
403	<
404	<	function TIBDatabaseInfo.GetReadSeqCount: TStringList;
405	<	begin
406	<	result := GetOperationCounts(isc_info_read_seq_count,FReadSeqCount);
407	<	end;
408	<
409	<	function TIBDatabaseInfo.GetUpdateCount: TStringList;
410	<	begin
411	<	result := GetOperationCounts(isc_info_update_count,FUpdateCount);
412	<	end;
413	<
414	<	function TIBDatabaseInfo.GetReadOnly: Long;
415	<	begin
416	<	result := GetLongDatabaseInfo(isc_info_db_read_only);
417	<	end;
418	<
419	<	function TIBDatabaseInfo.GetLongDatabaseInfo(DatabaseInfoCommand: Integer): Long;
420	<	var
421	<	local_buffer: array[0..IBLocalBufferLength - 1] of Char;
422	<	length: Integer;
423	<	_DatabaseInfoCommand: Char;
424	<	begin
425	<	_DatabaseInfoCommand := Char(DatabaseInfoCommand);
426	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @_DatabaseInfoCommand,
427	<	IBLocalBufferLength, local_buffer), True);
428	<	length := isc_vax_integer(@local_buffer[1], 2);
429	<	result := isc_vax_integer(@local_buffer[3], length);
430	<	end;
431	<
432	<	function TIBDatabaseInfo.GetStringDatabaseInfo(DatabaseInfoCommand: Integer): String;
433	<	var
434	<	local_buffer: array[0..IBBigLocalBufferLength - 1] of Char;
435	<	_DatabaseInfoCommand: Char;
436	<	begin
437	<	_DatabaseInfoCommand := Char(DatabaseInfoCommand);
438	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @_DatabaseInfoCommand,
439	<	IBBigLocalBufferLength, local_buffer), True);
440	<	local_buffer[4 + Int(local_buffer[3])] := #0;
441	<	result := String(PChar(@local_buffer[4]));
442	<	end;
443	<
444	<
445	<	function TIBDatabaseInfo.GetDBSQLDialect: Integer;
446	<	var
447	<	local_buffer: array[0..IBLocalBufferLength - 1] of Char;
448	<	length: Integer;
449	<	DatabaseInfoCommand: Char;
450	<	begin
451	<	DatabaseInfoCommand := Char(isc_info_db_SQL_Dialect);
452	<	Call(isc_database_info(StatusVector, @FDatabase.Handle, 1, @DatabaseInfoCommand,
453	<	IBLocalBufferLength, local_buffer), True);
454	<	if (local_buffer[0] <> Char(isc_info_db_SQL_dialect)) then
455	<	result := 1
456	<	else begin
457	<	length := isc_vax_integer(@local_buffer[1], 2);
458	<	result := isc_vax_integer(@local_buffer[3], length);
459	<	end;
460	<	end;
461	<
462	<
463	<	end.
1	>	{************************************************************************}
2	>	{                                                                        }
3	>	{       Borland Delphi Visual Component Library                          }
4	>	{       InterBase Express core components                                }
5	>	{                                                                        }
6	>	{       Copyright (c) 1998-2000 Inprise Corporation                      }
7	>	{                                                                        }
8	>	{    InterBase Express is based in part on the product                   }
9	>	{    Free IB Components, written by Gregory H. Deatz for                 }
10	>	{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
11	>	{    Free IB Components is used under license.                           }
12	>	{                                                                        }
13	>	{    The contents of this file are subject to the InterBase              }
14	>	{    Public License Version 1.0 (the "License"); you may not             }
15	>	{    use this file except in compliance with the License. You            }
16	>	{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17	>	{    Software distributed under the License is distributed on            }
18	>	{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
19	>	{    express or implied. See the License for the specific language       }
20	>	{    governing rights and limitations under the License.                 }
21	>	{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
22	>	{       Corporation. All Rights Reserved.                                }
23	>	{    Contributor(s): Jeff Overcash                                       }
24	>	{                                                                        }
25	>	{    IBX For Lazarus (Firebird Express)                                  }
26	>	{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
27	>	{    Portions created by MWA Software are copyright McCallum Whyman      }
28	>	{    Associates Ltd 2011 - 2018                                               }
29	>	{                                                                        }
30	>	{************************************************************************}
31	>
32	>	unit IBDatabaseInfo;
33	>
34	>	{$Mode Delphi}
35	>
36	>	interface
37	>
38	>	uses
39	>	SysUtils, Classes, IB, IBExternals, IBDatabase;
40	>
41	>	type
42	>
43	>	{ TIBDatabaseInfo }
44	>
45	>	TIBDatabaseInfo = class(TComponent)
46	>	private
47	>	function GetDateDBCreated: TDateTime;
48	>	function GetEncrypted: boolean;
49	>	function GetEncryptionKeyName: string;
50	>	function GetPagesFree: Long;
51	>	function GetPagesUsed: Long;
52	>	function GetTransactionCount: Long;
53	>	protected
54	>	FDatabase: TIBDatabase;
55	>	FUserNames   : TStringList;
56	>	FBackoutCount: TStringList;
57	>	FDeleteCount: TStringList;
58	>	FExpungeCount: TStringList;
59	>	FInsertCount: TStringList;
60	>	FPurgeCount: TStringList;
61	>	FReadIdxCount: TStringList;
62	>	FReadSeqCount: TStringList;
63	>	FUpdateCount: TStringList;
64	>	procedure CheckDatabase;
65	>	function GetAllocation: Long;
66	>	function GetBaseLevel: Long;
67	>	function GetDBFileName: String;
68	>	function GetDBSiteName: String;
69	>	function GetDBImplementationNo: Long;
70	>	function GetDBImplementationClass: Long;
71	>	function GetNoReserve: Long;
72	>	function GetODSMinorVersion: Long;
73	>	function GetODSMajorVersion: Long;
74	>	function GetPageSize: Long;
75	>	function GetVersion: String;
76	>	function GetCurrentMemory: Long;
77	>	function GetForcedWrites: Long;
78	>	function GetMaxMemory: Long;
79	>	function GetNumBuffers: Long;
80	>	function GetSweepInterval: Long;
81	>	function GetUserNames: TStringList;
82	>	function GetFetches: Long;
83	>	function GetMarks: Long;
84	>	function GetReads: Long;
85	>	function GetWrites: Long;
86	>	function GetBackoutCount: TStringList;
87	>	function GetDeleteCount: TStringList;
88	>	function GetExpungeCount: TStringList;
89	>	function GetInsertCount: TStringList;
90	>	function GetPurgeCount: TStringList;
91	>	function GetReadIdxCount: TStringList;
92	>	function GetReadSeqCount: TStringList;
93	>	function GetUpdateCount: TStringList;
94	>	function GetOperationCounts(DBInfoCommand: Integer; var FOperation: TStringList): TStringList;
95	>	function GetReadOnly: Long;
96	>	function GetStringDatabaseInfo(DatabaseInfoCommand: Integer): String;
97	>	function GetDBSQLDialect: Long;
98	>	public
99	>	constructor Create(AOwner: TComponent); override;
100	>	destructor Destroy; override;
101	>	function GetLongDatabaseInfo(DatabaseInfoCommand: Integer): Long;
102	>	function GetDatabasePage(PageNo: integer): string;
103	>	property Allocation: Long read GetAllocation;
104	>	property BaseLevel: Long read GetBaseLevel;
105	>	property DateDBCreated: TDateTime read GetDateDBCreated;
106	>	property DBFileName: String read GetDBFileName;
107	>	property DBSiteName: String read GetDBSiteName;
108	>	property DBImplementationNo: Long read GetDBImplementationNo;
109	>	property DBImplementationClass: Long read GetDBImplementationClass;
110	>	property Encrypted: boolean read GetEncrypted;
111	>	property EncryptionKeyName: string read GetEncryptionKeyName;
112	>	property NoReserve: Long read GetNoReserve;
113	>	property ODSMinorVersion: Long read GetODSMinorVersion;
114	>	property ODSMajorVersion: Long read GetODSMajorVersion;
115	>	property PageSize: Long read GetPageSize;
116	>	property Version: String read GetVersion;
117	>	property CurrentMemory: Long read GetCurrentMemory;
118	>	property ForcedWrites: Long read GetForcedWrites;
119	>	property MaxMemory: Long read GetMaxMemory;
120	>	property NumBuffers: Long read GetNumBuffers;
121	>	property SweepInterval: Long read GetSweepInterval;
122	>	property UserNames: TStringList read GetUserNames;
123	>	property Fetches: Long read GetFetches;
124	>	property Marks: Long read GetMarks;
125	>	property Reads: Long read GetReads;
126	>	property Writes: Long read GetWrites;
127	>	property TransactionCount: Long read GetTransactionCount;
128	>	property BackoutCount: TStringList read GetBackoutCount;
129	>	property DeleteCount: TStringList read GetDeleteCount;
130	>	property ExpungeCount: TStringList read GetExpungeCount;
131	>	property InsertCount: TStringList read GetInsertCount;
132	>	property PurgeCount: TStringList read GetPurgeCount;
133	>	property ReadIdxCount: TStringList read GetReadIdxCount;
134	>	property ReadSeqCount: TStringList read GetReadSeqCount;
135	>	property UpdateCount: TStringList read GetUpdateCount;
136	>	property DBSQLDialect : Long read GetDBSQLDialect;
137	>	property PagesUsed: Long read GetPagesUsed;
138	>	property PagesFree: Long read GetPagesFree;
139	>	property ReadOnly: Long read GetReadOnly;
140	>	published
141	>	property Database: TIBDatabase read FDatabase write FDatabase;
142	>	end;
143	>
144	>	implementation
145	>
146	>	uses
147	>	FBMessages;
148	>
149	>	{ TIBDatabaseInfo }
150	>
151	>	constructor TIBDatabaseInfo.Create(AOwner: TComponent);
152	>	begin
153	>	inherited Create(AOwner);
154	>	FUserNames := TStringList.Create;
155	>	FBackoutCount                        := nil;
156	>	FDeleteCount                         := nil;
157	>	FExpungeCount                        := nil;
158	>	FInsertCount                         := nil;
159	>	FPurgeCount                          := nil;
160	>	FReadIdxCount                        := nil;
161	>	FReadSeqCount                        := nil;
162	>	FUpdateCount                         := nil;
163	>	end;
164	>
165	>	destructor TIBDatabaseInfo.Destroy;
166	>	begin
167	>	if assigned(FUserNames) then FUserNames.Free;
168	>	if assigned(FBackoutCount) then FBackoutCount.Free;
169	>	if assigned(FDeleteCount) then FDeleteCount.Free;
170	>	if assigned(FExpungeCount) then FExpungeCount.Free;
171	>	if assigned(FInsertCount) then FInsertCount.Free;
172	>	if assigned(FPurgeCount) then FPurgeCount.Free;
173	>	if assigned(FReadIdxCount) then FReadIdxCount.Free;
174	>	if assigned(FReadSeqCount) then FReadSeqCount.Free;
175	>	if assigned(FUpdateCount) then FUpdateCount.Free;
176	>	inherited Destroy;
177	>	end;
178	>
179	>	function TIBDatabaseInfo.GetDateDBCreated: TDateTime;
180	>	begin
181	>	CheckDatabase;
182	>	with Database.Attachment.GetDBInformation([isc_info_creation_date]) do
183	>	if (Count > 0) and (Items[0].GetItemType = isc_info_creation_date) then
184	>	Result := Items[0].GetAsDateTime
185	>	else
186	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
187	>	end;
188	>
189	>	function TIBDatabaseInfo.GetEncrypted: boolean;
190	>	var ConnFlags: Long;
191	>	begin
192	>	Result := ODSMajorVersion >= 12;
193	>	if Result then
194	>	try
195	>	ConnFlags := GetLongDatabaseInfo(fb_info_conn_flags);
196	>	Result := (ConnFlags and fb_info_crypt_encrypted) <> 0;
197	>	except
198	>	Result := false; {Introduced in Firebird 3.0.3}
199	>	end;
200	>	end;
201	>
202	>	function TIBDatabaseInfo.GetEncryptionKeyName: string;
203	>	begin
204	>	CheckDatabase;
205	>	{Introduced in Firebird 3.0.3}
206	>	with Database.Attachment.GetDBInformation([fb_info_crypt_key]) do
207	>	if (Count > 0) and (Items[0].GetItemType = fb_info_crypt_key) then
208	>	Result := Items[0].AsString
209	>	else
210	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
211	>	end;
212	>
213	>	function TIBDatabaseInfo.GetPagesFree: Long;
214	>	begin
215	>	result := GetLongDatabaseInfo(fb_info_pages_used);
216	>	end;
217	>
218	>	function TIBDatabaseInfo.GetPagesUsed: Long;
219	>	begin
220	>	result := GetLongDatabaseInfo(fb_info_pages_free);
221	>	end;
222	>
223	>	function TIBDatabaseInfo.GetTransactionCount: Long;
224	>	begin
225	>	result := GetLongDatabaseInfo(isc_info_active_tran_count);
226	>	end;
227	>
228	>	procedure TIBDatabaseInfo.CheckDatabase;
229	>	begin
230	>	if Database = nil then
231	>	IBError(ibxeDatabaseNotAssigned,[]);
232	>	if Database.Attachment = nil then
233	>	IBError(ibxeDatabaseClosed,[]);
234	>	end;
235	>
236	>	function TIBDatabaseInfo.GetAllocation: Long;
237	>	begin
238	>	result := GetLongDatabaseInfo(isc_info_allocation);
239	>	end;
240	>
241	>	function TIBDatabaseInfo.GetBaseLevel: Long;
242	>	var Response: TByteArray;
243	>	begin
244	>	CheckDatabase;
245	>	with Database.Attachment.GetDBInformation([isc_info_base_level]) do
246	>	if (Count > 0) and (Items[0].GetItemType = isc_info_base_level) then
247	>	begin
248	>	Response := Items[0].GetAsBytes;
249	>	Result := Response[1];
250	>	end
251	>	else
252	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
253	>	end;
254	>
255	>	function TIBDatabaseInfo.GetDBFileName: String;
256	>	var
257	>	ConnectionType: integer;
258	>	SiteName: string;
259	>	begin
260	>	CheckDatabase;
261	>	with Database.Attachment.GetDBInformation([isc_info_db_id]) do
262	>	if (Count > 0) and (Items[0].GetItemType = isc_info_db_id) then
263	>	Items[0].DecodeIDCluster(ConnectionType,Result,SiteName)
264	>	else
265	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
266	>	end;
267	>
268	>	function TIBDatabaseInfo.GetDBSiteName: String;
269	>	var
270	>	ConnectionType: integer;
271	>	FileName: string;
272	>	begin
273	>	CheckDatabase;
274	>	with Database.Attachment.GetDBInformation([isc_info_db_id]) do
275	>	if (Count > 0) and (Items[0].GetItemType = isc_info_db_id) then
276	>	Items[0].DecodeIDCluster(ConnectionType,FileName,Result)
277	>	else
278	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
279	>	end;
280	>
281	>	function TIBDatabaseInfo.GetDBImplementationNo: Long;
282	>	var Response: TByteArray;
283	>	begin
284	>	CheckDatabase;
285	>	with Database.Attachment.GetDBInformation([isc_info_implementation]) do
286	>	if (Count > 0) and (Items[0].GetItemType = isc_info_implementation) then
287	>	begin
288	>	Response := Items[0].GetAsBytes;
289	>	Result := Response[1];
290	>	end
291	>	else
292	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
293	>	end;
294	>
295	>	function TIBDatabaseInfo.GetDBImplementationClass: Long;
296	>	var Response: TByteArray;
297	>	begin
298	>	CheckDatabase;
299	>	with Database.Attachment.GetDBInformation([isc_info_implementation]) do
300	>	if (Count > 0) and (Items[0].GetItemType = isc_info_implementation) then
301	>	begin
302	>	Response := Items[0].GetAsBytes;
303	>	Result := Response[2];
304	>	end
305	>	else
306	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
307	>	end;
308	>
309	>	function TIBDatabaseInfo.GetNoReserve: Long;
310	>	begin
311	>	result := GetLongDatabaseInfo(isc_info_no_reserve);
312	>	end;
313	>
314	>	function TIBDatabaseInfo.GetODSMinorVersion: Long;
315	>	begin
316	>	CheckDatabase;
317	>	Result := Database.Attachment.GetODSMinorVersion;
318	>	end;
319	>
320	>	function TIBDatabaseInfo.GetODSMajorVersion: Long;
321	>	begin
322	>	CheckDatabase;
323	>	Result := Database.Attachment.GetODSMajorVersion;
324	>	end;
325	>
326	>	function TIBDatabaseInfo.GetPageSize: Long;
327	>	begin
328	>	result := GetLongDatabaseInfo(isc_info_page_size);
329	>	end;
330	>
331	>	function TIBDatabaseInfo.GetVersion: String;
332	>	var Version: byte;
333	>	begin
334	>	CheckDatabase;
335	>	with Database.Attachment.GetDBInformation([isc_info_version]) do
336	>	if (Count > 0) and (Items[0].GetItemType = isc_info_version) then
337	>	Items[0].DecodeVersionString(Version,Result)
338	>	else
339	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
340	>	end;
341	>
342	>	function TIBDatabaseInfo.GetCurrentMemory: Long;
343	>	begin
344	>	result := GetLongDatabaseInfo(isc_info_current_memory);
345	>	end;
346	>
347	>	function TIBDatabaseInfo.GetForcedWrites: Long;
348	>	begin
349	>	result := GetLongDatabaseInfo(isc_info_forced_writes);
350	>	end;
351	>
352	>	function TIBDatabaseInfo.GetMaxMemory: Long;
353	>	begin
354	>	result := GetLongDatabaseInfo(isc_info_max_memory);
355	>	end;
356	>
357	>	function TIBDatabaseInfo.GetNumBuffers: Long;
358	>	begin
359	>	result := GetLongDatabaseInfo(isc_info_num_buffers);
360	>	end;
361	>
362	>	function TIBDatabaseInfo.GetSweepInterval: Long;
363	>	begin
364	>	result := GetLongDatabaseInfo(isc_info_sweep_interval);
365	>	end;
366	>
367	>	function TIBDatabaseInfo.GetUserNames: TStringList;
368	>	begin
369	>	CheckDatabase;
370	>	Result := FUserNames;
371	>	FUserNames.Clear;
372	>	with Database.Attachment.GetDBInformation([isc_info_user_names]) do
373	>	if (Count > 0) and (Items[0].GetItemType = isc_info_user_names) then
374	>	Items[0].DecodeUserNames(Result)
375	>	else
376	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
377	>	end;
378	>
379	>	function TIBDatabaseInfo.GetFetches: Long;
380	>	begin
381	>	result := GetLongDatabaseInfo(isc_info_fetches);
382	>	end;
383	>
384	>	function TIBDatabaseInfo.GetMarks: Long;
385	>	begin
386	>	result := GetLongDatabaseInfo(isc_info_marks);
387	>	end;
388	>
389	>	function TIBDatabaseInfo.GetReads: Long;
390	>	begin
391	>	result := GetLongDatabaseInfo(isc_info_reads);
392	>	end;
393	>
394	>	function TIBDatabaseInfo.GetWrites: Long;
395	>	begin
396	>	result := GetLongDatabaseInfo(isc_info_writes);
397	>	end;
398	>
399	>	function TIBDatabaseInfo.GetOperationCounts(DBInfoCommand: Integer;
400	>	var FOperation: TStringList): TStringList;
401	>	var opCounts: TDBOperationCounts;
402	>	i: integer;
403	>	begin
404	>	CheckDatabase;
405	>	if FOperation = nil then FOperation := TStringList.Create;
406	>	result := FOperation;
407	>	with Database.Attachment.GetDBInformation([DBInfoCommand]) do
408	>	if (Count > 0) and (Items[0].GetItemType = DBInfoCommand) then
409	>	opCounts := Items[0].getOperationCounts
410	>	else
411	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
412	>	for i := 0 to Length(opCounts) - 1 do
413	>	FOperation.Add(IntToStr(opCounts[i].TableID) +'='+IntToStr(opCounts[i].Count));
414	>	end;
415	>
416	>	function TIBDatabaseInfo.GetBackoutCount: TStringList;
417	>	begin
418	>	result := GetOperationCounts(isc_info_backout_count,FBackoutCount);
419	>	end;
420	>
421	>	function TIBDatabaseInfo.GetDeleteCount: TStringList;
422	>	begin
423	>	result := GetOperationCounts(isc_info_delete_count,FDeleteCount);
424	>	end;
425	>
426	>	function TIBDatabaseInfo.GetExpungeCount: TStringList;
427	>	begin
428	>	result := GetOperationCounts(isc_info_expunge_count,FExpungeCount);
429	>	end;
430	>
431	>	function TIBDatabaseInfo.GetInsertCount: TStringList;
432	>	begin
433	>	result := GetOperationCounts(isc_info_insert_count,FInsertCount);
434	>	end;
435	>
436	>	function TIBDatabaseInfo.GetPurgeCount: TStringList;
437	>	begin
438	>	result := GetOperationCounts(isc_info_purge_count,FPurgeCount);
439	>	end;
440	>
441	>	function TIBDatabaseInfo.GetReadIdxCount: TStringList;
442	>	begin
443	>	result := GetOperationCounts(isc_info_read_idx_count,FReadIdxCount);
444	>	end;
445	>
446	>	function TIBDatabaseInfo.GetReadSeqCount: TStringList;
447	>	begin
448	>	result := GetOperationCounts(isc_info_read_seq_count,FReadSeqCount);
449	>	end;
450	>
451	>	function TIBDatabaseInfo.GetUpdateCount: TStringList;
452	>	begin
453	>	result := GetOperationCounts(isc_info_update_count,FUpdateCount);
454	>	end;
455	>
456	>	function TIBDatabaseInfo.GetReadOnly: Long;
457	>	begin
458	>	result := GetLongDatabaseInfo(isc_info_db_read_only);
459	>	end;
460	>
461	>	function TIBDatabaseInfo.GetLongDatabaseInfo(DatabaseInfoCommand: Integer): Long;
462	>	begin
463	>	CheckDatabase;
464	>	with Database.Attachment.GetDBInformation([DatabaseInfoCommand]) do
465	>	if (Count > 0) and (Items[0].GetItemType = DatabaseInfoCommand) then
466	>	Result := Items[0].AsInteger
467	>	else
468	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
469	>	end;
470	>
471	>	function TIBDatabaseInfo.GetDatabasePage(PageNo: integer): string;
472	>	var DBRequest: IDIRB;
473	>	begin
474	>	DBRequest := Database.Attachment.AllocateDIRB;
475	>	DBRequest.Add(fb_info_page_contents).AsInteger := PageNo;
476	>	with Database.Attachment.GetDBInformation(DBRequest) do
477	>	if (Count > 0) and (Items[0].GetItemType = fb_info_page_contents) then
478	>	Result := Items[0].AsString
479	>	else
480	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
481	>	end;
482	>
483	>	function TIBDatabaseInfo.GetStringDatabaseInfo(DatabaseInfoCommand: Integer): String;
484	>	begin
485	>	CheckDatabase;
486	>	with Database.Attachment.GetDBInformation([DatabaseInfoCommand]) do
487	>	if (Count > 0) and (Items[0].GetItemType = DatabaseInfoCommand) then
488	>	Result := Items[0].AsString
489	>	else
490	>	IBError(ibxeUnexpectedDatabaseInfoResp,[nil]);
491	>	end;
492	>
493	>
494	>	function TIBDatabaseInfo.GetDBSQLDialect: Long;
495	>	begin
496	>	CheckDatabase;
497	>	with Database.Attachment.GetDBInformation([isc_info_db_SQL_Dialect]) do
498	>	if (Count > 0) and (Items[0].GetItemType = isc_info_db_SQL_Dialect) then
499	>	Result := Items[0].AsInteger
500	>	else
501	>	Result := 1;
502	>	end;
503	>
504	>
505	>	end.

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines