freepascal.compiler/rtl/tests/tcresref.pp

unit tcresref;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, fpcunit, TypInfo, testutils, testregistry;

type

  { TRefComponent }

  TRefComponent = Class(TComponent)
  private
    FRef1: TComponent;
    FRef2: TComponent;
  Published
    Property Ref1 : TComponent Read FRef1 Write FRef1;
    Property Ref2 : TComponent Read FRef2 Write FRef2;
  end;
  
  TRootA = Class(TRefComponent)
  end;
  
  TRootB = Class(TRefComponent)
  end;
  
  TA = Class(TRefComponent)
  end;
  TB = Class(TRefComponent)
  end;


  { TTestResolveReference }

  TTestResolveReference = class(TTestCase)
  Private
    RootA : TRootA;
    RootB : TRootB;
    PropA1,
    PropA2,
    PropB1,
    PropB2 : PPRopInfo;
    UnrA : TObject;
    UnrB : TObject;
  protected
    procedure SetUp; override; 
    procedure TearDown; override; 
  published
    procedure TestAddInst1;
    procedure TestAddInst2;
    procedure TestAddInst3;
    procedure TestAdd2;
    procedure TestAdd3;
    Procedure TestFixupReferenceNames1;
    procedure TestFixupReferenceNames2;
    procedure TestFixupReferenceNames3;
    Procedure TestFixupInstanceNames1;
    Procedure TestFixupInstanceNames2;
    procedure TestFixupInstanceNames3;
    procedure TestFixupInstanceNames4;
    procedure TestFixupInstanceNames5;
    procedure TestRedirectFixupReferences1;
    procedure TestRedirectFixupReferences2;
    procedure TestRedirectFixupReferences3;
    procedure TestRemoveFixupReferences1;
    procedure TestRemoveFixupReferences2;
    procedure TestFixupReferences1;
    procedure TestFixupReferences2;
    procedure TestFixupReferences3;
  end;

implementation


{$i sllist.inc}
{$i resref.inc}

{ ---------------------------------------------------------------------
  Auxiliary routines
  ---------------------------------------------------------------------}

// Simulate Adding RootA to unresolved instances
Function RootAToResolveList(TC : TTestResolveReference) : TUnresolvedInstance;

begin
  Result:=AddToResolveList(TC.RootA);
  TC.UnrA:=Result;
end;

// Simulate Adding RootB to unresolved instances
Function RootBToResolveList(TC : TTestResolveReference) : TUnresolvedInstance;

begin
  Result:=AddToResolveList(TC.RootB);
  TC.UnrB:=Result;
end;

// Simulate RootA.Ref1 -> RootB.A unresolved reference
Function SetupARef1A(TC : TTestResolveReference) : TUnresolvedReference;

begin
  Result:=RootAToResolveList(TC).AddReference(TC.RootA,TC.PropA1,'RootB','A');
end;

// Simulate RootA.Ref1 -> RootB.B unresolved reference
Function SetupARef1B(TC : TTestResolveReference) : TUnresolvedReference;

begin
  Result:=RootAToResolveList(TC).AddReference(TC.RootA,TC.PropA1,'RootB','B');
end;


// Simulate RootA.Ref2 -> RootB.A unresolved reference
Function SetupARef2A(TC : TTestResolveReference) : TUnresolvedReference;

begin
  Result:=RootAToResolveList(TC).AddReference(TC.RootA,TC.PropA2,'RootB','A');
end;
// Simulate RootA.Ref2 -> RootB.B unresolved reference
Function SetupARef2B(TC : TTestResolveReference) : TUnresolvedReference;

begin
  Result:=RootAToResolveList(TC).AddReference(TC.RootA,TC.PropA2,'RootB','B');
end;

// Simulate RootB.Ref2 -> RootA.B unresolved reference
Function SetupBRef2B(TC : TTestResolveReference) : TUnresolvedReference;

begin
  Result:=RootBToResolveList(TC).AddReference(TC.RootB,TC.PropB2,'RootA','B');
end;

Function SetupBRef1A(TC : TTestResolveReference) : TUnresolvedReference;

begin
  Result:=RootBToResolveList(TC).AddReference(TC.RootB,TC.PropB1,'RootA','A');
end;

