////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2026 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// This unit provides wrap classes to embed Delphi Dcc32 compiler into your   //
// application and to create plugin DLLs, which can expand application        //
// features.                                                                  //
// Uses source: Сергей Гурин, <gurin@mail.tomsknet.ru>,                       //
//              http://www.tomsk.net/2q/gurin/index.html                      //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20030129 - Creation, uses ideas by CRW16 and by Gurin Sergey, tested       //
// 20030215 - Inserted in main CRW32, tested                                  //
// 20030330 - Struggle for safety (add some try/except checks)...             //
// 20040725 - TDcc32Wrapper.Compile: 1)Now can compile *.exe, not only *.dll  //
//            2) CloseHandle(ProcessInfo.hProcess) to avoide handle leakage.  //
// 20231109 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_dcc32; // Delphi

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

{$WARN 5023 off : Unit "$1" not used in $2}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math,
 _crw_alloc, _crw_fpu, _crw_ef, _crw_str, _crw_fio, _crw_proc, _crw_rtc,
 _crw_apptools, _crw_crwapi, _crw_plugin_wrapper;

 ///////////////////////////////////////////////////////////////////////////////
 // Delphi 32-bit command line compiler constants.                            //
 // Conventions:                                                              //
 // 1) Always set dcc32.exe directory as current to compile any project       //
 // 2) dcc32.exe,rlink32.dll & etc placed in ..\bin directory                 //
 // 3) System *.dcu library placed in ..\lib directory                        //
 // 4) Compiled *.dll always send to ..\exe directory.                        //
 //    Compiled *.dcu always send to ..\tmp directory.                        //
 //    Copy/move file(s) to another place if uses another target directory.   //
 // 5) Projects always compiles with BUILD option.                            //
 // 6) Always check compiler integrity before compilation                     //
 ///////////////////////////////////////////////////////////////////////////////
