Automatically detect circular references in units *fixed*

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, System.Generics.Collections, System.Math, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.IOUtils,
  Vcl.Direct2D, Vcl.Grids;

type
  TForm1 = class(TForm)
    FileOpenDialog1: TFileOpenDialog;
    StringGrid1: TStringGrid;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  private
  { Private-Deklarationen }
    type

    TUnit = class
    public
      LineCount: Integer;
      Dependencies: TStringList;
      constructor Create(const AFileName: String);
      destructor Destroy; override;
    end;

  var
    Units: TObjectDictionary<String, TUnit>;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var
  Current: String;
  Index: Integer;
begin
  Units := TObjectDictionary<String, TUnit>.Create([doOwnsValues]);
  if not FileOpenDialog1.Execute then
  begin
    Application.Terminate;
    Exit;
  end;
  for Current in TDirectory.GetFiles(FileOpenDialog1.FileName, '*.pas') do
  begin
    Units.Add(TPath.GetFileNameWithoutExtension(Current),
      TUnit.Create(Current));
  end;
  StringGrid1.ColCount := Units.Count;
  if Units.Count <> 0 then
  begin
    StringGrid1.Rows[0].AddStrings(Units.Keys.ToArray);
    for Index := 0 to Pred(StringGrid1.ColCount) do
    begin
      if StringGrid1.RowCount <= Units[StringGrid1.Cols[Index][0]].Dependencies.Count
      then
      begin
        StringGrid1.RowCount :=
          Succ(Units[StringGrid1.Cols[Index][0]].Dependencies.Count);
      end;
      StringGrid1.Cols[Index].AddStrings(Units[StringGrid1.Cols[Index][0]]
        .Dependencies);
    end;
  end;
end;

{ TForm1.TUnit }

