dynamicarrays/prj/Delphi/DynamicArraysTests/TestBase.pas - master - lasersquad/DynamicArrays

dynamicarrays/prj/Delphi/DynamicArraysTests/TestBase.pas
298 строк9 KB
lasersquad0
added function MillisecToStr
19 май 2026, 23:41
19 май 2026, 23:416343382
unit TestBase;

interface

uses System.Generics.Defaults, DynamicArray;

type
  // Comparer classs used to compare complicated types in tests for THarraySorted<> class
  TMyComparer<T> = class(TComparer<T>)
  public
    function Compare(const Left, Right: T): Integer; override;
  end;

type
  TTestBase = class
  protected
  // array contans all created TObject (and descendants) instances by CreateValue<T> method.
  // used to Free all these classes in one place to avoid memoty leaks during tests.
    FObjects: THarrayG<TObject>;
    FComparableTypes: set of TTypeKind; // list of types that are compared by value in Delphi. for example class types (TObject and all descendants) are NOT compared by value

    function CreateValue<T:constructor>(const AValue: Integer): T;
    function CreateInteger<T>(const AValue: T): Integer;
    procedure FreeTObjects;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  function MillisecToStr(ms: Cardinal): string;

implementation

uses System.TypInfo, SysUtils, TestTObject;

function MillisecToStr(ms: Cardinal): string;
var
 milliseconds: Cardinal;
  seconds: Cardinal;
  minutes: Cardinal;
  hours: Cardinal;
begin
  milliseconds := ms mod 1000;
  seconds := (ms div 1000) mod 60;
  minutes := (ms div 60000) mod 60;
  hours := (ms div 3600000) mod 24;

  //char buf[100];
  if hours > 0 then
    Result := Format('%u h %u min %u sec %u ms', [hours, minutes, seconds, milliseconds])
  else if minutes > 0 then
    Result := Format('%u min %u sec %u ms', [minutes, seconds, milliseconds])
  else
    Result := Format('%u sec %u ms', [seconds, milliseconds]);
end;


// This class can properly compare two THArrayG<> values which were previously created by CreateValue<> procedure
function TMyComparer<T>.Compare(const Left, Right: T): Integer;
var
  i, cnt: Cardinal;
  L: THArrayG<Integer> absolute Left;
  R: THArrayG<Integer> absolute Right;
begin
  var TypeInfoPtr := TypeInfo(T);

  if TypeInfoPtr = TypeInfo(THArrayG<Integer>) then begin

    if L.Count > R.Count
      then cnt := R.Count
      else cnt := L.Count;

    for i := 0 to cnt - 1 do // compare min(L.Count, R.Count) elements from both arrays
      if L[i] > R[i] then Exit(1)
      else if L[i] < R[i] then Exit(-1);

    // first cnt elements sare equal in both arrays
    // in this case array that has more elements is greater than another
    if L.Count > R.Count then Exit(1)
    else if L.Count < R.Count then Exit(-1);

    Exit(0); // all elments in arrays are equal to each other - arrays are equal

  end else begin
    Result := Default.Compare(Left, Right);
  end;
end;

procedure TTestBase.FreeTObjects;
var
  I: Integer;
begin
   for I := 1 to FObjects.Count do FObjects[i - 1].Free;
   FObjects.ClearMem;
end;

function TTestBase.CreateValue<T>(const AValue: Integer): T;
var
  TypeDataPtr: PTypeData;
  TypeInfoPtr: PTypeInfo;
  TypeKind: TTypeKind;
  I8: Int8 absolute Result;
  U8: UInt8 absolute Result;
  I16: Int16 absolute Result;
  U16: UInt16 absolute Result;
  I32: Int32 absolute Result;
  U32: UInt32 absolute Result;
  I64: Int64 absolute Result;
  UStr: UnicodeString absolute Result;
  WStr: WideString absolute Result;
  AnsiStr: AnsiString absolute Result;
  ShortStr: ShortString absolute Result;
  IntHArr: THArrayG<Integer> absolute Result;
  IntTObj: TObject absolute Result;
  Pnter: Pointer absolute Result;
  Ch: AnsiChar absolute Result;
  WCh: WideChar absolute Result;
  flSingle: Single absolute Result;
  flDouble: Double absolute Result;
  flExtended: Extended absolute Result;
  flComp: Comp absolute Result;
  flCurrency: Currency absolute Result;
  Bool: Boolean absolute Result;
