unit UnitClass;

interface

uses Rtti, TypInfo, System.SysUtils;

Type
  UnitStringType = UTF8String;
  UnitArray = array of UnitStringType;

  TUnitType = record
    LowerName, LowerName2: string;
    Base: PTypeInfo;
  end;

  TUnitTypeArray = array of TUnitType;

  TUnitClass = record
  private
    UnitCountAll, AllCountType: Integer;

    TypesAll: TUnitTypeArray;
    UnitsAll: UnitArray;

  public
    Rtti: TRttiContext;

    function GetUnitsCount(): Integer;
    function GetUnits(Tt: PLibModule): UnitArray;
    function IsUnits(UnitName: UnitStringType): Boolean;
    function IsUnitsNoLower(UnitName: UnitStringType): Boolean;
    procedure AddUnit(UnitsAdd: UnitArray);

    function FindTypeInfo(ClassName: string; var S: string): PTypeInfo; overload;
    function FindTypeInfo(TType: PTypeInfo): string; overload;

    function FindType(ClassName: string; var S: string): TRttiType; overload;
    function FindType(TType: PTypeInfo): TRttiType; overload;
    function GetList(): TUnitTypeArray;
    function GetAllListCount(): Integer;
  end;

VAR
  TClassUnits: TUnitClass;

implementation

function TUnitClass.GetAllListCount(): Integer;
var
  Curr: PLibModule;
begin
  Result := 0;
  Curr := LibModuleList;
  repeat
    Inc(Result, Curr^.TypeInfo^.TypeCount);
    Curr := Curr.Next;
  until Curr = nil;
end;

function TUnitClass.GetList(): TUnitTypeArray;
label
  GotoEnd;
var
  Units: UnitArray;
  T: TPackageTypeInfo;
  Curr: PLibModule;
  ModuleCountTypes, LengthList, I, R, CurrUnit, Indx: Integer;
  TypeIter: PPTypeInfo;
  TypeName, LowStr: string;
begin
  if AllCountType <> GetAllListCount() then
  begin
    LengthList := Length(TypesAll);
    Curr := LibModuleList;
    Indx := 0;
    repeat
      Inc(Indx);
      Units := GetUnits(Curr);
      CurrUnit := 0;

      ModuleCountTypes := Curr^.TypeInfo^.TypeCount;
      Inc(AllCountType, ModuleCountTypes);

      SetLength(TypesAll, LengthList + ModuleCountTypes);

      T := Curr^.TypeInfo^;
      for I := 0 to ModuleCountTypes - 1 do
      begin
        TypeIter := T.TypeTable^[I];
        if TypeIter <> nil then
        begin
          if NativeInt(TypeIter) = 1 then
          begin
            Inc(CurrUnit);
            Continue;
          end else if (PPointer(TypeIter)^ = nil) then
            Continue;

          if Indx > 1 then
            if IsUnitsNoLower(Units[CurrUnit]) then
              Continue;

          TypeName := Units[CurrUnit] + '.' + TypeIter^^.Name;
          for R := 1 to Length(TypeName) do
            case TypeName[R] of
              '<', '>': goto GotoEnd;
              ',', '.': TypeName[R] := '\';
              'A' .. 'Z': TypeName[R] := Char(Word(TypeName[R]) or $0020);
            end;

          LowStr := Lowercase(TypeIter^^.NameFld.ToString);

          TypesAll[LengthList].LowerName := TypeName;
          TypesAll[LengthList].LowerName2 := LowStr;
          TypesAll[LengthList].Base := TypeIter^;
          Inc(LengthList);
        GotoEnd: end;
      end;

      Curr := Curr.Next;
      AddUnit(Units);
    until Curr = nil;
    SetLength(TypesAll, LengthList);
  end;

  Result := TypesAll;
end;

function TUnitClass.FindTypeInfo(ClassName: string; var S: string): PTypeInfo;
var
  V: TUnitType;
begin
  ClassName := Lowercase(ClassName);
  for V in GetList do
  begin
    if (V.LowerName = ClassName) or (V.LowerName2 = ClassName) then
    begin
      S := V.LowerName;
      Exit(V.Base);
    end;
  end;

  Result := nil;
end;

function TUnitClass.FindTypeInfo(TType: PTypeInfo): string;
var
  V: TUnitType;
begin
  for V in GetList do
  begin
    if V.Base = TType then
      Exit(V.LowerName);
  end;
  Result := '';
end;

function TUnitClass.FindType(ClassName: string; var S: string): TRttiType;
begin
  Result := Rtti.GetType(FindTypeInfo(ClassName, S));
end;

function TUnitClass.FindType(TType: PTypeInfo): TRttiType;
begin
  Result := Rtti.GetType(TType);
end;

function TUnitClass.GetUnitsCount(): Integer;
var
  Curr: PLibModule;
begin
  Result := 0;
  Curr := LibModuleList;
  repeat
    Inc(Result, Curr^.TypeInfo^.UnitCount);
    Curr := Curr.Next;
  until Curr = nil;
end;

function TUnitClass.GetUnits(Tt: PLibModule): UnitArray;
var
  P: Pointer;
  I, Len, Offset, UnitsCount: Integer;
  T: TPackageTypeInfo;
  Str: UnitStringType;
begin
  T := Tt^.TypeInfo^;
  UnitsCount := T.UnitCount;
  SetLength(Result, UnitsCount);

  P := Pointer(T.UnitNames);
  Offset := 0;
  for I := 0 to UnitsCount - 1 do
  begin
    Len := PByte(NativeInt(P) + Offset)^;
    if Len = 0 then
      Continue;

    Inc(Offset, 1);

    SetLength(Str, Len);
    Move(Pointer(NativeInt(P) + Offset)^, Str[1], Len);

    Result[I] := Lowercase(Str);

    Inc(Offset, Len);
  end;
end;

function TUnitClass.IsUnits(UnitName: UnitStringType): Boolean;
var
  I: Integer;
begin
  UnitName := Lowercase(UnitName);
  for I := Low(UnitsAll) to High(UnitsAll) do
    if UnitName = UnitsAll[I] then
      Exit(True);
  Result := False;
end;

function TUnitClass.IsUnitsNoLower(UnitName: UnitStringType): Boolean;
var
  I: Integer;
begin
  for I := Low(UnitsAll) to High(UnitsAll) do
    if UnitName = UnitsAll[I] then
      Exit(True);
  Result := False;
end;

procedure TUnitClass.AddUnit(UnitsAdd: UnitArray);
var
  I: Integer;
begin
  UnitCountAll := Length(UnitsAll);
  SetLength(UnitsAll, UnitCountAll + Length(UnitsAdd));
  for I := Low(UnitsAdd) to High(UnitsAdd) do
    if not IsUnits(UnitsAdd[I]) then
    begin
      UnitsAll[UnitCountAll] := UnitsAdd[I];
      Inc(UnitCountAll);
    end;
  SetLength(UnitsAll, UnitCountAll);
end;

initialization

SetLength(TClassUnits.TypesAll, 0);
SetLength(TClassUnits.UnitsAll, 0);
TClassUnits.AllCountType := 0;

TClassUnits.GetList;

finalization

SetLength(TClassUnits.TypesAll, 0);
SetLength(TClassUnits.UnitsAll, 0);
TClassUnits.AllCountType := 0;

end.