const
 Dcc32ExeName  = 'dcc32.exe';
 Dcc32CfgName  = 'dcc32.cfg';
 Dcc32BinDir   = '..\bin';
 Dcc32BinList  = 'dcc32.exe'    +EOL+
                 'rlink32.dll'  +EOL+
                 'borlndmm.dll' +EOL+
                 'delphimm.dll' +EOL+
                 'dcc32.cfg';
 Dcc32LibDir   = '..\lib';
 Dcc32LibList  = 'activex.dcu'  +EOL+
                 'actnlist.dcu' +EOL+
                 'buttons.dcu'  +EOL+
                 'buttons.res'  +EOL+
                 'checklst.dcu' +EOL+
                 'classes.dcu'  +EOL+
                 'clipbrd.dcu'  +EOL+
                 'colorgrd.dcu' +EOL+
                 'comconst.dcu' +EOL+
                 'comctrls.dcu' +EOL+
                 'commctrl.dcu' +EOL+
                 'commdlg.dcu'  +EOL+
                 'comobj.dcu'   +EOL+
                 'comserv.dcu'  +EOL+
                 'comstrs.dcu'  +EOL+
                 'consts.dcu'   +EOL+
                 'contnrs.dcu'  +EOL+
                 'controls.dcu' +EOL+
                 'controls.res' +EOL+
                 'dialogs.dcu'  +EOL+
                 'dlgs.dcu'     +EOL+
                 'extctrls.dcu' +EOL+
                 'flatsb.dcu'   +EOL+
                 'forms.dcu'    +EOL+
                 'graphics.dcu' +EOL+
                 'grids.dcu'    +EOL+
                 'imglist.dcu'  +EOL+
                 'imm.dcu'      +EOL+
                 'inifiles.dcu' +EOL+
                 'jconsts.dcu'  +EOL+
                 'jpeg.dcu'     +EOL+
                 'mask.dcu'     +EOL+
                 'math.dcu'     +EOL+
                 'menus.dcu'    +EOL+
                 'messages.dcu' +EOL+
                 'mmsystem.dcu' +EOL+
                 'multimon.dcu' +EOL+
                 'printers.dcu' +EOL+
                 'psapi.dcu'    +EOL+
                 'registry.dcu' +EOL+
                 'regstr.dcu'   +EOL+
                 'richedit.dcu' +EOL+
                 'sharemem.dcu' +EOL+
                 'shellapi.dcu' +EOL+
                 'shlobj.dcu'   +EOL+
                 'spin.dcu'     +EOL+
                 'spin.res'     +EOL+
                 'stdactns.dcu' +EOL+
                 'stdctrls.dcu' +EOL+
                 'sysconst.dcu' +EOL+
                 'sysinit.dcu'  +EOL+
                 'system.dcu'   +EOL+
                 'sysutils.dcu' +EOL+
                 'tabnotbk.dcu' +EOL+
                 'tlhelp32.dcu' +EOL+
                 'toolwin.dcu'  +EOL+
                 'typinfo.dcu'  +EOL+
                 'urlmon.dcu'   +EOL+
                 'windows.dcu'  +EOL+
                 'wininet.dcu'  +EOL+
                 'winsock.dcu'  +EOL+
                 'winspool.dcu' +EOL+
                 'winsvc.dcu';
 Dcc32ExeDir   = '..\exe';
 Dcc32TmpDir   = '..\tmp';
 Dcc32DefOpt   = '-B -E"..\exe" -N"..\tmp"';

 ///////////////////////////////////////////////////////////////////////////////
 // TDcc32Wrapper provides access to Dcc32.exe command line compiler to use   //
 // this compiler as embeded in your applications.                            //
 // Dcc32 files (about 2MB min) must present in some program subdirectories,  //
 // for example, dcc\bin (binary files), dcc\lib (system *.dcu library).      //
 // Create(aDcc32Dir)           Creates Dcc32 wrapper. If aDcc32Dir empty,    //
 //                             search Dcc32 in program subdirectories.       //
 // BinDir                      Full path of ..\bin subdirectory              //
 // LibDir                      Full path of ..\lib subdirectory              //
 // ExeDir                      Full path of ..\exe subdirectory              //
 // TmpDir                      Full path of ..\tmp subdirectory              //
 // Config                      If this text not empty, if will be written to //
 //                             Dcc32.cfg file before compile project.        //
 // StdOut                      After compilation this text contains hooked   //
 //                             compiler messages.                            //
 // Hints                       After compilation this text contains hooked   //
 //                             compiler hints.                               //
 // Warnings                    After compilation this text contains hooked   //
 //                             compiler warnings.                            //
 // Errors                      After compilation this text contains hooked   //
 //                             compiler errors.                              //
 // Fatals                      After compilation this text contains hooked   //
 //                             compiler fatals.                              //
 // CmdLineOptions              Dcc32 command line options                    //
 // RemedyCmd                   Command line to remedy Dcc32 if one damaged.  //
 //                             For example, to remedy from archive:          //
 //                             Resource\Remedy\Dcc32Bin.cmd Resource\Dcc32\  //
 // CanCompile(aProject)        Check compiler integrity & project existance  //
 // TryRemedy(aProject)         Try remedy compiler if one was damaged.       //
 //                             Use RemedyCmd command to remedy, for example  //
 //                             Resource\Remedy\Dcc32Bin.cmd Resource\Dcc32\  //
 // Compile(Proj,Dir,Ext)       Compile project file Proj. If Dir <> '', move //
 //                             compiled file Proj.Ext from ..\exe directoty  //
 //                             to Dir.                                       //
 // What compile method doing:                                                //
 // Before compile, set current directory to ..\bin and writes Config text to //
 // Dcc32.cfg. Compile always to ..\exe, send *.dcu to ..\tmp. Redirect Dcc32 //
 // output to temporary file and read this one after compilation. Then parse  //
 // hooked Dcc32 messages to Hints, Warnings, Errors, Fatals. For details use //
 // ParseDcc32Message function. Then, if destination directory specified,     //
 // move compiled file to this one.                                           //
 ///////////////////////////////////////////////////////////////////////////////
