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;
  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;
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.