// Simulate RootB.Ref1 -> RootA.B unresolved reference
Function SetupNRef1B(TC : TTestResolveReference) : TUnresolvedReference;

begin
  Result:=RootBToResolveList(TC).AddReference(TC.RootB,TC.PropB1,'RootA','B');
end;

// Simulate RootA.Ref2 -> RootA.A unresolved reference
Function SetupBRef2A(TC : TTestResolveReference) : TUnresolvedReference;

begin
  Result:=RootBToResolveList(TC).AddReference(TC.RootB,TC.PropB2,'RootA','A');
end;

{ ---------------------------------------------------------------------
  Search callback
  ---------------------------------------------------------------------}

Var
  TI : TTestResolveReference;

Function SearchRoots(Const AName : String) : TComponent;

begin
  Result:=Nil;
  If Assigned(TI) then
    begin
    If CompareText(AName,'RootA')=0 then
      Result:=TI.RootA
    else If CompareText(AName,'RootB')=0 then
      Result:=TI.RootB;
    end;
end;

{ ---------------------------------------------------------------------
  Setup/TearDown
  ---------------------------------------------------------------------}

procedure TTestResolveReference.SetUp;
begin
  TI:=Self;
  RegisterFindGlobalComponentProc(@SearchRoots);
  RootA:=TRootA.Create(Nil);
  RootA.Name:='RootA';
  With TA.Create(RootA) do
    Name:='A';
  With TB.Create(RootA) do
    Name:='B';
  RootB:=TRootB.Create(Nil);
  With TA.Create(RootB) do
    Name:='A';
  With TB.Create(RootB) do
    Name:='B';
  PRopA1:=GetPropInfo(TRootA,'Ref1');
  PRopA2:=GetPropInfo(TRootA,'Ref2');
  PRopB1:=GetPropInfo(TRootB,'Ref1');
  PRopB2:=GetPropInfo(TRootB,'Ref2');
end;

procedure TTestResolveReference.TearDown;
begin
  TI:=Nil;
  UnRegisterFindGlobalComponentProc(@SearchRoots);
  FreeAndNil(NeedResolving);
  FreeAndNil(RootA);
  FreeAndNil(RootB);
end;

{ ---------------------------------------------------------------------
  Actual tests
  ---------------------------------------------------------------------}

procedure TTestResolveReference.TestAddInst1;

Var
  A : TObject;

begin
  A:=AddToResolveList(RootA);
  If Not (A is TUnresolvedInstance) then
    Fail('AddToResolveList returns TUnresolvedInstance');
  AssertSame('UNresolvedinstance.Instance is RootA',RootA,TUnresolvedInstance(A).Instance);
  AssertSame('UNresolvedinstance.Next is nil',Nil,TUnresolvedInstance(A).Next);
end;

procedure TTestResolveReference.TestAddInst2;

Var
  A,B : TObject;

begin
  A:=AddToResolveList(RootA);
  B:=AddToResolveList(RootA);
  AssertSame('UNresolvedinstance.Instance is RootA',A,B);
end;

procedure TTestResolveReference.TestAddInst3;

Var
  A,B : TUnresolvedInstance;

begin
  A:=AddToResolveList(RootA);
  B:=AddToResolveList(RootB);
  AssertSame('UnresolvedInstances are chained',A,B.Next);
end;


procedure TTestResolveReference.TestAdd2;

Var
  R : TUnresolvedReference;

begin
  R:=SetupARef1A(Self);
  If (UnrA=Nil) then
    Fail('UnresolvedInstance A not set');
  AssertSame('TUnresolvedReference FRoot is rootA',RootA,R.FRoot);
  AssertSame('TUnresolvedReference FPropInfo is PropA1',PropA1,R.FPropInfo);
  AssertEquals('TUnresolvedReference FGlobal is rootB','RootB',R.FGlobal);
  AssertEquals('TUnresolvedReference FRelative is A','A',R.FRelative);
  AssertSame('Unresolved is root object',TUnresolvedinstance(UnrA).RootUnresolved,R);
end;

procedure TTestResolveReference.TestAdd3;

Var
  R1 : TUnresolvedReference;
  R2 : TUnresolvedReference;

