ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/testsuite/FBTestApp.pas
Revision: 333
Committed: Fri Feb 26 16:34:26 2021 UTC (16 months ago) by tony
File size: 6969 byte(s)
Log Message:
Add missing files
Line File contents
1 (*
2 * Firebird Interface (fbintf) Test suite. This program is used to
3 * test the Firebird Pascal Interface and provide a semi-automated
4 * pass/fail check for each test.
5 *
6 * The contents of this file are subject to the Initial Developer's
7 * Public License Version 1.0 (the "License"); you may not use this
8 * file except in compliance with the License. You may obtain a copy
9 * of the License here:
10 *
11 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
12 *
13 * Software distributed under the License is distributed on an "AS
14 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
15 * implied. See the License for the specific language governing rights
16 * and limitations under the License.
17 *
18 * The Initial Developer of the Original Code is Tony Whyman.
19 *
20 * The Original Code is (C) 2016-2020 Tony Whyman, MWA Software
21 * (http://www.mwasoftware.co.uk).
22 *
23 * All Rights Reserved.
24 *
25 * Contributor(s): ______________________________________.
26 *
27 *)
28 unit FBTestApp;
29
30 {$IFDEF MSWINDOWS}
31 {$DEFINE WINDOWS}
32 {$ENDIF}
33
34 {$IFDEF FPC}
35 {$mode delphi}
36 {$codepage utf8}
37 {$ENDIF}
38
39 interface
40
41 uses
42 Classes, SysUtils, TestApplication, IB;
43
44 type
45
46 { TFBTestBase }
47
48 TFBTestBase = class(TTestBase)
49 protected
50 function GetTestID: AnsiString; override;
51 function GetTestTitle: AnsiString; override;
52 function WriteServiceQueryResult(QueryResult: IServiceQueryResults): boolean;
53 procedure writeLicence(Item: IServiceQueryResultItem);
54 procedure WriteConfig(config: IServiceQueryResultItem);
55 procedure WriteUsers(users: IServiceQueryResultItem);
56 procedure WriteDBAttachments(att: IServiceQueryResultItem);
57 procedure WriteLimboTransactions(limbo: IServiceQueryResultItem);
58 end;
59
60 implementation
61
62 function TFBTestBase.GetTestID: AnsiString;
63 var s: AnsiString;
64 i,j: integer;
65 begin
66 i := 1;
67 s := TestTitle;
68 while not (s[i] in ['0'..'9']) and (i <= Length(s)) do inc(i);
69 j := i + 1;
70 while (s[j] in ['0'..'9']) and (i <= Length(s)) do inc(j);
71 Result := system.copy(s,i,j-i);
72 if Length(Result) = 1 then
73 Result := '0' + Result;
74 end;
75
76 function TFBTestBase.GetTestTitle: AnsiString;
77 begin
78 Result := '';
79 end;
80
81 function TFBTestBase.WriteServiceQueryResult(QueryResult: IServiceQueryResults): boolean;
82 var i: integer;
83 line: AnsiString;
84 begin
85 Result := true;
86 for i := 0 to QueryResult.GetCount - 1 do
87 with QueryResult[i] do
88 case getItemType of
89 isc_info_svc_version:
90 writeln(OutFile,'Service Manager Version = ',getAsInteger);
91 isc_info_svc_server_version:
92 writeln(OutFile,'Server Version = ',getAsString);
93 isc_info_svc_implementation:
94 writeln(OutFile,'Implementation = ',getAsString);
95 isc_info_svc_get_license:
96 writeLicence(QueryResult[i]);
97 isc_info_svc_get_license_mask:
98 writeln(OutFile,'Licence Mask = ',getAsInteger);
99 isc_info_svc_capabilities:
100 writeln(OutFile,'Capabilities = ',getAsInteger);
101 isc_info_svc_get_config:
102 WriteConfig(QueryResult[i]);
103 isc_info_svc_get_env:
104 writeln(OutFile,'Root Directory = ',getAsString);
105 isc_info_svc_get_env_lock:
106 writeln(OutFile,'Lock Directory = ',getAsString);
107 isc_info_svc_get_env_msg:
108 writeln(OutFile,'Message File = ',getAsString);
109 isc_info_svc_user_dbpath:
110 writeln(OutFile,'Security File = ',getAsString);
111 isc_info_svc_get_licensed_users:
112 writeln(OutFile,'Max Licenced Users = ',getAsInteger);
113 isc_info_svc_get_users:
114 WriteUsers(QueryResult[i]);
115 isc_info_svc_svr_db_info:
116 WriteDBAttachments(QueryResult[i]);
117 isc_info_svc_line:
118 begin
119 line := getAsString;
120 writeln(OutFile,line);
121 Result := line <> '';
122 end;
123 isc_info_svc_running:
124 writeln(OutFile,'Is Running = ',getAsInteger);
125 isc_info_svc_limbo_trans:
126 WriteLimboTransactions(QueryResult[i]);
127 isc_info_svc_to_eof,
128 isc_info_svc_timeout,
129 isc_info_truncated,
130 isc_info_data_not_ready,
131 isc_info_svc_stdin:
132 {ignore};
133 else
134 writeln(OutFile,'Unknown Service Response Item ', getItemType);
135 end;
136 writeln(OutFile);
137 end;
138
139 procedure TFBTestBase.writeLicence(Item: IServiceQueryResultItem);
140 var i: integer;
141 begin
142 for i := 0 to Item.getCount - 1 do
143 with Item[i] do
144 case getItemType of
145 isc_spb_lic_id:
146 writeln(OutFile,'Licence ID = ',GetAsString);
147 isc_spb_lic_key:
148 writeln(OutFile,'Licence Key = ',GetAsString);
149 end;
150 end;
151
152 procedure TFBTestBase.WriteConfig(config: IServiceQueryResultItem);
153 var i: integer;
154 begin
155 writeln(OutFile,'Firebird Configuration File');
156 for i := 0 to config.getCount - 1 do
157 writeln(OutFile,'Key = ',config[i].getItemType,', Value = ',config[i].getAsInteger);
158 writeln(OutFile);
159 end;
160
161 procedure TFBTestBase.WriteUsers(users: IServiceQueryResultItem);
162 var i: integer;
163 begin
164 writeln(OutFile,'Sec. Database User');
165 for i := 0 to users.getCount - 1 do
166 with users[i] do
167 case getItemType of
168 isc_spb_sec_username:
169 writeln(OutFile,'User Name = ',getAsString);
170 isc_spb_sec_firstname:
171 writeln(OutFile,'First Name = ',getAsString);
172 isc_spb_sec_middlename:
173 writeln(OutFile,'Middle Name = ',getAsString);
174 isc_spb_sec_lastname:
175 writeln(OutFile,'Last Name = ',getAsString);
176 isc_spb_sec_userid:
177 writeln(OutFile,'User ID = ',getAsInteger);
178 isc_spb_sec_groupid:
179 writeln(OutFile,'Group ID = ',getAsInteger);
180 else
181 writeln(OutFile,'Unknown user info ', getItemType);
182 end;
183 writeln(OutFile);
184 end;
185
186 procedure TFBTestBase.WriteDBAttachments(att: IServiceQueryResultItem);
187 var i: integer;
188 begin
189 writeln(OutFile,'DB Attachments');
190 for i := 0 to att.getCount - 1 do
191 with att[i] do
192 case getItemType of
193 isc_spb_num_att:
194 writeln(OutFile,'No. of Attachments = ',getAsInteger);
195 isc_spb_num_db:
196 writeln(OutFile,'Databases In Use = ',getAsInteger);
197 isc_spb_dbname:
198 writeln(OutFile,'DB Name = ',getAsString);
199 end;
200 end;
201
202 procedure TFBTestBase.WriteLimboTransactions(limbo: IServiceQueryResultItem);
203 var i: integer;
204 begin
205 writeln(OutFile,'Limbo Transactions');
206 for i := 0 to limbo.getCount - 1 do
207 with limbo[i] do
208 case getItemType of
209 isc_spb_single_tra_id:
210 writeln(OutFile,'Single DB Transaction = ',getAsInteger);
211 isc_spb_multi_tra_id:
212 writeln(OutFile,'Multi DB Transaction = ',getAsInteger);
213 isc_spb_tra_host_site:
214 writeln(OutFile,'Host Name = ',getAsString);
215 isc_spb_tra_advise:
216 writeln(OutFile,'Resolution Advisory = ',getAsInteger);
217 isc_spb_tra_remote_site:
218 writeln(OutFile,'Server Name = ',getAsString);
219 isc_spb_tra_db_path:
220 writeln(OutFile,'DB Primary File Name = ',getAsString);
221 isc_spb_tra_state:
222 begin
223 write(OutFile,'State = ');
224 case getAsInteger of
225 isc_spb_tra_state_limbo:
226 writeln(OutFile,'limbo');
227 isc_spb_tra_state_commit:
228 writeln(OutFile,'commit');
229 isc_spb_tra_state_rollback:
230 writeln(OutFile,'rollback');
231 isc_spb_tra_state_unknown:
232 writeln(OutFile,'Unknown');
233 end;
234 end;
235 end;
236 end;
237
238 end.
239