UDmMain.pas

unit UDmMain;

interface

uses
  System.SysUtils,
  System.Classes,
  System.IOUtils,
  System.Generics.Collections;

type
  TUnite = class
  private
    FUName: string;
    FFileUnitName: string;
    FInitializationSection: string;
    FTypeSection: string;
    FImplementationSection: string;
    FUsesIntfSection: string;
    FHeaderSection: string;
    FFinalizationSection: string;
    FUsesImpSection: string;

    procedure SetFileUnitName( const Value: string );
    procedure SetHeaderSection( const Value: string );
    procedure SetImplementationSection( const Value: string );
    procedure SetInitializationSection( const Value: string );
    procedure SetTypeSection( const Value: string );
    procedure SetUName( const Value: string );
    procedure SetUsesIntfSection( const Value: string );
    procedure SetFinalizationSection( const Value: string );
    procedure SetUsesImpSection( const Value: string );
  public
    constructor Create;
    procedure WriteUnit;

    property FileUnitName: string read FFileUnitName write SetFileUnitName;
    property UName: string read FUName write SetUName;
    property HeaderSection: string read FHeaderSection write SetHeaderSection;
    property UsesIntfSection: string read FUsesIntfSection write SetUsesIntfSection;
    property TypeSection: string read FTypeSection write SetTypeSection;
    property UsesImpSection: string read FUsesImpSection write SetUsesImpSection;
    property ImplementationSection: string read FImplementationSection write SetImplementationSection;
    property InitializationSection: string read FInitializationSection write SetInitializationSection;
    property FinalizationSection: string read FFinalizationSection write SetFinalizationSection;
  end;

  TDmMain = class( TDataModule )
  private
    { Déclarations privées }
    FFolderOutput: string;
    FUnitComments: string;
    FUsesIntf: string;
    FUses: string;
    FFile: TArray< string >;
    FLinePos: Integer;
    FUnites: TObjectDictionary< string, TUnite >;

    function GetUnitComments: string;
    function GetUsesIntf: string;
    function GetUses: string;
    function IsClassDef( aLine: string; out aDeclare: boolean ): boolean;
    function WordInLine( aWord, aLine: string ): boolean;
    function IsLineComments( aLine: string ): boolean;

    procedure GetListeClass;
    procedure GetImplementation;
    procedure AddUses( aUsesIntf, aUsesImpl, aLine: string );
    procedure WriteUnits;
  public
    { Déclarations publiques }
    procedure Execute( ASource, AOutput: string );
    // procedure Execute1( ASource, AOutput: string );
  end;

var
  DmMain: TDmMain;

implementation

{%CLASSGROUP 'System.Classes.TPersistent'}


uses UConsts;

{$R *.dfm}

{ TDmMain }

procedure TDmMain.AddUses( aUsesIntf, aUsesImpl, aLine: string );
var
  LPos: Integer;
  LType: string;
begin
  LPos := Pos( ':', aLine );
  if ( LPos > 0 ) then
  begin
    LType := Copy( aLine, LPos + 1, Pos( ';', aLine, LPos + 1 ) - LPos - 1 ).Trim;

    if FUnites.ContainsKey( LType ) and not( WordInLine( LType, aUsesIntf ) ) and not( WordInLine( LType, aUsesImpl ) ) then
    begin
      aUsesImpl := aUsesImpl + ', ' + LType;
    end;
  end;
end;

procedure TDmMain.Execute( ASource, AOutput: string );
begin
  if FileExists( ASource ) then
  begin
    ForceDirectories( AOutput );
    FFolderOutput := AOutput;

    FFile := TFile.ReadAllLines( ASource );

    FUnitComments := GetUnitComments;
    FUsesIntf := GetUsesIntf;
    FUses := GetUses;
    GetListeClass;
    GetImplementation;

    WriteUnits;

    FreeAndNil( FUnites );
    SetLength( FFile, 0 );
  end
  else
  begin
    Writeln( 'Source inexistante : ' + ASource );
  end;
end;

procedure TDmMain.GetImplementation;
var
  LLine, LNbBlock: Integer;
  LUses: string;
  LClass: string;
  LPosD, LPosF: SmallInt;
  LUnite: TUnite;
  LAdd: boolean;
