ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/dbInfo/Unit1.pas
Revision: 380
Committed: Mon Jan 10 10:13:17 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 6073 byte(s)
Log Message:
propset for eol-style

File Contents

# 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 var S: TStrings;
88 begin
89 IBTransaction1.Active := true;
90 TableNameLookup.Active := true;
91 Memo1.Lines.Add('Authentication Method = '+ IBDatabase1.AuthenticationMethod);
92 Memo1.Lines.Add('Remote Protocol = ' + IBDatabase1.RemoteProtocol);
93 Memo1.Lines.Add('Attachment SQLDialect = ' + IntToStr(IBDatabase1.DBSQLDialect));
94 S := TStringList.Create;
95 try
96 IBDatabase1.Attachment.getFBVersion(S);
97 Memo1.Lines.AddStrings(S);
98 finally
99 S.Free;
100 end;
101 with IBDatabaseInfo1 do
102 begin
103 Memo1.Lines.Add('Firebird Library Pathname = ' + IBDatabase1.FirebirdAPI.GetFBLibrary.GetLibraryFilePath);
104 Memo1.Lines.Add('DB SQLDialect = ' + IntToStr(DBSQLDialect));
105 Memo1.Lines.Add('Allocation = ' + IntToStr(Allocation));
106 Memo1.Lines.Add('Base Level = ' + IntToStr(BaseLevel));
107 Memo1.Lines.Add('DB File Name = ' + DBFileName);
108 Memo1.Lines.Add('DB Site Name = ' + DBSiteName);
109 Memo1.Lines.Add('DB Implementation No = ' + IntToStr(DBImplementationNo));
110 Memo1.Lines.Add('Database Created: ' + DateTimeToStr(DateDBCreated));
111 Memo1.Lines.Add('DB Implementation Class = ' + IntToStr(DBImplementationClass));
112 ShowBoolValue(NoReserve, 'No Space Reserved','Space is Reserved');
113 Memo1.Lines.Add('ODS Minor Version = ' + IntToStr(ODSMinorVersion));
114 Memo1.Lines.Add('ODS Major Version = ' + IntToStr(ODSMajorVersion));
115 Memo1.Lines.Add('Page Size = ' + IntToStr(PageSize));
116 Memo1.Lines.Add('Version = ' + Version);
117 Memo1.Lines.Add('Current Memory = ' + IntToStr(CurrentMemory));
118 ShowBoolValue(ForcedWrites,'Forced Writes Enabled','Forced Writes Disabled');
119 Memo1.Lines.Add('Max Memory = ' + IntToStr(MaxMemory));
120 Memo1.Lines.Add('Number of Buffers = ' + IntToStr(NumBuffers));
121 Memo1.Lines.Add('Sweep Interval = ' + IntToStr(SweepInterval));
122 ShowStrings('User Names',UserNames);
123 Memo1.Lines.Add('Fetches = ' + IntToStr(Fetches));
124 Memo1.Lines.Add('Marks = ' + IntToStr(Marks));
125 Memo1.Lines.Add('Reads = ' + IntToStr(Reads));
126 Memo1.Lines.Add('Writes = ' + IntToStr(Writes));
127 if ODSMajorVersion >= 12 then
128 begin
129 Memo1.Lines.Add('Pages Free = ' + IntToStr(PagesFree));
130 Memo1.Lines.Add('Pages Used = ' + IntToStr(PagesUsed));
131 end;
132 Memo1.Lines.Add('Transaction Count = ' + IntToStr(TransactionCount));
133 AddPerfStats('Backout Count',BackoutCount);
134 AddPerfStats('Delete Count',DeleteCount);
135 AddPerfStats('Expunge Count',ExpungeCount);
136 AddPerfStats('Insert Count',InsertCount);
137 AddPerfStats('Purge Count',PurgeCount);
138 AddPerfStats('Read Idx Count',ReadIdxCount);
139 AddPerfStats('Read Seq Count',ReadSeqCount);
140 AddPerfStats('Update Count',UpdateCount);
141 Memo1.Lines.Add('');
142 ShowBoolValue(ReadOnly,'Database is Read Only','Database is Read/Write');
143 Memo1.Lines.Add('Hex Dump of Database Page 100:');
144 Memo1.Lines.Add(HexString(GetDatabasePage(100)));
145 end;
146 end;
147
148 procedure TForm1.ShowBoolValue(aValue: Long; WhenTrue, WhenFalse: string);
149 begin
150 if aValue <> 0 then
151 Memo1.Lines.Add(WhenTrue)
152 else
153 Memo1.Lines.Add(WhenFalse);
154 end;
155
156 procedure TForm1.ShowStrings(aCaption: string; List: TStrings);
157 var s: string;
158 i: integer;
159 begin
160 s := aCaption + ': ';
161 for i := 0 to List.Count - 1 do
162 begin
163 if i > 0 then
164 s := s + ', ';
165 s := s + List[i];
166 end;
167 Memo1.Lines.Add(s);
168 end;
169
170 function TForm1.HexString(s: AnsiString): string;
171 var i: integer;
172 begin
173 Result := '';
174 for i := 1 to length(s) do
175 Result += Format('%x ',[byte(s[i])]);
176 end;
177
178 procedure TForm1.AddPerfStats(Heading: string;
179 stats: TStrings);
180 var i: integer;
181 begin
182 with Memo1.Lines do
183 begin
184 if stats.count = 0 then exit;
185 Add('');
186 Add(Heading);
187 for i := 0 to stats.Count - 1 do
188 begin
189 if TableNameLookup.Locate('RDB$RELATION_ID',stats.Names[i],[]) then
190 Add(' ' + TableNameLookup.FieldByName('RDB$RELATION_NAME').AsString + ' = ' + stats.ValueFromIndex[i]);
191 end;
192 end;
193 end;
194
195
196 end.
197

Properties

Name Value
svn:eol-style native