dexed/src/u_makeproject.pas

unit u_makeproject;

{$I u_defines.inc}

interface

uses
  Classes, SysUtils, fpjson, jsonparser, jsonscanner, process, strutils,
  LazFileUtils, RegExpr, fgl, math,
  u_common, u_interfaces, u_observer, u_dialogs, u_processes,
  u_writableComponent, u_compilers, u_semver, u_stringrange;

type

TMakeProjectOptionsBase = class(TWritableLfmTextComponent)
strict private
  fNumThreads: integer;
  fSourceDirectories: TStringList;
  fExcludedSourceExtensions: TStringList;
  fQuiet: boolean;
  fKeepGoing: boolean;
  procedure setSourceDirectories(value: TStringList);
  procedure setExcludedSourceExtensions(value: TStringList);
published
  property keepGoing: boolean read fKeepGoing write fKeepGoing default false;
  property quiet: boolean read fQuiet write fQuiet default false;
  property numThreads: integer read fNumThreads write fNumThreads default 1;
  property sourceDirectories: TStringList read fSourceDirectories write setSourceDirectories;
  property excludedSourceExtensions: TStringList read fExcludedSourceExtensions write setExcludedSourceExtensions;
public
  constructor create(aOwner: TComponent); override;
  destructor destroy(); override;
  procedure assign(other: TPersistent); override;
end;

TMakeProjectOptions = class(TMakeProjectOptionsBase, IEditableOptions)
strict private
  fBackup: TMakeProjectOptionsBase;
  function optionedWantCategory(): string;
  function optionedWantEditorKind: TOptionEditorKind;
  function optionedWantContainer: TPersistent;
  procedure optionedEvent(event: TOptionEditorEvent);
  function optionedOptionsModified: boolean;
public
  constructor create(aOwner: TComponent); override;
  destructor destroy; override;
end;

TMakeProject = class(TComponent, ICommonProject)
private

  fProjectSubject: TProjectSubject;
  fRules: TStringList;
  fMsgs: IMessagesDisplay;
  fMakeProc: TDexedProcess;
  fAsProjectItf: ICommonProject;
  fBasePath: string;
  fFilename: string;
  fCompiled: boolean;
  fInGroup: boolean;
  fRuleIndex: integer;
  fSrcs: TStringList;

  procedure makeProcOutput(proc: TObject);
  procedure makeProcTerminated(proc: TObject);

public

  constructor create(aOwner: TComponent); override;
  destructor destroy; override;

  // indicates if the project is owned by a group.
  function inGroup: boolean;
  // flag the project as grouped
  procedure inGroup(value: boolean);
  // in a context of a group, activates the project
  procedure activate;
  // indicates the project format
  function getFormat: TProjectFormat;
  // returns an object that can be cast using the result of getFormat()
  function getProject: TObject;
  // returns the project filename
  function filename: string;
  // loads project from filename
  procedure loadFromFile(const fname: string);
  // saves project to filename
  procedure saveToFile(const fname: string);
  // reloads
  procedure reload;
  // indicates if the project is modified
  function modified: boolean;
  // returns the base dir used to solve relative paths
  function basePath: string;
  // returns the name of the file that's produced
  function outputFilename: string;
  // returns the kind of binary produced
  function binaryKind: TProjectBinaryKind;
  // returns the command line used to compile the project
  function getCommandLine: string;
  // stops compilation
  procedure stopCompilation;

// configs -----------------------------------------------------------------

  // returns the count of configuration (or config count * type count for pfDUB)
  function configurationCount: integer;
  // sets the active configuration
  procedure setActiveConfigurationIndex(index: integer);
  // returns the name of the nth configuration
  function configurationName(index: integer): string;
  // return the index of the active config
  function getActiveConfigurationIndex: integer;

// project sources ---------------------------------------------------------

  // returns the count of source files for the current config
  function sourcesCount: integer;
  // returns the source absolute filename.
  function sourceAbsolute(index: integer): string;
  // returns the source relative filename.
  function sourceRelative(index: integer): string;
  // returns true if aFilename is a project source.
  function isSource(const aFilename: string): boolean;
  // returns the count of import paths for the current config
  function importsPathCount: integer;
  // returns the import absolute path
  function importPath(index: integer): string;