begin
  LUses := '';
  LLine := FLinePos;
  while ( LLine <= High( FFile ) ) do
  begin
    // Writeln(LLine);

    if ( LLine < High( FFile ) ) and ( WordInLine( 'uses', FFile[ LLine + 1 ].ToLower ) ) and not( IsLineComments( FFile[ LLine + 1 ] ) ) then
    begin
      repeat
        Inc( LLine );
        if not( IsLineComments( FFile[ LLine ] ) ) then
        begin
          LUses := LUses + FFile[ LLine ];
        end;
      until ( Pos( ';', FFile[ LLine ] ) >= 0 );

      LUses := Copy( LUses, 1, Pos( ';', LUses ) + 1 ) + END_LINE;

      Inc( LLine );
    end;

    if ( ( Pos( 'function', FFile[ LLine ].Trim.ToLower ) > 0 )
      or ( Pos( 'procedure', FFile[ LLine ].Trim.ToLower ) > 0 )
      or ( Pos( 'constructor', FFile[ LLine ].Trim.ToLower ) > 0 )
      or ( Pos( 'destructor', FFile[ LLine ].Trim.ToLower ) > 0 ) )
      and ( Pos( '.', FFile[ LLine ] ) > 0 )
      and not( IsLineComments( FFile[ LLine ] ) ) then
    begin
      LPosD := Pos( ' ', FFile[ LLine ] );
      LPosF := Pos( '.', FFile[ LLine ] );
      LClass := Copy( FFile[ LLine ], LPosD + 1, LPosF - LPosD - 1 );

      if FUnites.TryGetValue( LClass, LUnite ) then
      begin
        LUnite.UsesImpSection := 'implementataion' + END_LINE + LUses + END_LINE;

        LUnite.ImplementationSection := LUnite.ImplementationSection + FFile[ LLine ] + END_LINE;

        AddUses( LUnite.UsesIntfSection, LUses, FFile[ LLine ] );

        LAdd := False;

        while not( WordInLine( 'begin', FFile[ LLine ].ToLower ) ) do
        begin
          Inc( LLine );
          LAdd := True;
        end;

        if LAdd then
        begin
          AddUses( LUnite.UsesIntfSection, LUses, FFile[ LLine ] );
          LUnite.ImplementationSection := LUnite.ImplementationSection + FFile[ LLine ] + END_LINE;
        end;

        LNbBlock := 1;

        while ( LLine <= High( FFile ) ) and ( LNbBlock > 0 ) do
        begin
          Inc( LLine );

          AddUses( LUnite.UsesIntfSection, LUses, FFile[ LLine ] );

          LUnite.ImplementationSection := LUnite.ImplementationSection + FFile[ LLine ] + END_LINE;

          if ( WordInLine( 'begin', FFile[ LLine ].ToLower ) )
            or ( WordInLine( 'case', FFile[ LLine ].ToLower ) )
            or ( WordInLine( 'try', FFile[ LLine ].ToLower ) ) then
          begin
            Inc( LNbBlock );
          end
          else if ( WordInLine( 'end;', FFile[ LLine ].ToLower ) ) then
          begin
            Dec( LNbBlock );
          end;
        end;

        LUnite.ImplementationSection := LUnite.ImplementationSection + END_LINE;

        Inc( LLine );
      end
      else
      begin
        Inc( LLine );
      end;
    end
    else
    begin
      Inc( LLine );
    end;
  end;
end;

procedure TDmMain.GetListeClass;
var
  LClassName: string;
  LInherit: string;
  LFileName: string;
  LUnite: TUnite;
  LDeclare: boolean;
  LLine, LPos: Integer;
  LType: string;