begin
  R1:=SetupARef1A(Self);
  R2:=SetupARef2B(Self);
  AssertSame('TUnresolvedReference FRoot is rootA',RootA,R2.FRoot);
  AssertSame('TUnresolvedReference FPropInfo is PropA2',PropA2,R2.FPropInfo);
  AssertEquals('TUnresolvedReference FGlobal is rootB','RootB',R2.FGlobal);
  AssertEquals('TUnresolvedReference FRelative is A','B',R2.FRelative);
  AssertSame('Unresolved references are chained',R1,R2.Next);
end;

procedure TTestResolveReference.TestFixupReferenceNames1;

Var
  L : TStringList;
begin
  SetupARef1A(Self);
  L:=TstringList.Create;
  try
    GetFixupReferenceNames(RootA,L);
    AssertEquals('Number of referenced components in root component RootA is 1',1,L.Count);
    AssertEquals('Root component referred to is RootB','RootB',L[0]);
  finally
    L.Free;
  end;
end;

procedure TTestResolveReference.TestFixupReferenceNames2;

Var
  L : TStringList;
begin
  // Should result in 1 referenced name only.
  SetupARef1A(Self);
  SetupARef2B(Self);
  L:=TstringList.Create;
  try
    GetFixupReferenceNames(RootA,L);
    AssertEquals('Number of referenced components in root component RootA is 1',1,L.Count);
    AssertEquals('Root component referred to is always RootB','RootB',L[0]);
  finally
    L.Free;
  end;
end;

procedure TTestResolveReference.TestFixupReferenceNames3;

Var
  L : TStringList;
begin
  // Should result in 1 referenced name only.
  SetupARef1A(Self);
  SetupARef2B(Self);
  L:=TstringList.Create;
  try
    GetFixupReferenceNames(RootB,L);
    AssertEquals('Number of referenced components in root component RootB is 0',0,L.Count);
  finally
    L.Free;
  end;
end;

//procedure GetFixupInstanceNames(Root: TComponent; const ReferenceRootName: string; Names: TStrings);

procedure TTestResolveReference.TestFixupInstanceNames1;

Var
  L : TStringList;
begin
  SetupARef1A(Self);
  L:=TstringList.Create;
  try
    GetFixupinstanceNames(RootA,'RootB',L);
    AssertEquals('Number of references in RootA to component RootB is 1',1,L.Count);
    AssertEquals('Subcomponent of RootB referenced is A','A',L[0]);
  finally
    L.Free;
  end;
end;

procedure TTestResolveReference.TestFixupInstanceNames2;

Var
  L : TStringList;
begin
  SetupARef1A(Self);
  SetupARef2B(Self);
  L:=TstringList.Create;
  try
    GetFixupinstanceNames(RootA,'RootB',L);
    AssertEquals('Number of references in RootA to component RootB is 2',2,L.Count);
    If L.IndexOf('A')=-1 then
      Fail('A is not in list of references to RootB');
    If L.IndexOf('B')=-1 then
      Fail('B is not in list of references to RootB');
  finally
    L.Free;
  end;
end;

procedure TTestResolveReference.TestFixupInstanceNames3;

Var
  L : TStringList;
begin
  SetupARef1A(Self);
  SetupARef2B(Self);
  L:=TstringList.Create;
  try
    GetFixupinstanceNames(RootA,'RootA',L);
    AssertEquals('Number of references in RootA to component RootA is 0',0,L.Count);
  finally
    L.Free;
  end;
end;

procedure TTestResolveReference.TestFixupInstanceNames4;

Var
  L : TStringList;
begin
  SetupARef1A(Self);
  SetupARef2B(Self);
  L:=TstringList.Create;
  try
    GetFixupinstanceNames(RootB,'RootB',L);
    AssertEquals('Number of references in RootB to component RootB is 0',0,L.Count);
  finally
    L.Free;
  end;
end;

procedure TTestResolveReference.TestFixupInstanceNames5;

Var
  L : TStringList;
begin
  SetupARef1A(Self);
  SetupBRef2B(Self);
  L:=TstringList.Create;
  try
    GetFixupinstanceNames(RootB,'RootB',L);
    AssertEquals('Number of references in RootB to component RootB is 0',0,L.Count);
  finally
    L.Free;
  end;
end;