type
 EDcc32Failure = class(EEchoException);
 TDcc32Wrapper = class(TMasterObject)
 private
  myDcc32Dir : LongString;
  myConfig   : TText;
  myStdOut   : TText;
  myHints    : TText;
  myWarnings : TText;
  myErrors   : TText;
  myFatals   : TText;
  myTmpCfg   : TText;
  myCmdOpt   : LongString;
  myRemedy   : LongString;
  function    GetBinDir     : LongString;
  function    GetLibDir     : LongString;
  function    GetExeDir     : LongString;
  function    GetTmpDir     : LongString;
  function    GetConfig     : TText;
  function    GetStdOut     : TText;
  function    GetHints      : TText;
  function    GetWarnings   : TText;
  function    GetErrors     : TText;
  function    GetFatals     : TText;
  function    TmpCfg        : TText;
  function    GetCmdLineOpt:LongString;
  procedure   SetCmdLineOpt(const aOpt:LongString);
  function    GetRemedyCmd:LongString;
  procedure   SetRemedyCmd(const aRemedy:LongString);
 protected
  procedure   ErrorFound(E:Exception; const Note:LongString=''); override;
 public
  constructor Create(const aDcc32Dir:LongString='');
  destructor  Destroy; override;
  property    BinDir         : LongString  read GetBinDir;
  property    LibDir         : LongString  read GetLibDir;
  property    ExeDir         : LongString  read GetExeDir;
  property    TmpDir         : LongString  read GetTmpDir;
  property    Config         : TText       read GetConfig;
  property    StdOut         : TText       read GetStdOut;
  property    Hints          : TText       read GetHints;
  property    Warnings       : TText       read GetWarnings;
  property    Errors         : TText       read GetErrors;
  property    Fatals         : TText       read GetFatals;
  property    CmdLineOptions : LongString  read GetCmdLineOpt write SetCmdLineOpt;
  property    RemedyCmd      : LongString  read GetRemedyCmd  write SetRemedyCmd;
  function    CanCompile(aProject:LongString=''):Boolean;
  function    TryRemedy(const aProject:LongString=''):Boolean;
  function    Compile(const aProject:LongString;
                      const aDestDir:LongString=''):Boolean;
 end;

function  NewDcc32Wrapper(const aDcc32Dir:LongString=''):TDcc32Wrapper;
procedure Kill(var TheObject:TDcc32Wrapper); overload;

 ///////////////////////////////////////////////////////////////////////////////
 // []                                                                        //
 // ;************************************************************             //
 // ;*** Delphi command line compiler settings                ***             //
 // ;*** Dcc32BinDir = Directory where dcc32.exe placed       ***             //
 // ;*** Dcc32CfgSec = Section where dcc32.cfg file saved     ***             //
 // ;*** Dcc32CmdOpt = Default dcc32.exe command line options ***             //
 // ;*** Dcc32Remedy = Command to remedy damaged Dcc32        ***             //
 // ;************************************************************             //
 // [Dcc32.Exe]                                                               //
 // Dcc32BinDir = Resource\Dcc32\Bin                                          //
 // Dcc32CfgSec = Dcc32.Cfg                                                   //
 // Dcc32CmdOpt = -B -E"..\exe" -N"..\tmp"                                    //
 // Dcc32Remedy = Resource\Remedy\Dcc32Bin.cmd Resource\Dcc32\                //
 // []                                                                        //
 // ;************************************************************             //
 // ;*** This section contains dcc32.cfg - options for Dcc32  ***             //
 // ;************************************************************             //
 // [Dcc32.Cfg]                                                               //
 // -$A+ -$B- -$C+ -$D+ -$E- -$F- -$G+ -$H+ -$I+ -$J+ -$K- -$L+ -$M- -$N+     //
 // -$O+ -$P+ -$Q- -$R- -$S- -$T- -$U- -$V+ -$W- -$X+ -$YD -$Z1               //
 // -AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;//
 // -B -H+ -W+ -GP -cg -$M16384,1048576 -K$00400000                           //
 // -E"..\exe"                                                                //
 // -N"..\tmp"                                                                //
 // -I"..\lib;..\syslib"                                                      //
 // -R"..\lib;..\syslib"                                                      //
 // -O"..\lib;..\syslib"                                                      //
 // -U"..\lib;..\syslib" }                                                    //
 ///////////////////////////////////////////////////////////////////////////////
function  NewDcc32WrapperFromIniFile:TDcc32Wrapper;

 ///////////////////////////////////////////////////////////////////////////////
 // Use Dcc32 function to compile your projects easy.                         //
 // Dcc32 automatically creates TDcc32Wrapper object if one does not exists,  //
 // so you should not declare any variables. Created object will be destroyed //
 // on program exit. You also may Dcc32.Free if you don't need Dcc32 any more.//
 // Example:                                                                  //
 //  Dcc32.Compile('plugin1.dpr');  // Create Dcc32Wrapper and compile        //
 //  Dcc32.Free;                    // Destroy wrapper                        //
 //  ...                                                                      //
 //  Dcc32.Compile('plugin2.dpr');  // Create wrapper again and compile       //
 ///////////////////////////////////////////////////////////////////////////////
