examples/dbInfo/Unit1.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*) 
            
unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  IB, IBDatabase, IBDatabaseInfo, IBQuery, IBExternals;

type

  { TForm1 }

  TForm1 = class(TForm)
    IBDatabase1: TIBDatabase;
    IBDatabaseInfo1: TIBDatabaseInfo;
    IBTransaction1: TIBTransaction;
    Memo1: TMemo;
    TableNameLookup: TIBQuery;
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1AfterConnect(Sender: TObject);
  private
    procedure AddPerfStats(Heading: string; stats: TStrings);
    { private declarations }
    procedure ShowBoolValue(aValue: Long; WhenTrue, WhenFalse: string);
    procedure ShowStrings(aCaption: string; List: TStrings);
    function HexString(s: AnsiString): string;
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormShow(Sender: TObject);
begin
  Memo1.Lines.Clear;
  repeat
    try
      IBDatabase1.Connected := true;
    except
     on E:EIBClientError do
      begin
        Close;
        Exit
      end;
    On E:Exception do
     MessageDlg(E.Message,mtError,[mbOK],0);
    end;
  until IBDatabase1.Connected;
end;

procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
begin
  IBTransaction1.Active := true;
  TableNameLookup.Active := true;
  Memo1.Lines.Add('Authentication Method = '+ IBDatabase1.AuthenticationMethod);
  Memo1.Lines.Add('Remote Protocol = ' + IBDatabase1.RemoteProtocol);
  Memo1.Lines.Add('Attachment SQLDialect = ' + IntToStr(IBDatabase1.DBSQLDialect));
  with IBDatabaseInfo1 do
  begin
    Memo1.Lines.Add('DB SQLDialect = ' + IntToStr(DBSQLDialect));
    Memo1.Lines.Add('Allocation = ' + IntToStr(Allocation));
    Memo1.Lines.Add('Base Level = ' + IntToStr(BaseLevel));
    Memo1.Lines.Add('DB File Name = ' + DBFileName);
    Memo1.Lines.Add('DB Site Name = ' + DBSiteName);
    Memo1.Lines.Add('DB Implementation No = ' + IntToStr(DBImplementationNo));
    Memo1.Lines.Add('Database Created: ' + DateTimeToStr(DateDBCreated));
    Memo1.Lines.Add('DB Implementation Class = ' + IntToStr(DBImplementationClass));
    ShowBoolValue(NoReserve, 'No Space Reserved','Space is Reserved');
    Memo1.Lines.Add('ODS Minor Version = ' + IntToStr(ODSMinorVersion));
    Memo1.Lines.Add('ODS Major Version = ' + IntToStr(ODSMajorVersion));
    Memo1.Lines.Add('Page Size = ' + IntToStr(PageSize));
    Memo1.Lines.Add('Version = ' + Version);
    Memo1.Lines.Add('Current Memory = ' + IntToStr(CurrentMemory));
    ShowBoolValue(ForcedWrites,'Forced Writes Enabled','Forced Writes Disabled');
    Memo1.Lines.Add('Max Memory = ' + IntToStr(MaxMemory));
    Memo1.Lines.Add('Number of Buffers = ' + IntToStr(NumBuffers));
    Memo1.Lines.Add('Sweep Interval = ' + IntToStr(SweepInterval));
    ShowStrings('User Names',UserNames);
    Memo1.Lines.Add('Fetches = ' + IntToStr(Fetches));
    Memo1.Lines.Add('Marks = ' + IntToStr(Marks));
    Memo1.Lines.Add('Reads = ' + IntToStr(Reads));
    Memo1.Lines.Add('Writes = ' + IntToStr(Writes));
    if ODSMajorVersion >= 12 then
    begin
      Memo1.Lines.Add('Pages Free = ' + IntToStr(PagesFree));
      Memo1.Lines.Add('Pages Used = ' + IntToStr(PagesUsed));
    end;
    Memo1.Lines.Add('Transaction Count = ' + IntToStr(TransactionCount));
    AddPerfStats('Backout Count',BackoutCount);
    AddPerfStats('Delete Count',DeleteCount);
    AddPerfStats('Expunge Count',ExpungeCount);
    AddPerfStats('Insert Count',InsertCount);
    AddPerfStats('Purge Count',PurgeCount);
    AddPerfStats('Read Idx Count',ReadIdxCount);
    AddPerfStats('Read Seq Count',ReadSeqCount);
    AddPerfStats('Update Count',UpdateCount);
    Memo1.Lines.Add('');
    ShowBoolValue(ReadOnly,'Database is Read Only','Database is Read/Write');
    Memo1.Lines.Add('Hex Dump of Database Page 100:');
    Memo1.Lines.Add(HexString(GetDatabasePage(100)));
  end;