// sub routines for the actions --------------------------------------------

  // tries to compile.
  procedure compile;
  //
  procedure checkSemantics;
  // indicates wether last complation was successful.
  function compiled: boolean;
  // tries to execute the project output.
  procedure run(const runArgs: string = '');
  // test the project (only for pfDUB)
  procedure test;
  // returns true if the target has not to be recompiled
  function targetUpToDate: boolean;
end;

implementation

var
  makeProjectOptions: TMakeProjectOptions;
const
  optFname = 'makeProjectsOptions.txt';

constructor TMakeProjectOptionsBase.create(aOwner: TComponent);
begin
  inherited create(aOwner);
  fNumThreads := 1;
  fSourceDirectories := TStringList.Create;
  fSourceDirectories.AddStrings(['src', 'import', 'include']);
  fExcludedSourceExtensions := TStringList.Create;
  fExcludedSourceExtensions.AddStrings(['.txt', '.md', '.gcov']);
end;

destructor TMakeProjectOptionsBase.destroy();
begin
  fSourceDirectories.Free;
  fExcludedSourceExtensions.Free;
  inherited;
end;

procedure TMakeProjectOptionsBase.setSourceDirectories(value: TStringList);
begin
  fSourceDirectories.Assign(value);
end;

procedure TMakeProjectOptionsBase.setExcludedSourceExtensions(value: TStringList);
begin
  fExcludedSourceExtensions.Assign(value);
end;

procedure TMakeProjectOptionsBase.assign(other: TPersistent);
var
  src: TMakeProjectOptionsBase;
begin
  if other is TMakeProjectOptionsBase then
  begin
    src := TMakeProjectOptionsBase(other);
    fSourceDirectories.Assign(src.sourceDirectories);
    fExcludedSourceExtensions.Assign(src.excludedSourceExtensions);
    fQuiet:= src.fQuiet;
    fKeepGoing:= src.fKeepGoing;
    fNumThreads:= src.fNumThreads;
  end
  else inherited;
end;

constructor TMakeProjectOptions.create(aOwner: TComponent);
var
  fname: string;
begin
  inherited;
  fBackup := TMakeProjectOptionsBase.Create(nil);
  EntitiesConnector.addObserver(self);
  fname := getDocPath + optFname;
  if fname.fileExists then
    loadFromFile(fname);
end;

destructor TMakeProjectOptions.destroy;
begin
  saveToFile(getDocPath + optFname);
  EntitiesConnector.removeObserver(self);
  fBackup.free;
  inherited;
end;

function TMakeProjectOptions.optionedWantCategory(): string;
begin
  exit('Makefile projects');
end;

function TMakeProjectOptions.optionedWantEditorKind: TOptionEditorKind;
begin
  exit(oekGeneric);
end;

function TMakeProjectOptions.optionedWantContainer: TPersistent;
begin
  fBackup.assign(self);
  exit(self);
end;

procedure TMakeProjectOptions.optionedEvent(event: TOptionEditorEvent);
begin
  case event of
    oeeAccept: fBackup.assign(self);
    oeeCancel: self.assign(fBackup);
    oeeSelectCat:fBackup.assign(self);
  end;
end;

function TMakeProjectOptions.optionedOptionsModified: boolean;
begin
  exit(false);
end;

constructor TMakeProject.create(aOwner: TComponent);
begin
  inherited create(aOwner);
  fRules := TStringList.Create;
  fSrcs := TStringList.Create;
  fProjectSubject := TProjectSubject.Create;
  fAsProjectItf := self as ICommonProject;
  fMsgs := getMessageDisplay;

  subjProjNew(fProjectSubject, self);
end;

destructor TMakeProject.destroy;
begin
  killProcess(fMakeProc);
  subjProjClosing(fProjectSubject, self);
  fProjectSubject.free;
  fRules.Free;
  fSrcs.Free;
  inherited;
end;

function TMakeProject.inGroup: boolean;
begin
  result := fInGroup;
end;

procedure TMakeProject.inGroup(value: boolean);
begin
  fInGroup := value;
end;

procedure TMakeProject.activate;
begin
  subjProjFocused(fProjectSubject, fAsProjectItf);
end;