begin
  FUnites := TObjectDictionary< string, TUnite >.Create;

  LLine := FLinePos;
  while ( LLine <= High( FFile ) ) and ( FFile[ LLine ].Trim.ToLower <> 'implementation' ) do
  begin
    if not( IsLineComments( FFile[ LLine ] ) ) and ( IsClassDef( FFile[ LLine ].ToLower, LDeclare ) ) then
    begin
      LClassName := Copy( FFile[ LLine ], 1, Pos( '=', FFile[ LLine ] ) - 1 ).Trim;

      LPos := Pos( '(', FFile[ LLine ] );

      if ( LPos > 0 ) then
      begin
        LInherit := Copy( FFile[ LLine ], LPos + 1, Pos( ')', FFile[ LLine ], LPos ) - LPos - 1 );
        if FUnites.ContainsKey( LInherit ) and not( WordInLine( LInherit, LUnite.UsesIntfSection ) ) then
        begin
          LUnite.UsesIntfSection := LUnite.UsesIntfSection + ', ' + LInherit;
        end;
      end;

      LFileName := TPath.Combine( FFolderOutput, 'U' + LClassName + '.pas' );

      if not( FUnites.TryGetValue( LClassName, LUnite ) ) then
      begin
        try
          LUnite := TUnite.Create;
          LUnite.FileUnitName := LFileName;
          LUnite.UName := 'U' + LClassName;
          LUnite.HeaderSection := FUnitComments + END_LINE +
            'unit ' + LUnite.UName + ';' + END_LINE;

          LUnite.UsesIntfSection := FUsesIntf + END_LINE + FUses;

          LUnite.TypeSection := FFile[ LLine ] + END_LINE;

          FUnites.Add( LClassName, LUnite );
        except
          on e: exception do
          begin
            Writeln( LFileName );
          end;
        end;
      end
      else
      begin
        LUnite.TypeSection := LUnite.TypeSection + FFile[ LLine ] + END_LINE;
      end;

      if not( LDeclare ) then
      begin
        Inc( LLine );

        while ( LLine <= High( FFile ) ) and ( FFile[ LLine ].Trim <> 'end;' ) do
        begin
          LUnite.TypeSection := LUnite.TypeSection + FFile[ LLine ] + END_LINE;

          LPos := Pos( ':', FFile[ LLine ] );
          if ( LPos > 0 ) then
          begin
            LType := Copy( FFile[ LLine ], LPos + 1, Pos( ';', FFile[ LLine ], LPos + 1 ) - LPos - 1 ).Trim;

            if FUnites.ContainsKey( LType ) and not( WordInLine( LType, LUnite.UsesIntfSection ) ) then
            begin
              LUnite.UsesIntfSection := LUnite.UsesIntfSection + ', ' + LType;
            end;
          end;

          Inc( LLine );
        end;

        LUnite.TypeSection := LUnite.TypeSection + FFile[ LLine ] + END_LINE;
      end;
    end;

    Inc( LLine );
  end;

  FLinePos := LLine;
end;

// procedure TDmMain.Execute1( ASource, AOutput: string );
// var
// LFileStream: TFileStream;
// LStreamReader: TStreamReader;
// LLine: string;
// begin
// if FileExists( ASource ) then
// begin
// LFileStream := TFileStream.Create( ASource, fmOpenRead or fmShareDenyWrite );
// try
// LStreamReader := TStreamReader.Create( LFileStream, TEncoding.UTF8, True );
// try
// while not LStreamReader.EndOfStream do
// begin
// LLine := LStreamReader.ReadLine;
// Writeln( LLine );
// end;
// finally
// LStreamReader.Free;
// end;
// finally
// LFileStream.Free;
// end;
// end
// else
// begin
// Writeln( 'Source inexistante : ' + ASource );
// end;
// end;

function TDmMain.GetUnitComments: string;
begin
  Result := '';
  for var i := 0 to High( FFile ) do
  begin
    if ( Pos( 'unit', FFile[ i ].ToLower ) > 0 ) then
    begin
      FLinePos := i;

      Exit;
    end;

    Result := Result + FFile[ i ] + END_LINE;
  end;
end;

function TDmMain.GetUses: string;
begin
  Result := Copy( FFile[ FLinePos ].Trim, 5, Length( FFile[ FLinePos ] ) ).Trim;

  if ( Result[ Length( Result ) ] = ';' ) then
  begin
    Result := Copy( Result, 1, Length( Result ) - 1 );
    Inc( FLinePos );
  end
  else
  begin
    for var i := FLinePos + 1 to High( FFile ) do
    begin
      if not( IsLineComments( FFile[ i ] ) ) and ( Pos( ';', FFile[ i ] ) > 0 ) then
      begin
        Result := Result + Copy( FFile[ i ], 1, Length( FFile[ i ] ) - 1 );
        FLinePos := i + 1;
        Exit
      end
      else
      begin
        Result := Result + FFile[ i ];
      end;
    end;
  end;
end;