function  Dcc32:TDcc32Wrapper;

 ///////////////////////////////////////////////////////////////////////////////
 // Use ParseDcc32Message function to parse Dcc32.exe output hints, warnings, //
 // errors and fatals. For example:                                           //
 //  Dcc32.Compile('proj.dpr');                                               //
 //  for i:=0 to Dcc32.Hints.Count-1 do                                       //
 //  with ParseDcc32Message(Dcc32.Hints[i]) do                                //
 //  writeln('Hint File:',FileName,' Line:',LineNum,' Token:',Token);         //
 ///////////////////////////////////////////////////////////////////////////////
type
 TParseDcc32Message = packed record
  Status   : (cmsNone, cmsHint, cmsWarning, cmsError, cmsFatal);
  FileName : PureString;
  LineNum  : Integer;
  Token    : PureString;
 end;

function ParseDcc32Message(const aMessage:LongString):TParseDcc32Message;

function SafeCompileDelphiProject(const aProject:LongString):Boolean;

implementation

 //////////////////////////////////
 // TDcc32Wrapper implementation //
 //////////////////////////////////
procedure CheckDcc32Dir(const FileName:LongString; const FileDetails:TSearchRec;
                              SubDirLevel:Integer; var Terminate:Boolean;
                              CustomData:Pointer);
begin
 if not HasFlags(FileDetails.Attr,faDirectory) then
 if IsSameFileName(ExtractFileNameExt(FileName),Dcc32ExeName) then begin
  StrPLCopy(PChar(CustomData),DropBackSlash(ExtractFilePath(FileName)),255);
  Terminate:=true;
 end;
end;

procedure FindDcc32Dir(var aDcc32Dir:LongString);
var Buf:TParsingBuffer;
begin
 aDcc32Dir:='';
 try
  SafeFillChar(Buf,SizeOf(Buf),0);
  ForEachFile(HomeDir,Dcc32ExeName,CheckDcc32Dir,5,@Buf);
  aDcc32Dir:=StrPas(Buf);
 except
  on E:Exception do BugReport(E,nil,'FindDcc32Dir');
 end;
end;

constructor TDcc32Wrapper.Create(const aDcc32Dir:LongString='');
begin
 inherited Create;
 myDcc32Dir:=DropBackSlash(Trim(aDcc32Dir));
 if IsEmptyStr(myDcc32Dir) then FindDcc32Dir(myDcc32Dir);
 myConfig:=NewText;
 myConfig.Master:=@myConfig;
 myStdOut:=NewText;
 myStdOut.Master:=@myStdOut;
 myHints:=NewText;
 myHints.Master:=@myHints;
 myWarnings:=NewText;
 myWarnings.Master:=@myWarnings;
 myErrors:=NewText;
 myErrors.Master:=@myErrors;
 myFatals:=NewText;
 myFatals.Master:=@myFatals;
 myTmpCfg:=NewText;
 myTmpCfg.Master:=@myTmpCfg;
 myCmdOpt:=Dcc32DefOpt;
 myRemedy:='';
 Exceptions:=false;
 ErrorReportProc:=DefaultObjectErrorReportProc;
end;

destructor  TDcc32Wrapper.Destroy;
begin
 myDcc32Dir:='';
 myCmdOpt:='';
 myRemedy:='';
 Kill(myConfig);
 Kill(myStdOut);
 Kill(myHints);
 Kill(myWarnings);
 Kill(myErrors);
 Kill(myFatals);
 Kill(myTmpCfg);
 inherited Destroy;
end;

function TDcc32Wrapper.GetBinDir:LongString;
begin
 if Assigned(Self)
 then Result:=FExpand(AddPathDelim(myDcc32Dir)+Dcc32BinDir)
 else Result:='';
end;

function TDcc32Wrapper.GetLibDir:LongString;
begin
 if Assigned(Self)
 then Result:=FExpand(AddPathDelim(myDcc32Dir)+Dcc32LibDir)
 else Result:='';