// procedure RedirectFixupReferences(Root: TComponent; const OldRootName, NewRootName: string);

procedure TTestResolveReference.TestRedirectFixupReferences1;

Var
  L : TStringList;
  R1 : TUnresolvedReference;
  R2 : TUnresolvedReference;
  
begin
  R1:=SetupARef1A(Self);
  R2:=SetupARef2B(Self);
  RedirectFixupReferences(RootA,'RootB','RootC');
  AssertEquals('Redirected R1.Root is RootC','RootC',R1.FGLobal);
  AssertEquals('Redirected R1.Root is RootC','RootC',R2.FGLobal);
end;

procedure TTestResolveReference.TestRedirectFixupReferences2;

Var
  L : TStringList;
  R1 : TUnresolvedReference;
  R2 : TUnresolvedReference;

begin
  R1:=SetupARef1A(Self);
  R2:=SetupBRef2B(Self);
  RedirectFixupReferences(RootA,'RootB','RootC');
  AssertEquals('Redirected R1.Root is RootC','RootC',R1.FGLobal);
  AssertEquals('R2.Root is not redirected, remains RootA','RootA',R2.FGLobal);
end;

procedure TTestResolveReference.TestRedirectFixupReferences3;

Var
  R1,R2 : TUnresolvedReference;

begin
  R1:=SetupARef1A(Self);
  R2:=SetupARef2B(Self);
  RedirectFixupReferences(RootA,'RootC','RootQ');
  AssertEquals('R1.Root is not redirected, remains RootB','RootB',R1.FGLobal);
  AssertEquals('R2.Root is not redirected, remains RootB','RootB',R2.FGLobal);
end;

// procedure RemoveFixupReferences(Root: TComponent; const RootName: string);
procedure TTestResolveReference.TestRemoveFixupReferences1;

begin
  SetupARef1A(Self);
  SetupARef2A(Self);
  RemoveFixupReferences(RootA,'RootB');
  AssertSame('No references left',Nil,NeedResolving.Root);
end;

procedure TTestResolveReference.TestRemoveFixupReferences2;

Var
  RA,RB : TUnresolvedInstance;
  R1,R2 : TUnresolvedReference;

begin
  RA:=RootAToResolveList(Self);
  RB:=RootBToResolveList(Self);
  R1:=SetupARef1A(Self);
  R2:=SetupBRef2A(Self);
  RemoveFixupReferences(RootA,'RootB');
  AssertSame('1 reference left',RB,NeedResolving.Root);
end;


procedure TTestResolveReference.TestFixupReferences1;

begin
  SetupARef1A(Self);
  GlobalFixupReferences;
  AssertSame('RootA.Ref1 resolved to RootB.A',RootB.FindComponent('A'),RootA.Ref1);
  AssertEquals('No more resolving needs to be done',0,NeedResolving.Count);
end;

procedure TTestResolveReference.TestFixupReferences2;

Var
  RI : TUnresolvedInstance;
  UR : TUnresolvedReference;

begin
  // Add Not existing
  RI:=RootBToResolveList(Self);
  UR:=RI.AddReference(RootB,PropB1,'RootC','A');
  // Add existing
  SetupARef1A(Self);
  GlobalFixupReferences;
  AssertSame('RootA.Ref1 resolved to RootB.A',RootB.FindComponent('A'),RootA.Ref1);
  AssertSame('Reference to RootC unresolved',RI,NeedResolving.Root);
end;

procedure TTestResolveReference.TestFixupReferences3;

Var
  RI : TUnresolvedInstance;
  UR : TUnresolvedReference;

begin
  // Add Not existing
  RI:=RootAToResolveList(Self);
  UR:=RI.AddReference(RootA,PropA2,'RootC','A');
  // Add existing
  SetupARef1A(Self);
  GlobalFixupReferences;
  AssertSame('RootA.Ref1 resolved to RootB.A',RootB.FindComponent('A'),RootA.Ref1);
  AssertSame('Reference to RootC unresolved',RI,NeedResolving.Root);
  AssertSame('Reference to RootC unresolved',RI.RootUnresolved,UR);
end;

initialization
  RegisterTest(TTestResolveReference);
  InitCriticalSection(ResolveSection);
  
finalization
  DoneCriticalsection(ResolveSection);
end.