1 |
(* |
2 |
* IBX Test suite. This program is used to test the IBX non-visual |
3 |
* components and provides a semi-automated pass/fail check for each test. |
4 |
* |
5 |
* The contents of this file are subject to the Initial Developer's |
6 |
* Public License Version 1.0 (the "License"); you may not use this |
7 |
* file except in compliance with the License. You may obtain a copy |
8 |
* of the License here: |
9 |
* |
10 |
* http://www.firebirdsql.org/index.php?op=doc&id=idpl |
11 |
* |
12 |
* Software distributed under the License is distributed on an "AS |
13 |
* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or |
14 |
* implied. See the License for the specific language governing rights |
15 |
* and limitations under the License. |
16 |
* |
17 |
* The Initial Developer of the Original Code is Tony Whyman. |
18 |
* |
19 |
* The Original Code is (C) 2021 Tony Whyman, MWA Software |
20 |
* (http://www.mwasoftware.co.uk). |
21 |
* |
22 |
* All Rights Reserved. |
23 |
* |
24 |
* Contributor(s): ______________________________________. |
25 |
* |
26 |
*) |
27 |
unit Test05; |
28 |
|
29 |
{$mode objfpc}{$H+} |
30 |
|
31 |
{Test 5: Firebird 4 Data Types} |
32 |
|
33 |
interface |
34 |
|
35 |
uses |
36 |
Classes, SysUtils, TestApplication, IBXTestBase, DB, IB, IBCustomDataSet, |
37 |
IBDatabase, IBExtract; |
38 |
|
39 |
const |
40 |
aTestID = '05'; |
41 |
aTestTitle = 'Firebird 4 Data Types'; |
42 |
|
43 |
type |
44 |
|
45 |
{ TTest05 } |
46 |
|
47 |
TTest05 = class(TIBXTestBase) |
48 |
private |
49 |
FDataSet: TIBDataSet; |
50 |
FExtract: TIBExtract; |
51 |
procedure HandleExtractLine(Sender: TObject; start, count: integer); |
52 |
procedure HandleAfterInsert(DataSet: TDataSet); |
53 |
protected |
54 |
procedure CreateObjects(Application: TTestApplication); override; |
55 |
function GetTestID: AnsiString; override; |
56 |
function GetTestTitle: AnsiString; override; |
57 |
procedure InitTest; override; |
58 |
procedure InitialiseDatabase(aDatabase: TIBDatabase) override; |
59 |
function SkipTest: boolean; override; |
60 |
public |
61 |
procedure RunTest(CharSet: AnsiString; SQLDialect: integer); override; |
62 |
end; |
63 |
|
64 |
|
65 |
implementation |
66 |
|
67 |
uses FmtBCD, IBUtils; |
68 |
|
69 |
{ TTest05 } |
70 |
|
71 |
procedure TTest05.HandleExtractLine(Sender: TObject; start, count: integer); |
72 |
var i: integer; |
73 |
begin |
74 |
for i := 0 to count - 1 do |
75 |
writeln(OutFile,FExtract.Items[start + i]); |
76 |
end; |
77 |
|
78 |
procedure TTest05.HandleAfterInsert(DataSet: TDataSet); |
79 |
begin |
80 |
with DataSet do |
81 |
begin |
82 |
(FieldByName('F1') as TIBDateTimeField).SetAsDateTimeTZ(EncodeDate(1918,11,11) + FBEncodeTime(0,11,0,1111),'CET'); ; |
83 |
(FieldByName('f2') as TIBTimeField).SetAsDateTimeTZ(EncodeTime(22,02,10,5),'America/Los_Angeles'); |
84 |
FieldByName('F3').AsCurrency := 12345678912.12; |
85 |
FieldByName('f4').AsBCD := StrToBCD('64100000000.011'); |
86 |
FieldByName('F5').AsBCD := StrToBCD('123456123456123456123456.123456'); |
87 |
FieldByName('F6').AsBCD := StrToBCD('123456789123456789'); |
88 |
end; |
89 |
end; |
90 |
|
91 |
procedure TTest05.CreateObjects(Application: TTestApplication); |
92 |
begin |
93 |
inherited CreateObjects(Application); |
94 |
FDataSet := TIBDataSet.Create(Application); |
95 |
with FDataSet do |
96 |
begin |
97 |
Database := IBDatabase; |
98 |
SelectSQL.Text := 'Select * From IBXTEST A'; |
99 |
InsertSQL.Text := |
100 |
'Insert Into IBXTEST(TABLEKEY, F1, F2, F3, F4, F5, F6) Values(:TABLEKEY, :F1, :F2, :F3, :F4, :F5, :F6)'; |
101 |
RefreshSQL.Text := |
102 |
'Select * From IBXTEST A '+ |
103 |
'Where A.TABLEKEY = :TABLEKEY'; |
104 |
ModifySQL.Text := |
105 |
'Update IBXTEST A Set ' + |
106 |
' A.F1 = :F1,' + |
107 |
' A.F2 = :F2,' + |
108 |
' A.F3 = :F3,' + |
109 |
' A.F4 = :F4,' + |
110 |
' A.F5 = :F5,' + |
111 |
' A.F6 = :F6 ' + |
112 |
'Where A.TABLEKEY = :OLD_TABLEKEY'; |
113 |
DeleteSQL.Text := |
114 |
'Delete From IBXTEST A '+ |
115 |
'Where A.TABLEKEY = :OLD_TABLEKEY'; |
116 |
DataSetCloseAction := dcSaveChanges; |
117 |
AutoCommit := acCommitRetaining; |
118 |
GeneratorField.Generator := 'IBXGEN'; |
119 |
GeneratorField.Field := 'TABLEKEY'; |
120 |
GeneratorField.ApplyOnEvent := gaeOnNewRecord; |
121 |
AfterInsert := @HandleAfterInsert; |
122 |
end; |
123 |
FExtract := TIBExtract.Create(Application); |
124 |
FExtract.Database := IBDatabase; |
125 |
FExtract.Transaction := IBTransaction; |
126 |
FExtract.OnExtractLines := @HandleExtractLine; |
127 |
end; |
128 |
|
129 |
function TTest05.GetTestID: AnsiString; |
130 |
begin |
131 |
Result := aTestID; |
132 |
end; |
133 |
|
134 |
function TTest05.GetTestTitle: AnsiString; |
135 |
begin |
136 |
Result := aTestTitle; |
137 |
end; |
138 |
|
139 |
procedure TTest05.InitTest; |
140 |
begin |
141 |
IBDatabase.DatabaseName := Owner.GetNewDatabaseName; |
142 |
IBDatabase.CreateIfNotExists := true; |
143 |
ReadWriteTransaction; |
144 |
end; |
145 |
|
146 |
procedure TTest05.InitialiseDatabase(aDatabase: TIBDatabase); |
147 |
begin |
148 |
if aDatabase.attachment.GetODSMajorVersion < 13 then |
149 |
begin |
150 |
aDatabase.DropDatabase; |
151 |
raise ESkipException.Create('This test requires Firebird 4'); |
152 |
end; |
153 |
inherited InitialiseDatabase(aDatabase); |
154 |
end; |
155 |
|
156 |
function TTest05.SkipTest: boolean; |
157 |
begin |
158 |
Result := FirebirdAPI.GetClientMajor < 4; |
159 |
if Result then |
160 |
writeln(OutFile,'Skipping ',TestTitle); |
161 |
end; |
162 |
|
163 |
procedure TTest05.RunTest(CharSet: AnsiString; SQLDialect: integer); |
164 |
var OldDefaultFormatSettings: TFormatSettings; |
165 |
begin |
166 |
OldDefaultFormatSettings := DefaultFormatSettings; |
167 |
IBDatabase.Connected := true; |
168 |
try |
169 |
DefaultFormatSettings.LongTimeFormat := 'HH:MM:SS.zzzz'; |
170 |
IBTransaction.Active := true; |
171 |
FDataSet.Active := true; |
172 |
writeln(OutFile,'Extracting Database Schema'); |
173 |
FExtract.ExtractObject(eoDatabase,'',[etGrantsToUser]); |
174 |
writeln(OutFile); |
175 |
writeln(OutFile,'Add a record'); |
176 |
FDataSet.Append; |
177 |
FDataSet.Post; |
178 |
PrintDataSet(FDataSet); |
179 |
writeln(OutFile,'F1 in UTC Time = ', DateTimeToStr((FDataSet.FieldByName('F1') as TIBDateTimeField).GetAsUTCDateTime)); |
180 |
writeln(OutFile,'F2 in UTC Time = ', FBFormatDateTime('HH:MM:SS.zzzz',(FDataSet.FieldByName('F2') as TIBDateTimeField).GetAsUTCDateTime)); |
181 |
writeln(Outfile,'TZ Text Option = GMT'); |
182 |
FDataset.TZTextOption := tzGMT; |
183 |
PrintDataSet(FDataSet); |
184 |
writeln(Outfile,'TZ Text Option = Original format'); |
185 |
FDataset.TZTextOption := tzOriginalID; |
186 |
PrintDataSet(FDataSet); |
187 |
writeln(Outfile,'TZ Text Option = offset with Default time zone date of 2020/7/1'); |
188 |
FDataset.Active := false; |
189 |
FDataset.TZTextOption := tzOffset; |
190 |
FDataset.DefaultTZDate := EncodeDate(2020,7,1); |
191 |
FDataset.Active := true; |
192 |
PrintDataSet(FDataSet); |
193 |
writeln(Outfile,'Update a record with a non default time zone date'); |
194 |
FDataset.Edit; |
195 |
(FDataSet.FieldByName('F2') as TIBDateTimeField).SetAsDateTimeTZ(EncodeTime(11,02,10,15),'America/New_York'); |
196 |
FDataSet.Post; |
197 |
PrintDataSet(FDataSet); |
198 |
writeln(Outfile,'Restore original default time zone date'); |
199 |
FDataset.Active := false; |
200 |
FDataset.DefaultTZDate := EncodeDate(2020,1,1); |
201 |
FDataset.Active := true; |
202 |
PrintDataSet(FDataSet); |
203 |
finally |
204 |
DefaultFormatSettings := OldDefaultFormatSettings; |
205 |
IBDatabase.DropDatabase; |
206 |
end; |
207 |
end; |
208 |
|
209 |
initialization |
210 |
RegisterTest(TTest05); |
211 |
|
212 |
end. |
213 |
|