end;

procedure TForm1.ShowBoolValue(aValue: Long; WhenTrue, WhenFalse: string);
begin
  if aValue <> 0 then
    Memo1.Lines.Add(WhenTrue)
  else
    Memo1.Lines.Add(WhenFalse);
end;

procedure TForm1.ShowStrings(aCaption: string; List: TStrings);
var s: string;
    i: integer;
begin
  s := aCaption + ': ';
  for i := 0 to List.Count - 1 do
  begin
    if i > 0 then
      s := s + ', ';
    s := s + List[i];
  end;
  Memo1.Lines.Add(s);
end;

function TForm1.HexString(s: AnsiString): string;
var i: integer;
begin
  Result := '';
  for i := 1 to length(s) do
    Result += Format('%x ',[byte(s[i])]);
end;

procedure TForm1.AddPerfStats(Heading: string;
  stats: TStrings);
var i: integer;
begin
  with Memo1.Lines do
  begin
    if stats.count = 0 then exit;
    Add('');
    Add(Heading);
    for i := 0 to stats.Count - 1 do
    begin
      if TableNameLookup.Locate('RDB$RELATION_ID',stats.Names[i],[]) then
        Add('  ' + TableNameLookup.FieldByName('RDB$RELATION_NAME').AsString + ' = ' + stats.ValueFromIndex[i]);
    end;
  end;
end;


end.