end;

function TDcc32Wrapper.GetExeDir:LongString;
begin
 if Assigned(Self)
 then Result:=FExpand(AddPathDelim(myDcc32Dir)+Dcc32ExeDir)
 else Result:='';
end;

function TDcc32Wrapper.GetTmpDir:LongString;
begin
 if Assigned(Self)
 then Result:=FExpand(AddPathDelim(myDcc32Dir)+Dcc32TmpDir)
 else Result:='';
end;

function TDcc32Wrapper.GetConfig:TText;
begin
 if Assigned(Self) then Result:=myConfig else Result:=nil;
end;

function TDcc32Wrapper.GetStdOut:TText;
begin
 if Assigned(Self) then Result:=myStdOut else Result:=nil;
end;

function TDcc32Wrapper.GetHints:TText;
begin
 if Assigned(Self) then Result:=myHints else Result:=nil;
end;

function TDcc32Wrapper.GetWarnings:TText;
begin
 if Assigned(Self) then Result:=myWarnings else Result:=nil;
end;

function TDcc32Wrapper.GetErrors:TText;
begin
 if Assigned(Self) then Result:=myErrors else Result:=nil;
end;

function TDcc32Wrapper.GetFatals:TText;
begin
 if Assigned(Self) then Result:=myFatals else Result:=nil;
end;

function TDcc32Wrapper.TmpCfg:TText;
begin
 if Assigned(Self) then Result:=myTmpCfg else Result:=nil;
end;

function TDcc32Wrapper.GetCmdLineOpt:LongString;
begin
 if Assigned(Self) then Result:=myCmdOpt else Result:='';
end;

procedure TDcc32Wrapper.SetCmdLineOpt(const aOpt:LongString);
begin
 if Assigned(Self) then myCmdOpt:=Trim(aOpt);
end;

function TDcc32Wrapper.GetRemedyCmd:LongString;
begin
 if Assigned(Self) then Result:=myRemedy else Result:='';
end;

procedure TDcc32Wrapper.SetRemedyCmd(const aRemedy:LongString);
begin
 if Assigned(Self) then myRemedy:=Trim(aRemedy);
end;

procedure TDcc32Wrapper.ErrorFound(E:Exception; const Note:LongString);
begin
 if Exceptions then begin
  if E is Exception
  then RAISE EDcc32Failure.Create(E.Message)
  else RAISE EDcc32Failure.Create(Note);
 end else ErrorReport(E,Note);
end;

function TDcc32Wrapper.CanCompile(aProject:LongString=''):Boolean;
var i:Integer; s:LongString; p:TText;
begin
 Result:=false;
 if Assigned(Self) then
 try
  // проверить задан ли каталог компилятора
  if IsEmptyStr(myDcc32Dir) then FindDcc32Dir(myDcc32Dir);
  if IsEmptyStr(myDcc32Dir) then RAISE EDcc32Failure.Create('Dcc32 directory not specified.');
  // создать необходимые каталоги компилятора
  if not MkDir(BinDir) then RAISE EDcc32Failure.Create(Format('Error MkDir("%s").',[BinDir]));
  if not MkDir(LibDir) then RAISE EDcc32Failure.Create(Format('Error MkDir("%s").',[LibDir]));
  if not MkDir(ExeDir) then RAISE EDcc32Failure.Create(Format('Error MkDir("%s").',[ExeDir]));
  if not MkDir(TmpDir) then RAISE EDcc32Failure.Create(Format('Error MkDir("%s").',[TmpDir]));
  // проверить файлы в каталоге ..\bin
  p:=NewText;
  try
   p.Text:=Dcc32BinList;
   for i:=0 to p.Count-1 do
   if IsNonEmptyStr(p[i]) then begin
    s:=FExpand(AddPathDelim(BinDir)+Trim(p[i]));
    s:=UnifyFileAlias(s);
    if not FileExists(s)
    then RAISE EDcc32Failure.Create(Format('File "%s" not found.',[s]));
   end;
  finally
   Kill(p);
  end;
  // проверить файлы в каталоге ..\lib
  p:=NewText;
  try
   p.Text:=Dcc32LibList;
   for i:=0 to p.Count-1 do
   if IsNonEmptyStr(p[i]) then begin
    s:=FExpand(AddPathDelim(LibDir)+Trim(p[i]));
    s:=UnifyFileAlias(s);
    if not FileExists(s)
    then RAISE EDcc32Failure.Create(Format('File "%s" not found.',[s]));
   end;
  finally
   Kill(p);
  end;
  // проверить файл проекта
  if IsNonEmptyStr(aProject) then begin
   aProject:=UnifyFileAlias(aProject);
   if not FileExists(aProject)
   then RAISE EDcc32Failure.Create(Format('File "%s" not found.',[aProject]));
   if not SameText(ExtractFileExt(aProject),'.dpr')
   then RAISE EDcc32Failure.Create(Format('Invalid extension in "%s".',[aProject]));
  end;
  Result:=true;
 except
  on E:Exception do ErrorFound(E,'CanCompile');
 end;