constructor TForm1.TUnit.Create(const AFileName: String);

  function IsTerm(const AStr: PChar; const ATerm: String): Boolean;
  var
    Index: Integer;
  begin
    for Index := 0 to Pred(ATerm.Length) do
    begin
      if (AStr[Index] = #0) or
        (UpCase(AStr[Index]) <> UpCase(ATerm.Chars[Index])) then
      begin
        Exit(False);
      end;
    end;
    Result := AStr[Index] in [' ', #9, #10, #13];
  end;

  function GetTerm(var AStr: PChar): String;
  begin
    Initialize(Result);
    while AStr[0] in ['A' .. 'Z', 'a' .. 'z', '0' .. '9', '_', '.', ' ', #9,
      #10, #13] do
    begin
      if not(AStr[0] in [' ', #9, #10, #13]) then
      begin
        Result := Concat(Result, AStr[0]);
      end;
      Inc(AStr);
    end;
  end;

var
  Lines: TStringList;
  Current: PChar;
  Section: (sectUnknown, sectApplication, sectApplicationUses, sectUnit,
    sectUnitInterface, sectUnitInterfaceUses, sectUnitImplementation,
    sectUnitImplementationUses);
begin
  inherited Create;
  Dependencies := TStringList.Create;
  Lines := TStringList.Create;
  try
    Lines.LoadFromFile(AFileName);
    LineCount := Lines.Count;
    Current := PChar(Lines.Text);
    Section := sectUnknown;
    while Current[0] <> #0 do
    begin
      case Current[0] of
        '/':
          if Current[1] = '/' then
          begin
            Inc(Current, 2);
            while not((Current[0] = #13) and (Current[1] = #10)) do
            begin
              Inc(Current);
            end;
            Inc(Current, 2);
          end
          else
          begin
            Inc(Current);
          end;
        '(':
          if Current[1] = '*' then
          begin
            Inc(Current, 2);
            while not((Current[0] = '*') and (Current[1] = ')')) do
            begin
              Inc(Current);
            end;
            Inc(Current, 2);
          end
          else
          begin
            Inc(Current);
          end;
        '{':
          begin
            Inc(Current);
            while Current[0] <> '}' do
            begin
              Inc(Current);
            end;
            Inc(Current);
          end;
        '''':
          begin
            Inc(Current);
            while Current[0] <> '''' do
            begin
              Inc(Current);
            end;
            Inc(Current);
          end;
        'A' .. 'Z', 'a' .. 'z', '_':
          begin
            case Section of
              sectUnknown:
                if IsTerm(Current, 'application') then
                begin
                  Section := sectApplication;
                end
                else
                begin
                  if IsTerm(Current, 'unit') then
                  begin
                    Section := sectUnit;
                  end;
                end;
              sectApplication:
                if IsTerm(Current, 'uses') then
                begin
                  Section := sectApplicationUses;
                end;
              sectUnitInterface:
                if IsTerm(Current, 'uses') then
                begin
                  Section := sectUnitInterfaceUses;
                end
                else
                begin
                  if IsTerm(Current, 'implementation') then
                  begin
                    Section := sectUnitImplementation;
                  end;
                end;
              sectUnit:
                if IsTerm(Current, 'interface') then
                begin
                  Section := sectUnitInterface;
                end;
              sectUnitImplementation:
                if IsTerm(Current, 'uses') then
                begin
                  Section := sectUnitImplementationUses;
                end;
              // Here we only need unit interface uses clauses
              { sectApplicationUses, } sectUnitInterfaceUses { , }
              { sectUnitImplementationUses } :
                begin
                  Dependencies.Add(GetTerm(Current));
                  Continue;
                end;
            end;
            Inc(Current);
            while Current[0] in ['A' .. 'Z', 'a' .. 'z', '0' .. '9', '_'] do
            begin
              Inc(Current);
            end;
          end;
        '&':
          begin
            Inc(Current);
            while Current[0] in ['A' .. 'Z', 'a' .. 'z', '0' .. '9', '_'] do
            begin
              Inc(Current);
            end;
          end;
        '0' .. '9':
          begin
            Inc(Current);
            while Current[0] in ['E', 'e', '0' .. '9', '.'] do
            begin
              Inc(Current);
            end;
          end;
        '$':
          begin
            Inc(Current);
            while Current[0] in ['A' .. 'F', 'a' .. 'f', '0' .. '9'] do
            begin
              Inc(Current);
            end;
          end;
        '#':
          begin
            Inc(Current);
            while Current[0] in ['0' .. '9'] do
            begin
              Inc(Current);
            end;
          end;
        ' ', ')', '[', ']', '.', ',', ':', '=', '<', '>', '+', '-', '*', '@',
          '^', #9, #10, #13:
          begin
            Inc(Current);
          end;
        ';':
          begin
            case Section of
              sectApplicationUses:
                Section := sectApplication;
              sectUnitInterfaceUses:
                Section := sectUnitInterface;
              sectUnitImplementationUses:
                Section := sectUnitImplementation;
            end;
            Inc(Current);
          end;
      else
        begin
          raise Exception.CreateFmt('Invalid character: %s',
            [QuotedStr(Current[0])]);
        end;
      end;
    end;
  finally
    Lines.Free;
  end;
end;

destructor TForm1.TUnit.Destroy;
begin
  Dependencies.Free;
  inherited;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Units.Free;
end;

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);

  function FindDependency(const AUnit, ADependency: String;
    const ARecDepth: Integer): Boolean;
  var
    Current: String;
  begin
    if (ARecDepth <> 0) and Units.ContainsKey(AUnit) then
    begin
      Result := Units[AUnit].Dependencies.IndexOf(ADependency) <> -1;
      if not Result then
      begin
        for Current in Units[AUnit].Dependencies do
        begin
          if FindDependency(Current, ADependency, Pred(ARecDepth)) then
          begin
            Exit(True);
          end;
        end;
      end;
    end
    else
    begin
      Result := False;
    end;
  end;

begin
  StringGrid1.Canvas.Brush.Color := StringGrid1.Color;
  StringGrid1.Canvas.FillRect(Rect);
  StringGrid1.Canvas.Font := StringGrid1.Font;
  if ARow = 0 then
  begin
    StringGrid1.Canvas.Font.Style := [fsBold];
  end
  else
  begin
    if Units.ContainsKey(StringGrid1.Cells[ACol, ARow]) then
    begin
      if FindDependency(StringGrid1.Cells[ACol, ARow],
        StringGrid1.Cols[ACol][0], 1) then
      begin
        StringGrid1.Canvas.Brush.Color := clRed;
      end
      else
      begin
        StringGrid1.Canvas.Brush.Color := clGreen;
      end;
    end;
  end;
  StringGrid1.Canvas.TextRect(Rect, Rect.Left + 2, Rect.Top + 2,
    StringGrid1.Cells[ACol, ARow]);
  if StringGrid1.ColWidths[ACol] < StringGrid1.Canvas.TextWidth
    (StringGrid1.Cells[ACol, ARow]) + 8 then
  begin
    StringGrid1.ColWidths[ACol] := StringGrid1.Canvas.TextWidth
      (StringGrid1.Cells[ACol, ARow]) + 8;
  end;
end;

end.