function TDmMain.GetUsesIntf: string;
begin
  Result := '';

  for var i := FLinePos + 1 to High( FFile ) do
  begin
    if WordInLine( 'uses', FFile[ i ] ) then
    begin
      Result := Result + 'uses' + END_LINE;
      FLinePos := i;

      Exit;
    end;

    Result := Result + FFile[ i ] + END_LINE;
  end;
end;


function TDmMain.IsClassDef( aLine: string; out aDeclare: boolean ): boolean;

var
  LPos: SmallInt;
begin
  Result := False;
  aDeclare := False;

  LPos := Pos( 'class', aLine );
  if ( LPos > 0 ) then
  begin
    if aLine[ LPos - 1 ] <> '=' then
    begin
      if aLine[ LPos - 1 ] = ' ' then
      begin
        if CharInSet( aLine[ LPos + 5 ], [ ';', ' ', '(', #$A, #$D ] ) then
        begin
          Result := True;

          aDeclare := ( aLine[ LPos + 5 ] = ';' );
        end;
      end;
    end
    else
    begin
      Result := True;
    end;
  end;
end;

function TDmMain.IsLineComments( aLine: string ): boolean;
var
  wComment: string;
  wPos: SmallInt;
begin
  Result := False;

  wPos := Pos( '//', aLine );

  if ( wPos > 0 ) then
  begin
    Result := ( Copy( aLine, 1, wPos + 1 ).Trim = '//' );
  end;
end;

function TDmMain.WordInLine( aWord, aLine: string ): boolean;
begin
  Result := False;

  if ( Pos( aWord + ' ', aLine ) = 1 )
    or ( Pos( ' ' + aWord + ' ', aLine ) > 0 )
    or ( Pos( ' ' + aWord + ',', aLine ) > 0 )
    or ( Pos( ',' + aWord + ',', aLine ) > 0 )
    or ( ( Pos( ' ' + aWord, aLine ) > 0 ) and ( Pos( ' ' + aWord, aLine ) + Length( aWord ) >= Length( aLine ) ) )
    or ( ( Pos( aWord, aLine ) = 1 ) and ( Pos( aWord, aLine ) + Length( aWord ) >= Length( aLine ) ) ) then
  begin
    Result := True;
  end;
end;

procedure TDmMain.WriteUnits;
var
  LPair: TPair< string, TUnite >;
begin
  for LPair in FUnites do
  begin
    LPair.Value.WriteUnit;
    LPair.Value.Free;
  end;
end;

{ TUnite }

constructor TUnite.Create;
begin
  FHeaderSection := '';
  FUsesIntfSection := '';
  FTypeSection := '';
  FUsesImpSection := '';
  FImplementationSection := '';
  FInitializationSection := '';
  FFinalizationSection := '';
end;

procedure TUnite.SetFileUnitName( const Value: string );
begin
  FFileUnitName := Value;
end;

procedure TUnite.SetFinalizationSection( const Value: string );
begin
  FFinalizationSection := Value;
end;

procedure TUnite.SetHeaderSection( const Value: string );
begin
  FHeaderSection := Value;
end;

procedure TUnite.SetImplementationSection( const Value: string );
begin
  FImplementationSection := Value;
end;

procedure TUnite.SetInitializationSection( const Value: string );
begin
  FInitializationSection := Value;
end;

procedure TUnite.SetTypeSection( const Value: string );
begin
  FTypeSection := Value;
end;

procedure TUnite.SetUName( const Value: string );
begin
  FUName := Value;
end;

procedure TUnite.SetUsesImpSection( const Value: string );
begin
  FUsesImpSection := Value;
end;

procedure TUnite.SetUsesIntfSection( const Value: string );
begin
  FUsesIntfSection := Value;
end;

procedure TUnite.WriteUnit;
var
  F: TextFile;
begin
  AssignFile( F, FFileUnitName );
  Rewrite( F );

  Writeln( F, FHeaderSection );
  Writeln( F, FUsesIntfSection + ';' );
  Writeln( F, '' );
  Writeln( F, FTypeSection + END_LINE );
  Writeln( F, FUsesImpSection );
  Writeln( F, FImplementationSection );
  Writeln( F, FInitializationSection );
  Writeln( F, FFinalizationSection );
  Writeln( F, '' );
  Writeln( F, 'end.' );

  CloseFile( F );
end;

end.