function TMakeProject.getFormat: TProjectFormat;
begin
  result := pfMAKE;
end;

function TMakeProject.getProject: TObject;
begin
  result := self;
end;

function TMakeProject.filename: string;
begin
  result := fFilename;
end;

procedure TMakeProject.loadFromFile(const fname: string);
var
  lines: TStringList;
  srcs: TStringList;
  line0: string;
  line1: string;
  hidden: string = DirectorySeparator + '.';
  f: string;
  p: string;
  e: string;
  s: string;
  colPos: integer;
  i: integer;
  badExt: boolean;
begin
  fRules.Clear;
  fRules.add('default');
  fRuleIndex := 0;

  fFilename := fname;
  if not FilenameIsAbsolute(fFilename) then
    fFilename := ExpandFileName(fFilename);
  fBasePath := fFilename.extractFilePath;

  lines := TStringList.Create;
  try
    lines.LoadFromFile(fFilename);
    if lines.Count > 1 then
      for i := 0 to lines.Count-2 do
    begin
      line0 := lines[i];
      line1 := lines[i+1];
      colPos:= pos(':', line0);
      if line0.isBlank or line1.isBlank or (colPos < 2) then
        continue;
      if (line0.length > 1) and not (line0[1] in [' ', #9]) and
         (line1.length > 1) and (line1[1] in [' ', #9]) and not (line1[2] in [' ', #9]) then
        fRules.Add(line0[1..colPos-1]);
    end;
  finally
    lines.Free;
  end;

  fSrcs.Clear;
  fSrcs.Sorted:=false;
  srcs := TStringList.Create;
  try
    for p in makeProjectOptions.sourceDirectories do
    begin
      listFiles(srcs, fBasePath + p, true);
      for f in srcs do
      begin
        if pos(hidden, f) = 0 then
        begin
          badExt := false;
          s := f.extractFileExt();
          for e in makeProjectOptions.excludedSourceExtensions do
            if SameText(e, s) then
          begin
            badExt := true;
            break;
          end;
          if not badExt then
            fSrcs.Add(f[fBasePath.length + 1 .. f.length]);
        end;
      end;
      srcs.Clear;
    end;
  finally
    srcs.Free;
  end;
  fSrcs.Sorted:=true;

  subjProjChanged(fProjectSubject, self);

end;

procedure TMakeProject.saveToFile(const fname: string);
begin
end;

procedure TMakeProject.reload;
begin
  if fFilename.fileExists then
    loadFromFile(fFilename);
end;

function TMakeProject.modified: boolean;
begin
  result := false;
end;

function TMakeProject.basePath: string;
begin
  result := fBasePath;
end;

function TMakeProject.outputFilename: string;
begin
  result := '';
end;

function TMakeProject.binaryKind: TProjectBinaryKind;
begin
  result := TProjectBinaryKind.unknown;
end;

function TMakeProject.getCommandLine: string;
begin
  result := 'make ' + '-f' + fFilename;
  if not fRuleIndex.equals(0) then
    result += ' ' + fRules[fRuleIndex];
  if makeProjectOptions.keepGoing then
    result += ' -k';
  if makeProjectOptions.quiet then
    result += ' -q';
  if makeProjectOptions.numThreads > 1 then
    result += ' -j' + makeProjectOptions.numThreads.ToString();
end;

procedure TMakeProject.stopCompilation;
begin
  if fMakeProc.isAssigned and fMakeProc.Running then
    fMakeProc.Terminate(1);
end;

function TMakeProject.configurationCount: integer;
begin
  result := fRules.Count;
end;

procedure TMakeProject.setActiveConfigurationIndex(index: integer);
begin
  if fRuleIndex = index then
    exit;
  fRuleIndex := min(fRules.Count - 1, index);
  fRuleIndex := max(0, fRuleIndex);
  subjProjChanged(fProjectSubject, fAsProjectItf);
end;

function TMakeProject.configurationName(index: integer): string;
begin
  result := fRules[index];
end;

function TMakeProject.getActiveConfigurationIndex: integer;
begin
  result := fRuleIndex;
end;

function TMakeProject.sourcesCount: integer;
begin
  result := fSrcs.count;
end;

function TMakeProject.sourceAbsolute(index: integer): string;
var
  fname: string;
begin
  fname := fSrcs[index];
  if FilenameIsAbsolute(fname) then
    result := fname
  else
    result := expandFilenameEx(fBasePath, fname);
end;

function TMakeProject.sourceRelative(index: integer): string;
begin
  result := fSrcs[index];
end;

function TMakeProject.isSource(const aFilename: string): boolean;
var
  str: string;
begin
  str := fFilename.extractFileDir;
  result := aFilename.StartsWith(str);
end;

function TMakeProject.importsPathCount: integer;
begin
  result := 0;
end;

function TMakeProject.importPath(index: integer): string;
begin
  result := '';
end;

procedure TMakeProject.makeProcOutput(proc: TObject);
var
  lst: TStringList;
  str: string;
begin
  lst := TStringList.Create;
  try
    fMakeProc.getFullLines(lst);
    fMsgs.beginMessageCall();
    for str in lst do
      fMsgs.message(str, fAsProjectItf, amcProj, amkAuto);
    fMsgs.endMessageCall();
  finally
    lst.Free;
  end;
end;

procedure TMakeProject.makeProcTerminated(proc: TObject);
var
  n: string;
begin
  makeProcOutput(proc);
  n := shortenPath(filename);
  fCompiled := fMakeProc.ExitStatus = 0;
  if fCompiled then
  begin
    fMsgs.message(n + ' has been successfully compiled', fAsProjectItf, amcProj, amkInf);
  end
  else
  begin
    fMsgs.message(n + ' has not been successfully compiled', fAsProjectItf, amcProj, amkWarn);
    fMsgs.message(format('error: make has returned the status %s',
      [prettyReturnStatus(fMakeProc)]), fAsProjectItf, amcProj, amkErr);
    if fMakeProc.autoKilled then
      fMsgs.message(format('the process was autokilled because the size of its output exceeded %d',
        [fMakeProc.autoKillProcThreshold]), nil, amcProj, amkWarn);
  end;
  subjProjCompiled(fProjectSubject, fAsProjectItf, fCompiled);
end;

procedure TMakeProject.compile;
var
  p: string;
begin
  if fMakeProc.isAssigned and fMakeProc.Active then
  begin
    fMsgs.message('the project is already being compiled by make', fAsProjectItf, amcProj, amkWarn);
    exit;
  end;
  killProcess(fMakeProc);
  fCompiled := false;

  fMsgs.clearByData(fAsProjectItf);
  subjProjCompiling(fProjectSubject, fAsProjectItf);

  p := shortenPath(fFilename);
  fMakeProc := TDexedProcess.create(nil);
  fMakeProc.executable := 'make';

  fMakeProc.Parameters.AddStrings([ '-f', fFilename]);
  if not fRuleIndex.equals(0) then
      fMakeProc.Parameters.Add(fRules[fRuleIndex]);
  if makeProjectOptions.keepGoing then
    fMakeProc.Parameters.Add('-k');
  if makeProjectOptions.quiet then
    fMakeProc.Parameters.Add('-q');
  if makeProjectOptions.numThreads > 1 then
    fMakeProc.Parameters.Add('-j' + makeProjectOptions.numThreads.ToString());

  fMakeProc.Options := fMakeProc.Options + [poStderrToOutPut, poUsePipes];
  fMakeProc.ShowWindow := swoHIDE;
  fMakeProc.CurrentDirectory := fFilename.extractFilePath;
  fMakeProc.XTermProgram:=consoleProgram;
  fMakeProc.OnTerminate:= @makeProcTerminated;
  fMakeProc.OnReadData:= @makeProcOutput;
  fMsgs.message('compiling ' + p, fAsProjectItf, amcProj, amkInf);
  fMakeProc.execute;
end;

procedure TMakeProject.checkSemantics;
begin
end;

function TMakeProject.compiled: boolean;
begin
  result := fCompiled;
end;

procedure TMakeProject.run(const runArgs: string = '');
begin
end;

procedure TMakeProject.test;
begin
end;

function TMakeProject.targetUpToDate: boolean;
begin
  result := false;
end;

initialization
  makeProjectOptions:= TMakeProjectOptions.create(nil);
finalization
  makeProjectOptions.free;
end.