Revision:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	5808 byte(s)
Log Message:	Fixes Merged
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26
27	unit Unit1;
28
29	{$mode objfpc}{$H+}
30
31	interface
32
33	uses
34	Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
35	IB, IBDatabase, IBDatabaseInfo, IBQuery, IBExternals;
36
37	type
38
39	{ TForm1 }
40
41	TForm1 = class(TForm)
42	IBDatabase1: TIBDatabase;
43	IBDatabaseInfo1: TIBDatabaseInfo;
44	IBTransaction1: TIBTransaction;
45	Memo1: TMemo;
46	TableNameLookup: TIBQuery;
47	procedure FormShow(Sender: TObject);
48	procedure IBDatabase1AfterConnect(Sender: TObject);
49	private
50	procedure AddPerfStats(Heading: string; stats: TStrings);
51	{ private declarations }
52	procedure ShowBoolValue(aValue: Long; WhenTrue, WhenFalse: string);
53	procedure ShowStrings(aCaption: string; List: TStrings);
54	function HexString(s: AnsiString): string;
55	public
56	{ public declarations }
57	end;
58
59	var
60	Form1: TForm1;
61
62	implementation
63
64	{$R *.lfm}
65
66	{ TForm1 }
67
68	procedure TForm1.FormShow(Sender: TObject);
69	begin
70	Memo1.Lines.Clear;
71	repeat
72	try
73	IBDatabase1.Connected := true;
74	except
75	on E:EIBClientError do
76	begin
77	Close;
78	Exit
79	end;
80	On E:Exception do
81	MessageDlg(E.Message,mtError,[mbOK],0);
82	end;
83	until IBDatabase1.Connected;
84	end;
85
86	procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
87	begin
88	IBTransaction1.Active := true;
89	TableNameLookup.Active := true;
90	Memo1.Lines.Add('Authentication Method = '+ IBDatabase1.AuthenticationMethod);
91	Memo1.Lines.Add('Remote Protocol = ' + IBDatabase1.RemoteProtocol);
92	Memo1.Lines.Add('Attachment SQLDialect = ' + IntToStr(IBDatabase1.DBSQLDialect));
93	with IBDatabaseInfo1 do
94	begin
95	Memo1.Lines.Add('DB SQLDialect = ' + IntToStr(DBSQLDialect));
96	Memo1.Lines.Add('Allocation = ' + IntToStr(Allocation));
97	Memo1.Lines.Add('Base Level = ' + IntToStr(BaseLevel));
98	Memo1.Lines.Add('DB File Name = ' + DBFileName);
99	Memo1.Lines.Add('DB Site Name = ' + DBSiteName);
100	Memo1.Lines.Add('DB Implementation No = ' + IntToStr(DBImplementationNo));
101	Memo1.Lines.Add('Database Created: ' + DateTimeToStr(DateDBCreated));
102	Memo1.Lines.Add('DB Implementation Class = ' + IntToStr(DBImplementationClass));
103	ShowBoolValue(NoReserve, 'No Space Reserved','Space is Reserved');
104	Memo1.Lines.Add('ODS Minor Version = ' + IntToStr(ODSMinorVersion));
105	Memo1.Lines.Add('ODS Major Version = ' + IntToStr(ODSMajorVersion));
106	Memo1.Lines.Add('Page Size = ' + IntToStr(PageSize));
107	Memo1.Lines.Add('Version = ' + Version);
108	Memo1.Lines.Add('Current Memory = ' + IntToStr(CurrentMemory));
109	ShowBoolValue(ForcedWrites,'Forced Writes Enabled','Forced Writes Disabled');
110	Memo1.Lines.Add('Max Memory = ' + IntToStr(MaxMemory));
111	Memo1.Lines.Add('Number of Buffers = ' + IntToStr(NumBuffers));
112	Memo1.Lines.Add('Sweep Interval = ' + IntToStr(SweepInterval));
113	ShowStrings('User Names',UserNames);
114	Memo1.Lines.Add('Fetches = ' + IntToStr(Fetches));
115	Memo1.Lines.Add('Marks = ' + IntToStr(Marks));
116	Memo1.Lines.Add('Reads = ' + IntToStr(Reads));
117	Memo1.Lines.Add('Writes = ' + IntToStr(Writes));
118	if ODSMajorVersion >= 12 then
119	begin
120	Memo1.Lines.Add('Pages Free = ' + IntToStr(PagesFree));
121	Memo1.Lines.Add('Pages Used = ' + IntToStr(PagesUsed));
122	end;
123	Memo1.Lines.Add('Transaction Count = ' + IntToStr(TransactionCount));
124	AddPerfStats('Backout Count',BackoutCount);
125	AddPerfStats('Delete Count',DeleteCount);
126	AddPerfStats('Expunge Count',ExpungeCount);
127	AddPerfStats('Insert Count',InsertCount);
128	AddPerfStats('Purge Count',PurgeCount);
129	AddPerfStats('Read Idx Count',ReadIdxCount);
130	AddPerfStats('Read Seq Count',ReadSeqCount);
131	AddPerfStats('Update Count',UpdateCount);
132	Memo1.Lines.Add('');
133	ShowBoolValue(ReadOnly,'Database is Read Only','Database is Read/Write');
134	Memo1.Lines.Add('Hex Dump of Database Page 100:');
135	Memo1.Lines.Add(HexString(GetDatabasePage(100)));
136	end;
137	end;
138
139	procedure TForm1.ShowBoolValue(aValue: Long; WhenTrue, WhenFalse: string);
140	begin
141	if aValue <> 0 then
142	Memo1.Lines.Add(WhenTrue)
143	else
144	Memo1.Lines.Add(WhenFalse);
145	end;
146
147	procedure TForm1.ShowStrings(aCaption: string; List: TStrings);
148	var s: string;
149	i: integer;
150	begin
151	s := aCaption + ': ';
152	for i := 0 to List.Count - 1 do
153	begin
154	if i > 0 then
155	s := s + ', ';
156	s := s + List[i];
157	end;
158	Memo1.Lines.Add(s);
159	end;
160
161	function TForm1.HexString(s: AnsiString): string;
162	var i: integer;
163	begin
164	Result := '';
165	for i := 1 to length(s) do
166	Result += Format('%x ',[byte(s[i])]);
167	end;
168
169	procedure TForm1.AddPerfStats(Heading: string;
170	stats: TStrings);
171	var i: integer;
172	begin
173	with Memo1.Lines do
174	begin
175	if stats.count = 0 then exit;
176	Add('');
177	Add(Heading);
178	for i := 0 to stats.Count - 1 do
179	begin
180	if TableNameLookup.Locate('RDB$RELATION_ID',stats.Names[i],[]) then
181	Add(' ' + TableNameLookup.FieldByName('RDB$RELATION_NAME').AsString + ' = ' + stats.ValueFromIndex[i]);
182	end;
183	end;
184	end;
185
186
187	end.
188