end;

function TDcc32Wrapper.TryRemedy(const aProject:LongString=''):Boolean;
var CurrDir,OutStr:LongString;
begin
 Result:=False;
 if Assigned(Self) then
 if IsNonEmptyStr(RemedyCmd) then
 try
  CurrDir:=GetCurrDir;
  try
   // CD program home dir
   if not SetCurrDir(HomeDir)
   then RAISE EDcc32Failure.Create(Format('Could not set directory "%s".',[HomeDir]));
   // Execute Remedy command
   if not RunCommandInDir(HomeDir,RemedyCmd,OutStr)
   then RAISE EDcc32Failure.Create(Format('Error executing "%s".',[RemedyCmd]));
   if (OutStr<>'') then begin
    Echo('Run: '+RemedyCmd);
    Echo(OutStr);
   end;
   // Check project is compileable
   Result:=CanCompile(aProject);
  finally
   SetCurrDir(CurrDir);
  end;
 except
  on E:Exception do ErrorFound(E,'TryRemedy');
 end;
end;

function TDcc32Wrapper.Compile(const aProject:LongString;
                               const aDestDir:LongString=''):Boolean;
var CurrDir,CmdLine,WorkDir,OutStr,aProjExt,Src,Dst:LongString;
var Line:Integer; Parse:TParseDcc32Message;
begin
 Result:=False;
 if Assigned(Self) then
 try
  // сохранить текущий каталог, инициализировать переменные
  CurrDir:=GetCurrDir;
  TmpCfg.Count:=0;
  StdOut.Count:=0;
  Hints.Count:=0;
  Warnings.Count:=0;
  Errors.Count:=0;
  Fatals.Count:=0;
  OutStr:='';
  try
   // проверить задан ли каталог компилятора
   if IsEmptyStr(myDcc32Dir) then FindDcc32Dir(myDcc32Dir);
   if IsEmptyStr(myDcc32Dir) then RAISE EDcc32Failure.Create('Dcc32 directory not specified.');
   // перейти в каталог компилятора
   if not MkDir(BinDir)
   then RAISE EDcc32Failure.Create(Format('Error MkDir("%s").',[BinDir]));
   if not SetCurrDir(BinDir)
   then RAISE EDcc32Failure.Create(Format('Could not set directory "%s".',[BinDir]));
   // сохранить текущий конфиг и установить новый, если надо
   if Config.Count>0 then begin
    TmpCfg.ReadFile(Dcc32CfgName);
    Config.WriteFile(Dcc32CfgName);
   end;
   // проверить наличие компилятора и проекта
   if not CanCompile(aProject) and not TryRemedy(aProject)
   then RAISE EDcc32Failure.Create(Format('Could not compile "%s".',[aProject]));
   try
    // Подготовка
    WorkDir:=myDcc32Dir;
    CmdLine:=Format('%s %s %s',[Dcc32ExeName,CmdLineOptions,aProject]);
    // Запуск компилятора
    if not RunCommandInDir(WorkDir,CmdLine,OutStr)
    then RAISE EDcc32Failure.Create(Format('Error compile "%s".',[aProject]));
    // Определить тип файла результата - .DLL или .EXE
    if FileExists(ForcePath(ExeDir,ForceExtension(aProject,'.DLL'))) then aProjExt:='.DLL' else
    if FileExists(ForcePath(ExeDir,ForceExtension(aProject,'.EXE'))) then aProjExt:='.EXE' else aProjExt:='';
    if IsEmptyStr(aProjExt)
    then RAISE EDcc32Failure.Create(Format('Project "%s" destination file not found.',[aProject]));
    // переместить результат в каталог - приемник
    if (Length(aDestDir)>0) and (Length(aProjExt)>0) then begin
     Src:=ForcePath(ExeDir,  ForceExtension(aProject,aProjExt));
     Dst:=ForcePath(aDestDir,ForceExtension(aProject,aProjExt));
     if not FileExists(Src)
     then RAISE EDcc32Failure.Create(Format('File "%s" not found.',[Src]));
     if not FileErase(Dst)
     then RAISE EDcc32Failure.Create(Format('Could not erase "%s".',[Dst]));
     if not FileRename(Src,Dst)
     then RAISE EDcc32Failure.Create(Format('Could not rename "%s" to "%s".',[Src,Dst]));
     FileRename(ForcePath(ExeDir,  ForceExtension(aProject,'.MAP')),
                ForcePath(aDestDir,ForceExtension(aProject,'.MAP')));
    end;
    // теперь все в порядке
    Result:=true;
   finally
    // закрыть, прочитать в память и удалить файл ошибок,
    // после этого проанализировать выход компилятора
    if IsNonEmptyStr(OutStr) then begin
     StdOut.Text:=ValidateEol(OutStr);
     for Line:=0 to StdOut.Count-1 do begin
      Parse:=ParseDcc32Message(StdOut[Line]);
      case Parse.Status of
       cmsHint    : Hints.AddLn(StdOut[Line]);
       cmsWarning : Warnings.AddLn(StdOut[Line]);
       cmsError   : Errors.AddLn(StdOut[Line]);
       cmsFatal   : Fatals.Addln(StdOut[Line]);
      end;
     end;
    end;
    // восстановить файл dcc32.cfg
    if (Config.Count>0) and (TmpCfg.Count>0) then TmpCfg.WriteFile(Dcc32CfgName);
   end;
  finally
   // восстановление прежнего каталога и удаление буферов
   SetCurrDir(CurrDir);
   TmpCfg.Count:=0;
  end;
  // проверить сообщения компилятора об обнаружении ошибок
  if (Errors.Count>0) or (Fatals.Count>0) then begin
   Result:=false;
   RAISE EDcc32Failure.Create(Format('Errors or fatals in "%s".',[aProject]));
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

