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: 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 = 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 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.0,StrToFloat(Variable.Value)); Variable.DataType:=rtBoolean; Variable.AsFloat:=1.23; AssertEquals('Float type remains',rtFloat,Variable.DataType); AssertEquals('Float as string',1.23,StrToFloat(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); FChild := TFPReportElement.Create(nil); end; procedure TTestReportChildren.TearDown; begin FreeAndNil(FC); FreeAndNil(FChild); 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; E := TFPReportElementWithChildren.Create(nil); try FChild.Parent := E; AssertSame('Parent was saved', E, FChild.parent); AssertEquals('Changed was called', 1, FC.ChangedCalled); AssertEquals('Old Parent childcount is 0', 0, FC.ChildCount); AssertEquals('Parent childcount is 1', 1, E.ChildCount); AssertSame('Parent first child is OK', FChild, E.Child[0]); finally E.Free; end; 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); AssertNull('Child parent was removed when parent is freed', FChild.Parent); 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 B := TFPReportCustomBand.Create(nil); try P := TMyFPReportPage.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 P.Free; end; AssertNull('Band notified that page is gone', B.Parent); AssertNull('Band notified that page is gone', B.Page); finally B.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 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 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; AssertEquals('Failed on 4', 1, TMyFPReportPage(Report.Pages[0]).FPrepareObjectsCalled); AssertEquals('Failed on 5', 1, TMyFPReportPage(Report.Pages[1]).FPrepareObjectsCalled); AssertEquals('Failed on 6', 1, 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; AssertEquals('Failed on 2', 3, 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; 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.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; TMemoFriend(FMemo).CreateRTLayout; TMemoFriend(FMemo).RecalcLayout; AssertEquals('Failed on 2', 2, FMemo.TextLines.Count); 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.