unit ToolsUnit;
{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF}
interface
uses
Classes, SysUtils, DB, testdecorator, fpcunit;
Const
// Number of "N" test datasets (as opposed to FieldDatasets) that will be created
// The connectors should have these records prepared in their Create*Dataset procedures.
MaxDataSet = 35;
// Number of records in a trace dataset:
NForTraceDataset = 15;
type
{ TDBConnector }
TDBConnectorClass = class of TDBConnector;
TDBConnector = class(TPersistent)
private
FLogTimeFormat: TFormatSettings; //for error logging only
FFormatSettings: TFormatSettings;
FChangedFieldDataset : boolean;
protected
FChangedDatasets : array[0..MaxDataSet] of boolean;
FUsedDatasets : TFPList;
procedure SetTestUniDirectional(const AValue: boolean); virtual;
function GetTestUniDirectional: boolean; virtual;
// These methods should be implemented by all descendents
// They are called each time a test needs a TDataset descendent
// n: the dataset index to return (also number of records in set)
// Presupposes that Create*Dataset(s) has been called already.
Function InternalGetNDataset(n : integer) : TDataset; virtual; abstract;
Function InternalGetFieldDataset : TDataSet; virtual; abstract;
// These methods should be implemented by all descendents
// They are called e.g. in the constructor. They can be used
// to create the tables on disk, or on a DB server
procedure CreateNDatasets; virtual; abstract;
procedure CreateFieldDataset; virtual; abstract;
// These methods are called after each test in which a dataset is used
// by calling GetXXXDataset with Achange=true
// They should reset all data to their right/initial values.
procedure ResetNDatasets; virtual;
procedure ResetFieldDataset; virtual;
// These methods are called e.g. in the destructor.
// They should clean up all mess, like tables on disk or on a DB server
procedure DropNDatasets; virtual; abstract;
procedure DropFieldDataset; virtual; abstract;
// If logging is enabled, writes Message to log file and flushes
// Logging uses tab-separated columns
procedure LogMessage(Category,Message: string);
public
constructor Create; virtual;
destructor Destroy; override;
procedure DataEvent(dataset :TDataset);
Function GetNDataset(n : integer) : TDataset; overload;
Function GetNDataset(AChange : Boolean; n : integer) : TDataset; overload;
Function GetFieldDataset : TDataSet; overload;
Function GetFieldDataset(AChange : Boolean) : TDataSet; overload;
// Gets a dataset that tracks calculation of calculated fields etc.
Function GetTraceDataset(AChange : Boolean) : TDataset; virtual;
// Run before a test is started
procedure StartTest(TestName: string);
// Run after a test is stopped
procedure StopTest(TestName: string);
property TestUniDirectional: boolean read GetTestUniDirectional write SetTestUniDirectional;
property FormatSettings: TFormatSettings read FFormatSettings;
end;
{ TTestDataLink }
TTestDataLink = class(TDataLink)
protected
procedure DataSetScrolled(Distance: Integer); override;
procedure DataSetChanged; override;
{$IFDEF fpc}
procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
{$ELSE}
procedure DataEvent(Event: TDataEvent; Info: longint); override;
{$ENDIF}
end;
{ TDBBasicsTestSetup }
TDBBasicsTestSetup = class(TTestSetup)
protected
procedure OneTimeSetup; override;
procedure OneTimeTearDown; override;
end;
{ TDBBasicsTestCase }
TDBBasicsTestCase = class(TTestCase)
protected
procedure SetUp; override;
procedure TearDown; override;
// Verify whether all values in FieldDataset are present and correct
procedure CheckFieldDatasetValues(ADataSet: TDataSet);
// Verify whether all values in NDataset are present and correct
procedure CheckNDatasetValues(ADataSet: TDataSet; n: integer);
end;
const
DataEventnames : Array [TDataEvent] of String[21] =
('deFieldChange', 'deRecordChange', 'deDataSetChange', 'deDataSetScroll',
'deLayoutChange', 'deUpdateRecord', 'deUpdateState', 'deCheckBrowseMode',
'dePropertyChange', 'deFieldListChange', 'deFocusControl' ,'deParentScroll',
'deConnectChange', 'deReconcileError', 'deDisabledStateChange');
const
testValuesCount = 25;
testFloatValues : Array[0..testValuesCount-1] of double = (-maxSmallint-1,-maxSmallint,-256,-255,-128,-127,-1,0,1,127,128,255,256,maxSmallint,maxSmallint+1,0.123456,-0.123456,4.35,12.434E7,9.876e-5,123.45678,2.4,3.2,0.4,23);
testCurrencyValues : Array[0..testValuesCount-1] of currency = (-MaxLongInt-1,-MaxSmallint-1,-256,-255,-43.34,-2.5,-0.21,0,0.32,45.45,256,45,1234.56,12.34,0.12,MaxSmallInt+1,MaxLongInt+1,-6871947.67,68719476736,2748779069.44,922337203685.47,-92233720368547,99999999999999,-9223372036854.25,-9223372036854.7);
testFmtBCDValues : Array[0..testValuesCount-1] of string = ('-100','-65.5','-54.3333','-43.3334','-2.5','-0.234567','45.4','0.3','45.414585','127','128','255','256','45','0.3','45.4','127','128','255','256','45','1234.56789','43.23','43.500001','99.88');
testIntValues : Array[0..testValuesCount-1] of integer = (-maxInt,-maxInt+1,-maxSmallint-1,-maxSmallint,-256,-255,-128,-127,-1,0,1,127,128,255,256,maxSmallint,maxSmallint+1,MaxInt-1,MaxInt,100,130,150,-150,-132,234);
testWordValues : Array[0..testValuesCount-1] of Word = (1,2,3,4,5,6,7,8,0,1,127,128,255,256,maxSmallint,maxSmallint+1,maxSmallInt-1,maxSmallInt,65535,100,130,150,151,132,234);
testSmallIntValues : Array[0..testValuesCount-1] of smallint = (-maxSmallint,-maxSmallint+1,-256,-255,-128,-127,-1,0,1,127,128,255,256,maxSmallint,maxSmallint-1,100,110,120,130,150,-150,-132,234,231,42);
testLargeIntValues : Array[0..testValuesCount-1] of LargeInt = (-$7fffffffffffffff,-$7ffffffffffffffe,-maxInt-1,-maxInt+1,-maxSmallint,-maxSmallint+1,-256,-255,-128,-127,-1,0,1,127,128,255,256,maxSmallint,maxSmallint-1,maxSmallint+1,MaxInt-1,MaxInt,$7fffffffffffffff-1,$7fffffffffffffff,235253244);
testBooleanValues : Array[0..testValuesCount-1] of boolean = (true,false,false,true,true,false,false,true,false,true,true,true,false,false,false,false,true,true,true,true,false,true,true,false,false);
testStringValues : Array[0..testValuesCount-1] of string = (
'',
'a',
'ab',
'abc',
'abcd',
'abcde',
'abcdef',
'abcdefg',
'abcdefgh',
'abcdefghi',
'abcdefghij',
'lMnOpQrStU',
'1234567890',
'_!@#$%^&*(',
'_!@#$%^&*(',
' ''quotes'' ',
')-;:/?.<>',
'~`|{}- =', // note that there's no \ (backslash) since some db's uses that as escape-character
' WRaP ',
'wRaP ',
' wRAP',
'this',
// 'is',
'fun',
'VB7^',
'vdfbst'
);
testDateValues : Array[0..testValuesCount-1] of string = (
'2000-01-01',
'1999-12-31',
'2004-02-29',
'2004-03-01',
'1991-02-28',
'1991-03-01',
'1997-11-29',
'2040-10-16',
'1977-09-29',
'1977-12-31',
'1917-12-29',
'1900-01-01',
'1899-12-31',
'1899-12-30',
'1899-12-29',
'1800-03-30',
'1754-06-04',
'1753-01-01',
'1650-05-10',
'0904-04-12',
'0199-07-09',
'0079-11-29',
'0031-11-02',
'0001-12-31',
'0001-01-01'
);
testTimeValues : Array[0..testValuesCount-1] of string = (
'10:45:12.000',
'00:00:00.000',
'24:00:00.000',
'33:25:15.000',
'04:59:16.000',
'05:45:59.000',
'11:45:12.000',
'12:45:12.000',
'14:45:14.000',
'14:45:52.000',
'15:35:12.000',
'16:35:42.000',
'16:45:12.000',
'18:45:22.000',
'19:45:12.000',
'16:45:12.010',
'13:55:12.200',
'13:46:12.543',
'15:35:12.000',
'17:25:12.530',
'19:45:12.003',
'10:54:12.999',
'12:25:12.000',
'20:15:12.758',
'23:59:59.000'
);
var dbtype,
dbconnectorname,
dbconnectorparams,
dbname,
dbuser,
dbhostname,
dbpassword,
dbcharset,
dblogfilename,
dbQuoteChars : string;
dblogfile : TextFile;
DataEvents : string;
DBConnector : TDBConnector;
testValues : Array [TFieldType,0..testvaluescount -1] of string;
procedure InitialiseDBConnector;
procedure FreeDBConnector;
function DateTimeToTimeString(d: tdatetime) : string;
function TimeStringToDateTime(d: String): TDateTime;
function StringToByteArray(const s: ansistring): Variant;
function StringToBytes(const s: ansistring): TBytes;
implementation
uses
inifiles, FmtBCD, Variants;
var DBConnectorRefCount: integer;
{ TDBConnector }
constructor TDBConnector.Create;
begin
FFormatSettings.DecimalSeparator:='.';
FFormatSettings.ThousandSeparator:=#0;
FFormatSettings.DateSeparator:='-';
FFormatSettings.TimeSeparator:=':';
FFormatSettings.ShortDateFormat:='yyyy/mm/dd';
FFormatSettings.LongTimeFormat:='hh:nn:ss.zzz';
// Set up time format for logging output:
// ISO 8601 type date string so logging is uniform across machines
FLogTimeFormat.DecimalSeparator:='.';
FLogTimeFormat.ThousandSeparator:=#0;
FLogTimeFormat.DateSeparator:='-';
FLogTimeFormat.TimeSeparator:=':';
FLogTimeFormat.ShortDateFormat:='yyyy-mm-dd';
FLogTimeFormat.LongTimeFormat:='hh:nn:ss';
FUsedDatasets := TFPList.Create;
CreateFieldDataset;
CreateNDatasets;
end;
destructor TDBConnector.Destroy;
begin
if assigned(FUsedDatasets) then FUsedDatasets.Destroy;
DropNDatasets;
DropFieldDataset;
Inherited;
end;
function TDBConnector.GetTestUniDirectional: boolean;
begin
result := false;
end;
procedure TDBConnector.SetTestUniDirectional(const AValue: boolean);
begin
raise exception.create('Connector does not support tests for unidirectional datasets');
end;
procedure TDBConnector.DataEvent(dataset : tdataset);
begin
DataEvents := DataEvents + 'DataEvent' + ';';
end;
procedure TDBConnector.ResetNDatasets;
begin
DropNDatasets;
CreateNDatasets;
end;
procedure TDBConnector.ResetFieldDataset;
begin
DropFieldDataset;
CreateFieldDataset;
end;
function TDBConnector.GetNDataset(n: integer): TDataset;
begin
Result := GetNDataset(False,n);
end;
function TDBConnector.GetNDataset(AChange : Boolean; n: integer): TDataset;
begin
if AChange then FChangedDatasets[n] := True;
Result := InternalGetNDataset(n);
FUsedDatasets.Add(Result);
end;
function TDBConnector.GetFieldDataset: TDataSet;
begin
Result := GetFieldDataset(False);
end;
function TDBConnector.GetFieldDataset(AChange: Boolean): TDataSet;
begin
if AChange then FChangedFieldDataset := True;
Result := InternalGetFieldDataset;
FUsedDatasets.Add(Result);
end;
function TDBConnector.GetTraceDataset(AChange: Boolean): TDataset;
begin
result := GetNDataset(AChange,NForTraceDataset);
end;
procedure TDBConnector.StartTest(TestName: string);
begin
// Log if necessary
LogMessage('Test','Starting test '+TestName);
end;
procedure TDBConnector.StopTest(TestName: string);
var i : integer;
ds : TDataset;
begin
LogMessage('Test','Stopping test '+TestName);
for i := 0 to FUsedDatasets.Count -1 do
begin
ds := tdataset(FUsedDatasets[i]);
if ds.active then ds.Close;
ds.Free;
end;
FUsedDatasets.Clear;
if FChangedFieldDataset then ResetFieldDataset;
for i := 0 to MaxDataSet do if FChangedDatasets[i] then
begin
ResetNDatasets;
fillchar(FChangedDatasets,sizeof(FChangedDatasets),ord(False));
break;
end;
end;
procedure TDBConnector.LogMessage(Category,Message: string);
begin
if dblogfilename<>'' then //double check: only if logging enabled
begin
try
Message:=StringReplace(Message, #9, '\t', [rfReplaceAll, rfIgnoreCase]);
Message:=StringReplace(Message, LineEnding, '\n', [rfReplaceAll, rfIgnoreCase]);
writeln(dbLogFile, TimeToStr(Now(), FLogTimeFormat) + #9 +
Category + #9 +
Message);
Flush(dbLogFile); //in case tests crash
except
// ignore log file errors
end;
end;
end;
{ TTestDataLink }
procedure TTestDataLink.DataSetScrolled(Distance: Integer);
begin
DataEvents := DataEvents + 'DataSetScrolled' + ':' + inttostr(Distance) + ';';
inherited DataSetScrolled(Distance);
end;
procedure TTestDataLink.DataSetChanged;
begin
DataEvents := DataEvents + 'DataSetChanged;';
inherited DataSetChanged;
end;
{$IFDEF FPC}
procedure TTestDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
{$ELSE}
procedure TTestDataLink.DataEvent(Event: TDataEvent; Info: Longint);
{$ENDIF}
begin
if Event <> deFieldChange then
DataEvents := DataEvents + DataEventnames[Event] + ':' + inttostr(info) + ';'
else
DataEvents := DataEvents + DataEventnames[Event] + ':' + TField(info).FieldName + ';';
inherited DataEvent(Event, Info);
end;
{ TDBBasicsTestSetup }
procedure TDBBasicsTestSetup.OneTimeSetup;
begin
InitialiseDBConnector;
end;
procedure TDBBasicsTestSetup.OneTimeTearDown;
begin
FreeDBConnector;
end;
{ TDBBasicsTestCase }
procedure TDBBasicsTestCase.SetUp;
begin
inherited SetUp;
DBConnector.StartTest(TestName);
end;
procedure TDBBasicsTestCase.TearDown;
begin
DBConnector.StopTest(TestName);
inherited TearDown;
end;
procedure TDBBasicsTestCase.CheckFieldDatasetValues(ADataSet: TDataSet);
var i: integer;
begin
with ADataSet do
begin
First;
for i := 0 to testValuesCount-1 do
begin
CheckEquals(i, FieldByName('ID').AsInteger, 'ID');
CheckEquals(testStringValues[i], FieldByName('FSTRING').AsString, 'FSTRING');
CheckEquals(testIntValues[i], FieldByName('FINTEGER').AsInteger, 'FINTEGER');
CheckEquals(testLargeIntValues[i], FieldByName('FLARGEINT').AsLargeInt, 'FLARGEINT');
Next;
end;
CheckTrue(Eof, 'Eof');
end;
end;
procedure TDBBasicsTestCase.CheckNDatasetValues(ADataSet: TDataSet; n: integer);
var i: integer;
begin
with ADataSet do
begin
First;
for i := 1 to n do
begin
CheckEquals(i, FieldByName('ID').AsInteger, 'ID');
CheckEquals('TestName' + inttostr(i), FieldByName('NAME').AsString, 'NAME');
Next;
end;
CheckTrue(Eof, 'Eof');
end;
end;
procedure ReadIniFile;
var IniFile : TIniFile;
begin
IniFile := TIniFile.Create(GetCurrentDir + PathDelim + 'database.ini');
dbtype:='';
if ParamCount>0 then
dbtype := ParamStr(1);
if (dbtype='') or not IniFile.SectionExists(dbtype) then
dbtype := IniFile.ReadString('Database','Type','');
dbconnectorname := IniFile.ReadString(dbtype,'Connector','');
dbname := IniFile.ReadString(dbtype,'Name','');
dbuser := IniFile.ReadString(dbtype,'User','');
dbhostname := IniFile.ReadString(dbtype,'Hostname','');
dbpassword := IniFile.ReadString(dbtype,'Password','');
dbcharset := IniFile.ReadString(dbtype,'CharSet','');
dbconnectorparams := IniFile.ReadString(dbtype,'ConnectorParams','');
dblogfilename := IniFile.ReadString(dbtype,'LogFile','');
dbquotechars := IniFile.ReadString(dbtype,'QuoteChars','"');
IniFile.Free;
end;
procedure SetupLog;
begin
if dblogfilename<>'' then
begin
try
AssignFile(dblogfile,dblogfilename);
if not(FileExists(dblogfilename)) then
begin
ReWrite(dblogfile);
CloseFile(dblogfile);
end;
Append(dblogfile);
except
dblogfilename:=''; //rest of code relies on this as a log switch
end;
end;
end;
procedure CloseLog;
begin
if dblogfilename<>'' then
begin
try
CloseFile(dbLogFile);
except
// Ignore log file errors
end;
end;
end;
procedure InitialiseDBConnector;
var DBConnectorClass : TPersistentClass;
i : integer;
FormatSettings : TFormatSettings;
begin
if DBConnectorRefCount>0 then exit;
FormatSettings.DecimalSeparator:='.';
FormatSettings.ThousandSeparator:=#0;
testValues[ftString] := testStringValues;
testValues[ftFixedChar] := testStringValues;
testValues[ftTime] := testTimeValues;
testValues[ftDate] := testDateValues;
testValues[ftBlob] := testStringValues;
testValues[ftMemo] := testStringValues;
testValues[ftWideString] := testStringValues;
testValues[ftWideMemo] := testStringValues;
testValues[ftFMTBcd] := testFmtBCDValues;
for i := 0 to testValuesCount-1 do
begin
testValues[ftBoolean,i] := BoolToStr(testBooleanValues[i], True);
testValues[ftFloat,i] := FloatToStr(testFloatValues[i],FormatSettings);
testValues[ftSmallint,i] := IntToStr(testSmallIntValues[i]);
testValues[ftInteger,i] := IntToStr(testIntValues[i]);
testValues[ftWord,i] := IntToStr(testWordValues[i]);
testValues[ftLargeint,i] := IntToStr(testLargeIntValues[i]);
testValues[ftCurrency,i] := CurrToStr(testCurrencyValues[i],FormatSettings);
testValues[ftBCD,i] := CurrToStr(testCurrencyValues[i],FormatSettings);
// For date '0001-01-01' other time-part like '00:00:00' causes "Invalid variant type cast", because of < MinDateTime constant
if (testDateValues[i]>'0001-01-01') and (testTimeValues[i]>='00:00:01') and (testTimeValues[i]<'24:00:00') then
testValues[ftDateTime,i] := testDateValues[i] + ' ' + testTimeValues[i]
else
testValues[ftDateTime,i] := testDateValues[i];
end;
if dbconnectorname = '' then raise Exception.Create('There is no db connector specified');
DBConnectorClass := GetClass('T'+dbconnectorname+'DBConnector');
if assigned(DBConnectorClass) then
DBConnector := TDBConnectorClass(DBConnectorClass).create
else Raise Exception.Create('Unknown db connector specified: ' + 'T'+dbconnectorname+'DBConnector');
inc(DBConnectorRefCount);
end;
procedure FreeDBConnector;
begin
dec(DBConnectorRefCount);
if DBConnectorRefCount=0 then
FreeAndNil(DBConnector);
end;
function DateTimeToTimeString(d: tdatetime): string;
var
millisecond: word;
second : word;
minute : word;
hour : word;
begin
// Format the datetime in the format hh:nn:ss.zzz, where the hours can be bigger then 23.
DecodeTime(d,hour,minute,second,millisecond);
hour := hour + (trunc(d) * 24);
result := Format('%.2d:%.2d:%.2d.%.3d',[hour,minute,second,millisecond]);
end;
function TimeStringToDateTime(d: String): TDateTime;
var
millisecond: word;
second : word;
minute : word;
hour : word;
days : word;
begin
// Convert the string in the format hh:nn:ss.zzz to a datetime.
hour := strtoint(copy(d,1,2));
minute := strtoint(copy(d,4,2));
second := strtoint(copy(d,7,2));
millisecond := strtoint(copy(d,10,3));
days := hour div 24;
hour := hour mod 24;
result := ComposeDateTime(days,EncodeTime(hour,minute,second,millisecond));
end;
function StringToByteArray(const s: ansistring): Variant;
var P: Pointer;
Len: integer;
begin
Len := Length(s) * SizeOf(AnsiChar);
Result := VarArrayCreate([0, Len-1], varByte);
P := VarArrayLock(Result);
try
Move(s[1], P^, Len);
finally
VarArrayUnlock(Result);
end;
end;
function StringToBytes(const s: ansistring): TBytes;
var Len: integer;
begin
Len := Length(s) * SizeOf(AnsiChar);
SetLength(Result, Len);
Move(s[1], Result[0], Len);
end;
initialization
ReadIniFile;
SetupLog;
DBConnectorRefCount:=0;
finalization
CloseLog;
end.
