unit TestJitClass; {$mode objfpc}{$H+} {$ModeSwitch typehelpers} {$inline off} {$WARN 4055 off : Conversion between ordinals and pointers is not portable} interface uses Classes, SysUtils, TypInfo, Math, fpcunit, testutils, testregistry, JitClass, JitTypes, LazLogger, Rtti; type TInitProcedure = procedure of object; { TPropListTest } TPropListTest = class private FOwner: TTestCase; FObject: TObject; FPropCount: Integer; FPropList: PPropList; protected function GetPPropInfo(APropName: String): PPropInfo; public constructor Create(AnOwner: TTestCase; AnObject: TObject); destructor Destroy; override; procedure AssertPropCount(AName: String; AExpCount: Integer); procedure AssertPropOffsets(AName: String=''); procedure AssertHasProp(AName, APropName: String; AExpType: TTypeKind); procedure AssertHasProp(AName, APropName: String; AExpType: TTypeKind; AValue: Int64); procedure AssertHasProp(AName, APropName: String; AExpType: TTypeKind; AValue: String); end; { TJitClassTest } TJitClassTest = class(TTestCase) private FFreedObjList, FFreedMemList: TList; procedure DoObjFreed(Sender: TObject); procedure AssertWasObjFreed(AName: String; AnObj: TObject); procedure AssertWasNotObjFreed(AName: String; AnObj: TObject); procedure StartMemMonitor; procedure StartAndClearMemMonitor; procedure StopMemMonitor; procedure ClearMemMonitor; procedure AssertWasMemFreed(AName: String; AMem: Pointer); procedure AssertWasNotMemFreed(AName: String; AMem: Pointer); procedure DumpPropInfo(AClass: TClass); private // Methods for circle ref testing FJitTypeLib: TJitTypeLibrary; FJitCreator: array [1..3] of TJitClassCreator; function GetCreator(ABase: TClass; AName: String; PropClass: String = ''; ATakeCreatorOwnerShip: Boolean = False): TJitClassCreator; function GetCreator(ABase: TJitClassCreator; AName: String; PropClass: String = ''; ATakeCreatorOwnerShip: Boolean = False): TJitClassCreator; procedure InitTwoClasses; procedure InitTwoClassesWithOneSelfRef; procedure InitTwoClassesWithDoubleLink; procedure InitTwoClassesAnchestor; procedure InitTwoClassesAnchestorWithAnchestorProp; procedure InitTwoClassesAnchestorWithAnchestorPropOneWay; // not for auto ref count tests // NOT a circle procedure InitThreeClasses; procedure InitThreeClassesWithOneSelfRef; procedure InitThreeClassesWithOneDoubleLink; procedure InitThreeClassesWithSubLoop; procedure InitThreeClassesWithSubLoopAndOneSelfRef; procedure InitThreeClassesWithTwoSubLoop; procedure InitThreeClassesChained; procedure InitThreeClassesChainedIndirect; procedure InitThreeClassesOneAnchestor; procedure InitThreeClassesOneAnchestorIndirect; procedure InitThreeClassesAnchestorParallel; procedure InitThreeClassesAnchestorParallelIndirect; // 5 classes procedure InitThreeClassesAnchestorParallelAndChildRef; procedure InitThreeClassesAnchestorParallelAndChildRefIndirect; procedure InitThreeClassesAnchestorParallelAndChildRefIndirect_2; procedure InitThreeClassesAnchestorParallelAndChildLoop; procedure InitThreeClassesAnchestorParallelAndChildLoopIndirect; procedure InitThreeClassesAnchestorParallelAndChildLoopIndirect_2; procedure InitThreeClassesTwoAnchestor; procedure InitThreeClassesTwoAnchestorIndirect; procedure TestTwoClassRefCount(AnInitProc: TInitProcedure); procedure TestThreeClassRefCount(AnInitProc: TInitProcedure); protected procedure DoStreamCopy(AJitSource, AJitDest: TComponent); procedure DoTestSimpleClass(AJitClass, AnExpParentClass: TComponentClass); procedure TearDown; override; published procedure TestSimpleClass; // Test unmodified Jit procedure TestSimpleClassNested; // Test unmodified Jit, with Jit as base procedure TestJitPropSimple; procedure TestJitParseClass; procedure TestJitPropCircularClassDef; procedure TestManagedJitProp; procedure TestRefCount; procedure TestRefCountProp; procedure TestRefCountClassCircle; procedure TestRefCountMethodCircle; procedure TestParseJitType; // Parser errors / also run with valgrind procedure TestSetEnum; procedure TestMethods; end; implementation var MMgr: TMemoryManager; HeapState: TFPCHeapStatus; GlobFreedMemList: TList; InMyFreeMem: Integer; function GetMemUsed: integer; begin GetMemoryManager(MMgr); HeapState := MMgr.GetFPCHeapStatus(); Result := HeapState.CurrHeapUsed; end; var TestVirt: Integer; OrigFreemem : Function(p:pointer):ptruint; OrigFreememSize : Function(p:pointer;Size:ptruint):ptruint; Function MyFreemem(p:pointer):ptruint; begin inc(InMyFreeMem); Result := OrigFreemem(p); if (InMyFreeMem = 1) and (GlobFreedMemList <> nil) then begin GlobFreedMemList.Add(p); end; dec(InMyFreeMem); end; Function MyFreememSize(p:pointer;Size:ptruint):ptruint; begin inc(InMyFreeMem); Result := OrigFreememSize(p,Size); if (InMyFreeMem = 1) and (GlobFreedMemList <> nil) then begin GlobFreedMemList.Add(p); end; dec(InMyFreeMem); end; type { TMyBaseClass } TMyBaseClass = class(TComponent) private FMyBaseInt: Integer; public procedure MyVirt; virtual; published property MyBaseInt: Integer read FMyBaseInt write FMyBaseInt; end; { TMyClass } TMyClass = class(TMyBaseClass) private FMyLines: TStringList; FMyEvent: TNotifyEvent; FMyText: AnsiString; procedure SetMyLines(AValue: TStringList); protected procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; public FMyDynArray: Array of integer; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure MyVirt; override; published MyField: TMyBaseClass; procedure MyFoo(Sender: TObject); property MyLines: TStringList read FMyLines write SetMyLines; property MyText: AnsiString read FMyText write FMyText; property MyEvent: TNotifyEvent read FMyEvent write FMyEvent; end; const MYCLASS_PROP_COUNT = 6; { TMyBaseClass } procedure TMyBaseClass.MyVirt; begin TestVirt := 1; end; { TMyClass } procedure TMyClass.SetMyLines(AValue: TStringList); begin if FMyLines = AValue then Exit; FMyLines.Assign(AValue); end; procedure TMyClass.GetChildren(Proc: TGetChildProc; Root: TComponent); begin inherited GetChildren(Proc, Root); if MyField <> nil then Proc(MyField); end; constructor TMyClass.Create(AOwner: TComponent); begin inherited Create(AOwner); FMyLines := TStringList.Create; end; destructor TMyClass.Destroy; begin FMyLines.Free; MyField.Free; inherited Destroy; end; procedure TMyClass.MyVirt; begin TestVirt := 2; end; procedure TMyClass.MyFoo(Sender: TObject); begin // end; { TPropListTest } function TPropListTest.GetPPropInfo(APropName: String): PPropInfo; var i: Integer; begin Result := nil; for i := 0 to FPropCount-1 do if FPropList^[i]^.Name = APropName then exit(FPropList^[i]); end; constructor TPropListTest.Create(AnOwner: TTestCase; AnObject: TObject); begin FOwner := AnOwner; FObject := AnObject; FPropCount := GetPropList(AnObject, FPropList); end; destructor TPropListTest.Destroy; begin if FPropCount > 0 then Freemem(FPropList); inherited Destroy; end; procedure TPropListTest.AssertPropCount(AName: String; AExpCount: Integer); begin FOwner.AssertEquals(AName+' (PropCount)', AExpCount, FPropCount); end; procedure TPropListTest.AssertPropOffsets(AName: String); var CurPvmt, ParPvmt: pvmt; PropInf: PPropInfo; MaxOffs, MinOffs: SizeInt; ParMaxOffs: SmallInt; PropCount, i: Integer; begin CurPvmt := PPVmt(FObject)^; PropCount := FPropCount; ParPvmt := CurPvmt^.vParent; MaxOffs := CurPvmt^.vInstanceSize; if ParPvmt <> nil then begin MinOffs := ParPvmt^.vInstanceSize; ParMaxOffs := GetTypeData(ParPvmt^.vTypeInfo)^.Propcount; end else begin ParMaxOffs := -1; MinOffs := 0 end; FOwner.AssertTrue('', PropCount > 0); FOwner.AssertTrue('', PropCount >= ParMaxOffs); for i := 0 to PropCount-1 do begin PropInf := FPropList^[i]; if i >= ParMaxOffs then FOwner.AssertTrue('', PropInf^.PropProcs = (ptConst shl 4)); if PropInf^.PropProcs = 0 then begin //if PtrUInt(PropInf^.GetProc) <> 0 then FOwner.AssertTrue(AName+' (GetProc)', (PtrUInt(PropInf^.GetProc) <> 0)); FOwner.AssertTrue(AName+' (GetProc)', (PtrUInt(PropInf^.GetProc) < MaxOffs)); if PtrUInt(PropInf^.SetProc) <> 0 then FOwner.AssertTrue(AName+' (SetProc))', (PtrUInt(PropInf^.SetProc) < MaxOffs)); if i >= ParMaxOffs then begin // belong to CurPvmt / must be bigger than MinOffs; //if PtrUInt(PropInf^.GetProc) <> 0 then FOwner.AssertTrue(AName+' (GetProc)', (PtrUInt(PropInf^.GetProc) >= MinOffs)); if PtrUInt(PropInf^.SetProc) <> 0 then FOwner.AssertTrue(AName+' (SetProc))', (PtrUInt(PropInf^.SetProc) >= MinOffs)); end; end; end; end; procedure TPropListTest.AssertHasProp(AName, APropName: String; AExpType: TTypeKind); var PropInfo: PPropInfo; begin PropInfo := GetPPropInfo(APropName); FOwner.AssertTrue(AName+' (HasProp '+APropName+')', PropInfo <> nil); FOwner.AssertTrue(AName+' (HasPropType '+APropName+')', PropInfo^.PropType <> nil); FOwner.AssertEquals(AName+' (HasPropType '+APropName+' match)', ord(AExpType), ord(PropInfo^.PropType^.Kind)); end; procedure TPropListTest.AssertHasProp(AName, APropName: String; AExpType: TTypeKind; AValue: Int64); var PropInfo: PPropInfo; begin PropInfo := GetPPropInfo(APropName); FOwner.AssertTrue(AName+' (HasProp '+APropName+')', PropInfo <> nil); FOwner.AssertTrue(AName+' (HasPropType '+APropName+')', PropInfo^.PropType <> nil); FOwner.AssertEquals(AName+' (HasPropType '+APropName+' match)', ord(AExpType), ord(PropInfo^.PropType^.Kind)); FOwner.AssertEquals(AName+' (Val for '+APropName+')', AValue, GetOrdProp(FObject, PropInfo)); end; procedure TPropListTest.AssertHasProp(AName, APropName: String; AExpType: TTypeKind; AValue: String); var PropInfo: PPropInfo; begin PropInfo := GetPPropInfo(APropName); FOwner.AssertTrue(AName+' (HasProp '+APropName+')', PropInfo <> nil); FOwner.AssertTrue(AName+' (HasPropType '+APropName+')', PropInfo^.PropType <> nil); FOwner.AssertEquals(AName+' (HasPropType '+APropName+' match)', ord(AExpType), ord(PropInfo^.PropType^.Kind)); FOwner.AssertEquals(AName+' (Val for '+APropName+')', AValue, GetStrProp(FObject, PropInfo)); end; { TJitClassTest } procedure TJitClassTest.DoObjFreed(Sender: TObject); begin if FFreedObjList = nil then FFreedObjList := TList.Create; FFreedObjList.Add(Pointer(Sender)); end; procedure TJitClassTest.AssertWasObjFreed(AName: String; AnObj: TObject); begin AssertTrue(AName, (FFreedObjList <> nil) and (FFreedObjList.IndexOf(Pointer(AnObj)) >= 0)); end; procedure TJitClassTest.AssertWasNotObjFreed(AName: String; AnObj: TObject); begin AssertFalse(AName, (FFreedObjList <> nil) and (FFreedObjList.IndexOf(Pointer(AnObj)) >= 0)); end; procedure TJitClassTest.StartMemMonitor; begin if FFreedMemList = nil then FFreedMemList := TList.Create; GlobFreedMemList := FFreedMemList; end; procedure TJitClassTest.StartAndClearMemMonitor; begin ClearMemMonitor; StartMemMonitor; end; procedure TJitClassTest.StopMemMonitor; begin GlobFreedMemList := nil; end; procedure TJitClassTest.ClearMemMonitor; begin inc(InMyFreeMem); if FFreedMemList <> nil then FFreedMemList.Clear; dec(InMyFreeMem); end; procedure TJitClassTest.AssertWasMemFreed(AName: String; AMem: Pointer); begin AssertTrue(AName, (FFreedMemList <> nil) and (FFreedMemList.IndexOf(AMem) >= 0)); end; procedure TJitClassTest.AssertWasNotMemFreed(AName: String; AMem: Pointer); begin AssertFalse(AName, (FFreedMemList <> nil) and (FFreedMemList.IndexOf(AMem) >= 0)); end; procedure TJitClassTest.DumpPropInfo(AClass: TClass); var PropCount, i: Integer; PropList: PPropList; begin PropCount := GetPropList(AClass, PropList); if PropCount>0 then begin try DebugLn(['--- ', PropCount, ' InstSize ', PVmt(AClass)^.vInstanceSize]); for i := 0 to PropCount-1 do DebugLn('## %25s %2d // %2d %2d // %10d %d %d %d ', [ PropList^[i]^.Name, PropList^[i]^.NameIndex, PropList^[i]^.Index, PropList^[i]^.Default, ptruint(PropList^[i]^.PropType), ptruint(PropList^[i]^.GetProc), ptruint(PropList^[i]^.SetProc), ptruint(PropList^[i]^.StoredProc) ]); finally Freemem(PropList); end; end; end; procedure TJitClassTest.DoStreamCopy(AJitSource, AJitDest: TComponent); var strm: TMemoryStream; Driver: TAbstractObjectWriter; Writer: TWriter; Reader: TReader; begin strm := TMemoryStream.Create; Driver := TBinaryObjectWriter.Create(strm,4096); Writer := TWriter.Create(Driver); Writer.WriteRootComponent(AJitSource); Driver.Free; Writer.Free; strm.Position := 0; Reader := TReader.Create(strm, 4096); Reader.ReadRootComponent(AJitDest); Reader.Free; strm.Free; end; procedure TJitClassTest.DoTestSimpleClass(AJitClass, AnExpParentClass: TComponentClass); var JitObject, JitObject2: TMyClass; MemUsed, MemUsed2, PropCount, i: Integer; PropList: PPropList; TestProps: TPropListTest; begin AssertEquals('Got class-name', 'TJitTestSimpleClass', AJitClass.ClassName); AssertEquals('Got unit-name', 'foo.pas', AJitClass.UnitName); AssertEquals('Got class-parent', AnExpParentClass, AJitClass.ClassParent); AssertEquals('Got instance-size', TMyClass.InstanceSize, AJitClass.InstanceSize); MemUsed := GetMemUsed; // Call the virtual method JitObject := TMyClass(AJitClass.Create(nil)); TMyBaseClass(JitObject).MyVirt; AssertEquals('virt meth call', 2, TestVirt); // check all memory is freed JitObject.Free; MemUsed2 := GetMemUsed; AssertEquals('Memory freed', MemUsed, MemUsed2); // check all memory is freed / including managed types JitObject := TMyClass(AJitClass.Create(nil)); SetLength(JitObject.FMyDynArray, 100); JitObject.Free; MemUsed2 := GetMemUsed; AssertEquals('Memory freed (dyn array)', MemUsed, MemUsed2); // check RTTI properties JitObject := TMyClass(AJitClass.Create(nil)); SetLength(JitObject.FMyDynArray, 1); JitObject.MyBaseInt := 88123; JitObject.MyText := 'SomeText'; JitObject.MyLines.Text := 'Line123'; JitObject.MyEvent := @JitObject.MyFoo; JitObject.MyField := TMyBaseClass.Create(JitObject); JitObject.MyField.Name := 'MyField'; TestProps := TPropListTest.Create(Self, JitObject); try TestProps.AssertPropCount('', 6); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'MyBaseInt', tkInteger, 88123); TestProps.AssertHasProp('', 'MyText', tkAnsiString, 'SomeText'); TestProps.AssertHasProp('', 'MyLines', tkClass); TestProps.AssertHasProp('', 'MyEvent', tkMethod); finally TestProps.Free; end; // stream and copy JitObject2 := TMyClass(AJitClass.Create(nil)); DoStreamCopy(JitObject, JitObject2); AssertEquals('Stream-copied BaseInt', 88123, JitObject2.MyBaseInt); AssertEquals('Stream-copied MyText', 'SomeText', JitObject2.MyText); AssertEquals('Stream-copied MyLines', 'Line123', JitObject2.MyLines[0]); AssertTrue ('Stream-copied MyEvent', @JitObject.MyFoo = JitObject2.MyEvent); AssertTrue ('Stream-copied MyField', JitObject2.MyField <> nil); AssertEquals('Stream-copied MyField', 'MyField', JitObject2.MyField.Name); TestProps := TPropListTest.Create(Self, JitObject2); try TestProps.AssertPropCount('', 6); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'MyBaseInt', tkInteger, 88123); TestProps.AssertHasProp('', 'MyText', tkAnsiString, 'SomeText'); TestProps.AssertHasProp('', 'MyLines', tkClass); TestProps.AssertHasProp('', 'MyEvent', tkMethod); finally TestProps.Free; end; JitObject2.Free; PropCount := GetPropList(JitObject, PropList); if PropCount>0 then begin try for i := 0 to PropCount-1 do WriteLn('## ', ' / ', PropList^[i]^.Name, ' / ', PropList^[i]^.NameIndex, ' / ', PropList^[i]^.Index, ' / ', PropList^[i]^.Default, ' / ', ptruint(PropList^[i]^.PropType), ' / ', ptruint(PropList^[i]^.GetProc), ' / ', ptruint(PropList^[i]^.SetProc), ' / ', ptruint(PropList^[i]^.StoredProc) ); finally Freemem(PropList); end; end; // RTTI methods AssertEquals('Func of Addr', PtrUint(@TMyClass.MyFoo), PtrUint(AJitClass.MethodAddress('MyFoo'))); AssertEquals('Addr of Func', 'MyFoo', AJitClass.MethodName(@TMyClass.MyFoo)); AssertEquals('Func of Addr', PtrUint(@TMyClass.MyFoo), PtrUint(JitObject.MethodAddress('MyFoo'))); AssertEquals('Addr of Func', 'MyFoo', JitObject.MethodName(@TMyClass.MyFoo)); AssertEquals('Func of Addr', PtrUint(@TMyClass.MyFoo), PtrUint(JitObject.ClassType.MethodAddress('MyFoo'))); AssertEquals('Addr of Func', 'MyFoo', JitObject.ClassType.MethodName(@TMyClass.MyFoo)); AssertEquals('Func of none Addr', 0, PtrUint(AJitClass.MethodAddress('NotHere'))); AssertEquals('Addr of none Func', '', AJitClass.MethodName(codepointer($11002233))); // RTTI fields AssertEquals('Addr of Field', PtrUint(@JitObject.MyField), PtrUint(JitObject.FieldAddress('MyField'))); AssertEquals('Addr of none Field', 0, PtrUint(JitObject.FieldAddress('NotHere'))); JitObject.Free; end; procedure TJitClassTest.TearDown; begin inherited TearDown; GlobFreedMemList := nil; FreeAndNil(FFreedObjList); FreeAndNil(FFreedMemList); end; procedure TJitClassTest.TestSimpleClass; var JitCreator: TJitClassCreator; type TTa= array of record a,b,c: cardinal; end; // vartype -1 // elSize 12 TTb= array of record a,b,c: string; end; // vartype -1 // elSize 24 TTc= array of byte; // vartype 17 // elSize 1 var a,b,c: PTypeInfo; begin a := PTypeInfo(TypeInfo(tta)); b := PTypeInfo(TypeInfo(ttb)); c := PTypeInfo(TypeInfo(ttc)); JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleClass', 'foo.pas'); DoTestSimpleClass(TComponentClass(JitCreator.JitClass), TMyClass); JitCreator.Free; end; procedure TJitClassTest.TestSimpleClassNested; var JitCreator, JitCreatorNested: TJitClassCreator; begin (* Include an empty JitClass as parent Test that a JitClass can be used as parent *) JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'foo.pas'); JitCreatorNested := TJitClassCreator.Create(JitCreator.JitClass, 'TJitTestSimpleClass', 'foo.pas'); DoTestSimpleClass(TComponentClass(JitCreatorNested.JitClass), TComponentClass(JitCreator.JitClass)); JitCreator.Free; JitCreatorNested.Free; end; procedure TJitClassTest.TestJitPropSimple; var JitCreator: TJitClassCreator; JitClass: TComponentClass; JitObject, JitObject2: TComponent; TestProps: TPropListTest; PropList: PPropList; PropCount, i: Integer; begin JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'foo.pas'); JitCreator.JitProperties.Add('JitInt32', 'longint'); JitCreator.JitProperties.Add('JitInt64', 'int64'); JitCreator.JitProperties.Add('JitWord1', 'word'); JitCreator.JitProperties.Add('JitWord2', 'Word'); JitCreator.JitProperties.Add('JitString', 'AnsiString'); JitClass := TComponentClass(JitCreator.JitClass); JitObject := JitClass.Create(nil); PropCount := GetPropList(JitObject, PropList); if PropCount>0 then begin try for i := 0 to PropCount-1 do WriteLn(format('## %15s %2d / %2d %10d / %x %d %d %d', [ AnsiString(PropList^[i]^.Name), PropList^[i]^.NameIndex, PropList^[i]^.Index, PropList^[i]^.Default, ptruint(PropList^[i]^.PropType), ptruint(PropList^[i]^.GetProc), ptruint(PropList^[i]^.SetProc), ptruint(PropList^[i]^.StoredProc) ])); finally Freemem(PropList); end; end; TestProps := TPropListTest.Create(Self, JitObject); try TestProps.AssertPropCount('', 11); TestProps.AssertPropOffsets; //TestProps.AssertHasProp('', 'MyBaseInt', tkInteger, 88123); //TestProps.AssertHasProp('', 'MyText', tkAnsiString, 'SomeText'); TestProps.AssertHasProp('', 'MyLines', tkClass); TestProps.AssertHasProp('', 'MyEvent', tkMethod); TestProps.AssertHasProp('', 'JitInt32', tkInteger); TestProps.AssertHasProp('', 'JitInt64', tkInt64); TestProps.AssertHasProp('', 'JitWord1', tkInteger); TestProps.AssertHasProp('', 'JitWord2', tkInteger); TestProps.AssertHasProp('', 'JitString', tkAString); finally TestProps.Free; end; SetOrdProp(JitObject, 'JitInt32', $66771122); SetOrdProp(JitObject, 'JitInt64', $7557444475574444); SetOrdProp(JitObject, 'JitWord1', $2332); SetOrdProp(JitObject, 'JitWord2', $4334); SetStrProp(JitObject, 'JitString', 'Hello World'); AssertEquals(GetOrdProp(JitObject, 'JitInt32'), $66771122); AssertEquals(GetOrdProp(JitObject, 'JitInt64'), $7557444475574444); AssertEquals(GetOrdProp(JitObject, 'JitWord1'), $2332); AssertEquals(GetOrdProp(JitObject, 'JitWord2'), $4334); AssertEquals(GetStrProp(JitObject, 'JitString'), 'Hello World'); // set in reverse order SetStrProp(JitObject, 'JitString', 'Hello World'); SetOrdProp(JitObject, 'JitWord2', $4334); SetOrdProp(JitObject, 'JitWord1', $2332); SetOrdProp(JitObject, 'JitInt64', $7557444475574444); SetOrdProp(JitObject, 'JitInt32', $66771122); AssertEquals(GetOrdProp(JitObject, 'JitInt32'), $66771122); AssertEquals(GetOrdProp(JitObject, 'JitInt64'), $7557444475574444); AssertEquals(GetOrdProp(JitObject, 'JitWord1'), $2332); AssertEquals(GetOrdProp(JitObject, 'JitWord2'), $4334); AssertEquals(GetStrProp(JitObject, 'JitString'), 'Hello World'); JitObject2 := JitClass.Create(nil); DoStreamCopy(JitObject, JitObject2); AssertEquals(GetOrdProp(JitObject2, 'JitInt32'), $66771122); AssertEquals(GetOrdProp(JitObject2, 'JitInt64'), $7557444475574444); AssertEquals(GetOrdProp(JitObject2, 'JitWord1'), $2332); AssertEquals(GetOrdProp(JitObject2, 'JitWord2'), $4334); AssertEquals(GetStrProp(JitObject2, 'JitString'), 'Hello World'); JitObject2.Free; JitObject.Free; JitCreator.Free; end; procedure TJitClassTest.TestJitParseClass; var JitCreator: TJitClassCreator; JitTypeLib: TJitTypeLibrary; begin JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestClass', 'foo'); JitCreator.JitProperties.ParseFromClassDeclaration( 'class(foo)' + 'published' + ' property TestProp1: int64 read foo write foo;' + ' property TestProp2: int64 read foo;' + 'a: word;' + 'function foo: boolean;' + ' property TestProp3: int64 read foo;' + 'end' ); AssertTrue(JitCreator.JitProperties.IndexOf('TestProp1') >= 0); AssertTrue(JitCreator.JitProperties.IndexOf('TestProp2') >= 0); AssertTrue(JitCreator.JitProperties.IndexOf('TestProp3') >= 0); AssertTrue(JitCreator.JitProperties.IndexOf('TestFoo') < 0); JitCreator.Free; JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestClass', 'foo'); JitCreator.JitProperties.ParseFromClassDeclaration( ' property TestProp1: int64 read foo write foo;' + ' property TestProp2: int64 read foo;' + 'a: word;' + 'function foo: boolean;' + ' property TestProp3: int64 read foo;' ); AssertTrue(JitCreator.JitProperties.IndexOf('TestProp1') >= 0); AssertTrue(JitCreator.JitProperties.IndexOf('TestProp2') >= 0); AssertTrue(JitCreator.JitProperties.IndexOf('TestProp3') >= 0); JitCreator.Free; JitTypeLib := TJitTypeLibrary.Create; JitTypeLib.AddAlias('string', 'ansistring'); JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestClass', 'foo', JitTypeLib); JitCreator.JitProperties.ParseFromClassDeclaration( ' property TestProp1: string read foo write foo;' + ' property TestProp2: ansistring read foo;' ); AssertTrue(JitCreator.JitProperties.IndexOf('TestProp1') >= 0); AssertTrue(JitCreator.JitProperties.IndexOf('TestProp2') >= 0); JitCreator.Free; JitTypeLib.Free; end; procedure TJitClassTest.TestJitPropCircularClassDef; procedure DoTestProps(AClass: TClass); var Obj: TComponent; TestProps: TPropListTest; begin Obj := TComponentClass(AClass).Create(nil); TestProps := TPropListTest.Create(Self, Obj); try //TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4); TestProps.AssertPropOffsets; finally TestProps.Free; Obj.Free; end; end; procedure TestTwoClassProps(AnInitProc: TInitProcedure; NotACircle: Boolean = False); var i, MemUsed: Integer; cl: TClass; pi: PPropInfo; ti: PTypeInfo; begin for i := 1 to 2 do begin AnInitProc(); case i of // which class to access first 1: FJitCreator[1].JitClass; 2: FJitCreator[2].JitClass; end; MemUsed := GetMemUsed; DoTestProps(FJitCreator[1].JitClass); DoTestProps(FJitCreator[2].JitClass); if not NotACircle then AssertEquals('No more Memory alloc', MemUsed, GetMemUsed); FJitTypeLib.Free; FJitCreator[1].Free; FJitCreator[2].Free; end; // only access one class for i := 1 to 2 do begin AnInitProc(); case i of // which class to access first 1: cl := FJitCreator[1].JitClass; 2: cl := FJitCreator[2].JitClass; end; DoTestProps(cl); if cl.ClassParent.ClassName <> 'TMyClass' then DoTestProps(cl.ClassParent); pi := GetPropInfo(cl, 'a'); if pi <> nil then begin ti := pi^.PropType; AssertTrue(ti <> nil); if ti^.Kind = tkClass then DoTestProps(GetTypeData(ti)^.ClassType); end; pi := GetPropInfo(cl, 'b'); if pi <> nil then begin ti := pi^.PropType; AssertTrue(ti <> nil); if ti^.Kind = tkClass then DoTestProps(GetTypeData(ti)^.ClassType); end; pi := GetPropInfo(cl, 'par'); if pi <> nil then begin ti := pi^.PropType; AssertTrue(ti <> nil); if ti^.Kind = tkClass then DoTestProps(GetTypeData(ti)^.ClassType); end; FJitTypeLib.Free; FJitCreator[1].Free; FJitCreator[2].Free; end; end; procedure TestThreeClassProps(AnInitProc: TInitProcedure); var i, MemUsed: Integer; cl: TClass; pi: PPropInfo; ti: PTypeInfo; begin for i := 1 to 3 do begin AnInitProc(); case i of // which class to access first 1: FJitCreator[1].JitClass; 2: FJitCreator[2].JitClass; 3: FJitCreator[3].JitClass; end; MemUsed := GetMemUsed; DoTestProps(FJitCreator[1].JitClass); DoTestProps(FJitCreator[2].JitClass); DoTestProps(FJitCreator[3].JitClass); AssertEquals('No more Memory alloc', MemUsed, GetMemUsed); FJitTypeLib.Free; FJitCreator[1].Free; FJitCreator[2].Free; FJitCreator[3].Free; end; // only access one class for i := 1 to 3 do begin AnInitProc(); case i of // which class to access first 1: cl := FJitCreator[1].JitClass; 2: cl := FJitCreator[2].JitClass; 3: cl := FJitCreator[3].JitClass; end; DoTestProps(cl); if cl.ClassParent.ClassName <> 'TMyClass' then DoTestProps(cl.ClassParent); pi := GetPropInfo(cl, 'a'); if pi <> nil then begin ti := pi^.PropType; AssertTrue(ti <> nil); if ti^.Kind = tkClass then DoTestProps(GetTypeData(ti)^.ClassType); end; pi := GetPropInfo(cl, 'b'); if pi <> nil then begin ti := pi^.PropType; AssertTrue(ti <> nil); if ti^.Kind = tkClass then DoTestProps(GetTypeData(ti)^.ClassType); end; pi := GetPropInfo(cl, 'par'); if pi <> nil then begin ti := pi^.PropType; AssertTrue(ti <> nil); if ti^.Kind = tkClass then DoTestProps(GetTypeData(ti)^.ClassType); end; FJitTypeLib.Free; FJitCreator[1].Free; FJitCreator[2].Free; FJitCreator[3].Free; end; end; var JitObject1, JitObject2: TComponent; TestProps: TPropListTest; begin (* set up different circular scenarios *) ////////////////////////////////// // 1 classes circle FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassOne'); JitObject1 := TComponentClass(FJitCreator[1].JitClass).Create(nil); TestProps := TPropListTest.Create(Self, JitObject1); try TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'a', tkClass); TestProps.AssertHasProp('', 'prop1', tkInt64); TestProps.AssertHasProp('', 'prop2', tkInteger); TestProps.AssertHasProp('', 'prop3', tkInt64); finally TestProps.Free; end; JitObject1.Free; FJitCreator[1].Free; FJitTypeLib.Free; // 2 class Property Circle InitTwoClasses; JitObject1 := TComponentClass(FJitCreator[1].JitClass).Create(nil); JitObject2 := TComponentClass(FJitCreator[2].JitClass).Create(nil); TestProps := TPropListTest.Create(Self, JitObject1); try TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'a', tkClass); TestProps.AssertHasProp('', 'prop1', tkInt64); TestProps.AssertHasProp('', 'prop2', tkInteger); TestProps.AssertHasProp('', 'prop3', tkInt64); finally TestProps.Free; end; TestProps := TPropListTest.Create(Self, JitObject2); try TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'a', tkClass); TestProps.AssertHasProp('', 'prop1', tkInt64); TestProps.AssertHasProp('', 'prop2', tkInteger); TestProps.AssertHasProp('', 'prop3', tkInt64); finally TestProps.Free; end; JitObject1.Free; JitObject2.Free; FJitCreator[1].Free; FJitCreator[2].Free; FJitTypeLib.Free; // Anchestor Class, has child-class as property InitTwoClassesAnchestor; JitObject1 := TComponentClass(FJitCreator[1].JitClass).Create(nil); JitObject2 := TComponentClass(FJitCreator[2].JitClass).Create(nil); TestProps := TPropListTest.Create(Self, JitObject1); try TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 4); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'a', tkClass); TestProps.AssertHasProp('', 'prop1', tkInt64); TestProps.AssertHasProp('', 'prop2', tkInteger); TestProps.AssertHasProp('', 'prop3', tkInt64); finally TestProps.Free; end; TestProps := TPropListTest.Create(Self, JitObject2); try TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 6); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'a', tkClass); TestProps.AssertHasProp('', 'prop1', tkBool); TestProps.AssertHasProp('', 'prop2', tkInteger); TestProps.AssertHasProp('', 'prop3', tkInt64); TestProps.AssertHasProp('', 'bprop1', tkInt64); TestProps.AssertHasProp('', 'bprop2', tkInt64); finally TestProps.Free; end; JitObject1.Free; JitObject2.Free; FJitCreator[1].Free; FJitCreator[2].Free; FJitTypeLib.Free; // Child Class, has anchestor-class as property / not a circle InitTwoClassesAnchestorWithAnchestorPropOneWay; JitObject1 := TComponentClass(FJitCreator[1].JitClass).Create(nil); JitObject2 := TComponentClass(FJitCreator[2].JitClass).Create(nil); TestProps := TPropListTest.Create(Self, JitObject1); try TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 3); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'prop1', tkInt64); TestProps.AssertHasProp('', 'prop2', tkInteger); TestProps.AssertHasProp('', 'prop3', tkInt64); finally TestProps.Free; end; TestProps := TPropListTest.Create(Self, JitObject2); try TestProps.AssertPropCount('', MYCLASS_PROP_COUNT + 6); TestProps.AssertPropOffsets; TestProps.AssertHasProp('', 'prop1', tkBool); TestProps.AssertHasProp('', 'prop2', tkInteger); TestProps.AssertHasProp('', 'prop3', tkInt64); TestProps.AssertHasProp('', 'par', tkClass); TestProps.AssertHasProp('', 'bprop1', tkInt64); TestProps.AssertHasProp('', 'bprop2', tkInt64); finally TestProps.Free; end; JitObject1.Free; JitObject2.Free; FJitCreator[1].Free; FJitCreator[2].Free; FJitTypeLib.Free; ///////////////////// TestTwoClassProps(@InitTwoClasses); TestTwoClassProps(@InitTwoClassesWithOneSelfRef); TestTwoClassProps(@InitTwoClassesWithDoubleLink); TestTwoClassProps(@InitTwoClassesAnchestor); TestTwoClassProps(@InitTwoClassesAnchestorWithAnchestorProp); TestTwoClassProps(@InitTwoClassesAnchestorWithAnchestorPropOneWay, True); TestThreeClassProps(@InitThreeClasses); TestThreeClassProps(@InitThreeClassesWithOneSelfRef); TestThreeClassProps(@InitThreeClassesWithOneDoubleLink); TestThreeClassProps(@InitThreeClassesWithSubLoop); TestThreeClassProps(@InitThreeClassesWithSubLoopAndOneSelfRef); TestThreeClassProps(@InitThreeClassesWithTwoSubLoop); TestThreeClassProps(@InitThreeClassesChained); TestThreeClassProps(@InitThreeClassesChainedIndirect); TestThreeClassProps(@InitThreeClassesOneAnchestor); TestThreeClassProps(@InitThreeClassesOneAnchestorIndirect); TestThreeClassProps(@InitThreeClassesAnchestorParallel); TestThreeClassProps(@InitThreeClassesAnchestorParallelIndirect); // 5 classes TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildRef); TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildRefIndirect); TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildRefIndirect_2); TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildLoop); TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildLoopIndirect); TestThreeClassProps(@InitThreeClassesAnchestorParallelAndChildLoopIndirect_2); TestThreeClassProps(@InitThreeClassesTwoAnchestor); TestThreeClassProps(@InitThreeClassesTwoAnchestorIndirect); end; procedure TJitClassTest.TestManagedJitProp; var JitCreator: TJitClassCreator; JitClass: TComponentClass; JitObject: TComponent; a: ansistring; MemUsedBeforeCreate, MemUsedAfterCreate, MemUsedTmp: Integer; begin a := ''; JitCreator := TJitClassCreator.Create(TMyClass, 'TJitClass', 'foo'); JitCreator.JitProperties.Add('JitString', 'AnsiString'); JitClass := TComponentClass(JitCreator.JitClass); MemUsedBeforeCreate := GetMemUsed; JitObject := JitClass.Create(nil); JitObject.Destroy; AssertEquals('Memory for object released', MemUsedBeforeCreate, GetMemUsed); MemUsedBeforeCreate := GetMemUsed; JitObject := JitClass.Create(nil); MemUsedAfterCreate := GetMemUsed; MemUsedTmp := GetMemUsed; SetStrProp(JitObject, 'JitString', a); AssertEquals('No Memory used by setting empty string', MemUsedTmp, GetMemUsed); SetLength(a, 100); MemUsedTmp := GetMemUsed; SetStrProp(JitObject, 'JitString', a); AssertEquals('No Memory used by setting string with data', MemUsedTmp, GetMemUsed); MemUsedTmp := GetMemUsed; a := ''; AssertEquals('Memory for string hold by jitprop', MemUsedTmp, GetMemUsed); SetStrProp(JitObject, 'JitString', a); // empty again AssertEquals('Memory for string hold by jitprop freed (set to empty)', MemUsedAfterCreate, GetMemUsed); SetLength(a, 100); MemUsedTmp := GetMemUsed; SetStrProp(JitObject, 'JitString', a); a := ''; AssertEquals('Memory for string hold by jitprop (2)', MemUsedTmp, GetMemUsed); JitObject.Destroy; AssertEquals('Memory for string released', MemUsedBeforeCreate, GetMemUsed); JitCreator.Free; end; procedure TJitClassTest.TestRefCount; var JitTypeLib: TJitTypeLibrary; MyEnLock, OthEnLock, MySetLock: TRefCountedJitReference; MyEn, OthEn, MySet: TJitType; MyEnInfo, OthEnInfo, MySetInfo: PTypeInfo; begin JitTypeLib := TJitTypeLibrary.Create; MyEn := JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)'); OthEn := JitTypeLib.AddType('OtherEnum', '(o1, o2, o3, o4, o5)'); // Get Locks MyEnLock := MyEn.LockReference; OthEnLock := OthEn.LockReference; AssertEquals('LockCount for MyEnum (used by set)', 2, MyEnLock.RefCount); AssertEquals('LockCount for OtherEnum', 2, OthEnLock.RefCount); // Get Lock for MySet => No TypeInfo call yet => no lock to nested MyEnum MySet := JitTypeLib.AddType('MySet', 'set of MyEnum'); MySetLock := MySet.LockReference; AssertEquals('LockCount for MySet', 2, MySetLock.RefCount); AssertEquals('LockCount for MyEnum 2', 2, MyEnLock.RefCount); AssertEquals('LockCount for OtherEnum 2', 2, OthEnLock.RefCount); // Watch when Objects are freed MyEn.AddFreeNotification(@DoObjFreed); OthEn.AddFreeNotification(@DoObjFreed); MySet.AddFreeNotification(@DoObjFreed); // Access MySet TypeInfo => MySet will need MyEnum MySetInfo := MySet.TypeInfo; AssertEquals('LockCount for MyEn used', 3, MyEnLock.RefCount); AssertEquals('LockCount for OthEn not parsed', 2, OthEnLock.RefCount); AssertEquals('LockCount for MySet parsed', 2, MySetLock.RefCount); // Get all TypeInfo => start monitoring FreeMem calls MyEnInfo := MyEn.TypeInfo; OthEnInfo := OthEn.TypeInfo; StartMemMonitor; AssertEquals('LockCount for MyEn parsed', 3, MyEnLock.RefCount); AssertEquals('LockCount for OthEn parsed', 2, OthEnLock.RefCount); // Still the same ref object? The increase by LockReference, should be visible in the earlier ref MyEn.LockReference; AssertEquals('LockCount for MyEn locked 2', 4, MyEnLock.RefCount); OthEn.LockReference; AssertEquals('LockCount for OthEn locked 2', 3, OthEnLock.RefCount); MySet.LockReference; AssertEquals('LockCount for MySet locked 2', 3, MySetLock.RefCount); // Free the lib => JitType objects should be freed too AssertWasNotObjFreed('', MySet); AssertWasNotObjFreed('', MyEn); AssertWasNotObjFreed('', OthEn); JitTypeLib.Free; AssertWasObjFreed('', MySet); AssertWasObjFreed('', MyEn); AssertWasObjFreed('', OthEn); // LockCounts went down by one (no longer locked by the JitType object AssertEquals('LockCount for MyEn kept', 3, MyEnLock.RefCount); AssertEquals('LockCount for OthEn kept', 2, OthEnLock.RefCount); AssertEquals('LockCount for MySet kept', 2, MySetLock.RefCount); // Release MySet, which gives up one ref to MyEnum MySetLock.ReleaseLock; AssertWasNotMemFreed('', MySetInfo); // Check FreeMem(TypeInfo) for MySet MySetLock.ReleaseLock; AssertWasMemFreed('', MySetInfo); AssertEquals('LockCount for MyEn kept', 2, MyEnLock.RefCount); AssertEquals('LockCount for OthEn kept', 2, OthEnLock.RefCount); MyEnLock.ReleaseLock; OthEnLock.ReleaseLock; AssertWasNotMemFreed('', MyEnInfo); AssertWasNotMemFreed('', OthEnInfo); // Check FreeMem(TypeInfo) MyEnLock.ReleaseLock; OthEnLock.ReleaseLock; AssertWasMemFreed('', MyEnInfo); AssertWasMemFreed('', OthEnInfo); //////////////////////// // Test Mem without external lock StartAndClearMemMonitor; JitTypeLib := TJitTypeLibrary.Create; MyEn := JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)'); MyEnInfo := MyEn.TypeInfo; StartAndClearMemMonitor; AssertWasNotMemFreed('', MyEnInfo); JitTypeLib.Free; AssertWasMemFreed('', MyEnInfo); StopMemMonitor; StartAndClearMemMonitor; end; procedure TJitClassTest.TestRefCountProp; var JitCreator: TJitClassCreator; JitTypeLib: TJitTypeLibrary; MyEnLock, ClassLock: TRefCountedJitReference; MyEn: TJitType; MyEnInfo: PTypeInfo; begin JitTypeLib := TJitTypeLibrary.Create; MyEn := JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)'); MyEnInfo := MyEn.TypeInfo; StartMemMonitor; MyEnLock := MyEn.LockReference; AssertEquals('LockCount for MyEnum after typeinfo', 2, MyEnLock.RefCount); JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'foo.pas'); JitCreator.TypeLibrary := JitTypeLib; JitCreator.JitProperties.Add('a', 'MyEnum'); JitCreator.JitClass; AssertEquals('LockCount for MyEnum after jitclass', 3, MyEnLock.RefCount); JitTypeLib.Free; AssertEquals('LockCount for MyEnum after typelib free', 2, MyEnLock.RefCount); JitCreator.Free; AssertEquals('LockCount for MyEnum after creator free', 1, MyEnLock.RefCount); AssertWasNotMemFreed('', MyEnInfo); MyEnLock.ReleaseLock; AssertWasMemFreed('', MyEnInfo); /////////////// // Add as property // hold creator by lock JitTypeLib := TJitTypeLibrary.Create; MyEn := JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)'); MyEnInfo := MyEn.TypeInfo; StartAndClearMemMonitor; MyEnLock := MyEn.LockReference; AssertEquals('LockCount for MyEnum after typeinfo', 2, MyEnLock.RefCount); JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'foo.pas'); JitCreator.TypeLibrary := JitTypeLib; JitCreator.JitProperties.Add('a', 'MyEnum'); ClassLock := JitCreator.LockReference; AssertEquals('LockCount for class ', 2, ClassLock.RefCount); JitCreator.JitClass; AssertEquals('LockCount for MyEnum after jitclass', 3, MyEnLock.RefCount); JitTypeLib.Free; AssertEquals('LockCount for MyEnum after typelib free', 2, MyEnLock.RefCount); JitCreator.Free; AssertEquals('LockCount for MyEnum after creator free (locked)', 2, MyEnLock.RefCount); AssertEquals('LockCount for class after creator free', 1, ClassLock.RefCount); ClassLock.ReleaseLock; AssertEquals('LockCount for MyEnum after creator free (unlocked)', 1, MyEnLock.RefCount); AssertWasNotMemFreed('', MyEnInfo); MyEnLock.ReleaseLock; AssertWasMemFreed('', MyEnInfo); end; function TJitClassTest.GetCreator(ABase: TClass; AName: String; PropClass: String = ''; ATakeCreatorOwnerShip: Boolean = False): TJitClassCreator; begin Result := TJitClassCreator.Create(ABase, AName, 'foo'); Result.TypeLibrary := FJitTypeLib; if PropClass <> '' then Result.JitProperties.Add('a', PropClass); FJitTypeLib.AddJitClass(Result.JitClassName, Result, ATakeCreatorOwnerShip); Result.JitProperties.Add('prop1', 'Int64'); Result.JitProperties.Add('prop2', 'word'); Result.JitProperties.Add('prop3', 'Int64'); end; function TJitClassTest.GetCreator(ABase: TJitClassCreator; AName: String; PropClass: String; ATakeCreatorOwnerShip: Boolean): TJitClassCreator; begin Result := TJitClassCreator.Create(ABase, AName, 'foo'); Result.TypeLibrary := FJitTypeLib; if PropClass <> '' then Result.JitProperties.Add('b', PropClass); FJitTypeLib.AddJitClass(Result.JitClassName, Result, ATakeCreatorOwnerShip); Result.JitProperties.Add('bprop1', 'Int64'); Result.JitProperties.Add('bprop2', 'Int64'); Result.JitProperties.Add('prop1', 'boolean'); // replace prop end; procedure TJitClassTest.InitTwoClasses; begin FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo'); FJitCreator[2] := GetCreator(TMyClass, 'TMyClassTwo', 'TMyClassOne'); end; procedure TJitClassTest.InitTwoClassesWithOneSelfRef; begin (* One -> Two One -> One Two -> One *) InitTwoClasses; FJitCreator[1].JitProperties.Add('b', 'TMyClassOne'); // self ref end; procedure TJitClassTest.InitTwoClassesWithDoubleLink; begin (* One -> Two One -> Two (2nd property) Two -> One *) InitTwoClasses; FJitCreator[1].JitProperties.Add('b', 'TMyClassTwo'); // 2nd prop to TMyClassTwo; end; procedure TJitClassTest.InitTwoClassesAnchestor; begin (* One -> Two Two >> One (inherits) *) (* Anchestor Class, has child-class as property *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo'); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo'); end; procedure TJitClassTest.InitTwoClassesAnchestorWithAnchestorProp; begin (* One -> Two Two >> One (inherits) Two -> One (prop) *) (* Anchestor Class, has child-class as property AND Child has anchestor as prop *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo'); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo'); FJitCreator[2].JitProperties.Add('par', 'TMyClassOne'); end; procedure TJitClassTest.InitTwoClassesAnchestorWithAnchestorPropOneWay; begin // NOT a circle (* Two >> One (inherits) Two -> One (prop) *) (* Child Class, has anchestor-class as property / not a circle *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne'); // anchestor does NOT refer to the child FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo'); FJitCreator[2].JitProperties.Add('par', 'TMyClassOne'); end; procedure TJitClassTest.InitThreeClasses; begin (* One -> Two Two -> Three Three -> One *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo'); FJitCreator[2] := GetCreator(TMyClass, 'TMyClassTwo', 'TMyClassThree'); FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassOne'); end; procedure TJitClassTest.InitThreeClassesWithOneSelfRef; begin (* One -> Two One -> One Two -> Three Three -> One *) InitThreeClasses; FJitCreator[1].JitProperties.Add('c', 'TMyClassOne'); end; procedure TJitClassTest.InitThreeClassesWithOneDoubleLink; begin (* One -> Two One -> Two (2nd prop) Two -> Three Three -> One *) InitThreeClasses; FJitCreator[1].JitProperties.Add('c', 'TMyClassTwo'); end; procedure TJitClassTest.InitThreeClassesWithSubLoop; begin (* One -> Two One -> Three Two -> Three Three -> One *) InitThreeClasses; FJitCreator[1].JitProperties.Add('b', 'TMyClassThree'); end; procedure TJitClassTest.InitThreeClassesWithSubLoopAndOneSelfRef; begin (* One -> Two One -> One One -> Three Two -> Three Three -> One *) InitThreeClasses; FJitCreator[1].JitProperties.Add('b', 'TMyClassThree'); FJitCreator[1].JitProperties.Add('c', 'TMyClassOne'); end; procedure TJitClassTest.InitThreeClassesWithTwoSubLoop; begin (* One -> Two One -> Three Two -> Three Three -> One Three -> One (2nd prop) *) InitThreeClasses; FJitCreator[1].JitProperties.Add('b', 'TMyClassThree'); FJitCreator[3].JitProperties.Add('c', 'TMyClassOne'); end; procedure TJitClassTest.InitThreeClassesChained; begin // 2 separate loops / only ONE is in both loops (* One -> Two One -> Three Two -> One Three -> One *) // FJitCreator[1] will be in 2 circles: One with FJitCreator[2] / the other one with FJitCreator[3] // FJitCreator[2] and FJitCreator[3] are anly connected to FJitCreator[1] FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThree'); FJitCreator[2] := GetCreator(TMyClass, 'TMyClassTwo', 'TMyClassOne'); FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassOne'); end; procedure TJitClassTest.InitThreeClassesChainedIndirect; begin // 2 separate loops / only ONE is in both loops (* One -> TwoHolder -> Two One -> ThreeHolder -> Three Two -> One Three -> One *) // FJitCreator[1] will be in 2 circles: One with FJitCreator[2] / the other one with FJitCreator[3] // FJitCreator[2] and FJitCreator[3] are anly connected to FJitCreator[1] FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder'); GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True); GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True); FJitCreator[2] := GetCreator(TMyClass, 'TMyClassTwo', 'TMyClassOne'); FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassOne'); end; procedure TJitClassTest.InitThreeClassesOneAnchestor; begin (* One -> Three Three -> Two Two >> One (inherits) *) (* Anchestor Class, has child-class via 3rd obj as property *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassThree'); FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassTwo'); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo'); end; procedure TJitClassTest.InitThreeClassesOneAnchestorIndirect; begin (* One -> ThreeHolder -> Three Three -> TwoHolder -> Two Two >> One (inherits) *) (* Anchestor Class, has child-class via 3rd obj as property *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassThreeHolder'); GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True); GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True); FJitCreator[3] := GetCreator(TMyClass, 'TMyClassThree', 'TMyClassTwoHolder'); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo'); end; procedure TJitClassTest.InitThreeClassesAnchestorParallel; begin // 2 separate loops / only ONE is in both loops (* One -> Two One -> Three Two >> One (inherits) Three >> One (inherits) *) (* Anchestor Class, has TWO child-classes, BOTH as property *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThree'); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo'); FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree'); end; procedure TJitClassTest.InitThreeClassesAnchestorParallelIndirect; begin // 2 separate loops / only ONE is in both loops (* One -> TwoHolder -> Two One -> ThreeHolder -> Three Two >> One (inherits) Three >> One (inherits) *) (* Anchestor Class, has TWO child-classes, BOTH as property via indirection *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder'); GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True); GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo'); FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree'); end; procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildRef; begin (* One -> Two One -> Three Two >> One (inherits) Two -> Three Three >> One (inherits) *) (* Anchestor Class, has TWO child-classes, BOTH as property One child has the other child as prop *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThree'); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThree'); FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree'); end; procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildRefIndirect; begin (* One -> TwoHolder -> Two One -> ThreeHolder -> Three Two >> One (inherits) Two -> ThreeHolder -> Three Three >> One (inherits) *) (* Anchestor Class, has TWO child-classes, BOTH as property One child has the other child as prop *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder'); GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True); GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThreeHolder'); FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree'); end; procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildRefIndirect_2; begin (* One -> TwoHolder -> Two One -> ThreeHolder -> Three Two >> One (inherits) Two -> ThreeHolder_2 -> Three // use different holder Three >> One (inherits) *) (* Anchestor Class, has TWO child-classes, BOTH as property One child has the other child as prop *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder'); GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True); GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True); GetCreator(TMyClass, 'TMyClassThreeHolder_2', 'TMyClassThree', True); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThreeHolder_2'); FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree'); end; procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildLoop; begin // 3 circles (* One -> Two One -> Three Two >> One (inherits) Two -> Three Three >> One (inherits) Three -> Two *) (* Anchestor Class, has TWO child-classes, BOTH as property Bothe children has the other child as prop (loop) *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwo'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThree'); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThree'); FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree', 'TMyClassTwo'); end; procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildLoopIndirect; begin // 3 circles (* One -> TwoHolder -> Two One -> ThreeHolder -> Three Two >> One (inherits) Two -> ThreeHolder -> Three Three >> One (inherits) Three -> TwoHolder -> Two *) (* Anchestor Class, has TWO child-classes, BOTH as property Bothe children has the other child as prop (loop) *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder'); GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True); GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThreeHolder'); FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree', 'TMyClassTwoHolder'); end; procedure TJitClassTest.InitThreeClassesAnchestorParallelAndChildLoopIndirect_2; begin // 3 circles (* One -> TwoHolder -> Two One -> ThreeHolder -> Three Two >> One (inherits) Two -> ThreeHolder_2 -> Three Three >> One (inherits) Three -> TwoHolder_2 -> Two *) (* Anchestor Class, has TWO child-classes, BOTH as property Bothe children has the other child as prop (loop) *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassTwoHolder'); FJitCreator[1].JitProperties.Add('b', 'TMyClassThreeHolder'); GetCreator(TMyClass, 'TMyClassTwoHolder', 'TMyClassTwo', True); GetCreator(TMyClass, 'TMyClassTwoHolder_2', 'TMyClassTwo', True); GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True); GetCreator(TMyClass, 'TMyClassThreeHolder_2', 'TMyClassThree', True); FJitCreator[2] := GetCreator(FJitCreator[1], 'TMyClassTwo', 'TMyClassThreeHolder_2'); FJitCreator[3] := GetCreator(FJitCreator[1], 'TMyClassThree', 'TMyClassTwoHolder_2'); end; procedure TJitClassTest.InitThreeClassesTwoAnchestor; begin (* One -> Three Two >> One (inherits) Three >> Two (inherits) *) (* Class, has grand child-class that has property to orig class *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassThree'); // inherit TMyClassOne FJitCreator[2] := TJitClassCreator.Create(FJitCreator[1], 'TMyClassTwo', 'foo'); FJitCreator[2].TypeLibrary := FJitTypeLib; FJitTypeLib.AddJitClass(FJitCreator[2].JitClassName, FJitCreator[2]); // inherit TMyClassTwo; FJitCreator[3] := GetCreator(FJitCreator[2], 'TMyClassThree'); end; procedure TJitClassTest.InitThreeClassesTwoAnchestorIndirect; begin (* One -> ThreeHolder -> Three Two >> One (inherits) Three >> Two (inherits) *) (* Class, has grand child-class that has property to orig class *) FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassThreeHolder'); GetCreator(TMyClass, 'TMyClassThreeHolder', 'TMyClassThree', True); // inherit TMyClassOne FJitCreator[2] := TJitClassCreator.Create(FJitCreator[1], 'TMyClassTwo', 'foo'); FJitCreator[2].TypeLibrary := FJitTypeLib; FJitTypeLib.AddJitClass(FJitCreator[2].JitClassName, FJitCreator[2]); // inherit TMyClassTwo; FJitCreator[3] := GetCreator(FJitCreator[2], 'TMyClassThree'); end; procedure TJitClassTest.TestTwoClassRefCount( AnInitProc: TInitProcedure); var i, j, MemUsed: Integer; JitClassOneInfo, JitClassTwoInfo: PTypeInfo; jc: TJitClassCreator; begin for i := 1 to 2 do for j := 1 to 2 do begin AnInitProc(); case i of // which class to access first 1: JitClassOneInfo := FJitCreator[1].TypeInfo; 2: JitClassTwoInfo := FJitCreator[2].TypeInfo; end; JitClassOneInfo := FJitCreator[1].TypeInfo; // access the other / double access to the first does not matter JitClassTwoInfo := FJitCreator[2].TypeInfo; StartAndClearMemMonitor; FJitTypeLib.Free; case j of // which class to destroy first 1: FreeAndNil(FJitCreator[1]); 2: FreeAndNil(FJitCreator[2]); end; AssertWasNotMemFreed('', JitClassOneInfo); AssertWasNotMemFreed('', JitClassTwoInfo); FreeAndNil(FJitCreator[1]); FreeAndNil(FJitCreator[2]); AssertWasMemFreed('', JitClassOneInfo); AssertWasMemFreed('', JitClassTwoInfo); end; // only access one typeinfo StopMemMonitor; for i := 1 to 2 do for j := 1 to 2 do begin MemUsed := GetMemUsed; AnInitProc(); case i of // which class to access first 1: jc := FJitCreator[1]; 2: jc := FJitCreator[2]; end; JitClassOneInfo := jc.TypeInfo; FJitTypeLib.Free; case j of // which class to destroy first 1: FreeAndNil(FJitCreator[1]); 2: FreeAndNil(FJitCreator[2]); end; FreeAndNil(FJitCreator[1]); FreeAndNil(FJitCreator[2]); AssertEquals('mem used ', MemUsed, GetMemUsed); end; end; procedure TJitClassTest.TestThreeClassRefCount(AnInitProc: TInitProcedure); var i, j, k, MemUsed: Integer; JitClassOneInfo, JitClassTwoInfo, JitClassThreeInfo: PTypeInfo; LastToFree, jc: TJitClassCreator; begin for i := 1 to 3 do for j := 1 to 3 do for k := 1 to 3 do begin AnInitProc(); case i of // which class to access first 1: JitClassOneInfo := FJitCreator[1].TypeInfo; 2: JitClassTwoInfo := FJitCreator[2].TypeInfo; 3: JitClassThreeInfo := FJitCreator[3].TypeInfo; end; JitClassOneInfo := FJitCreator[1].TypeInfo; JitClassTwoInfo := FJitCreator[2].TypeInfo; JitClassThreeInfo := FJitCreator[3].TypeInfo; StartAndClearMemMonitor; FJitTypeLib.Free; case j of // which class to destroy last 1: begin LastToFree := FJitCreator[1]; FJitCreator[1] := nil; end; 2: begin LastToFree := FJitCreator[2]; FJitCreator[2] := nil; end; 3: begin LastToFree := FJitCreator[3]; FJitCreator[3] := nil; end; end; case k of // which class to destroy first 1: FreeAndNil(FJitCreator[1]); 2: FreeAndNil(FJitCreator[2]); 3: FreeAndNil(FJitCreator[3]); end; FJitCreator[1].Free; FJitCreator[2].Free; FJitCreator[3].Free; AssertWasNotMemFreed('', JitClassOneInfo); AssertWasNotMemFreed('', JitClassTwoInfo); AssertWasNotMemFreed('', JitClassThreeInfo); LastToFree.Free; AssertWasMemFreed('', JitClassOneInfo); AssertWasMemFreed('', JitClassTwoInfo); AssertWasMemFreed('', JitClassThreeInfo); end; // only access one typeinfo StopMemMonitor; for i := 1 to 3 do for j := 1 to 3 do for k := 1 to 3 do begin MemUsed := GetMemUsed; AnInitProc(); case i of // which class to access first 1: jc := FJitCreator[1]; 2: jc := FJitCreator[2]; 3: jc := FJitCreator[3]; end; JitClassOneInfo := jc.TypeInfo; FJitTypeLib.Free; case j of // which class to destroy last 1: FreeAndNil(FJitCreator[1]); 2: FreeAndNil(FJitCreator[2]); 3: FreeAndNil(FJitCreator[3]); end; case k of // which class to destroy first 1: FreeAndNil(FJitCreator[1]); 2: FreeAndNil(FJitCreator[2]); 3: FreeAndNil(FJitCreator[3]); end; FJitCreator[1].Free; FJitCreator[2].Free; FJitCreator[3].Free; AssertEquals('mem used ', MemUsed, GetMemUsed); end; end; procedure TJitClassTest.TestRefCountClassCircle; var JitClassOneInfo, JitClassTwoInfo, JitClassThreeInfo: PTypeInfo; begin ////////////////////////////////// // 1 classes circle FJitTypeLib := TJitTypeLibrary.Create; FJitCreator[1] := GetCreator(TMyClass, 'TMyClassOne', 'TMyClassOne'); JitClassOneInfo := FJitCreator[1].TypeInfo; StartMemMonitor; FJitTypeLib.Free; AssertWasNotMemFreed('', JitClassOneInfo); FJitCreator[1].Free; AssertWasMemFreed('', JitClassOneInfo); TestTwoClassRefCount(@InitTwoClasses); TestTwoClassRefCount(@InitTwoClassesWithOneSelfRef); TestTwoClassRefCount(@InitTwoClassesWithDoubleLink); TestTwoClassRefCount(@InitTwoClassesAnchestor); TestTwoClassRefCount(@InitTwoClassesAnchestorWithAnchestorProp); TestThreeClassRefCount(@InitThreeClasses); TestThreeClassRefCount(@InitThreeClassesWithOneSelfRef); TestThreeClassRefCount(@InitThreeClassesWithOneDoubleLink); TestThreeClassRefCount(@InitThreeClassesWithSubLoop); TestThreeClassRefCount(@InitThreeClassesWithSubLoopAndOneSelfRef); TestThreeClassRefCount(@InitThreeClassesWithTwoSubLoop); TestThreeClassRefCount(@InitThreeClassesChained); TestThreeClassRefCount(@InitThreeClassesChainedIndirect); TestThreeClassRefCount(@InitThreeClassesOneAnchestor); TestThreeClassRefCount(@InitThreeClassesOneAnchestorIndirect); TestThreeClassRefCount(@InitThreeClassesAnchestorParallel); TestThreeClassRefCount(@InitThreeClassesAnchestorParallelIndirect); // 5 classes TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildRef); TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildRefIndirect); TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildRefIndirect_2); TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildLoop); TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildLoopIndirect); TestThreeClassRefCount(@InitThreeClassesAnchestorParallelAndChildLoopIndirect_2); TestThreeClassRefCount(@InitThreeClassesTwoAnchestor); TestThreeClassRefCount(@InitThreeClassesTwoAnchestorIndirect); end; procedure TJitClassTest.TestRefCountMethodCircle; var JitTypeLib: TJitTypeLibrary; MyProc: TJitType; MyProcInfo: PTypeInfo; begin JitTypeLib := TJitTypeLibrary.Create; MyProc := JitTypeLib.AddType('TMyProc', 'procedure (a: TMyProc)'); MyProcInfo := MyProc.TypeInfo; StartMemMonitor; AssertWasNotMemFreed('', MyProcInfo); JitTypeLib.Free; AssertWasMemFreed('', MyProcInfo); end; procedure TJitClassTest.TestParseJitType; var JitCreator: TJitClassCreator; Cnt: Integer; JitTypeLib: TJitTypeLibrary; t: PTypeInfo; function DoParseNoError(AName: String; ADecl: String): PTypeInfo; var jp: TJitProperty; begin AName := AName + ' ' + ADecl + ' '; inc(Cnt); try jp := JitCreator.JitProperties.Add('a'+IntToStr(Cnt), ADecl); Result := jp.TypeInfo; //AssertTrue(AName, jp.TypeInfo <> nil); except AssertTrue(AName + 'no except', False); end; end; function ParseNoError(AName: String; ADecl: String): PTypeInfo; var s: String; begin Result := DoParseNoError(AName, ADecl); DoParseNoError(AName+' IN record', 'record a: '+ADecl+' end'); s := Trim(ADecl); if (s <> '') and (s[Length(s)] <> ';') then DoParseNoError(AName+' IN record ;', 'record a: '+ADecl+'; end'); end; procedure ParseExpectError(AName: String; ADecl: String); var jp: TJitProperty; t: Boolean; begin AName := AName + ' ' + ADecl + ' '; inc(Cnt); t := True; try jp := JitCreator.JitProperties.Add('a'+IntToStr(Cnt), ADecl); jp.TypeInfo; t := False; // should skipped by exception except on E: Exception do if not (e is JitTypeParserException) then t := False; // wrong exception type end; AssertTrue(AName, t); // should not reach if above fails end; begin Cnt := 0; JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestSimpleOuterClass', 'unitfoo'); JitTypeLib := TJitTypeLibrary.Create; JitCreator.TypeLibrary := JitTypeLib; JitTypeLib.AddAlias('integer', 'longint'); JitTypeLib.AddAlias('int32', 'integer'); JitTypeLib.AddType('MyEnum', '(e1, e2, e3, e4, e5, e6)', 'unitfoo'); JitTypeLib.AddType('OtherEnum', '(zo1, o2, zo3, o4, zo5)', 'abc'); JitTypeLib.AddType('OtherEnum', '(o1, o2, o3, o4, o5)', 'unitfoo'); JitTypeLib.AddType('OtherEnumX', '(xo1, o2, xo3, o4, xo5)', 'unitbar'); ParseExpectError('', 'string'); ParseNoError('', 'string[1]'); JitTypeLib.AddAlias('string', 'AnsiString'); ParseNoError('', 'longint'); ParseNoError('', 'integer'); ParseNoError('', 'int32'); ParseNoError('', 'string'); ParseNoError('', 'string[1]'); ParseNoError('', 'string[255]'); ParseNoError('', 'string[$FF]'); ParseNoError('', 'string[%10]'); ParseNoError('', 'string[&10]'); ParseNoError('', 'procedure'); ParseNoError('', 'procedure()'); ParseNoError('', 'procedure of object'); ParseNoError('', 'procedure () of object'); ParseNoError('', 'function: int64 '); ParseNoError('', 'function(): int64'); ParseNoError('', 'function: int64 of object'); ParseNoError('', 'function(): int64 of object'); ParseNoError('', 'function(): OtherEnum of object'); ParseNoError('', 'function(): unitfoo.OtherEnum of object'); ParseNoError('', 'function(): abc.OtherEnum of object'); ParseNoError('', 'function(a,b: MyEnum): int64 '); ParseNoError('', 'function(a,b: unitfoo.MyEnum): int64 '); ParseNoError('', 'function(a,b: word; c: boolean=true; const x): int64 '); ParseNoError('', 'function(a,b: word; c: boolean=true; const x; d,e: array of int64): int64 '); ParseNoError('', 'record end;'); ParseNoError('', 'record a,b: word end;'); ParseNoError('', 'record a,b: word; end;'); ParseNoError('', 'record a,b: word; c: procedure() end;'); ParseNoError('', 'record a,b: word; c: procedure(); end;'); ParseNoError('', 'record a,b: word; c: procedure(); x: record xx: boolean end; end;'); ParseNoError('', 'record a,b: word; c: procedure(); x: record xx: boolean end end;'); ParseNoError('', 'record b: MyEnum end;'); ParseNoError('', 'record b: MyEnum; end;'); ParseNoError('', 'record b: unitfoo.MyEnum end;'); ParseNoError('', 'record b: unitfoo.MyEnum; end;'); ParseNoError('', '1..3'); ParseNoError('', '''a''..''c'''); ParseNoError('', 'e2..e3'); ParseNoError('', 'MyEnum.e2..e3'); ParseNoError('', 'e2..MyEnum.e3'); ParseNoError('', 'MyEnum.e2..MyEnum.e3'); ParseNoError('', 'MyEnum(e2)..MyEnum.e3'); ParseNoError('', 'MyEnum.e2..MyEnum(e3)'); t := ParseNoError('', 'o2..o4'); AssertEquals('has o3', GetEnumValue(t, 'o3'), 2); AssertEquals('has not xo3', GetEnumValue(t, 'xo3'), -1); AssertEquals('has not zo3', GetEnumValue(t, 'zo3'), -1); ParseNoError('', 'unitbar.OtherEnumX.o2..unitbar.OtherEnumX(o4)'); ParseNoError('', 'OtherEnumX.o2..OtherEnumX(o4)'); ParseNoError('', 'OtherEnumX(o2)..OtherEnumX(o4)'); ParseNoError('', 'OtherEnumX.o2..OtherEnumX.o4'); t := ParseNoError('', 'OtherEnumX.o2..o4'); AssertEquals('has xo3', GetEnumValue(t, 'xo3'), 2); AssertEquals('has not o3', GetEnumValue(t, 'o3'), -1); AssertEquals('has not zo3', GetEnumValue(t, 'zo3'), -1); t := ParseNoError('', 'abc.OtherEnum.o2..o4'); AssertEquals('has zo3', GetEnumValue(t, 'zo3'), 2); AssertEquals('has not o3', GetEnumValue(t, 'o3'), -1); AssertEquals('has not xo3', GetEnumValue(t, 'xo3'), -1); ParseNoError('', 'set of (a,b,c)'); ParseNoError('', 'set of byte'); ParseNoError('', 'set of 1..3'); ParseNoError('', 'set of Byte(1)..Byte(3)'); ParseNoError('', 'set of MyEnum'); ParseNoError('', 'set of unitfoo.MyEnum'); ParseNoError('', 'set of MyEnum(1)..e3'); ParseNoError('', 'set of unitfoo.MyEnum(1)..e3'); ParseNoError('', 'set of e2..e5'); // typelibrary with enum (en1..en7) ParseNoError('', 'array of int64'); ParseNoError('', 'array of array of int64'); ParseNoError('', 'array of string'); ParseNoError('', 'array of string[2]'); ParseNoError('', 'array of record a: word; end;'); ParseNoError('', 'array of record a: (b,c) end;'); ParseNoError('', 'record a: array of string[2]; b: word; end;'); ParseExpectError('', 'foo'); ParseExpectError('', 'procedure foo'); ParseExpectError('', 'procedure: foo'); ParseExpectError('', 'procedure of '); ParseExpectError('', 'procedure(a: foo)'); ParseExpectError('', 'function:'); ParseExpectError('', 'function: foo'); ParseExpectError('', 'function(): unitbar.OtherEnum'); ParseExpectError('', 'function: array of int64'); ParseExpectError('', 'string[256]'); ParseExpectError('', 'string[0]'); ParseExpectError('', 'string[-1]'); ParseExpectError('', 'OtherEnumX.o2..OtherEnum.o4'); ParseExpectError('', 'abc.OtherEnumX.o2..unitfoo.OtherEnum.o4'); ParseExpectError('', 'record b: unitbar.MyEnum; end;'); ParseExpectError('', 'record b: what.MyEnum; end;'); //ParseExpectError('', 'set of o2..e5'); // typelibrary with enum (en1..en7) // TEST & escaping JitTypeLib.AddAlias('&function', 'integer'); ParseNoError('', '&Function'); ParseNoError('', '&integer'); ParseNoError('', '&longint'); ParseExpectError('', 'Function'); ParseExpectError('', '&foo'); JitCreator.Free; JitTypeLib.Free; end; procedure TJitClassTest.TestSetEnum; procedure CheckEnum(TpInf: PTypeInfo; Names: array of string; UnitName: string; ExpMinVal: Integer = 0); var i: Integer; TpDat: PTypeData; MinVal: LongInt; begin AssertTrue('kind', TpInf^.Kind = tkEnumeration); TpDat := GetTypeData(TpInf); MinVal := TpDat^.MinValue; AssertEquals('minval', ExpMinVal, TpDat^.MinValue); AssertEquals('elem count', Length(Names), GetEnumNameCount(TpInf)); AssertEquals('unitname', UnitName, GetEnumName(TpInf, Length(Names) + MinVal)); // unitname for i := 0 to length(Names) - 1 do begin AssertEquals('elem', Names[i], GetEnumName(TpInf, i+MinVal)); AssertEquals('', i+MinVal, GetEnumValue(TpInf, Names[i])); end; //AssertEquals('bad val', -1, GetEnumValue(TpInf, UnitName)); AssertEquals('bad val', -1, GetEnumValue(TpInf, 'nevereverusethis')); end; procedure CheckSet(TpInf: PTypeInfo; Names: array of string); var i: Integer; CT: PTypeInfo; MinVal: LongInt; begin AssertTrue('kind', TpInf^.Kind = tkSet); CT := GetTypeData(TpInf)^.CompType; MinVal := GetTypeData(CT)^.MinValue; for i := 0 to length(Names) - 1 do begin AssertEquals('elem', Names[i], SetToString(TpInf, 1 << (i+MinVal), False)); end; end; var JitTypeLib: TJitTypeLibrary; jp, en1, en2: TJitType; ti, ti2: PTypeInfo; begin JitTypeLib := TJitTypeLibrary.Create; jp := TJitTypeInfo.Create('x','(a,b,c)', 'unitfoo'); ti := jp.TypeInfo; CheckEnum(ti, ['a', 'b', 'c'], 'unitfoo'); jp.Free; en1 := JitTypeLib.AddType('En1','(a,b,c,d,e)', 'unitfoo'); ti := en1.TypeInfo; CheckEnum(ti, ['a', 'b', 'c', 'd', 'e'], 'unitfoo'); en2 := JitTypeLib.AddType('En2','b..d', 'unitbar'); ti := en2.TypeInfo; CheckEnum(ti, ['b', 'c', 'd'], 'unitbar', 1); ti2 := GetTypeData(ti)^.BaseType; AssertTrue('', ti2 = en1.TypeInfo); CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo'); jp := TJitTypeInfo.Create('x','en1.b..d', 'unitabc', JitTypeLib); ti := jp.TypeInfo; CheckEnum(ti, ['b', 'c', 'd'], 'unitabc', 1); ti2 := GetTypeData(ti)^.BaseType; AssertTrue('', ti2 = en1.TypeInfo); CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo'); jp.Free; jp := TJitTypeInfo.Create('x','set of (a,b,c)', 'unitfoo'); ti := jp.TypeInfo; CheckSet(ti, ['a', 'b', 'c']); ti2 := GetTypeData(ti)^.CompType; CheckEnum(ti2, ['a', 'b', 'c'], 'unitfoo'); jp.Free; jp := TJitTypeInfo.Create('x','set of En1', 'unitsome', JitTypeLib); ti := jp.TypeInfo; CheckSet(ti, ['a', 'b', 'c', 'd', 'e']); ti2 := GetTypeData(ti)^.CompType; CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo'); jp.Free; jp := TJitTypeInfo.Create('x','set of En2', 'unitsome', JitTypeLib); ti := jp.TypeInfo; CheckSet(ti, ['b', 'c', 'd']); ti2 := GetTypeData(ti)^.CompType; CheckEnum(ti2, ['b', 'c', 'd'], 'unitbar', 1); ti2 := GetTypeData(ti2)^.BaseType; CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo'); jp.Free; jp := TJitTypeInfo.Create('x','set of EN1(b)..d', 'unitsome', JitTypeLib); ti := jp.TypeInfo; CheckSet(ti, ['b', 'c', 'd']); ti2 := GetTypeData(ti)^.CompType; CheckEnum(ti2, ['b', 'c', 'd'], 'unitsome', 1); ti2 := GetTypeData(ti2)^.BaseType; AssertTrue('', ti2 = en1.TypeInfo); CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo'); jp.Free; jp := TJitTypeInfo.Create('x','set of EN2(b)..d', 'unitother', JitTypeLib); ti := jp.TypeInfo; CheckSet(ti, ['b', 'c', 'd']); ti2 := GetTypeData(ti)^.CompType; CheckEnum(ti2, ['b', 'c', 'd'], 'unitother', 1); ti2 := GetTypeData(ti2)^.BaseType; AssertTrue('', ti2 = en2.TypeInfo); jp.Free; jp := TJitTypeInfo.Create('x','set of EN1.b..d', 'unitsome', JitTypeLib); ti := jp.TypeInfo; CheckSet(ti, ['b', 'c', 'd']); ti2 := GetTypeData(ti)^.CompType; CheckEnum(ti2, ['b', 'c', 'd'], 'unitsome', 1); ti2 := GetTypeData(ti2)^.BaseType; AssertTrue('', ti2 = en1.TypeInfo); CheckEnum(ti2, ['a', 'b', 'c', 'd', 'e'], 'unitfoo'); jp.Free; jp := TJitTypeInfo.Create('x','set of EN2.b..d', 'unitother', JitTypeLib); ti := jp.TypeInfo; CheckSet(ti, ['b', 'c', 'd']); ti2 := GetTypeData(ti)^.CompType; CheckEnum(ti2, ['b', 'c', 'd'], 'unitother', 1); ti2 := GetTypeData(ti2)^.BaseType; AssertTrue('', ti2 = en2.TypeInfo); jp.Free; jp := TJitTypeInfo.Create('x','set of EN2.b..EN2.d', 'unitother', JitTypeLib); ti := jp.TypeInfo; CheckSet(ti, ['b', 'c', 'd']); ti2 := GetTypeData(ti)^.CompType; CheckEnum(ti2, ['b', 'c', 'd'], 'unitother', 1); ti2 := GetTypeData(ti2)^.BaseType; AssertTrue('', ti2 = en2.TypeInfo); jp.Free; JitTypeLib.Free; end; procedure TJitClassTest.TestMethods; var JitTypeLib: TJitTypeLibrary; procedure DoTest(Decl: String; ExpParam: array of string); var context: TRttiContext; jp: TJitTypeInfo; t: TRttiType; params: specialize TArray; i: Integer; begin context := TRttiContext.Create; jp := TJitTypeInfo.Create('x', Decl, JitTypeLib); t := context.GetType(jp.TypeInfo); AssertTrue(t <> nil); AssertTrue(t is TRttiInvokableType); params := TRttiInvokableType(t).GetParameters; AssertEquals(Length(ExpParam), Length(params)); for i := 0 to Length(ExpParam) - 1 do begin //debugln(params[i].tostring); AssertEquals(LowerCase(ExpParam[i]), LowerCase(params[i].ToString)); end; jp.Free; context.Free; end; begin JitTypeLib := TJitTypeLibrary.Create; JitTypeLib.AddType('TEnum1', '(a,b,c)'); DoTest('function (const a: byte; b,c: word): boolean', ['const a: byte', 'b: word', 'c: word'] ); DoTest('function (const a: byte; var b,c: word): boolean of object', ['const a: byte', 'var b: word', 'var c: word'] ); DoTest('procedure (var a: TEnum1; b: array of Int64) of object', ['var a: TEnum1', {$IFDEF FooFIxed}'b: '+{$ENDIF}'array of Int64'] ); JitTypeLib.Free; end; initialization RegisterTest(TJitClassTest); GetMemoryManager(MMgr); OrigFreemem := MMgr.Freemem; OrigFreememSize := MMgr.FreememSize; MMgr.Freemem := @MyFreemem; MMgr.FreememSize := @MyFreememSize; SetMemoryManager(MMgr); end.