begin
  Result := T.Create;

  TypeInfoPtr := TypeInfo(T);
  TypeDataPtr := GetTypeData(TypeInfoPtr);
  TypeKind := GetTypeKind(T);

  case TypeKind of
    tkInteger:
      begin
        case TypeDataPtr.OrdType of
          otSByte: I8  := Int8(AValue);
          otUByte: U8  := UInt8(AValue);
          otSWord: I16 := Int16(AValue);
          otUWord: U16 := UInt16(AValue);
          otSLong: I32 := Int32(AValue);
          otULong: U32 := UInt32(AValue);
        else
          System.Assert(False, 'CreateValue<T>: Invalid integer type');
        end;
      end;

    tkInt64: I64 := Int64(AValue);

    tkWString: WStr    := IntToStr(AValue);
    tkUString: UStr    := IntToStr(AValue);
    tkLString: AnsiStr := AnsiString(IntToStr(AValue));
    tkString:  ShortStr:= ShortString(IntToStr(AValue));
    tkPointer: Pnter   := Pointer(AValue);
    tkChar:    Ch      := AnsiChar(AValue);
    tkWChar:   WCh     := WideChar(AValue);

    tkFloat:
      case TypeDataPtr.FloatType of
         ftSingle:  flSingle   := AValue;
         ftDouble:  flDouble   := AValue;
         ftExtended:flExtended := AValue;
         ftComp:    flComp     := AValue;
         ftCurr:    flCurrency := AValue;
      else
         System.Assert(False, 'CreateValue<T>: Invalid float type');
      end;

    tkEnumeration:
      begin
        if TypeInfoPtr.Name = 'Boolean'
          then Bool := AValue <> 0
          else U8 := UInt8(Avalue); // real enumeration type here. enumerations cannot hold more than 256 values.
      end;

    tkClass:
      begin
        if TypeInfoPtr = TypeInfo(THArrayG<Integer>) then begin
          //object instance has already created above, see Result := T.Create line;
          IntHArr.AddValue(AValue);
          FObjects.AddValue(IntHArr);
        end else if TypeInfoPtr = TypeInfo(TObject) then begin
          //object instance has already created above, see Result := T.Create line;
          FObjects.AddValue(IntTObj);
        end
        else System.Assert(False, 'CreateValue<T>: Class is not supported');
      end;

     //tkDynArray:
  else
    System.Assert(False, 'CreateValue<T>: Type kind is not supported');
  end;
end;

destructor TTestBase.Destroy;
begin
  FreeTObjects;
  FreeAndNil(FObjects);
  inherited;
end;

constructor TTestBase.Create;
begin
  inherited Create;
  FObjects := THArrayG<TObject>.Create;
  FComparableTypes := [tkInteger, tkInt64, tkFloat, tkChar, tkWChar, tkString, tkUString, tkLString, tkWString, tkPointer, tkEnumeration, tkRecord];
end;

function TTestBase.CreateInteger<T>(const AValue: T): Integer;
var
  TypeDataPtr: PTypeData;
  TypeInfoPtr: PTypeInfo;
  TypeKind: TTypeKind;
  Value: T;
  I8: Int8 absolute Value;
  U8: UInt8 absolute Value;
  I16: Int16 absolute Value;
  U16: UInt16 absolute Value;
  I32: Int32 absolute Value;
  U32: UInt32 absolute Value;
  I64: Int64 absolute Value;
  WStr: WideString absolute Value;
  UStr: UnicodeString absolute Value;
  AnsiStr: AnsiString absolute Value;
  ShortStr: ShortString absolute Value;
  IntArr: THArrayG<Integer> absolute Value;
  IntObj: TObject absolute Value;
  Pnter: Pointer absolute Value;
  Ch: AnsiChar absolute Value;
  WCh: WideChar absolute Value;
  flSingle: Single absolute Value;
  flDouble: Double absolute Value;
  flExtended: Extended absolute Value;
  flComp: Comp absolute Value;
  flCurrency: Currency absolute Value;
  Bool: Boolean absolute Value;
begin
  TypeInfoPtr := TypeInfo(T);
  TypeDataPtr := GetTypeData(TypeInfoPtr);
  TypeKind := GetTypeKind(T);
  Value := AValue;

  Result := -1; // default result

  case TypeKind of
    tkInteger:
      begin
        case TypeDataPtr.OrdType of
          otSByte: Result  := I8;
          otUByte: Result := U8;
          otSWord: Result := I16;
          otUWord: Result := U16;
          otSLong: Result := I32;
          otULong: Result := U32;
        else
          System.Assert(False, 'CreateInteger<T>: Invalid integer type');
        end;
      end;
     tkInt64: I64 := I64;

     tkWString: Result := StrToInt(WStr);
     tkUString: Result := StrToInt(UStr);
     tkLString: Result := StrToInt(string(AnsiStr));
     tkString:  Result := StrToInt(string(ShortStr));
     tkPointer: Result := Integer(Pnter);
     tkChar:    Result := Integer(Ch);
     tkWChar:   Result := Integer(WCh);

     tkFloat:
     case TypeDataPtr.FloatType of
         ftSingle:  Result :=  Round(flSingle);
         ftDouble:  Result :=  Round(flDouble);
         ftExtended:Result :=  Round(flExtended);
         ftComp:    Result :=  Round(flComp);
         ftCurr:    Result :=  Round(flCurrency);
     else
         System.Assert(False, 'CreateInteger<T>: Invalid float type');
     end;

     tkEnumeration:
     begin
       if TypeInfoPtr.Name = 'Boolean'
         then Result :=  Integer(Bool)
         else Result := U8; // real enumeration type here. enumerations cannot hold more than 256 values.
     end;

     tkClass:
       begin
        if TypeInfoPtr = TypeInfo(THArrayG<Integer>) then begin
          Result := IntArr.GetValue(0);
        end else if TypeInfoPtr = TypeInfo(TObject) then begin
          Result := Integer(IntObj);
        end else System.Assert(False, 'CreateInteger<T>: Class is not supported');
       end;
  else
    System.Assert(False, 'CreateInteger<T>: Type kind is not supported');
  end;
end;

end.