{ This file is part of the Free Pascal run time library. Copyright (c) 1999-2022 by Michael van Canneyt and other members of the Free Pascal development team base report tests See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} unit tcbasereport; {$mode objfpc}{$H+} {.$define gdebug} interface uses Classes, SysUtils, fpcunit, testregistry, fpexprpars, fpCanvas, fpReport; type TMyFPReportComponent = class(TFPReportComponent) public procedure StartLayout; override; procedure EndLayout; override; procedure StartRender; override; procedure EndRender; override; end; TMyFPReportElement = class(TFPReportElement) private FChangedCalled: integer; public procedure CallChange; procedure ResetChanged; procedure DoChanged; override; property ChangedCalled: integer read FChangedCalled; end; TMyFPReportElementWithChildren = class(TFPReportElementWithChildren) private FChangedCalled: integer; public procedure CallChange; procedure ResetChanged; procedure DoChanged; override; property ChangedCalled: integer read FChangedCalled; end; TMyFPReportPageSize = class(TFPReportPageSize) private FChangedCalled: integer; public procedure ResetChanged; procedure Changed; override; property ChangedCalled: integer read FChangedCalled; end; TMyFPReportPage = class(TFPReportPage) private FChangedCalled: integer; FPrepareObjectsCalled: integer; procedure SetupPage; protected procedure PrepareObjects(aRTParent: TFPReportElement); override; public constructor Create(AOwner: TComponent); override; procedure ResetChanged; procedure DoChanged; override; property ChangedCalled: integer read FChangedCalled; end; TMyReportTitleBand = class(TFPReportCustomTitleBand) private FPrepareObjectsCalled: integer; protected procedure PrepareObjects(aRTParent: TFPReportElement); override; public constructor Create(AOwner: TComponent); override; end; TMyDataBand = class(TFPReportDataBand) private FPrepareObjectsCalled: integer; protected procedure PrepareObjects(aRTParent: TFPReportElement); override; public constructor Create(AOwner: TComponent); override; end; TMyCustomReport = class(TFPReport) end; TMyFPReportData = class(TFPReportData) private FCC: integer; FDFC: integer; FEC: integer; FFC: integer; FNC: integer; FOC: integer; FOE: boolean; FReportEOF: boolean; public procedure ResetCounts; procedure DoInitDataFields; override; procedure DoOpen; override; procedure DoFirst; override; procedure DoNext; override; procedure DoClose; override; function DoEOF: boolean; override; property InitDataFieldsCount: integer read FDFC; property OpenCount: integer read FOC; property FirstCount: integer read FFC; property NextCount: integer read FNC; property CloseCount: integer read FCC; property EOFCount: integer read FEC; property ReportEOF: boolean read FReportEOF write FReportEOF; property OldEOF: boolean read FOE; property Datafields; end; TTestFPPageSize = class(TTestCase) published procedure TestCreate; end; TTestFPPapers = class(TTestCase) protected FM: TFPReportPaperManager; procedure Setup; override; procedure TearDown; override; procedure RegisterPapers(ACount: integer; Local: boolean = True); end; TTestFPPaperManager = class(TTestFPPapers) private FAccess: integer; procedure TestAccess; protected procedure Setup; override; published procedure TestCreate; procedure TestRegister1; procedure TestRegister2; procedure TestRegister3; procedure TestRegisterDuplicate; procedure TestClear; procedure TestFind1; procedure TestFind2; procedure TestFind3; procedure IllegalAccess1; procedure IllegalAccess2; procedure IllegalAccess3; procedure IllegalAccess4; procedure IllegalAccess5; procedure IllegalAccess6; procedure IllegalAccess7; procedure IllegalAccess8; procedure TestWidth; procedure TestHeight; end; TTestFPReportPageSize = class(TTestFPPapers) private FP: TMyFPReportPageSize; protected procedure Setup; override; procedure TearDown; override; published procedure TestCreate; procedure TestCreateWithPage; procedure TestCreateByPage; procedure TestChanged1; procedure TestChanged2; procedure TestChanged3; procedure TestPaperName1; procedure TestPaperName2; procedure TestAssign; end; TBaseReportComponentTest = class(TTestCase) private FC: TMyFPReportComponent; procedure ExpectState(const aExpected: TFPReportState); protected procedure AssertEquals(Msg: string; const aExpected, AActual: TFPReportState); overload; procedure SetUp; override; procedure TearDown; override; end; TTestReportComponent = class(TBaseReportComponentTest) published procedure TestCreate; procedure TestLayoutState; procedure TestRenderState; end; TBaseReportElementTest = class(TTestCase) private FC: TMyFPReportElement; protected procedure SetUp; override; procedure TearDown; override; end; TReportElementTest = class(TBaseReportElementTest) published procedure TestCreate; procedure TestDoChange; procedure TestChangeCount; procedure TestChangeCountNested; procedure TestChangeCountNested2; procedure TestVisibleChanges; procedure TestLayoutChanges; procedure TestFrameChanges; procedure TestAssign; procedure TestEquals1; procedure TestEquals2; procedure TestEquals3; procedure TestEquals4; procedure TestEquals5; end; TTestReportChildren = class(TTestCase) private FC, FC2: TMyFPReportElementWithChildren; FChild: TFPReportElement; protected procedure SetUp; override; procedure TearDown; override; procedure WrongParent; published procedure TestCreate; procedure TestSetParent1; procedure TestSetParent2; procedure TestSetParent3; procedure TestSetParent4; procedure TestSetParent5; procedure TestSetParent6; end; TTestReportFrame = class(TBaseReportElementTest) published procedure TestCreate; procedure TestWidthChange; procedure TestColorChange; procedure TestPenStyleChange; procedure TestShapeChange; procedure TestLinesChange; procedure TestAssign; procedure TestEquals1; procedure TestEquals2; procedure TestEquals3; procedure TestEquals4; procedure TestEquals5; procedure TestEquals6; procedure TestEquals7; end; TTestReportLayout = class(TBaseReportElementTest) published procedure TestCreate; procedure TestTopChange; procedure TestLeftChange; procedure TestWidthChange; procedure TestHeightChange; procedure TestAssign; procedure TestEquals1; procedure TestEquals2; procedure TestEquals3; procedure TestEquals4; procedure TestEquals5; procedure TestEquals6; end; TTestCaseWithData = class(TTestCase) private FData: TFPReportUserData; FSL: TStringList; procedure InitializeData(const ACount: integer); procedure SetReportData(const ADataCount: Byte); procedure DoGetDataValue(Sender: TObject; const AValueName: string; var AValue: variant); procedure DoGetDataEOF(Sender: TObject; var IsEOF: boolean); protected procedure SetUp; override; procedure TearDown; override; public property Data: TFPReportUserData read FData write FData; end; TTestCaseWithDataAndReport = class(TTestCaseWithData) private FReport: TMyCustomReport; protected procedure SetUp; override; procedure TearDown; override; public property Report: TMyCustomReport read FReport write FReport; end; TTestReportPage = class(TTestCase) private FP: TMyFPReportPage; protected procedure Setup; override; procedure TearDown; override; published procedure TestCreate1; procedure TestCreate2; procedure TestCreate3; procedure TestPageSize1; procedure TestPageSize2; procedure TestPageSize3; procedure TestBand1; procedure TestBand2; procedure TestData; procedure TestAssign; procedure TestFindBand; end; TTestReportData = class(TTestCase) private FD: TMyFPReportData; FHandler: boolean; procedure AssertField(Prefix: string; F: TFPReportDataField; AFieldName: string; AFieldKind: TFPReportFieldKind; ADisplayWidth: integer = 0); protected procedure DoOpen(Sender: TObject); procedure DoNext(Sender: TObject); procedure Setup; override; procedure TearDown; override; procedure CreateFields; procedure DoFieldByName; published procedure TestCreate; procedure TestOpen1; procedure TestNext; procedure TestInitFieldDefs; procedure TestInitFieldDefs_OnlyAllowedOnce; procedure TestEOF1; procedure TestAddDatafield; procedure TestDatafieldAdd; procedure TestCreateFields; procedure TestDatafieldIndexOf1; procedure TestDatafieldIndexOf2; procedure TestFindField1; procedure TestFindField2; procedure TestFindByName1; procedure TestFindByName2; procedure TestFieldAssign; procedure TestGetValue; procedure TestEasyAccessProperties; end; { Testing UserData by pulling data from a DataField } TTestUserReportData = class(TTestCase) private FD: TFPReportUserData; FExpectName: string; FReturnValue: variant; procedure DoValue(Sender: TObject; const AValueName: string; var AValue: variant); protected procedure Setup; override; procedure TearDown; override; published procedure TestGetValue; end; { Testing UserData by pulling data from a StringList } TTestUserReportData2 = class(TTestCase) private FData: TFPReportUserData; FSL: TStringList; procedure DoGetValue(Sender: TObject; const AValueName: string; var AValue: variant); procedure DoGetEOF(Sender: TObject; var IsEOF: boolean); protected procedure Setup; override; procedure TearDown; override; published procedure TestGetValue; procedure TestOnGetEOF1; procedure TestOnGetEOF2; end; TTestDataBand = class(TTestCaseWithDataAndReport) private FDataBand: TFPReportDataBand; protected procedure Setup; override; procedure TearDown; override; published procedure TestData; procedure TestDataPropertyAutoSet; end; TTestCustomReport = class(TTestCase) private FRpt: TMyCustomReport; FBeginReportCount: integer; FEndReportCount: integer; FSL: TStringList; FData: TFPReportUserData; procedure HandleOnBeginReport; procedure HandleOnEndReport; procedure InitializeData(const ACount: integer); procedure SetReportData(const ADataCount: Byte); procedure DoGetDataValue(Sender: TObject; const AValueName: string; var AValue: variant); procedure DoGetDataEOF(Sender: TObject; var IsEOF: boolean); procedure DoGetDataFieldNames(Sender: TObject; List: TStrings); protected procedure Setup; override; procedure TearDown; override; public property Data: TFPReportUserData read FData; property Report: TMyCustomReport read FRpt write FRpt; published procedure TestBeginReportEvent; procedure TestEndReportEvent; procedure TestPagePrepareObjects; procedure TestBandPrepareObjects; procedure TestRTObjects1; procedure TestRTObjects2; procedure TestRTObjects3; procedure TestRTObjects4_OneDataItem; procedure TestRTObjects5_TwoDataItems; procedure TestInternalFunction_Page; procedure TestInternalFunction_Page_with_text; procedure TestInternalFunction_RecNo; procedure TestInternalFunction_Today; procedure TestInternalFunction_Today_with_text; procedure TestInternalFunction_Author; procedure TestInternalFunction_Author_with_text; procedure TestInternalFunction_Title; procedure TestInternalFunction_Title_with_text; end; { TTestReportMemo } TTestReportMemo = class(TTestCase) private FMemo: TFPReportMemo; procedure CauseFontNotFoundException; protected procedure SetUp; override; procedure TearDown; override; published procedure TestCreate; procedure TestPrepareTextBlocks; procedure TestPrepareTextBlocks_multiline_data; procedure TestPrepareTextBlocks_multiline_wraptext; procedure TestPrepareTextBlocks_multiline_wraptext_oneword; procedure TestPrepareTextBlocks_multiline_wraptext_oneword_overflow; procedure TestPrepareTextBlocks_multiline_wraptext_oneword_split; procedure TestRGBToReportColor; procedure TestHTMLColorToReportColor_length7; procedure TestHTMLColorToReportColor_length6; procedure TestHTMLColorToReportColor_length3; procedure TestCreateTestBlock; procedure TestCreateTestBlock_IsURL; procedure TestSubStr; procedure TestTokenCount; procedure TestToken; end; TTestBandList = class(TTestCase) private FList: TBandList; b1: TFPReportPageHeaderBand; b2: TFPReportTitleBand; b3: TFPReportDataBand; procedure CreateBands; procedure AddAllBandsToList; protected procedure SetUp; override; procedure TearDown; override; published procedure TestAdd; procedure TestItems; procedure TestClear; procedure TestDelete; procedure TestFind1; procedure TestFind2; end; { TTestVariableBase } TTestVariableBase = Class(TTestCase) Public Class procedure AssertEquals(Const Msg : String; AExpected,AActual : TResultType); overload; end; { TTestVariable } TTestVariable = Class(TTestVariableBase) private FVar: TFPReportVariable; Protected Procedure SetUp; override; Procedure TearDown; override; Property Variable : TFPReportVariable Read FVar; Published Procedure TestEmpty; Procedure TestName; Procedure TestBoolean; Procedure TestInteger; Procedure TestDateTime; Procedure TestFloat; Procedure TestString; Procedure TestExpressionResult; end; { TTestVariables } TTestVariables = Class(TTestVariableBase) private FVar: TFPReportVariables; FV : Array[0..2] of TFPReportVariable; procedure AddThree; Protected Procedure SetUp; override; Procedure TearDown; override; Property Variables : TFPReportVariables Read FVar; Published Procedure TestEmpty; Procedure TestAdd; Procedure TestIndexOf; Procedure TestFind; end; implementation uses TypInfo, DateUtils, fpTTF; type TMemoFriend = class(TFPReportMemo); { TTestVariables } procedure TTestVariables.SetUp; begin inherited SetUp; FVar:=TFPReportVariables.Create(Nil,TFPReportVariable); end; procedure TTestVariables.TearDown; begin FreeAndNil(FVar); inherited TearDown; end; procedure TTestVariables.TestEmpty; begin AssertNotNull('Have variables',Variables); AssertEquals('Variable count',0,Variables.Count); AssertTrue('Variable class',Variables.ItemClass.InheritsFrom(TFPReportVariable)); end; procedure TTestVariables.TestAdd; Var V : TFPReportVariable; begin V:=Variables.addVariable('aName'); AssertNotNull('Have result',V); AssertEquals('Correct name','aName',V.Name); AssertEquals('Correct type',rtString,V.DataType); AssertEquals('Correct value','',V.AsString); AssertEquals('Added to collection',1,Variables.Count); AssertSame('In array',V,Variables[0]); ExpectException('Cannot add twice',EReportError); V:=Variables.addVariable('aName'); end; procedure TTestVariables.AddThree; Var I: integer; begin For I:=0 to 2 do FV[I]:=Variables.Addvariable('aName'+IntToStr(i+1)); end; procedure TTestVariables.TestIndexOf; begin AddThree; AssertEquals('First',0,Variables.IndexOfVariable('aName1')); AssertEquals('Second',1,Variables.IndexOfVariable('aName2')); AssertEquals('Third',2,Variables.IndexOfVariable('aName3')); AssertEquals('NonExisting',-1,Variables.IndexOfVariable('aName4')); end; procedure TTestVariables.TestFind; begin AddThree; AssertSame('First',FV[0],Variables.FindVariable('aName1')); AssertSame('Second',FV[1],Variables.FindVariable('aName2')); AssertSame('Third',FV[2],Variables.FindVariable('aName3')); AssertNull('NonExisting',Variables.FindVariable('aName4')); end; { TTestVariableBase } class procedure TTestVariableBase.AssertEquals(const Msg: String; AExpected, AActual: TResultType); begin AssertEquals(Msg,GetEnumName(TypeInfo(TResultType),Ord(AExpected)),GetEnumName(TypeInfo(TResultType),Ord(AActual))) end; { TTestVariable } procedure TTestVariable.SetUp; begin inherited SetUp; FVar:=TFPReportVariable.Create(Nil); end; procedure TTestVariable.TearDown; begin FreeandNil(FVar); inherited TearDown; end; procedure TTestVariable.TestEmpty; begin AssertNotNull('Have variable', Variable); AssertEquals('Boolean type',rtBoolean,Variable.DataType); AssertFalse('Boolean default value',Variable.AsBoolean); end; procedure TTestVariable.TestName; begin Variable.Name:='me'; // OK Variable.Name:='me.me'; // OK ExpectException('Name must be identifier',EReportError); Variable.Name:='me me'; // not OK end; procedure TTestVariable.TestBoolean; Var R : TFPExpressionResult; begin Variable.DataType:=rtBoolean; AssertEquals('Boolean type remains',rtBoolean,Variable.DataType); AssertFalse('Boolean default value',Variable.AsBoolean); AssertEquals('Boolean as string','False',Variable.Value); Variable.DataType:=rtFloat; Variable.AsBoolean:=true; AssertEquals('Boolean type remains',rtBoolean,Variable.DataType); AssertEquals('Boolean as string','True',Variable.Value); AssertTrue('Boolean value',Variable.AsBoolean); R:=Variable.AsExpressionResult; AssertEquals('Correct result',rtBoolean,r.resulttype); AssertEquals('Correct value',True,r.resBoolean); ExpectException('Cannot fetch as other type',EConvertError); Variable.AsString; end; procedure TTestVariable.TestInteger; Var R : TFPExpressionResult; begin Variable.DataType:=rtInteger; AssertEquals('Integer type remains',rtInteger,Variable.DataType); AssertEquals('Integer default value',0,Variable.AsInteger); AssertEquals('Integer as string','0',Variable.Value); Variable.DataType:=rtFloat; Variable.AsInteger:=123; AssertEquals('Integer type remains',rtInteger,Variable.DataType); AssertEquals('Integer as string','123',Variable.Value); AssertEquals('Integer value',123,Variable.AsInteger); R:=Variable.AsExpressionResult; AssertEquals('Correct result',rtInteger,r.resulttype); AssertEquals('Correct value',123,r.resInteger); ExpectException('Cannot fetch as other type',EConvertError); Variable.AsString; end; procedure TTestVariable.TestDateTime; Var R : TFPExpressionResult; begin Variable.DataType:=rtDateTime; AssertEquals('DateTime type remains',rtDateTime,Variable.DataType); AssertEquals('DateTime default value',0.0,Variable.AsDateTime); AssertEquals('DateTime as string','00000000T000000',Variable.Value); Variable.DataType:=rtDateTime; Variable.AsDateTime:=Date; AssertEquals('DateTime type remains',rtDateTime,Variable.DataType); AssertEquals('DateTime as string',FormatDateTime('yyyymmdd"T"000000',Date),Variable.Value); AssertEquals('DateTime value',Date,Variable.AsDateTime); R:=Variable.AsExpressionResult; AssertEquals('Correct result',rtDateTime,r.resulttype); AssertEquals('Correct value',Date,r.resDateTime); ExpectException('Cannot fetch as other type',EConvertError); Variable.AsString; end; procedure TTestVariable.TestFloat; Var R : TFPExpressionResult; begin Variable.DataType:=rtFloat; AssertEquals('Float type remains',rtFloat,Variable.DataType); AssertEquals('Float default value',0.0,Variable.AsFloat); AssertEquals('Float as string',' 0.0000000000000000E+000',Variable.Value); Variable.DataType:=rtBoolean; Variable.AsFloat:=1.23; AssertEquals('Float type remains',rtFloat,Variable.DataType); AssertEquals('Float as string',' 1.2300000000000000E+000',Variable.Value); AssertEquals('Float value',1.23,Variable.AsFloat); R:=Variable.AsExpressionResult; AssertEquals('Correct result',rtFloat,r.resulttype); AssertEquals('Correct value',1.23,r.resFloat); ExpectException('Cannot fetch as other type',EConvertError); Variable.AsString; end; procedure TTestVariable.TestString; Var R : TFPExpressionResult; begin Variable.DataType:=rtString; AssertEquals('String type remains',rtString,Variable.DataType); AssertEquals('String default value','',Variable.AsString); AssertEquals('String as string','',Variable.Value); Variable.DataType:=rtBoolean; Variable.AsString:='abc'; AssertEquals('String type remains',rtString,Variable.DataType); AssertEquals('String as string','abc',Variable.Value); AssertEquals('String value','abc',Variable.AsString); R:=Variable.AsExpressionResult; AssertEquals('Correct result',rtString,r.resulttype); AssertEquals('Correct value','abc',r.resString); ExpectException('Cannot fetch as other type',EConvertError); Variable.AsFloat; end; procedure TTestVariable.TestExpressionResult; Var R : TFPExpressionResult; begin R.ResultType:=rtFloat; R.ResFloat:=1.23; Variable.AsExpressionResult:=R; AssertEquals('Correct type ',rtFloat,Variable.DataType); AssertEquals('Correct value',1.23,Variable.AsFloat); R.ResultType:=rtBoolean; R.ResBoolean:=True; Variable.AsExpressionResult:=R; AssertEquals('Correct type ',rtBoolean,Variable.DataType); AssertEquals('Correct value',True,Variable.AsBoolean); R.ResultType:=rtString; R.ResString:='me'; Variable.AsExpressionResult:=R; AssertEquals('Correct type ',rtString,Variable.DataType); AssertEquals('Correct value','me',Variable.AsString); R.ResultType:=rtDateTime; R.ResDateTime:=Date; Variable.AsExpressionResult:=R; AssertEquals('Correct type ',rtDateTime,Variable.DataType); AssertEquals('Correct value',Date,Variable.AsDateTime); R.ResultType:=rtinteger; R.ResInteger:=1234; Variable.AsExpressionResult:=R; AssertEquals('Correct type ',rtinteger,Variable.DataType); AssertEquals('Correct value',1234,Variable.AsInteger); end; { TTestCaseWithData } procedure TTestCaseWithData.InitializeData(const ACount: Integer); var i: integer; begin // data is coming from the stringlist this time FSL := TStringList.Create; if ACount < 1 then Exit; for i := 1 to ACount do FSL.Add('Item ' + IntToStr(i)); end; procedure TTestCaseWithData.SetReportData(const ADataCount: Byte); begin if ADataCount < 1 then Exit; InitializeData(ADataCount); FData := TFPReportUserData.Create(nil); FData.OnGetValue := @DoGetDataValue; FData.OnGetEOF := @DoGetDataEOF; end; procedure TTestCaseWithData.DoGetDataValue(Sender: TObject; const AValueName: string; var AValue: variant); begin if AValueName = 'element' then AValue := FSL[FData.RecNo - 1]; end; procedure TTestCaseWithData.DoGetDataEOF(Sender: TObject; var IsEOF: boolean); begin if FData.RecNo > FSL.Count then IsEOF := True else IsEOF := False; end; procedure TTestCaseWithData.SetUp; begin inherited SetUp; end; procedure TTestCaseWithData.TearDown; begin FreeAndNil(FData); FreeAndNil(FSL); inherited TearDown; end; { TTestCaseWithDataAndReport } procedure TTestCaseWithDataAndReport.SetUp; begin inherited SetUp; FReport := TMyCustomReport.Create(nil); end; procedure TTestCaseWithDataAndReport.TearDown; begin inherited TearDown; FreeAndNil(FReport); end; { TBaseReportComponentTest } procedure TBaseReportComponentTest.ExpectState(const aExpected: TFPReportState); begin AssertEquals('ReportComponent.ReportState: ', AExpected, FC.ReportState); end; procedure TBaseReportComponentTest.AssertEquals(Msg: string; const aExpected, AActual: TFPReportState); begin AssertEquals(Msg, GetEnumName(TypeInfo(TFPReportState), Ord(AExpected)), GetEnumName(TypeInfo(TFPReportState), Ord(AActual))); end; procedure TBaseReportComponentTest.SetUp; begin FC := TMyFPReportComponent.Create(nil); end; procedure TBaseReportComponentTest.TearDown; begin FreeAndNil(FC); end; { TTestReportComponent } procedure TTestReportComponent.TestCreate; begin ExpectState(rsDesign); end; procedure TTestReportComponent.TestLayoutState; begin FC.StartLayout; ExpectState(rsLayout); FC.EndLayout; ExpectState(rsDesign); end; procedure TTestReportComponent.TestRenderState; begin FC.StartRender; ExpectState(rsRender); FC.EndRender; ExpectState(rsDesign); end; { TMyFPReportComponent } procedure TMyFPReportComponent.StartLayout; begin inherited StartLayout; end; procedure TMyFPReportComponent.EndLayout; begin inherited EndLayout; end; procedure TMyFPReportComponent.StartRender; begin inherited StartRender; end; procedure TMyFPReportComponent.EndRender; begin inherited EndRender; end; { TMyFPReportElement } procedure TMyFPReportElement.CallChange; begin Changed; end; procedure TMyFPReportElement.ResetChanged; begin FChangedCalled := 0; end; procedure TMyFPReportElement.DoChanged; begin inherited DoChanged; Inc(FChangedCalled); end; { TBaseReportElementTest } procedure TBaseReportElementTest.SetUp; begin inherited SetUp; FC := TMyFPReportElement.Create(nil); end; procedure TBaseReportElementTest.TearDown; begin FreeAndNil(FC); inherited TearDown; end; { TReportElementTest } procedure TReportElementTest.TestCreate; begin AssertEquals('Create does not invoke changed', 0, FC.ChangedCalled); AssertNotNull('Create creates frame', FC.Frame); AssertEquals('Create creates frame of correct class', TFPReportFrame, FC.Frame.Classtype); AssertNotNull('Create creates layout', FC.Layout); AssertEquals('Create creates layout of correct class ', TFPReportLayout, FC.Layout.Classtype); AssertEquals('Created element is visible', True, FC.Visible); AssertNull('No parent at create', FC.Parent); end; procedure TReportElementTest.TestDoChange; begin FC.CallChange; AssertEquals('Change calls dochange', 1, FC.ChangedCalled); end; procedure TReportElementTest.TestChangeCount; begin FC.BeginUpdate; try FC.CallChange; AssertEquals('First Change does notcall dochange', 0, FC.ChangedCalled); FC.CallChange; AssertEquals('Second Change does not call dochange', 0, FC.ChangedCalled); finally FC.EndUpdate; end; AssertEquals('EndUpdate calls dochange once', 1, FC.ChangedCalled); end; procedure TReportElementTest.TestChangeCountNested; begin FC.BeginUpdate; try FC.CallChange; AssertEquals('First Change does notcall dochange', 0, FC.ChangedCalled); FC.BeginUpdate; try FC.CallChange; AssertEquals('Second Change does not call dochange', 0, FC.ChangedCalled); finally FC.EndUpdate; AssertEquals('First endupdate does not call dochange', 0, FC.ChangedCalled); end; finally FC.EndUpdate; end; AssertEquals('Second EndUpdate calls dochange once', 1, FC.ChangedCalled); end; procedure TReportElementTest.TestChangeCountNested2; begin FC.BeginUpdate; try FC.CallChange; AssertEquals('First Change does notcall dochange', 0, FC.ChangedCalled); FC.BeginUpdate; try FC.CallChange; AssertEquals('Second Change does not call dochange', 0, FC.ChangedCalled); FC.CallChange; AssertEquals('Third Change does not call dochange', 0, FC.ChangedCalled); finally FC.EndUpdate; AssertEquals('First endupdate does not call dochange', 0, FC.ChangedCalled); end; finally FC.EndUpdate; end; AssertEquals('Second EndUpdate calls dochange once', 1, FC.ChangedCalled); end; procedure TReportElementTest.TestVisibleChanges; begin FC.ResetChanged; FC.Visible := False; AssertEquals('Setting visible calls change', 1, FC.ChangedCalled); end; procedure TReportElementTest.TestLayoutChanges; var L: TFPreportLayout; begin L := TFPreportLayout.Create(nil); try FC.Layout := L; AssertEquals('Setting layout calls change', 1, FC.ChangedCalled); finally L.Free; end; end; procedure TReportElementTest.TestFrameChanges; var F: TFPreportFrame; begin F := TFPreportFrame.Create(nil); try FC.Frame := F; AssertEquals('Setting frame calls change', 1, FC.ChangedCalled); finally F.Free; end; end; procedure TReportElementTest.TestAssign; var E: TFPReportElement; begin E := TMyFPReportElement.Create(nil); try FC.Layout.Top := 1; FC.Frame.Width := 2; E.Assign(FC); AssertEquals('Assigned frame equal', True, FC.Frame.Equals(E.Frame)); AssertEquals('Assigned layout equal', True, FC.Layout.Equals(FC.Layout)); finally E.Free; end; end; procedure TReportElementTest.TestEquals1; begin AssertEquals('Self always returns equal', True, FC.Equals(FC)); end; procedure TReportElementTest.TestEquals2; var E: TFPReportElement; begin E := TMyFPReportElement.Create(nil); try E.Assign(FC); AssertEquals('Assigned element returns equal', True, FC.Equals(E)); AssertEquals('Assigned element returns equal', True, E.Equals(FC)); finally E.Free; end; end; procedure TReportElementTest.TestEquals3; var E: TFPReportElement; begin E := TFPReportElement.Create(nil); try E.Assign(FC); AssertEquals('Different class makes unequal', True, FC.Equals(E)); AssertEquals('Different class makes unequal', True, E.Equals(FC)); finally E.Free; end; end; procedure TReportElementTest.TestEquals4; var E: TFPReportElement; begin E := TMyFPReportElement.Create(nil); try FC.Layout.Top := 1; E.Assign(FC); E.Layout.Top := 2; AssertEquals('Changed layout makes unequal', False, FC.Equals(E)); AssertEquals('Changed layout makes unequal', False, E.Equals(FC)); finally E.Free; end; end; procedure TReportElementTest.TestEquals5; var E: TFPReportElement; begin E := TMyFPReportElement.Create(nil); try FC.Layout.Top := 1; E.Assign(FC); E.Frame.Lines := [flLeft]; AssertEquals('Changed frame makes unequal', False, FC.Equals(E)); AssertEquals('Changed frame makes unequal', False, E.Equals(FC)); finally E.Free; end; end; { TTestReportFrame } procedure TTestReportFrame.TestCreate; begin AssertEquals('Failed on 1', 1, FC.Frame.Width); AssertEquals('Failed on 2', GetEnumName(TYpeInfo(TFPPenStyle), Ord(psSolid)), GetEnumName(TYpeInfo(TFPPenStyle), Ord(FC.Frame.Pen))); if not (FC.Frame.Lines = []) then Fail('Failed on 3'); AssertEquals('Failed on 4', GetEnumName(TypeInfo(TFPReportFrameShape), Ord(fsNone)), GetEnumName(TypeInfo(TFPReportFrameShape), Ord(FC.Frame.Shape))); end; procedure TTestReportFrame.TestWidthChange; begin FC.Frame.Width := 2; AssertEquals('Setting Width calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportFrame.TestColorChange; begin FC.Frame.Color := 3; AssertEquals('Setting Solor calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportFrame.TestPenStyleChange; begin FC.Frame.Pen := psDot; AssertEquals('Setting pen calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportFrame.TestShapeChange; begin FC.Frame.Shape := fsRoundedRect; AssertEquals('Setting pen calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportFrame.TestLinesChange; begin FC.Frame.Lines := [flBottom]; AssertEquals('Setting pen calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportFrame.TestAssign; var F: TFPReportFrame; begin F := TFPReportFrame.Create(nil); try F.Width := 3; F.Lines := [flBottom, flTop]; F.Color := 4; F.Pen := psDot; F.Shape := fsRoundedRect; FC.Frame.Assign(F); AssertSame('ReportElement not copied', FC, FC.Frame.ReportElement); AssertEquals('Assert calls changed', 1, FC.ChangedCalled); AssertEquals('Frame width equals 3', F.Width, FC.Frame.Width); AssertEquals('Frame penstyle equals psDot', GetEnumName(TYpeInfo(TFPPenStyle), Ord(F.Pen)), GetEnumName(TYpeInfo(TFPPenStyle), Ord(FC.Frame.Pen))); if not (FC.Frame.Lines = F.Lines) then Fail('Frame lines not copied correctly'); AssertEquals('Frame shape correctly copied', GetEnumName(TypeInfo(TFPReportFrameShape), Ord(F.Shape)), GetEnumName(TypeInfo(TFPReportFrameShape), Ord(FC.Frame.Shape))); finally F.Free; end; end; procedure TTestReportFrame.TestEquals1; var F: TFPReportFrame; begin F := TFPReportFrame.Create(nil); try FC.Frame.Width := 3; FC.Frame.Lines := [flBottom, flTop]; FC.Frame.Color := 4; FC.Frame.Pen := psDot; FC.Frame.Shape := fsRoundedRect; F.Assign(FC.Frame); F.Width := 2; AssertEquals('Width changed makes unequal', False, FC.Frame.Equals(F)); AssertEquals('Width changed makes unequal', False, F.Equals(FC.Frame)); finally F.Free; end; end; procedure TTestReportFrame.TestEquals2; var F: TFPReportFrame; begin F := TFPReportFrame.Create(nil); try FC.Frame.Width := 3; FC.Frame.Lines := [flBottom, flTop]; FC.Frame.Color := 4; FC.Frame.Pen := psDot; FC.Frame.Shape := fsRoundedRect; F.Assign(FC.Frame); F.Color := 2; AssertEquals('Color changed makes unequal', False, FC.Frame.Equals(F)); AssertEquals('Color changed makes unequal', False, F.Equals(FC.Frame)); finally F.Free; end; end; procedure TTestReportFrame.TestEquals3; var F: TFPReportFrame; begin F := TFPReportFrame.Create(nil); try FC.Frame.Width := 3; FC.Frame.Lines := [flBottom, flTop]; FC.Frame.Color := 4; FC.Frame.Pen := psDot; FC.Frame.Shape := fsRoundedRect; F.Assign(FC.Frame); F.Pen := psDash; AssertEquals('Pen changed makes unequal', False, FC.Frame.Equals(F)); AssertEquals('Pen changed makes unequal', False, F.Equals(FC.Frame)); finally F.Free; end; end; procedure TTestReportFrame.TestEquals4; var F: TFPReportFrame; begin F := TFPReportFrame.Create(nil); try FC.Frame.Width := 3; FC.Frame.Lines := [flBottom, flTop]; FC.Frame.Color := 4; FC.Frame.Pen := psDot; FC.Frame.Shape := fsRoundedRect; F.Assign(FC.Frame); F.Shape := fsShadow; AssertEquals('Shape changed makes unequal', False, FC.Frame.Equals(F)); AssertEquals('Shape changed makes unequal', False, F.Equals(FC.Frame)); finally F.Free; end; end; procedure TTestReportFrame.TestEquals5; var F: TFPReportFrame; begin F := TFPReportFrame.Create(nil); try FC.Frame.Width := 3; FC.Frame.Lines := [flBottom, flTop]; FC.Frame.Color := 4; FC.Frame.Pen := psDot; FC.Frame.Shape := fsRoundedRect; F.Assign(FC.Frame); F.Lines := [flLeft, flRight]; AssertEquals('Lines changed makes unequal', False, FC.Frame.Equals(F)); AssertEquals('Lines changed makes unequal', False, F.Equals(FC.Frame)); finally F.Free; end; end; procedure TTestReportFrame.TestEquals6; begin AssertEquals('Same frame always equals', True, FC.Frame.Equals(FC.Frame)); end; procedure TTestReportFrame.TestEquals7; var F: TFPReportFrame; begin F := TFPReportFrame.Create(nil); try FC.Frame.Width := 3; FC.Frame.Lines := [flBottom, flTop]; FC.Frame.Color := 4; FC.Frame.Pen := psDot; FC.Frame.Shape := fsRoundedRect; F.Assign(FC.Frame); AssertEquals('Equals after assign', True, FC.Frame.Equals(F)); AssertEquals('Equals after assign', True, F.Equals(FC.Frame)); finally F.Free; end; end; { TTestReportLayout } procedure TTestReportLayout.TestCreate; begin AssertEquals('Top is zero', 0, FC.Layout.top); AssertEquals('Left is zero', 0, FC.Layout.Left); AssertEquals('Width is zero', 0, FC.Layout.Width); AssertEquals('Height is zero', 0, FC.Layout.Width); end; procedure TTestReportLayout.TestTopChange; begin FC.Layout.Top := 2; AssertEquals('Setting top calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportLayout.TestLeftChange; begin FC.Layout.Left := 2; AssertEquals('Setting left calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportLayout.TestWidthChange; begin FC.Layout.Width := 2; AssertEquals('Setting width calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportLayout.TestHeightChange; begin FC.Layout.Height := 2; AssertEquals('Setting Height calls onChange', 1, FC.ChangedCalled); end; procedure TTestReportLayout.TestAssign; var L: TFPReportLayout; begin L := TFPReportlayout.Create(nil); try FC.Layout.Top := 1; FC.Layout.Left := 1; FC.Layout.Width := 10; FC.Layout.Height := 10; L.Assign(FC.Layout); AssertEquals('Top correct', FC.Layout.Top, L.Top); AssertEquals('Left correct', FC.Layout.Left, L.Left); AssertEquals('Width correct', FC.Layout.Width, L.Width); AssertEquals('Height correct', FC.Layout.Height, L.Height); finally L.Free; end; end; procedure TTestReportLayout.TestEquals1; var L: TFPReportLayout; begin L := TFPReportlayout.Create(nil); try FC.Layout.Top := 1; FC.Layout.Left := 1; FC.Layout.Width := 10; FC.Layout.Height := 10; L.Assign(FC.Layout); FC.Layout.Top := 2; AssertEquals('Top changed makes unequal', False, FC.Layout.Equals(L)); AssertEquals('Top changed makes unequal', False, L.Equals(FC.Layout)); finally L.Free; end; end; procedure TTestReportLayout.TestEquals2; var L: TFPReportLayout; begin L := TFPReportlayout.Create(nil); try FC.Layout.Top := 1; FC.Layout.Left := 1; FC.Layout.Width := 10; FC.Layout.Height := 10; L.Assign(FC.Layout); FC.Layout.Left := 2; AssertEquals('Left changed makes unequal', False, FC.Layout.Equals(L)); AssertEquals('Left changed makes unequal', False, L.Equals(FC.Layout)); finally L.Free; end; end; procedure TTestReportLayout.TestEquals3; var L: TFPReportLayout; begin L := TFPReportlayout.Create(nil); try FC.Layout.Top := 1; FC.Layout.Left := 1; FC.Layout.Width := 10; FC.Layout.Height := 10; L.Assign(FC.Layout); FC.Layout.Width := 2; AssertEquals('Width changed makes unequal', False, FC.Layout.Equals(L)); AssertEquals('Width changed makes unequal', False, L.Equals(FC.Layout)); finally L.Free; end; end; procedure TTestReportLayout.TestEquals4; var L: TFPReportLayout; begin L := TFPReportlayout.Create(nil); try FC.Layout.Top := 1; FC.Layout.Left := 1; FC.Layout.Width := 10; FC.Layout.Height := 10; L.Assign(FC.Layout); FC.Layout.Height := 2; AssertEquals('Height changed makes unequal', False, FC.Layout.Equals(L)); AssertEquals('Height changed makes unequal', False, L.Equals(FC.Layout)); finally L.Free; end; end; procedure TTestReportLayout.TestEquals5; var L: TFPReportLayout; begin L := TFPReportlayout.Create(nil); try FC.Layout.Top := 1; FC.Layout.Left := 1; FC.Layout.Width := 10; FC.Layout.Height := 10; L.Assign(FC.Layout); AssertEquals('Assign results in equal', True, FC.Layout.Equals(L)); AssertEquals('Assign results in equal', True, L.Equals(FC.Layout)); finally L.Free; end; end; procedure TTestReportLayout.TestEquals6; begin AssertEquals('Assign results in equal', True, FC.Layout.Equals(FC.Layout)); end; { TTestReportChildren } procedure TTestReportChildren.SetUp; begin FC := TMyFPReportElementWithChildren.Create(nil); FC2 := TMyFPReportElementWithChildren.Create(nil); FChild := TFPReportElement.Create(nil); end; procedure TTestReportChildren.TearDown; begin FreeAndNil(FChild); FreeAndNil(FC); FreeAndNil(FC2); end; procedure TTestReportChildren.WrongParent; begin FC.Parent := FChild; end; procedure TTestReportChildren.TestCreate; begin AssertEquals('No children at create', 0, FC.ChildCount); end; procedure TTestReportChildren.TestSetParent1; begin AssertException('Cannot set TReportElement as parent', EReportError, @WrongParent); end; procedure TTestReportChildren.TestSetParent2; begin FChild.parent := FC; AssertSame('Parent was saved', FC, FChild.parent); AssertEquals('Changed was called', 1, FC.ChangedCalled); AssertEquals('Parent childcount is 1', 1, FC.ChildCount); AssertSame('Parent first child is OK', FChild, FC.Child[0]); end; procedure TTestReportChildren.TestSetParent3; var E: TFPReportElementWithChildren; begin FChild.parent := FC; AssertSame('Parent was saved', FC, FChild.parent); AssertEquals('Parent childcount is 1', 1, FC.ChildCount); AssertSame('Parent first child is OK', FChild, FC.Child[0]); FC.ResetChanged; FChild.Parent := FC2; AssertSame('Parent was saved', FC2, FChild.parent); AssertEquals('Changed was called', 1, FC.ChangedCalled); AssertEquals('Old Parent childcount is 0', 0, FC.ChildCount); AssertEquals('Parent childcount is 1', 1, FC2.ChildCount); AssertSame('Parent first child is OK', FChild, FC2.Child[0]); end; procedure TTestReportChildren.TestSetParent4; begin FChild.parent := FC; AssertSame('Parent was saved', FC, FChild.parent); AssertEquals('Parent childcount is 1', 1, FC.ChildCount); AssertSame('Parent first child is OK', FChild, FC.Child[0]); FreeAndNil(FC); //FChild is freed due to free of parent //AssertNull('Child parent was removed when parent is freed', FChild.Parent); FChild := Nil; end; procedure TTestReportChildren.TestSetParent6; begin FChild.parent := FC; AssertSame('Parent was saved', FC, FChild.parent); AssertEquals('Parent childcount is 1', 1, FC.ChildCount); AssertSame('Parent first child is OK', FChild, FC.Child[0]); FChild.parent := nil; AssertNull('Child parent was removed when parent is freed', FChild.Parent); end; procedure TTestReportChildren.TestSetParent5; begin FChild.parent := FC; AssertSame('Parent was saved', FC, FChild.parent); AssertEquals('Parent childcount is 1', 1, FC.ChildCount); AssertSame('Parent first child is OK', FChild, FC.Child[0]); FreeAndNil(FChild); AssertEquals('Child removed when freed', 0, FC.ChildCount); end; { TMyFPReportElementWithChildren } procedure TMyFPReportElementWithChildren.CallChange; begin Changed; end; procedure TMyFPReportElementWithChildren.ResetChanged; begin FChangedCalled := 0; end; procedure TMyFPReportElementWithChildren.DoChanged; begin inherited DoChanged; Inc(FChangedCalled); end; { TTestFPPageSize } procedure TTestFPPageSize.TestCreate; var F: TFPReportPaperSize; begin F := TFPReportPaperSize.Create(1.23, 3.45); try AssertEquals('Width stored correctly', 1.23, F.Width, 0.001); AssertEquals('Height stored correctly', 3.45, F.Height, 0.001); finally F.Free; end; end; { TTestFPPaperManager } procedure TTestFPPapers.Setup; begin FM := TFPReportPaperManager.Create(nil); AssertNotNull(FM); end; procedure TTestFPPapers.TearDown; begin FreeAndNil(FM); end; procedure TTestFPPapers.RegisterPapers(ACount: integer; Local: boolean = True); var F: TFPReportPaperManager; begin if local then F := FM else F := PaperManager; if (ACount >= 1) then F.RegisterPaper('P3', 1.0, 2.0); if (ACount >= 2) then F.RegisterPaper('P2', 4.0, 8.0); if (ACount >= 3) then F.RegisterPaper('P1', 16.0, 32.0); end; procedure TTestFPPaperManager.TestAccess; begin case FAccess of 0: FM.PaperNames[-1]; 1: FM.PaperNames[FM.PaperCount]; 2: FM.PaperHeight[-1]; 3: FM.PaperHeight[FM.PaperCount]; 4: FM.PaperWidth[-1]; 5: FM.PaperWidth[FM.PaperCount]; 6: FM.WidthByName['NoPaper']; 7: FM.HeightByName['NoPaper']; end; end; procedure TTestFPPaperManager.Setup; begin inherited Setup; FAccess := -1; end; procedure TTestFPPaperManager.TestCreate; begin AssertEquals('No registered papers', 0, FM.PaperCount); end; procedure TTestFPPaperManager.TestRegister1; begin RegisterPapers(1); AssertEquals('1 registered paper', 1, FM.PaperCount); AssertEquals('Correct name', 'P3', FM.PaperNames[0]); end; procedure TTestFPPaperManager.TestRegister2; begin RegisterPapers(2); AssertEquals('2 registered papers', 2, FM.PaperCount); AssertEquals('Correct name paper 1', 'P2', FM.PaperNames[0]); AssertEquals('Correct name paper 2', 'P3', FM.PaperNames[1]); end; procedure TTestFPPaperManager.TestRegister3; begin RegisterPapers(3); AssertEquals('3 registered papers', 3, FM.PaperCount); AssertEquals('Correct name paper 1', 'P1', FM.PaperNames[0]); AssertEquals('Correct name paper 2', 'P2', FM.PaperNames[1]); AssertEquals('Correct name paper 3', 'P3', FM.PaperNames[2]); end; procedure TTestFPPaperManager.TestRegisterDuplicate; begin RegisterPapers(2); AssertEquals('2 registered papers', 2, FM.PaperCount); AssertEquals('Correct name paper 1', 'P2', FM.PaperNames[0]); AssertEquals('Correct name paper 2', 'P3', FM.PaperNames[1]); try FM.RegisterPaper('P3', 10.0, 20.0); Fail('We expected an exception to be raised.'); except on E: Exception do begin AssertEquals('Exception class', 'EReportError', E.ClassName); AssertEquals('Exception message', 'Paper name P3 already exists', E.Message); end; end; end; procedure TTestFPPaperManager.TestClear; begin RegisterPapers(2); AssertEquals('2 registered papers', 2, FM.PaperCount); AssertEquals('Correct name paper 1', 'P2', FM.PaperNames[0]); AssertEquals('Correct name paper 2', 'P3', FM.PaperNames[1]); FM.Clear; AssertEquals('0 registered papers', 0, FM.PaperCount); end; procedure TTestFPPaperManager.TestFind1; begin AssertEquals('No paper registered', -1, FM.IndexOfPaper('P1')); end; procedure TTestFPPaperManager.TestFind2; begin RegisterPapers(3); AssertEquals('No paper registered', -1, FM.IndexOfPaper('PA1')); end; procedure TTestFPPaperManager.TestFind3; begin RegisterPapers(3); AssertEquals('3 registered papers', 3, FM.PaperCount); AssertEquals('Find P1 OK', 0, FM.IndexOfPaper('P1')); AssertEquals('Find P2 OK', 1, FM.IndexOfPaper('P2')); AssertEquals('Find P3 OK', 2, FM.IndexOfPaper('P3')); end; procedure TTestFPPaperManager.IllegalAccess1; begin RegisterPapers(3); FAccess := 0; AssertException('Papername[-1]', EStringListError, @TestAccess); end; procedure TTestFPPaperManager.IllegalAccess2; begin RegisterPapers(3); FAccess := 1; AssertException('Papername[3]', EStringListError, @TestAccess); end; procedure TTestFPPaperManager.IllegalAccess3; begin RegisterPapers(3); FAccess := 2; AssertException('PaperHeight[-1]', EStringListError, @TestAccess); end; procedure TTestFPPaperManager.IllegalAccess4; begin RegisterPapers(3); FAccess := 3; AssertException('PaperHeight[3]', EStringListError, @TestAccess); end; procedure TTestFPPaperManager.IllegalAccess5; begin RegisterPapers(3); FAccess := 4; AssertException('PaperWidth[-1]', EStringListError, @TestAccess); end; procedure TTestFPPaperManager.IllegalAccess6; begin RegisterPapers(3); FAccess := 5; AssertException('PaperWidth[3]', EStringListError, @TestAccess); end; procedure TTestFPPaperManager.IllegalAccess7; begin RegisterPapers(3); FAccess := 6; AssertException('WidthByName[NoPaper]', EReportError, @TestAccess); end; procedure TTestFPPaperManager.IllegalAccess8; begin RegisterPapers(3); FAccess := 7; AssertException('WidthByName[NoPaper]', EReportError, @TestAccess); end; procedure TTestFPPaperManager.TestWidth; begin RegisterPapers(3); AssertEquals('Paper width 0', 16.0, FM.PaperWidth[0]); AssertEquals('Paper width 1', 4.0, FM.PaperWidth[1]); AssertEquals('Paper width 2', 1.0, FM.PaperWidth[2]); AssertEquals('Width[P1]', 16.0, FM.WidthByName['P1']); AssertEquals('Width[P2]', 4.0, FM.WidthByName['P2']); AssertEquals('Width[P3]', 1, FM.WidthByName['P3']); end; procedure TTestFPPaperManager.TestHeight; begin RegisterPapers(3); AssertEquals('Paper height 0', 32.0, FM.PaperHeight[0]); AssertEquals('Paper height 1', 8.0, FM.PaperHeight[1]); AssertEquals('Paper height 2', 2.0, FM.PaperHeight[2]); AssertEquals('Height[P1]', 32.0, FM.HeightByName['P1']); AssertEquals('Height[P2]', 8.0, FM.HeightByName['P2']); AssertEquals('Height[P3]', 2, FM.HeightByName['P3']); end; { TMyFPReportPageSize } procedure TMyFPReportPageSize.ResetChanged; begin FChangedCalled := 0; end; procedure TMyFPReportPageSize.Changed; begin Inc(FChangedCalled); inherited Changed; end; { TTestFPReportPageSize } procedure TTestFPReportPageSize.Setup; begin inherited Setup; FP := TMyFPReportPageSize.Create(nil); end; procedure TTestFPReportPageSize.TearDown; begin FreeAndNil(FP); inherited TearDown; end; procedure TTestFPReportPageSize.TestCreate; begin AssertNull('No page', FP.Page); AssertEquals('Zero width at create', 0.0, FP.Width); AssertEquals('Zero height at create', 0.0, FP.Height); AssertEquals('No paper name', '', FP.PaperName); end; procedure TTestFPReportPageSize.TestCreateWithPage; var P: TFPReportPage; F: TFPReportPageSize; begin P := TFPReportPage.Create(nil); try F := TFPReportPageSize.Create(P); try AssertSame('Pagesize created with page has page as page', P, F.Page); finally F.Free; end; finally P.Free end; end; procedure TTestFPReportPageSize.TestCreateByPage; var P: TFPReportPage; begin P := TFPReportPage.Create(nil); try AssertSame('Pagesize created with page has page as page', P, P.PageSize.Page); finally P.Free end; end; procedure TTestFPReportPageSize.TestChanged1; begin FP.Width := 1.23; AssertEquals('Setting width triggers change', 1, FP.ChangedCalled); end; procedure TTestFPReportPageSize.TestChanged2; begin FP.Height := 1.23; AssertEquals('Setting height triggers change', 1, FP.ChangedCalled); end; procedure TTestFPReportPageSize.TestChanged3; begin FP.PaperName := 'ABC'; AssertEquals('Setting paper name without associated paper does not trigger change', 0, FP.ChangedCalled); end; procedure TTestFPReportPageSize.TestPaperName1; var F: TFPReportPaperManager; begin F := PaperManager; if F.PaperCount = 0 then Registerpapers(3, False); FP.PaperName := F.PaperNames[0]; AssertEquals('Setting papername sets width', F.PaperWidth[0], FP.Width); AssertEquals('Setting papername sets height', F.PaperHeight[0], FP.Height); AssertEquals('Setting papername calls changed once', 1, FP.ChangedCalled); end; procedure TTestFPReportPageSize.TestPaperName2; var F: TFPReportPaperManager; begin F := PaperManager; if F.PaperCount = 0 then Registerpapers(3, False); FP.PaperName := F.PaperNames[0]; AssertEquals('Setting papername sets width', F.PaperWidth[0], FP.Width); AssertEquals('Setting papername sets height', F.PaperHeight[0], FP.Height); FP.ResetChanged; FP.PaperName := 'aloha'; // Non existing AssertEquals('Setting non-existing papername leaves width', F.PaperWidth[0], FP.Width); AssertEquals('Setting non-existing papername leaves height', F.PaperHeight[0], FP.Height); AssertEquals('Setting non-existing papername does not call changed', 0, FP.ChangedCalled); end; procedure TTestFPReportPageSize.TestAssign; var F: TMyFPreportPageSize; begin F := TMyFPreportPageSize.Create(nil); try FP.PaperName := 'me'; FP.Width := 1.23; FP.Height := 4.56; F.Assign(FP); AssertEquals('Assign assigns Width', FP.Width, F.Width); AssertEquals('Assign assigns height', FP.Height, F.Height); AssertEquals('Assign assigns papername', FP.PaperName, F.PaperName); AssertEquals('Assign calls Changed once', 1, F.ChangedCalled); finally F.Free; end; end; { TMyFPReportPage } procedure TMyFPReportPage.SetupPage; begin Orientation := poPortrait; { paper size } PageSize.PaperName := 'A4'; { page margins } Margins.Left := 30; Margins.Top := 20; Margins.Right := 30; Margins.Bottom := 20; end; procedure TMyFPReportPage.PrepareObjects(aRTParent: TFPReportElement); begin Inc(FPrepareObjectsCalled); inherited PrepareObjects(aRTParent); end; constructor TMyFPReportPage.Create(AOwner: TComponent); begin inherited Create(AOwner); Font.Name := 'LiberationSerif'; end; procedure TMyFPReportPage.ResetChanged; begin FChangedCalled := 0; end; procedure TMyFPReportPage.DoChanged; begin Inc(FChangedCalled); inherited DoChanged; end; { TMyReportTitleBand } procedure TMyReportTitleBand.PrepareObjects(aRTParent: TFPReportElement); begin Inc(FPrepareObjectsCalled); inherited PrepareObjects(aRTParent); end; constructor TMyReportTitleBand.Create(AOwner: TComponent); begin inherited Create(AOwner); Layout.Height := 20; end; { TMyDataBand } procedure TMyDataBand.PrepareObjects(aRTParent: TFPReportElement); begin Inc(FPrepareObjectsCalled); inherited PrepareObjects(aRTParent); end; constructor TMyDataBand.Create(AOwner: TComponent); begin inherited Create(AOwner); Layout.Height := 10; end; { TTestReportPage } procedure TTestReportPage.Setup; begin inherited Setup; FP := TMyFPReportPage.Create(nil); end; procedure TTestReportPage.TearDown; begin FreeAndNil(FP); inherited TearDown; end; procedure TTestReportPage.TestCreate1; begin AssertNull('Created page without parent has no report', FP.Report); AssertNotNull('Created page has margins', FP.Margins); AssertNotNull('Created page has pagesize', FP.PageSize); AssertEquals('Orientation is portrait', Ord(poPortrait), Ord(FP.Orientation)); AssertEquals('No bands', 0, FP.BandCount); end; procedure TTestReportPage.TestCreate2; var R: TFPReport; P: TMyFPReportPage; begin R := TFPReport.Create(nil); try P := TMyFPReportPage.Create(nil); try P.Report := R; AssertSame('Page owner is report when created', R, P.Report); AssertEquals('Report has one page', 1, R.PageCount); AssertSame('Page added to pages', P, R.Pages[0]); finally R.Free; end; AssertNull('Report has notified page', P.Report); finally P.Free; end; end; procedure TTestReportPage.TestCreate3; var R: TFPReport; P: TMyFPReportPage; begin R := TFPReport.Create(nil); P := TMyFPReportPage.Create(R); // Lets try passing Report as the AOwner in constructor try AssertSame('Page report is set', R, P.Report); AssertSame('Page added to pages', P, R.Pages[0]); P.Report := nil; AssertEquals('No more pages', 0, R.PageCount); finally // This will free P as well, because R was set as the owner R.Free; end; end; procedure TTestReportPage.TestPageSize1; begin FP.ResetChanged; FP.BeginUpdate; try FP.PageSize.Width := 10; FP.PageSize.Height := 20; finally FP.EndUpdate; end; AssertEquals('Changed called', 1, FP.ChangedCalled); AssertEquals('Top is zero', 0, FP.Layout.Top); AssertEquals('Left is zero', 0, FP.Layout.Left); AssertEquals('Width is pagewidth', FP.PageSize.Width, FP.Layout.Width); AssertEquals('Height is pageheight', FP.PageSize.Height, FP.Layout.Height); end; procedure TTestReportPage.TestPageSize2; begin FP.ResetChanged; FP.BeginUpdate; try FP.PageSize.Width := 10; FP.PageSize.Height := 20; FP.Margins.Left := 1; FP.Margins.Right := 2; FP.Margins.Top := 3; FP.Margins.Bottom := 4; finally FP.EndUpdate; end; AssertEquals('Changed called', 1, FP.ChangedCalled); AssertEquals('Top is top margin', 3, FP.Layout.Top); AssertEquals('Left is left margin', 1, FP.Layout.Left); AssertEquals('Width is pagewidth-rightmargin-leftmargin', 7, FP.Layout.Width); AssertEquals('Height is pageheight-topmargin-bottommargin', 13, FP.Layout.Height); end; procedure TTestReportPage.TestPageSize3; begin FP.ResetChanged; FP.BeginUpdate; try FP.Orientation := poLandScape; FP.PageSize.Width := 10; FP.PageSize.Height := 20; FP.Margins.Left := 1; FP.Margins.Right := 2; FP.Margins.Top := 3; FP.Margins.Bottom := 4; finally FP.EndUpdate; end; AssertEquals('Changed called', 1, FP.ChangedCalled); AssertEquals('Top is top margin', 3, FP.Layout.Top); AssertEquals('Left is left margin', 1, FP.Layout.Left); AssertEquals('Width is pageheight-rightmargin-leftmargin', 17, FP.Layout.Width); AssertEquals('Height is pagewidth-topmargin-bottommargin', 3, FP.Layout.Height); end; procedure TTestReportPage.TestBand1; var B: TFPReportCustomBand; begin B := TFPReportCustomBand.Create(nil); try FP.ResetChanged; B.Parent := FP; AssertEquals('Changed called', 1, FP.ChangedCalled); AssertSame('Parent stored correctly', FP, B.Page); AssertEquals('Bandcount correct', 1, FP.BandCount); AssertSame('Bands[0] correct', B, FP.Bands[0]); finally B.Free; end; AssertEquals('Bandcount correct', 0, FP.BandCount); end; procedure TTestReportPage.TestBand2; var B: TFPReportCustomBand; P: TMyFPReportPage; begin P := TMyFPReportPage.Create(nil); try B := TFPReportCustomBand.Create(nil); try B.Parent := P; AssertSame('Parent stored correctly', P, B.Page); AssertEquals('Bandcount correct', 1, P.BandCount); AssertSame('Bands[0] correct', B, P.Bands[0]); finally B.Free; end; AssertEquals('Page notified that Band is gone', 0, P.BandCount); finally P.Free; end; end; procedure TTestReportPage.TestData; var FData: TFPReportData; begin FData := TFPReportData.Create(nil); try FP.Data := FData; finally FData.Free; end; AssertNull('Data is cleared', FP.Data); end; procedure TTestReportPage.TestAssign; var E: TFPReportPage; begin E := TFPReportPage.Create(nil); try FP.Layout.Top := 1; FP.Frame.Width := 2; E.Assign(FP); AssertEquals('Failed on 1', True, FP.Frame.Equals(E.Frame)); AssertEquals('Failed on 2', True, FP.Layout.Equals(E.Layout)); AssertEquals('Failed on 3', Ord(E.Orientation), Ord(FP.Orientation)); AssertEquals('Failed on 4', True, FP.Margins.Equals(E.Margins)); finally E.Free; end; end; procedure TTestReportPage.TestFindBand; var t: TFPReportTitleBand; h: TFPReportPageHeaderBand; f: TFPReportPageFooterBand; d: TFPReportDataBand; begin t := TFPReportTitleBand.Create(FP); h := TFPReportPageHeaderBand.Create(FP); f := TFPReportPageFooterBand.Create(FP); d := TFPReportDataBand.Create(FP); AssertTrue('failed on 1', h = FP.FindBand(TFPReportPageHeaderBand)); AssertTrue('failed on 2', t <> FP.FindBand(TFPReportPageHeaderBand)); AssertTrue('failed on 3', t = FP.FindBand(TFPReportTitleBand)); AssertTrue('failed on 4', f = FP.FindBand(TFPReportPageFooterBand)); AssertTrue('failed on 5', d = FP.FindBand(TFPReportDataBand)); AssertTrue('failed on 6', FP.FindBand(TFPReportChildBand) = nil); end; { TMyFPReportData } procedure TMyFPReportData.ResetCounts; begin FCC := 0; FDFC := 0; FEC := 0; FFC := 0; FNC := 0; FOC := 0; end; procedure TMyFPReportData.DoInitDataFields; begin inherited DoInitDataFields; Inc(FDFC); end; procedure TMyFPReportData.DoOpen; begin inherited DoOpen; Inc(FOC); end; procedure TMyFPReportData.DoFirst; begin inherited DoFirst; Inc(FFC); end; procedure TMyFPReportData.DoNext; begin inherited DoNext; Inc(FNC); end; procedure TMyFPReportData.DoClose; begin inherited DoClose; Inc(FCC); end; function TMyFPReportData.DoEOF: boolean; begin FOE := inherited DoEOF; Inc(FEC); Result := FReportEOF; end; { TTestReportData } procedure TTestReportData.DoOpen(Sender: TObject); begin FHandler := True; AssertEquals('OnOpen called before DoOpen', 0, FD.OpenCount); AssertEquals('OnOpen called before InitFieldDefs', 0, FD.InitDataFieldsCount); end; procedure TTestReportData.DoNext(Sender: TObject); begin FHandler := True; AssertEquals('DoNext not yet called in handler', 0, FD.NextCount); AssertEquals('Recno is already 2 in donext', 2, FD.RecNo); end; procedure TTestReportData.Setup; begin inherited Setup; FD := TMyFPReportData.Create(nil); FHandler := False; end; procedure TTestReportData.TearDown; begin FreeAndNil(FD); inherited TearDown; end; procedure TTestReportData.CreateFields; begin FD.DataFields.AddField('string', rfkString).DisplayWidth := 10; FD.DataFields.AddField('boolean', rfkBoolean).DisplayWidth := 20; FD.DataFields.AddField('integer', rfkInteger).DisplayWidth := 30; FD.DataFields.AddField('float', rfkFloat).DisplayWidth := 40; FD.DataFields.AddField('datetime', rfkDateTime).DisplayWidth := 50; FD.Datafields.AddField('stream', rfkStream).DisplayWidth := 60; end; procedure TTestReportData.DoFieldByName; var F: TFPReportDataField; begin F := FD.Datafields.FieldByName('ohlala'); end; procedure TTestReportData.TestCreate; begin AssertEquals('Closed recno is 0', 0, FD.RecNo); AssertNotNull('DataFields created', FD.DataFields); AssertEquals('Closed fieldcount is 0', 0, FD.DataFields.Count); AssertSame('Datafields reportdata is self', FD, FD.DataFields.ReportData); end; procedure TTestReportData.TestOpen1; begin FD.OnOpen := @DoOpen; FD.Open; AssertEquals('OnOpen Handler called', True, FHandler); AssertEquals('DoOpen called once', 1, FD.OpenCount); AssertEquals('InitFieldDefs called once', 1, FD.InitDataFieldsCount); AssertEquals('Recno is 1', 1, FD.RecNo); end; procedure TTestReportData.TestNext; begin FD.OnNext := @DoNext; FD.Open; FHandler := False; FD.Next; AssertEquals('OnNext Handler called', True, FHandler); AssertEquals('DoNext Called once', 1, FD.NextCount); AssertEquals('Recno is 2 after next', 2, FD.RecNo); end; procedure TTestReportData.TestInitFieldDefs; begin FD.InitFieldDefs; AssertEquals('InitFieldDefs called once', 1, FD.InitDataFieldsCount); end; procedure TTestReportData.TestInitFieldDefs_OnlyAllowedOnce; begin FD.Open; AssertEquals('Failed on 1', 1, FD.InitDataFieldsCount); try FD.InitFieldDefs; Fail('Failed on 2. - we should not have reached here.'); except on E: Exception do begin AssertEquals('Failed on 3', E.ClassName, 'EReportError'); end; end; AssertEquals('Failed on 4', 1, FD.InitDataFieldsCount); end; procedure TTestReportData.TestEOF1; begin FD.ReportEOF := True; AssertEquals('ReportEOF works correctly', True, FD.EOF); AssertEquals('Inherited EOF returns false', False, FD.OldEOF); end; procedure TTestReportData.TestAddDatafield; var F: TFPReportDataField; begin F := FD.DataFields.AddField('test', rfkBoolean); AssertEquals('Boolean field Added', Ord(rfkBoolean), Ord(F.FieldKind)); AssertEquals('test field name Added', 'test', F.fieldname); AssertEquals('0 width field Added', 0, F.DisplayWidth); end; procedure TTestReportData.TestDatafieldAdd; var I: TCollectionItem; F: TFPReportDataField; begin I := FD.Datafields.Add; AssertEquals('add creates TFPReportDataField', TFPReportDataField, I.ClassType); F := I as TFPReportDataField; AssertEquals('Default field of string kind', Ord(rfkString), Ord(F.FieldKind)); AssertEquals('Default field name empty', '', F.FieldName); AssertEquals('Default field with 0', 0, F.DisplayWidth); end; procedure TTestReportData.AssertField(Prefix: string; F: TFPReportDataField; AFieldName: string; AFieldKind: TFPReportFieldKind; ADisplayWidth: integer = 0); var S1, S2: string; begin AssertEquals(Prefix + ' has correct field name', AfieldName, F.FieldName); S1 := GetEnumName(TypeInfo(TFPReportFieldKind), Ord(AFieldKind)); S2 := GetEnumName(TypeInfo(TFPReportFieldKind), Ord(F.FieldKind)); AssertEquals(Prefix + ' has corrrect fieldkind', S1, S2); AssertEquals(Prefix + ' has correct fieldwidth', ADisplayWidth, F.DisplayWidth); end; procedure TTestReportData.TestCreateFields; begin CreateFields; AssertEquals('Correct field count', 6, FD.FieldCount); AssertField('Field 0', FD.DataFields[0], 'string', rfkString, 10); AssertField('Field 1', FD.DataFields[1], 'boolean', rfkBoolean, 20); AssertField('Field 2', FD.DataFields[2], 'integer', rfkInteger, 30); AssertField('Field 3', FD.DataFields[3], 'float', rfkFloat, 40); AssertField('Field 4', FD.DataFields[4], 'datetime', rfkDateTime, 50); AssertField('Field 5', FD.DataFields[5], 'stream', rfkStream, 60); end; procedure TTestReportData.TestDatafieldIndexOf1; begin CreateFields; AssertEquals('Finds field at pos 0', 0, FD.DataFields.IndexOfField('string')); AssertEquals('Finds field at pos 3', 3, FD.DataFields.IndexOfField('float')); AssertEquals('Finds field at pos 5', 5, FD.DataFields.IndexOfField('stream')); AssertEquals('Finds field (casing) at pos 3', 3, FD.DataFields.IndexOfField('Float')); end; procedure TTestReportData.TestDatafieldIndexOf2; begin AssertEquals('No fields returns -1', -1, FD.DataFields.IndexOfField('string')); CreateFields; AssertEquals('Non-existing field returns -1', -1, FD.DataFields.IndexOfField('stringlslsl')); end; procedure TTestReportData.TestFindField1; begin AssertNull('No fields returns Nil', FD.DataFields.FindField('string')); CreateFields; AssertNull('Non-existing fields returns Nil', FD.DataFields.FindField('stringsss')); end; procedure TTestReportData.TestFindField2; begin CreateFields; AssertSame('FindField returns correct field', FD.DataFields[0], FD.DataFields.FindField('string')); AssertSame('FindField returns correct field', FD.DataFields[3], FD.DataFields.FindField('float')); AssertSame('FindField returns correct field (case insensitive)', FD.DataFields[3], FD.DataFields.FindField('floaT')); end; procedure TTestReportData.TestFindByName1; begin CreateFields; AssertSame('FieldByName returns correct field', FD.DataFields[0], FD.DataFields.FieldByName('string')); end; procedure TTestReportData.TestFindByName2; begin CreateFields; AssertException('FieldByName (non-existent) raises exception', EReportError, @DoFieldByName); end; procedure TTestReportData.TestFieldAssign; var F1, F2: TFPReportDataField; begin F1 := TFPReportDataField.Create(nil); try f2 := TFPReportDataField.Create(nil); try F1.FieldKind := rfkBoolean; F1.FieldName := 'bool'; F1.DisplayWidth := 12; F2.Assign(F1); AssertField('Assigned ', F2, 'bool', rfkBoolean, 12); finally F2.Free; end; finally F1.Free; end; end; procedure TTestReportData.TestGetValue; var v: variant; begin CreateFields; v := FD.Datafields[0].GetValue; AssertTrue('Failed on 1', V = Null); end; procedure TTestReportData.TestEasyAccessProperties; var I: integer; begin CreateFields; for I := 0 to FD.FieldCount - 1 do AssertEquals('FieldNames array OK', FD.DataFields[0].FieldName, FD.FieldNames[0]); for I := 0 to FD.FieldCount - 1 do AssertEquals('FieldWidth array OK', FD.DataFields[0].DisplayWidth, FD.FieldWidths[FD.FieldNames[0]]); for I := 0 to FD.FieldCount - 1 do AssertEquals('FieldTypes array OK', Ord(FD.DataFields[0].FieldKind), Ord(FD.FieldTypes[FD.FieldNames[0]])); end; { TTestUserReportData } procedure TTestUserReportData.Setup; begin FD := TFPReportUserData.Create(nil); FD.DataFields.AddField('string', rfkString); FD.OnGetValue := @DoValue; inherited; end; procedure TTestUserReportData.TearDown; begin FreeAndNil(FD); inherited TearDown; end; procedure TTestUserReportData.DoValue(Sender: TObject; const AValueName: string; var AValue: variant); begin AssertSame('DoValue Sender is reportdata', FD, Sender); AssertEquals('DoValue gets correct value name', FExpectName, AValueName); AValue := FReturnValue; end; procedure TTestUserReportData.TestGetValue; begin FExpectName := 'string'; FReturnValue := 10; AssertEquals('Return value correct', 10, FD.DataFields[0].GetValue); AssertEquals('FieldValues array value correct', 10, FD.FieldValues['string']); end; { TTestUserReportData2 } procedure TTestUserReportData2.DoGetValue(Sender: TObject; const AValueName: string; var AValue: variant); begin if AValueName = 'element' then AValue := FSL[FData.RecNo - 1]; end; procedure TTestUserReportData2.DoGetEOF(Sender: TObject; var IsEOF: boolean); begin if FData.RecNo > FSL.Count then IsEOF := True else IsEOF := False; end; procedure TTestUserReportData2.Setup; begin inherited Setup; FData := TFPReportUserData.Create(nil); FData.OnGetValue := @DoGetValue; // data is coming from the stringlist this time FSL := TStringList.Create; FSL.Add('Item 1'); FSL.Add('Item 2'); FSL.Add('Item 3'); FSL.Add('Item 4'); end; procedure TTestUserReportData2.TearDown; begin FData.Free; FSL.Free; inherited TearDown; end; procedure TTestUserReportData2.TestGetValue; begin FData.First; AssertEquals('Failed on 1', 'Item 1', FData.FieldValues['element']); FData.Next; AssertEquals('Failed on 2', 'Item 2', FData.FieldValues['element']); FData.Next; AssertEquals('Failed on 3', 'Item 3', FData.FieldValues['element']); FData.Next; AssertEquals('Failed on 4', 'Item 4', FData.FieldValues['element']); FData.Next; end; procedure TTestUserReportData2.TestOnGetEOF1; var i: integer; begin FData.First; for i := 1 to FSL.Count do FData.Next; // Should be False, because we haven't assigned OnGetEOF event handler AssertTrue('Failed on 1', FData.EOF = False); end; procedure TTestUserReportData2.TestOnGetEOF2; var i: integer; begin FData.OnGetEOF := @DoGetEOF; FData.First; for i := 1 to FSL.Count do FData.Next; AssertTrue('Failed on 1', FData.EOF = True); end; { TTestDataBand } procedure TTestDataBand.Setup; begin FDataBand := TFPReportDataBand.Create(nil); inherited Setup; end; procedure TTestDataBand.TearDown; begin FreeAndNil(FDataBand); inherited TearDown; end; procedure TTestDataBand.TestData; var D: TFPReportData; begin D := TFPReportData.Create(nil); try FDataBand.Data := D; AssertSame('Assigned data OK', D, FDataBand.Data) finally D.Free; end; AssertNull('Free notification of Data', FDataBand.Data); end; procedure TTestDataBand.TestDataPropertyAutoSet; var p: TMyFPReportPage; DataBand: TMyDataBand; D: TFPReportData; begin SetReportData(2); p := TMyFPReportPage.Create(Report); p.SetupPage; p.Name := 'Page1'; p.Data := Data; DataBand := TMyDataBand.Create(p); // DataBand should have been assigned p.Data automatically AssertSame('Failed on 1', TFPReportData(Data), DataBand.Data); D := TFPReportData.Create(nil); try DataBand.Data := D; AssertTrue('Failed on 2', p.Data <> DataBand.Data); finally D.Free; end; end; { TTestCustomReport } procedure TTestCustomReport.HandleOnBeginReport; begin Inc(FBeginReportCount); end; procedure TTestCustomReport.HandleOnEndReport; begin Inc(FEndReportCount); end; procedure TTestCustomReport.InitializeData(const ACount: integer); var i: integer; begin // data is coming from the stringlist this time FSL := TStringList.Create; if ACount < 1 then Exit; for i := 1 to ACount do FSL.Add('Item ' + IntToStr(i)); end; procedure TTestCustomReport.SetReportData(const ADataCount: Byte); begin if ADataCount < 1 then Exit; InitializeData(ADataCount); FData := TFPReportUserData.Create(nil); FData.OnGetValue := @DoGetDataValue; FData.OnGetEOF := @DoGetDataEOF; FData.OnGetNames := @DoGetDataFieldNames; end; procedure TTestCustomReport.DoGetDataValue(Sender: TObject; const AValueName: string; var AValue: variant); begin if AValueName = 'element' then AValue := FSL[FData.RecNo - 1]; end; procedure TTestCustomReport.DoGetDataEOF(Sender: TObject; var IsEOF: boolean); begin if FData.RecNo > FSL.Count then IsEOF := True else IsEOF := False; end; procedure TTestCustomReport.Setup; begin inherited Setup; PaperManager.Clear; PaperManager.RegisterStandardSizes; Report := TMyCustomReport.Create(nil); FBeginReportCount := 0; FEndReportCount := 0; gTTFontCache.Clear; gTTFontCache.SearchPath.Text := 'fonts'; gTTFontCache.BuildFontCache; end; procedure TTestCustomReport.TearDown; begin FreeAndNil(FRpt); FreeAndNil(FData); FreeAndNil(FSL); inherited TearDown; end; procedure TTestCustomReport.DoGetDataFieldNames(Sender: TObject; List: TStrings); begin List.Add('element'); end; procedure TTestCustomReport.TestBeginReportEvent; begin TMyFPReportPage.Create(Report); // add at least one page Report.OnBeginReport := @HandleOnBeginReport; AssertEquals('Failed on 1', 0, FBeginReportCount); Report.RunReport; AssertEquals('Failed on 2', 1, FBeginReportCount); AssertEquals('Failed on 3', 0, FEndReportCount); end; procedure TTestCustomReport.TestEndReportEvent; begin TMyFPReportPage.Create(Report); // add at least one page Report.OnEndReport := @HandleOnEndReport; AssertEquals('Failed on 1', 0, FEndReportCount); Report.RunReport; AssertEquals('Failed on 2', 1, FEndReportCount); AssertEquals('Failed on 3', 0, FBeginReportCount); end; procedure TTestCustomReport.TestPagePrepareObjects; var p: TMyFPReportPage; begin SetReportData(2); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.Data := Data; p := TMyFPReportPage.Create(Report); p.Name := 'Page2'; p.Data := Data; p := TMyFPReportPage.Create(Report); p.Name := 'Page3'; p.Data := Data; AssertEquals('Failed on 1', 0, TMyFPReportPage(Report.Pages[0]).FPrepareObjectsCalled); AssertEquals('Failed on 2', 0, TMyFPReportPage(Report.Pages[1]).FPrepareObjectsCalled); AssertEquals('Failed on 3', 0, TMyFPReportPage(Report.Pages[2]).FPrepareObjectsCalled); Report.RunReport; // due to Re-interpret of Page.Data, page is prepared per record (r38906) AssertEquals('Failed on 4', 2, TMyFPReportPage(Report.Pages[0]).FPrepareObjectsCalled); AssertEquals('Failed on 5', 2, TMyFPReportPage(Report.Pages[1]).FPrepareObjectsCalled); AssertEquals('Failed on 6', 2, TMyFPReportPage(Report.Pages[2]).FPrepareObjectsCalled); end; procedure TTestCustomReport.TestBandPrepareObjects; var p: TMyFPReportPage; TitleBand: TMyReportTitleBand; DataBand: TMyDataBand; begin SetReportData(2); p := TMyFPReportPage.Create(Report); p.SetupPage; p.Name := 'Page1'; p.Data := Data; TitleBand := TMyReportTitleBand.Create(p); DataBand := TMyDataBand.Create(p); DataBand.Data := FData; AssertEquals('Failed on 1', 0, p.FPrepareObjectsCalled); AssertEquals('Failed on 2', 0, TitleBand.FPrepareObjectsCalled); AssertEquals('Failed on 3', 0, DataBand.FPrepareObjectsCalled); Report.RunReport; AssertEquals('Failed on 4', 1, p.FPrepareObjectsCalled); AssertEquals('Failed on 5', 1, TitleBand.FPrepareObjectsCalled); AssertEquals('Failed on 6', 2, DataBand.FPrepareObjectsCalled); end; procedure TTestCustomReport.TestRTObjects1; var p: TMyFPReportPage; begin SetReportData(2); p := TMyFPReportPage.Create(Report); p.SetupPage; p.Name := 'Page1'; p.Data := Data; p := TMyFPReportPage.Create(Report); p.SetupPage; p.Name := 'Page2'; p.Data := Data; p := TMyFPReportPage.Create(Report); p.SetupPage; p.Name := 'Page3'; p.Data := Data; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; // due to Re-interpret of Page.Data, page is prepared per record (r38906) AssertEquals('Failed on 2', 6, Report.RTObjects.Count); end; procedure TTestCustomReport.TestRTObjects2; var p: TMyFPReportPage; TitleBand: TMyReportTitleBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(2); p := TMyFPReportPage.Create(Report); p.SetupPage; p.Name := 'Page1'; p.Data := Data; TitleBand := TMyReportTitleBand.Create(p); Memo := TFPReportMemo.Create(TitleBand); Memo.Text := 'THE REPORT TITLE'; Memo.Layout.Top := 5; Memo.Layout.Left := 10; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; // due to Re-interpret of Page.Data, page is prepared per record (r38906) AssertEquals('Failed on 2', 2, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); {$IFDEF gdebug} // writeln(Report.DebugPreparedPageAsJSON(0)); {$ENDIF} end; procedure TTestCustomReport.TestRTObjects3; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(2); p := TMyFPReportPage.Create(Report); p.SetupPage; p.Name := 'Page1'; p.Data := Data; DataBand := TMyDataBand.Create(p); Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := '[element]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 2, rtPage.ChildCount); AssertEquals('Failed on 5', 2, rtPage.BandCount); {$IFDEF gdebug} // writeln(Report.DebugPreparedPageAsJSON(0)); {$ENDIF} end; procedure TTestCustomReport.TestRTObjects4_OneDataItem; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); p := TMyFPReportPage.Create(Report); p.SetupPage; p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := '[element]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); {$IFDEF gdebug} // writeln(Report.DebugPreparedPageAsJSON(0)); {$ENDIF} end; procedure TTestCustomReport.TestRTObjects5_TwoDataItems; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(2); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Top := 0; DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := '[element]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 2, rtPage.ChildCount); AssertEquals('Failed on 5', 2, rtPage.BandCount); { each data row has its own data band } AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); AssertEquals('Failed on 7', 1, rtPage.Bands[1].ChildCount); {$IFDEF gdebug} // writeln(Report.DebugPreparedPageAsJSON(0)); {$ENDIF} end; procedure TTestCustomReport.TestInternalFunction_Page; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := '[PageNo]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); Memo := TFPReportMemo(rtPage.Bands[0].Child[0]); AssertEquals('Failed on 7', '1', Memo.Text); end; procedure TTestCustomReport.TestInternalFunction_Page_with_text; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := 'Page [PageNo]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); Memo := TFPReportMemo(rtPage.Bands[0].Child[0]); AssertEquals('Failed on 7', 'Page 1', Memo.Text); end; procedure TTestCustomReport.TestInternalFunction_RecNo; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; i: integer; begin SetReportData(5); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := '[recno('''')]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 5, rtPage.ChildCount); // 5 rendered data bands because we have 5 data records AssertEquals('Failed on 5', 5, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); for i := 0 to 4 do begin Memo := TFPReportMemo(rtPage.Bands[i].Child[0]); AssertEquals('Failed on 7.'+IntToStr(i), IntToStr(i+1), Memo.Text); { recno is 1-based } end; end; procedure TTestCustomReport.TestInternalFunction_Today; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := '[today]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); // 1 rendered data band because we have 1 data record AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); Memo := TFPReportMemo(rtPage.Bands[0].Child[0]); AssertEquals('Failed on 7', FormatDateTime('yyyy-mm-dd', Today), Memo.Text); end; procedure TTestCustomReport.TestInternalFunction_Today_with_text; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := 'Today is [today]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); // 1 rendered data band because we have 1 data record AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); Memo := TFPReportMemo(rtPage.Bands[0].Child[0]); AssertEquals('Failed on 7', 'Today is ' + FormatDateTime('yyyy-mm-dd', Today), Memo.Text); end; procedure TTestCustomReport.TestInternalFunction_Author; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := '[author]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); // 1 rendered data band because we have 1 data record AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); Memo := TFPReportMemo(rtPage.Bands[0].Child[0]); AssertEquals('Failed on 7', '', Memo.Text); // we never set Report.Author end; procedure TTestCustomReport.TestInternalFunction_Author_with_text; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); Report.Author := 'Graeme Geldenhuys'; p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := 'The Author is [author].'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); // 1 rendered data band because we have 1 data record AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); Memo := TFPReportMemo(rtPage.Bands[0].Child[0]); AssertEquals('Failed on 7', 'The Author is Graeme Geldenhuys.', Memo.Text); end; procedure TTestCustomReport.TestInternalFunction_Title; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := '[title]'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); // 1 rendered data band because we have 1 data record AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); Memo := TFPReportMemo(rtPage.Bands[0].Child[0]); AssertEquals('Failed on 7', '', Memo.Text); // we never set Report.Title end; procedure TTestCustomReport.TestInternalFunction_Title_with_text; var p: TMyFPReportPage; DataBand: TMyDataBand; Memo: TFPReportMemo; rtPage: TFPReportCustomPage; begin SetReportData(1); Report.Title := 'My Test Report'; p := TMyFPReportPage.Create(Report); p.Name := 'Page1'; p.SetupPage; p.Data := Data; DataBand := TMyDataBand.Create(p); DataBand.Layout.Height := 23; Memo := TFPReportMemo.Create(DataBand); Memo.Layout.Top := 5; Memo.Layout.Left := 10; Memo.Text := 'Report Title is "[title]".'; AssertEquals('Failed on 1', 0, Report.RTObjects.Count); Report.RunReport; AssertEquals('Failed on 2', 1, Report.RTObjects.Count); // runtime objects adhere to same hierarchy as design time AssertEquals('Failed on 3', 'TFPReportCustomPage', TObject(Report.RTObjects[0]).ClassName); rtPage := TFPReportCustomPage(Report.RTObjects[0]); AssertEquals('Failed on 4', 1, rtPage.ChildCount); // 1 rendered data band because we have 1 data record AssertEquals('Failed on 5', 1, rtPage.BandCount); AssertEquals('Failed on 6', 1, rtPage.Bands[0].ChildCount); Memo := TFPReportMemo(rtPage.Bands[0].Child[0]); AssertEquals('Failed on 7', 'Report Title is "My Test Report".', Memo.Text); end; { TTestReportMemo } procedure TTestReportMemo.CauseFontNotFoundException; begin TMemoFriend(FMemo).RecalcLayout; end; procedure TTestReportMemo.SetUp; begin inherited SetUp; FMemo := TFPReportMemo.Create(nil); FMemo.Layout.SetPosition(0, 0, 60, 5); end; procedure TTestReportMemo.TearDown; begin FMemo.Free; inherited TearDown; end; procedure TTestReportMemo.TestCreate; var m: TFPReportMemo; begin m := TFPReportMemo.Create(nil); try m.Text := 'abc 123'; AssertTrue('Failed on 1', m <> nil); finally m.Free; end; end; procedure TTestReportMemo.TestPrepareTextBlocks; begin gTTFontCache.Clear; gTTFontCache.SearchPath.Text := 'fonts'; gTTFontCache.BuildFontCache; FMemo.Layout.Width := 100; FMemo.Text := 'abc 123'; FMemo.UseParentFont := False; FMemo.Font.Name := 'Calibri'; FMemo.StretchMode := smActualHeight; TMemoFriend(FMemo).CreateRTLayout; TMemoFriend(FMemo).RecalcLayout; AssertEquals('Failed on 2', 1, FMemo.TextLines.Count); end; procedure TTestReportMemo.TestPrepareTextBlocks_multiline_data; begin gTTFontCache.Clear; gTTFontCache.SearchPath.Text := 'fonts'; gTTFontCache.BuildFontCache; FMemo.Layout.Width := 100; FMemo.Text := 'abc'+LineEnding+'123'; FMemo.UseParentFont := False; FMemo.Font.Name := 'Calibri'; FMemo.StretchMode := smActualHeight; TMemoFriend(FMemo).CreateRTLayout; TMemoFriend(FMemo).RecalcLayout; AssertEquals('Failed on 2', 2, FMemo.TextLines.Count); end; procedure TTestReportMemo.TestPrepareTextBlocks_multiline_wraptext; begin gTTFontCache.Clear; gTTFontCache.SearchPath.Text := 'fonts'; gTTFontCache.BuildFontCache; FMemo.Layout.Width := 6; FMemo.Text := 'abc 123'; FMemo.UseParentFont := False; FMemo.Font.Name := 'Calibri'; FMemo.StretchMode := smActualHeight; FMemo.WordOverflow := woOverflow; TMemoFriend(FMemo).CreateRTLayout; TMemoFriend(FMemo).RecalcLayout; AssertEquals('Failed on 2', 2, FMemo.TextLines.Count); end; procedure TTestReportMemo.TestPrepareTextBlocks_multiline_wraptext_oneword; begin gTTFontCache.Clear; gTTFontCache.SearchPath.Text := 'fonts'; gTTFontCache.BuildFontCache; FMemo.Layout.Width := 10; FMemo.Text := 'abc123'; FMemo.UseParentFont := False; FMemo.Font.Name := 'Calibri'; FMemo.StretchMode := smActualHeight; TMemoFriend(FMemo).CreateRTLayout; TMemoFriend(FMemo).RecalcLayout; AssertEquals('Failed on 1', 1, FMemo.TextLines.Count); // The length of abc1 fits. AssertEquals('Failed on 1', 'abc1', FMemo.TextLines[0]); end; procedure TTestReportMemo.TestPrepareTextBlocks_multiline_wraptext_oneword_overflow; begin gTTFontCache.Clear; gTTFontCache.SearchPath.Text := 'fonts'; gTTFontCache.BuildFontCache; FMemo.Layout.Width := 10; FMemo.Text := 'abc123'; FMemo.UseParentFont := False; FMemo.Font.Name := 'Calibri'; FMemo.StretchMode := smActualHeight; TMemoFriend(FMemo).WordOverflow:=woOverflow; TMemoFriend(FMemo).CreateRTLayout; TMemoFriend(FMemo).RecalcLayout; AssertEquals('Failed on 1', 1, FMemo.TextLines.Count); AssertEquals('Failed on 1', 'abc123', FMemo.TextLines[0]); end; procedure TTestReportMemo.TestPrepareTextBlocks_multiline_wraptext_oneword_split; begin gTTFontCache.Clear; gTTFontCache.SearchPath.Text := 'fonts'; gTTFontCache.BuildFontCache; FMemo.Layout.Width := 10; FMemo.Text := 'abc123'; FMemo.UseParentFont := False; FMemo.Font.Name := 'Calibri'; FMemo.StretchMode := smActualHeight; TMemoFriend(FMemo).WordOverflow:=woSplit; TMemoFriend(FMemo).CreateRTLayout; TMemoFriend(FMemo).RecalcLayout; AssertEquals('Failed on 1', 2, FMemo.TextLines.Count); AssertEquals('Failed on 2', 'abc1', FMemo.TextLines[0]); AssertEquals('Failed on 3', '23', FMemo.TextLines[1]); end; procedure TTestReportMemo.TestRGBToReportColor; var c: TFPReportColor; begin c := RGBToReportColor(255, 0, 0); AssertEquals('failed on 1', IntToHex(clRed, 8), IntToHex(c, 8)); c := RGBToReportColor(0, 128, 0); AssertEquals('failed on 2', IntToHex(clGreen, 8), IntToHex(c, 8)); c := RGBToReportColor(0, 0, 255); AssertEquals('failed on 3', IntToHex(clBlue, 8), IntToHex(c, 8)); end; procedure TTestReportMemo.TestHTMLColorToReportColor_length7; var c: TFPReportColor; begin c := TMemoFriend(FMemo).HtmlColorToFPReportColor('#FF0000', clBlack); AssertEquals('failed on 1', IntToHex(clRed, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('#008000', clBlack); AssertEquals('failed on 2', IntToHex(clGreen, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('#0000FF', clBlack); AssertEquals('failed on 3', IntToHex(clBlue, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('A0000FF', clBlack); AssertEquals('failed on 4', IntToHex(clBlack, 8), IntToHex(c, 8)); end; procedure TTestReportMemo.TestHTMLColorToReportColor_length6; var c: TFPReportColor; begin c := TMemoFriend(FMemo).HtmlColorToFPReportColor('FF0000', clBlack); AssertEquals('failed on 1', IntToHex(clRed, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('008000', clBlack); AssertEquals('failed on 2', IntToHex(clGreen, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('0000FF', clBlack); AssertEquals('failed on 3', IntToHex(clBlue, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('A0000FF', clBlack); AssertEquals('failed on 4', IntToHex(clBlack, 8), IntToHex(c, 8)); end; procedure TTestReportMemo.TestHTMLColorToReportColor_length3; var c: TFPReportColor; begin c := TMemoFriend(FMemo).HtmlColorToFPReportColor('F00', clBlack); AssertEquals('failed on 1', IntToHex(clRed, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('080', clBlack); AssertEquals('failed on 2', IntToHex($008800, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('00F', clBlack); AssertEquals('failed on 3', IntToHex(clBlue, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('A00F', clDkGray); AssertEquals('failed on 4', IntToHex(clDkGray, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('700', clBlack); AssertEquals('failed on 5', IntToHex($770000, 8), IntToHex(c, 8)); c := TMemoFriend(FMemo).HtmlColorToFPReportColor('006', clBlack); AssertEquals('failed on 6', IntToHex($000066, 8), IntToHex(c, 8)); end; procedure TTestReportMemo.TestCreateTestBlock; var tb: TFPTextBlock; begin tb := TMemoFriend(FMemo).CreateTextBlock(false); try AssertTrue('failed on 1', tb is TFPTextBlock); AssertFalse('failed on 2', tb is TFPHTTPTextBlock); finally tb.Free; end; end; procedure TTestReportMemo.TestCreateTestBlock_IsURL; var tb: TFPTextBlock; begin tb := TMemoFriend(FMemo).CreateTextBlock(true); try AssertTrue('failed on 1', tb is TFPTextBlock); AssertTrue('failed on 2', tb is TFPHTTPTextBlock); finally tb.Free; end; end; procedure TTestReportMemo.TestSubStr; var m: TMemoFriend; lStartPos: integer; begin m := TMemoFriend(FMemo); AssertEquals('failed on 1', '', m.SubStr('','','', 1, lStartPos)); AssertEquals('failed on 1.1', -1, lStartPos); AssertEquals('failed on 2', 'abc', m.SubStr('xxxabcyyy','xxx','yyy', 1, lStartPos)); AssertEquals('failed on 2.1', 4, lStartPos); AssertEquals('failed on 3', 'abc', m.SubStr('xxx,abc;xxx',',',';', 1, lStartPos)); AssertEquals('failed on 3.1', 5, lStartPos); AssertEquals('failed on 4', 'abc', m.SubStr('abc','','', 1, lStartPos)); AssertEquals('failed on 4.1', 4, lStartPos); AssertEquals('failed on 5', 'abc1', m.SubStr('abc1 abc2','','', 1, lStartPos)); AssertEquals('failed on 5.1', 4, lStartPos); AssertEquals('failed on 6', 'abc2', m.SubStr('abc1 abc2','','', 2, lStartPos)); AssertEquals('failed on 6.1', 16, lStartPos); AssertEquals('failed on 7', '', m.SubStr('abc1 abc2','','', 3, lStartPos)); AssertEquals('failed on 7.1', -1, lStartPos); AssertEquals('failed on 8', 'abc1', m.SubStr('abc1 abc2','','', 0, lStartPos)); AssertEquals('failed on 8.1', 4, lStartPos); AssertEquals('failed on 9', 'abc1', m.SubStr('abc1 abc2','','', -1, lStartPos)); AssertEquals('failed on 9.1', 4, lStartPos); end; procedure TTestReportMemo.TestTokenCount; var m: TMemoFriend; lStartPos: integer; begin m := TMemoFriend(FMemo); AssertEquals('failed on 1', '', m.SubStr('','','', 1, lStartPos)); AssertEquals('failed on 1.1', -1, lStartPos); AssertEquals('failed on 2', 'abc', m.SubStr('xxxabcyyy','xxx','yyy', 1, lStartPos)); AssertEquals('failed on 2.1', 4, lStartPos); AssertEquals('failed on 1', m.TokenCount('', ','), 0); AssertEquals('failed on 2', m.TokenCount('adf adf', ','), 1); AssertEquals('failed on 3', m.TokenCount('adf,', ','), 2); AssertEquals('failed on 4', m.TokenCount('adf,adf', ','), 2); AssertEquals('failed on 5', m.TokenCount('adf,adf,adf', ','), 3); AssertEquals('failed on 6', m.TokenCount('adf,adf,adf,', ','), 4); AssertEquals('failed on 6', m.TokenCount('0mm margin top and bottom.', ' '), 5); AssertEquals('failed on 6', m.TokenCount('0mm margin top and bottom. ', ' '), 6); end; procedure TTestReportMemo.TestToken; var m: TMemoFriend; lStartPos: integer; begin m := TMemoFriend(FMemo); AssertEquals('failed on 1', m.Token('', ',', 1), ''); AssertEquals('failed on 2', m.Token('a,b,c', ',', 1), 'a'); AssertEquals('failed on 3', m.Token('a,b,c', ',', 2), 'b'); AssertEquals('failed on 4', m.Token('a,b,c', ',', 3), 'c'); AssertEquals('failed on 5', m.Token('a,b,c', ',', 4), ''); AssertEquals('failed on 6', m.Token('aa,bb,cc', ',', 1), 'aa'); AssertEquals('failed on 7', m.Token('aa,bb,cc', ',', 2), 'bb'); AssertEquals('failed on 8', m.Token('aa,bb,cc', ',', 3), 'cc'); AssertEquals('failed on 9', m.Token('aa,bb,cc', ',', 4), ''); AssertEquals('failed on 10', m.Token('aa,bb,cc,', ',', 4), ''); AssertEquals('failed on 11', m.Token('0mm margin top and bottom.', ' ', 5), 'bottom.'); AssertEquals('failed on 12', m.Token('0mm margin top and bottom. ', ' ', 5), 'bottom.'); AssertEquals('failed on 13', m.Token('0mm margin top and bottom. ', ' ', 6), ''); end; { TTestBandList } procedure TTestBandList.CreateBands; begin b1 := TFPReportPageHeaderBand.Create(nil); b2 := TFPReportTitleBand.Create(nil); b3 := TFPReportDataBand.Create(nil); end; procedure TTestBandList.AddAllBandsToList; begin FList.Add(b1); FList.Add(b2); FList.Add(b3); end; procedure TTestBandList.SetUp; begin inherited SetUp; FList := TBandList.Create; CreateBands; end; procedure TTestBandList.TearDown; begin FreeAndNil(FList); FreeAndNil(b3); FreeAndNil(b2); FreeAndNil(b1); inherited TearDown; end; procedure TTestBandList.TestAdd; begin AssertEquals('Failed on 1', 0, FList.Count); AddAllBandsToList; AssertEquals('Failed on 2', 3, FList.Count); end; procedure TTestBandList.TestItems; begin AssertEquals('Failed on 1', 0, FList.Count); AddAllBandsToList; AssertEquals('Failed on 2', 3, FList.Count); AssertTrue('failed on 3', FList.Items[0] = b1); AssertTrue('failed on 4', FList.Items[1] = b2); AssertTrue('failed on 5', FList.Items[1] <> b1); AssertTrue('failed on 6', FList.Items[2] = b3); end; procedure TTestBandList.TestClear; begin AssertEquals('Failed on 1', 0, FList.Count); AddAllBandsToList; AssertEquals('Failed on 2', 3, FList.Count); FList.Clear; AssertEquals('Failed on 3', 0, FList.Count); AssertTrue('failed on 4', b1 <> nil); // List.Clear shouldn't free bands end; procedure TTestBandList.TestDelete; begin AssertEquals('Failed on 1', 0, FList.Count); AddAllBandsToList; AssertEquals('Failed on 2', 3, FList.Count); FList.Delete(0); AssertEquals('Failed on 3', 2, FList.Count); AssertTrue('failed on 4', b1 <> nil); // List.Delete shouldn't free bands AssertTrue('failed on 5', FList.Items[0] = b2); AssertTrue('failed on 6', FList.Items[1] = b3); end; procedure TTestBandList.TestFind1; var lBand: TFPReportCustomBand; lResult: integer; begin AssertEquals('Failed on 1', 0, FList.Count); AddAllBandsToList; AssertEquals('Failed on 2', 3, FList.Count); AssertTrue('failed on 3', FList.Find(TFPReportPageHeaderBand) <> nil); AssertTrue('failed on 4', FList.Find(TFPReportPageHeaderBand) = b1); AssertTrue('failed on 5', FList.Find(TFPReportTitleBand) = b2); AssertTrue('failed on 6', FList.Find(TFPReportDataBand) = b3); FList.Clear; AssertTrue('failed on 7', FList.Find(TFPReportTitleBand) = nil); end; procedure TTestBandList.TestFind2; var lBand: TFPReportCustomBand; lResult: integer; begin AssertEquals('Failed on 1', 0, FList.Count); lResult := FList.Find(TFPReportPageHeaderBand, lBand); AssertEquals('failed on 2', -1, lResult); AssertTrue('failed on 3', lBand = nil); AddAllBandsToList; AssertEquals('Failed on 4', 3, FList.Count); lResult := FList.Find(TFPReportPageHeaderBand, lBand); AssertEquals('failed on 5', 0, lResult); AssertTrue('failed on 6', lBand <> nil); AssertTrue('failed on 7', lBand = b1); lResult := FList.Find(TFPReportTitleBand, lBand); AssertEquals('failed on 8', 1, lResult); AssertTrue('failed on 9', lBand = b2); lResult := FList.Find(TFPReportDataBand, lBand); AssertEquals('failed on 10', 2, lResult); AssertTrue('failed on 11', lBand = b3); FList.Clear; lResult := FList.Find(TFPReportTitleBand, lBand); AssertTrue('failed on 12', lBand = nil); AssertTrue('failed on 13', lResult = -1); end; initialization RegisterTests( [TTestReportComponent, TReportElementTest, TTestReportChildren, TTestReportFrame, TTestReportLayout, TTestFPPageSize, TTestFPPaperManager, TTestFPReportPageSize, TTestReportPage, TTestReportData, TTestUserReportData, TTestUserReportData2, TTestDataBand, TTestCustomReport, TTestReportMemo, TTestBandList, TTestVariable, TTestVariables ]); end.