/////////////
// Utilities.
/////////////

function ParseDcc32Message(const aMessage:LongString):TParseDcc32Message;
var p,i:Integer; key:LongString;
begin
 with Result do
 try
  key:=' Fatal: ';
  p:=Pos(key, aMessage);
  if (p>0) then Status:=cmsFatal else begin
   key:=' Error: ';
   p:=Pos(key, aMessage);
   if (p>0) then Status:=cmsError else begin
    key:=' Warning: ';
    p:=Pos(key, aMessage);
    if (p>0) then Status:=cmsWarning else begin
     key:=' Hint: ';
     p:=Pos(key, aMessage);
     if (p>0) then Status:=cmsHint else begin
      Status:=cmsNone;
      key:='';
     end;
    end;
   end;
  end;
  FileName:='';
  LineNum:=0;
  Token:='';
  if (Status<>cmsNone) then begin
   i:=p-1;
   while (i>1) and (aMessage[i]<>'(') do Dec(i);
   if (i>1) then begin
    FileName:=Copy(aMessage,1,i-1);
    LineNum:=StrToIntDef(Copy(aMessage,i+1,p-i-2),0);
   end;
   i:=p+Length(key);
   Token:=Copy(aMessage,i,Length(aMessage)+1-i);
  end;
 except
  on E:Exception do begin
   Status:=cmsFatal;
   FileName:='';
   LineNum:=0;
   Token:='Dcc32 output parser error.';
  end;
 end;
end;

function NewDcc32Wrapper(const aDcc32Dir:LongString=''):TDcc32Wrapper;
begin
 Result:=nil;
 try
  Result:=TDcc32Wrapper.Create(aDcc32Dir);
 except
  on E:Exception do BugReport(E,nil,'NewDcc32Wrapper');
 end;
end;

procedure Kill(var TheObject:TDcc32Wrapper); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 end; 
end;

