ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/testsuite/testApp/TestApplication.pas
(Generate patch)

Comparing ibx/trunk/fbintf/testsuite/testApp/TestApplication.pas (file contents):
Revision 350 by tony, Fri Feb 26 16:43:23 2021 UTC vs.
Revision 351 by tony, Wed Oct 20 15:04:35 2021 UTC

# Line 77 | Line 77 | type
77    TTestBase = class
78    private
79      FOwner: TTestApplication;
80 +    FFloatTpl: AnsiString;
81 +    FCursorSeq: integer;
82      function GetFirebirdAPI: IFirebirdAPI;
83      procedure SetOwner(AOwner: TTestApplication);
84    protected
85      FHexStrings: boolean;
86 +    FShowBinaryBlob: boolean;
87      procedure DumpBCD(bcd: tBCD);
88      procedure ClientLibraryPathChanged; virtual;
89      procedure CreateObjects(Application: TTestApplication); virtual;
# Line 93 | Line 96 | type
96      procedure PrintSPB(SPB: ISPB);
97      procedure PrintMetaData(meta: IMetaData);
98      procedure ParamInfo(SQLParams: ISQLParams);
99 <    function ReportResults(Statement: IStatement): IResultSet;
99 >    function ReportResults(Statement: IStatement; ShowCursorName: boolean=false): IResultSet;
100      procedure ReportResult(aValue: IResults);
101      function StringToHex(octetString: string; MaxLineLength: integer=0): string;
102      procedure WriteArray(ar: IArray);
# Line 108 | Line 111 | type
111      procedure InitTest; virtual;
112      function SkipTest: boolean; virtual;
113      procedure ProcessResults; virtual;
114 +    procedure SetFloatTemplate(tpl: Ansistring);
115    public
116      constructor Create(aOwner: TTestApplication);  virtual;
117      function ChildProcess: boolean; virtual;
# Line 173 | Line 177 | type
177      function GetPassword: AnsiString;
178      function GetEmployeeDatabaseName: AnsiString;
179      function GetNewDatabaseName: AnsiString;
180 +    function GetTempDatabaseName: AnsiString;
181      function GetSecondNewDatabaseName: AnsiString;
182      function GetBackupFileName: AnsiString;
183      procedure RunAll;
# Line 186 | Line 191 | type
191      property Quiet: boolean read FQuiet;
192    end;
193  
194 +  { TMsgHash }
195 +
196 +  TMsgHash = class
197 +  private
198 +    FFinalised: boolean;
199 +  protected
200 +    procedure CheckNotFinalised;
201 +  public
202 +    procedure AddText(aText: AnsiString); virtual; abstract;
203 +    procedure Finalise; virtual;
204 +    function SameHash(otherHash: TMsgHash): boolean;
205 +    function Digest: AnsiString; virtual; abstract;
206 +    class function CreateMsgHash: TMsgHash;
207 +    property Finalised: boolean read FFinalised;
208 +  end;
209 +
210    ESkipException = class(Exception);
211  
212   var
# Line 197 | Line 218 | procedure RegisterTest(aTest: TTest);
218  
219   implementation
220  
221 + {$IFNDEF MSWINDOWS}
222 + uses MD5;
223 + {$ENDIF}
224 +
225   {$IFDEF MSWINDOWS}
226 < uses windows;
226 > uses {$IFDEF FPC}MD5,{$ENDIF} windows;
227  
228   function GetTempDir: AnsiString;
229   var
# Line 219 | Line 244 | begin
244   //    test.CreateObjects(TestApp);
245   end;
246  
247 + {$IFDEF FPC}
248 + type
249 +
250 +  { TMD5MsgHash }
251 +
252 +  TMD5MsgHash = class(TMsgHash)
253 +  private
254 +    FMD5Context: TMDContext;
255 +    FDigest: TMDDigest;
256 +  public
257 +    constructor Create;
258 +    procedure AddText(aText: AnsiString); override;
259 +    procedure Finalise; override;
260 +    function Digest: AnsiString; override;
261 +  end;
262 +
263 + {$DEFINE MSG_HASH_AVAILABLE}
264 +
265 + { TMD5MsgHash }
266 +
267 + constructor TMD5MsgHash.Create;
268 + begin
269 +  inherited Create;
270 +  MDInit(FMD5Context,MD_VERSION_5);
271 + end;
272 +
273 + procedure TMD5MsgHash.AddText(aText: AnsiString);
274 + begin
275 +  CheckNotFinalised;
276 +  MDUpdate(FMD5Context,PAnsiChar(aText)^,Length(aText));
277 + end;
278 +
279 + procedure TMD5MsgHash.Finalise;
280 + begin
281 +  CheckNotFinalised;
282 +  MDFinal(FMD5Context,FDigest);
283 +  inherited Finalise;
284 + end;
285 +
286 + function TMD5MsgHash.Digest: AnsiString;
287 + begin
288 +  if not FFinalised then
289 +    Finalise;
290 +  Result :=  MD5Print(FDigest);
291 + end;
292 +
293 + class function TMsgHash.CreateMsgHash: TMsgHash;
294 + begin
295 +  Result := TMD5MsgHash.Create;
296 + end;
297 + {$ENDIF}
298 +
299 + {$IFNDEF MSG_HASH_AVAILABLE}
300 + type
301 +
302 +  { TSimpleMsgHash }
303 +
304 +  TSimpleMsgHash = class(TMsgHash)
305 +  private
306 +    FDigest: Int64;
307 +    Finalised: boolean;
308 +  public
309 +    procedure AddText(aText: AnsiString); override;
310 +    function Digest: AnsiString; override;
311 +  end;
312 +
313 + { TSimpleMsgHash }
314 +
315 + procedure TSimpleMsgHash.AddText(aText: AnsiString);
316 + const
317 +  modulus = high(Int64) div 100;
318 + var i: integer;
319 + begin
320 +  CheckNotFinalised;
321 +  for i := 1 to length(aText) do
322 +    FDigest := (FDigest * 7 + ord(aText[i])) mod modulus;
323 + end;
324 +
325 + function TSimpleMsgHash.Digest: AnsiString;
326 + begin
327 +  if not Finalised then
328 +    Finalise;
329 +  Result := IntToStr(FDigest);
330 + end;
331 +
332 + class function TMsgHash.CreateMsgHash: TMsgHash;
333 + begin
334 +  Result := TSimpleMsgHash.Create;
335 + end;
336 +
337 + {$ENDIF}
338 +
339 + procedure TMsgHash.CheckNotFinalised;
340 + begin
341 +  if FFinalised then
342 +    raise Exception.Create('Digest has been finalised');
343 + end;
344 +
345 + procedure TMsgHash.Finalise;
346 + begin
347 +  FFinalised := true;
348 + end;
349 +
350 + function TMsgHash.SameHash(otherHash: TMsgHash): boolean;
351 + begin
352 +  Result := Digest = OtherHash.Digest;
353 + end;
354 +
355   { TTestBase }
356  
357   constructor TTestBase.Create(aOwner: TTestApplication);
358   begin
359    inherited Create;
360    FOwner := aOwner;
361 +  FFloatTpl := '#,###.00';
362   end;
363  
364   function TTestBase.ChildProcess: boolean;
# Line 420 | Line 554 | begin
554      writeln(OutFile,'Charset id = ',getCharSetID);
555      if getIsNullable then writeln(OutFile,'Nullable') else writeln(OutFile,'Not Null');
556      writeln(OutFile,'Size = ',GetSize);
557 +    if not IsNull then
558 +      writeln(Outfile,'Value = ',getAsString);
559      writeln(OutFile);
560    end;
561   end;
562  
563 < function TTestBase.ReportResults(Statement: IStatement): IResultSet;
563 > function TTestBase.ReportResults(Statement: IStatement; ShowCursorName: boolean): IResultSet;
564   begin
565    Result := Statement.OpenCursor;
566    try
567 +   if ShowCursorName then
568 +      writeln(Outfile,'Results for Cursor: ',Result.GetCursorName);
569      while Result.FetchNext do
570        ReportResult(Result);
571    finally
# Line 699 | Line 837 | begin
837      end;
838    SQL_FLOAT,SQL_DOUBLE,
839    SQL_D_FLOAT:
840 <    writeln(OutFile, aValue.Name,' = ',FormatFloat('#,##0.00',aValue.AsFloat));
840 >    writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble));
841  
842    SQL_INT64:
843      if aValue.Scale <> 0 then
844 <      writeln(OutFile, aValue.Name,' = ',FormatFloat('#,##0.00',aValue.AsFloat))
844 >      writeln(OutFile, aValue.Name,' = ',FormatFloat(FFloatTpl,aValue.AsDouble))
845      else
846        writeln(OutFile,aValue.Name,' = ',aValue.AsString);
847  
# Line 728 | Line 866 | begin
866        end
867      end
868      else
869 +    begin
870        writeln(OutFile,aValue.Name,' = (blob), Length = ',aValue.AsBlob.GetBlobSize);
871 +      if FShowBinaryBlob then
872 +        PrintHexString(aValue.AsString);
873 +    end;
874  
875    SQL_TEXT,SQL_VARYING:
876    begin
# Line 810 | Line 952 | begin
952    //Do nothing
953   end;
954  
955 + procedure TTestBase.SetFloatTemplate(tpl: Ansistring);
956 + begin
957 +  FFloatTpl := tpl;
958 + end;
959 +
960   { TTestApplication }
961  
962   class procedure TTestApplication.CreateTestList;
# Line 858 | Line 1005 | end;
1005   function TTestApplication.GetFirebirdAPI: IFirebirdAPI;
1006   begin
1007    if FFirebirdAPI = nil then
1008 +  begin
1009      FFirebirdAPI := IB.FirebirdAPI;
1010 +    FFirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);;
1011 +  end;
1012    Result := FFirebirdAPI;
1013   end;
1014  
# Line 926 | Line 1076 | begin
1076      Result := MakeConnectString(FServer,  FNewDatabaseName, inet,FPortNo);
1077   end;
1078  
1079 + function TTestApplication.GetTempDatabaseName: AnsiString;
1080 + begin
1081 +  Result := GetTempDir + 'fbtest.fbd';
1082 + end;
1083 +
1084   function TTestApplication.GetSecondNewDatabaseName: AnsiString;
1085   begin
1086    if FirebirdAPI.GetClientMajor < 3 then
# Line 948 | Line 1103 | begin
1103      DoTest(i);
1104      if not Quiet then
1105        writeln(Outfile,'------------------------------------------------------');
1106 +    Sleep(500);
1107    end;
1108   end;
1109  
# Line 1219 | Line 1375 | begin
1375        RunAll
1376      else
1377        RunTest(TestID);
1378 +    CleanUp;
1379    except on E: Exception do
1380      begin
1381        writeln('Exception: ',E.Message);

Diff Legend

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