function NewDcc32WrapperFromIniFile:TDcc32Wrapper;
var s:LongString;
begin
 s:='';
 if ReadIniFilePath(SysIniFile,'[Dcc32.Exe]','Dcc32BinDir',HomeDir,s)
 then MkDir(s) else s:='';
 Result:=NewDcc32Wrapper(s);
 if ReadIniFileAlpha(SysIniFile,'[Dcc32.Exe]','Dcc32CfgSec%a',s,efConfigNC)
 then Result.Config.Text:=ExtractTextSection(SysIniFile,UnifySection(s),efAsIs);
 if ReadIniFileString(SysIniFile,'[Dcc32.Exe]','Dcc32CmdOpt%s',s,efConfigNC)
 then Result.CmdLineOptions:=Trim(s);
 if ReadIniFileString(SysIniFile,'[Dcc32.Exe]','Dcc32Remedy%s',s,efConfigNC)
 then Result.RemedyCmd:=Trim(s);
end;

function SafeCompileDelphiProject(const aProject:LongString):Boolean;
 function CompileStatus(f:Boolean):LongString;
 begin
  if f
  then Result:=RusEng('КОМПИЛЯЦИЯ ПРОШЛА УСПЕШНО.','COMPILED OK.')
  else Result:=RusEng('КОМПИЛЯЦИЯ БЫЛА НЕУДАЧНОЙ.','COMPILATION FAILS.');
 end;
var
 Success  : Boolean;
 Problems : Integer;
begin
 Result:=false;
 try
  if FileExists(aProject) then begin
   if SameText(UnifyAlias(ExtractFileExt(aProject)),UnifyAlias('.dpr')) then begin
    Success:=dcc32.Compile(aProject,ExtractFilePath(aProject));
    dcc32.StdOut.Echo;
    Echo(Pad('',60,'*'));
    Echo(Format('Date-Time:      %s',[StdDateTimeStr(msecnow)]));
    Echo(Format('Project file:   %s',[GetRealFilePathName(aProject)]));
    Echo(Format('Project status: %s',[CompileStatus(Success)]));
    Echo(Format('Fatals:         %d',[dcc32.Fatals.Count]));
    Echo(Format('Errors:         %d',[dcc32.Errors.Count]));
    Echo(Format('Warnings:       %d',[dcc32.Warnings.Count]));
    Echo(Format('Hints:          %d',[dcc32.Hints.Count]));
    Echo(Pad('',60,'*'));
    Problems:=ord(not Success);
    if dcc32.Hints.Count>0 then begin
     Echo('Hints:');
     dcc32.Hints.Echo;
     inc(Problems);
    end;
    if dcc32.Warnings.Count>0 then begin
     Echo('Warnings:');
     dcc32.Warnings.Echo;
     inc(Problems);
    end;
    if dcc32.Errors.Count>0 then begin
     Echo('Errors:');
     dcc32.Errors.Echo;
     inc(Problems);
    end;
    if dcc32.Fatals.Count>0 then begin
     Echo('Fatals:');
     dcc32.Fatals.Echo;
     inc(Problems);
    end;
    if (Problems>0)
    then SendToMainConsole('@silent @view activate '+GetMainConsoleCaption+EOL);
    Result:=(Problems=0);
   end else Echo(RusEng('Проект должен иметь расширение .dpr!',
                        'Project must to have extension .dpr!'));
  end else Echo(Format(RusEng('Не найден проект: "%s".',
                              'Not found project: "%s".'),[aProject]));
 except
  on E:Exception do BugReport(E,nil,'SafeCompileDelphiProject');
 end;
end;

///////////////////////
// Dcc32 implementation
///////////////////////

const
 TheDcc32 : TDcc32Wrapper = nil;

function  Dcc32:TDcc32Wrapper;
begin
 if not Assigned(TheDcc32) then begin
  TheDcc32:=NewDcc32WrapperFromIniFile;
  TheDcc32.Master:=@TheDcc32;
 end;
 Result:=TheDcc32;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_dcc32;
begin
end;

procedure Free_crw_dcc32;
begin
 Kill(TheDcc32);
end;

initialization

 Init_crw_dcc32;

finalization

 Free_crw_dcc32;

end.

//////////////
// END OF FILE
//////////////

