 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2003, <kouriakine@mail.ru>
 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
 Modifications:
 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.
 ****************************************************************************
 }

unit _Dcc32;

{$I _sysdef}

interface

uses
  SysUtils, Windows, Classes, Math, _alloc, _fpu, _str, _fio, _CrwApi;

 ///////////////////////////////////////////////////////////////////////////////
 // TPluginWrapper can help you to load plugin DLL and run plugin function,   //
 // which exported by this DLL. Plugin function have signature:               //
 //  function(Api:TPluginApi):Integer; StdCall;                               //
 // Api class provides capabilities for main program <--> plugin interaction. //
 // Api class must be abstract virtual class, I mean, all members of this     //
 // class must be functions/procedures marked as "virtual; abstract;"         //
 // Main program create inherited Api class to overload abstract methods, but //
 // plugin knows only abstract Api. Plugin function executes in caller        //
 // context (address space, thread etc), but can use only methods provided by //
 // Api class.                                                                //
 // Publuc methods are:                                                       //
 //  DllInst    Return DLL instance <> 0, or 0 if DLL was not loaded          //
 //  DllPath    Return DLL file path                                          //
 //  PluginName Return plugin function name                                   //
 //  DllLoad    Load DLL, find plugin function address.                       //
 //             Return DLL instance <> 0 if Ok or 0 if any error.             //
 //  DllFree    Free DLL, if one was loaded.                                  //
 //  Execute    Load DLL, if need, and execute plugin function.               //
 //             Return Integer result of plugin function in lower 32 bits.    //
 //             Return Int64(-1) if any error.                                //
 // Example:                                                                  //
 //  Plugin DLL:                                                              //
 //   Library PluginLib;                                                      //
 //   uses _CrwApi;                                                           //
 //   function PluginExample(Api:TPluginApi):Integer; StdCall;                //
 //   begin                                                                   //
 //    with Api,SysApi do                                                     //
 //    if InitStdOut(Output) then begin                                       //
 //     writeln('Message from Plugin DLL!');                                  //
 //    end;                                                                   //
 //   end;                                                                    //
 //  Main program:                                                            //
 //   Api:=TCrwApiServer.Create;                                              //
 //   Plugin:=NewPluginWrapper('PluginLib.dll','PluginExample');              //
 //   Code:=Plugin.Execute(Api);                                              //
 //   if Code=-1 then writeln('Error') else writeln('Result=',Integer(Code)); //
 //   Kill(Plugin);                                                           //
 ///////////////////////////////////////////////////////////////////////////////
type
 EPluginFailure = class(EEchoException);
 TPluginWrapper = class(TMasterObject)
 private
  myDllInst : HMODULE;
  myDllPath : packed array[0..255] of Char;
  myPluginF : TPluginFun;
  myPluginN : packed array[0..255] of Char;
  function    GetDllInst:HMODULE;
  function    GetDllPath:ShortString;
  function    GetPluginName:ShortString;
 protected
  procedure   ErrorFound(E:Exception; const Note:LongString=''); override;
 public
  constructor Create(const aDllPath,aPluginName:ShortString);
  destructor  Destroy; override;
  property    DllInst    : HMODULE     read GetDllInst;
  property    DllPath    : ShortString read GetDllPath;
  property    PluginName : ShortString read GetPluginName;
  function    DllLoad    : HMODULE;
  procedure   DllFree;
  function    Execute(Api:TPluginApi):Int64;
 end;

function  NewPluginWrapper(const aDllPath,aPluginName:ShortString):TPluginWrapper;
procedure Kill(var TheObject:TPluginWrapper); overload;

 ///////////////////////////////////////////////////////////////////////////////
 // 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'    +CRLF+
                 'rlink32.dll'  +CRLF+
                 'borlndmm.dll' +CRLF+
                 'delphimm.dll' +CRLF+
                 'dcc32.cfg';
 Dcc32LibDir   = '..\lib';
 Dcc32LibList  = 'activex.dcu'  +CRLF+
                 'actnlist.dcu' +CRLF+
                 'buttons.dcu'  +CRLF+
                 'buttons.res'  +CRLF+
                 'checklst.dcu' +CRLF+
                 'classes.dcu'  +CRLF+
                 'clipbrd.dcu'  +CRLF+
                 'colorgrd.dcu' +CRLF+
                 'comconst.dcu' +CRLF+
                 'comctrls.dcu' +CRLF+
                 'commctrl.dcu' +CRLF+
                 'commdlg.dcu'  +CRLF+
                 'comobj.dcu'   +CRLF+
                 'comserv.dcu'  +CRLF+
                 'comstrs.dcu'  +CRLF+
                 'consts.dcu'   +CRLF+
                 'contnrs.dcu'  +CRLF+
                 'controls.dcu' +CRLF+
                 'controls.res' +CRLF+
                 'dialogs.dcu'  +CRLF+
                 'dlgs.dcu'     +CRLF+
                 'extctrls.dcu' +CRLF+
                 'flatsb.dcu'   +CRLF+
                 'forms.dcu'    +CRLF+
                 'graphics.dcu' +CRLF+
                 'grids.dcu'    +CRLF+
                 'imglist.dcu'  +CRLF+
                 'imm.dcu'      +CRLF+
                 'inifiles.dcu' +CRLF+
                 'jconsts.dcu'  +CRLF+
                 'jpeg.dcu'     +CRLF+
                 'mask.dcu'     +CRLF+
                 'math.dcu'     +CRLF+
                 'menus.dcu'    +CRLF+
                 'messages.dcu' +CRLF+
                 'mmsystem.dcu' +CRLF+
                 'multimon.dcu' +CRLF+
                 'printers.dcu' +CRLF+
                 'psapi.dcu'    +CRLF+
                 'registry.dcu' +CRLF+
                 'regstr.dcu'   +CRLF+
                 'richedit.dcu' +CRLF+
                 'sharemem.dcu' +CRLF+
                 'shellapi.dcu' +CRLF+
                 'shlobj.dcu'   +CRLF+
                 'spin.dcu'     +CRLF+
                 'spin.res'     +CRLF+
                 'stdactns.dcu' +CRLF+
                 'stdctrls.dcu' +CRLF+
                 'sysconst.dcu' +CRLF+
                 'sysinit.dcu'  +CRLF+
                 'system.dcu'   +CRLF+
                 'sysutils.dcu' +CRLF+
                 'tabnotbk.dcu' +CRLF+
                 'tlhelp32.dcu' +CRLF+
                 'toolwin.dcu'  +CRLF+
                 'typinfo.dcu'  +CRLF+
                 'urlmon.dcu'   +CRLF+
                 'windows.dcu'  +CRLF+
                 'wininet.dcu'  +CRLF+
                 'winsock.dcu'  +CRLF+
                 'winspool.dcu' +CRLF+
                 '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 : packed array[0..255] of Char;
  myConfig   : TText;
  myStdOut   : TText;
  myHints    : TText;
  myWarnings : TText;
  myErrors   : TText;
  myFatals   : TText;
  myTmpCfg   : TText;
  myCmdOpt   : ShortString;
  myRemedy   : packed array[0..255] of Char;
  function    GetBinDir     : ShortString;
  function    GetLibDir     : ShortString;
  function    GetExeDir     : ShortString;
  function    GetTmpDir     : ShortString;
  function    GetConfig     : TText;
  function    GetStdOut     : TText;
  function    GetHints      : TText;
  function    GetWarnings   : TText;
  function    GetErrors     : TText;
  function    GetFatals     : TText;
  function    TmpCfg        : TText;
  function    GetCmdLineOpt:ShortString;
  procedure   SetCmdLineOpt(const aOpt:ShortString);
  function    GetRemedyCmd:ShortString;
  procedure   SetRemedyCmd(const aRemedy:ShortString);
 protected
  procedure   ErrorFound(E:Exception; const Note:LongString=''); override;
 public
  constructor Create(const aDcc32Dir:ShortString='');
  destructor  Destroy; override;
  property    BinDir         : ShortString read GetBinDir;
  property    LibDir         : ShortString read GetLibDir;
  property    ExeDir         : ShortString read GetExeDir;
  property    TmpDir         : ShortString 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 : ShortString read GetCmdLineOpt write SetCmdLineOpt;
  property    RemedyCmd      : ShortString read GetRemedyCmd  write SetRemedyCmd;
  function    CanCompile(const aProject:ShortString=''):Boolean;
  function    TryRemedy(const aProject:ShortString=''):Boolean;
  function    Compile(const aProject:ShortString;
                      const aDestDir:ShortString=''):Boolean;
 end;

function  NewDcc32Wrapper(const aDcc32Dir:ShortString=''):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 : ShortString;
  LineNum  : Integer;
  Token    : ShortString;
 end;

function ParseDcc32Message(const aMessage:ShortString):TParseDcc32Message;

implementation

 ///////////////////////////////////
 // TPluginWrapper implementation //
 ///////////////////////////////////
constructor TPluginWrapper.Create(const aDllPath,aPluginName:ShortString);
begin
 inherited Create;
 myDllInst:=0;
 StrPCopy(myDllPath,DefaultExtension(Trim(aDllPath),'.dll'));
 myPluginF:=nil;
 StrPCopy(myPluginN,Trim(aPluginName));
 Exceptions:=false;
 ErrorReportProc:=DefaultObjectErrorReportProc;
end;

destructor TPluginWrapper.Destroy;
begin
 DllFree;
 inherited Destroy;
end;

function TPluginWrapper.GetDllInst:HMODULE;
begin
 if Assigned(Self) then Result:=myDllInst else Result:=0;
end;

function TPluginWrapper.GetDllPath:ShortString;
begin
 if Assigned(Self) then Result:=StrPas(myDllPath) else Result:='';
end;

function TPluginWrapper.GetPluginName:ShortString;
begin
 if Assigned(Self) then Result:=StrPas(myPluginN) else Result:='';
end;

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

function TPluginWrapper.DllLoad:HMODULE;
begin
 Result:=0;
 if Assigned(Self) then
 try
  myPluginF:=nil;
  if DllInst = 0 then begin
   if FileExists(DllPath)
   then myDllInst:=LoadLibrary(myDllPath)
   else RAISE EPluginFailure.Create(Format('File "%s" not found.',[DllPath]));
  end;
  if DllInst = 0
  then RAISE EPluginFailure.Create(Format('Error LoadLibrary("%s"): "%s".',
                                          [DllPath,SysErrorMessage(GetLastError)]));
  myPluginF:=TPluginFun(GetProcAddress(DllInst,myPluginN));
  if Assigned(myPluginF)
  then Result:=DllInst
  else RAISE EPluginFailure.Create(Format('Function "%s" not found  in "%s".',
                                          [PluginName,DllPath]));
 except
  on E:Exception do begin
   DllFree;
   ErrorFound(E);
  end;
 end;
end;

procedure TPluginWrapper.DllFree;
begin
 if Assigned(Self) then
 try
  try
   if DllInst <> 0 then
   if not FreeLibrary(DllInst)
   then RAISE EPluginFailure.Create(Format('Error FreeLibrary("%s"): "%s".',
                                           [DllPath,SysErrorMessage(GetLastError)]));
  finally
   myPluginF:=nil;
   myDllInst:=0;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TPluginWrapper.Execute(Api:TPluginApi):Int64;
begin
 Result:=-1;
 if Assigned(Api) then
 if Assigned(Self) then
 try
  try
   if not Assigned(myPluginF) then DllLoad;
   if Assigned(myPluginF) then begin
    Api.ServerActionsBeforeExecution;
    try
     Result:=myPluginF(Api);
    finally
     Api.ServerActionsAfterExecution;
    end;
   end;
  finally
   FpuSetExceptions(false);
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function NewPluginWrapper(const aDllPath,aPluginName: ShortString):TPluginWrapper;
begin
 Result:=nil;
 try
  Result:=TPluginWrapper.Create(aDllPath,aPluginName);
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TPluginWrapper); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

 //////////////////////////////////
 // TDcc32Wrapper implementation //
 //////////////////////////////////
procedure CheckDcc32Dir(const FileName:ShortString; const FileDetails:TSearchRec;
                              SubDirLevel:Integer; var Terminate:Boolean;
                              CustomData:Pointer);
begin
 if FileDetails.Attr and FILE_ATTRIBUTE_DIRECTORY = 0 then
 if UnifyAlias(ExtractFileNameExt(FileName))=UnifyAlias(Dcc32ExeName) then begin
  StrPCopy(PChar(CustomData),DropBackSlash(ExtractFilePath(FileName)));
  Terminate:=true;
 end;
end;

procedure FindDcc32Dir(aDcc32Dir:PChar);
begin
 StrCopy(aDcc32Dir,'');
 try
  ForEachFile(HomeDir,Dcc32ExeName,CheckDcc32Dir,5,aDcc32Dir);
 except
  on E:Exception do begin
   BugReport(E);
   StrCopy(aDcc32Dir,'');
  end;
 end;
end;

constructor TDcc32Wrapper.Create(const aDcc32Dir:ShortString='');
begin
 inherited Create;
 StrPCopy(myDcc32Dir,DropBackSlash(aDcc32Dir));
 if StrLen(myDcc32Dir)=0 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
 Kill(myConfig);
 Kill(myStdOut);
 Kill(myHints);
 Kill(myWarnings);
 Kill(myErrors);
 Kill(myFatals);
 Kill(myTmpCfg);
 inherited Destroy;
end;

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

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

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

function TDcc32Wrapper.GetTmpDir:ShortString;
begin
 if Assigned(Self)
 then Result:=FExpand(AddBackSlash(StrPas(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:ShortString;
begin
 if Assigned(Self) then Result:=myCmdOpt else Result:='';
end;

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

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

procedure TDcc32Wrapper.SetRemedyCmd(const aRemedy:ShortString);
begin
 if Assigned(Self) then StrPCopy(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(const aProject:ShortString=''):Boolean;
var
 i : Integer;
 s : ShortString;
 p : TText;
begin
 Result:=false;
 if Assigned(Self) then
 try
  // проверить задан ли каталог компилятора
  if StrLen(myDcc32Dir)=0 then FindDcc32Dir(myDcc32Dir);
  if StrLen(myDcc32Dir)=0 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 not IsEmptyStr(p[i]) then begin
    s:=FExpand(AddBackSlash(BinDir)+Trim(p[i]));
    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 not IsEmptyStr(p[i]) then begin
    s:=FExpand(AddBackSlash(LibDir)+Trim(p[i]));
    if not FileExists(s)
    then RAISE EDcc32Failure.Create(Format('File "%s" not found.',[s]));
   end;
  finally
   Kill(p);
  end;
  // проверить файл проекта
  if Length(aProject)>0 then begin
   if not FileExists(aProject)
   then RAISE EDcc32Failure.Create(Format('File "%s" not found.',[aProject]));
   if UnifyAlias(ExtractFileExt(aProject))<>UnifyAlias('.dpr')
   then RAISE EDcc32Failure.Create(Format('Invalid extension in "%s".',[aProject]));
  end;
  Result:=true;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TDcc32Wrapper.TryRemedy(const aProject:ShortString=''):Boolean;
var
 CurrDir     : ShortString;
 ProgDir     : packed array[0..255] of Char;
 TempFile    : THandle;
 TempName    : packed array[0..255] of Char;
 ResultCode  : Cardinal;
 StartupInfo : TStartupInfo;
 ProcessInfo : TProcessInformation;
 SecurityAtt : TSecurityAttributes;
begin
 Result:=False;
 if Assigned(Self) then
 if StrLen(myRemedy)>0 then
 try
  // сохранить текущий каталог, инициализировать переменные
  CurrDir:=GetCurrDir;
  TempFile:=INVALID_HANDLE_VALUE;
  StrPCopy(TempName,CreateTempFile);
  try
   // перейти в домашний каталог программы
   if not SetCurrDir(HomeDir)
   then RAISE EDcc32Failure.Create(Format('Could not set directory "%s".',[HomeDir]));
   try
    // установить атрибуты безопасности,
    // разрешить наследование дочернему процессу
    ZeroMemory(@SecurityAtt, SizeOf(SecurityAtt));
    with SecurityAtt do begin
     nLength              := SizeOf(SecurityAtt);
     lpSecurityDescriptor := nil;
     bInheritHandle       := BOOL(True);
    end;
    // создать временный файл для перехвата сообщений
    TempFile := CreateFile(TempName, GENERIC_WRITE, 0, @SecurityAtt,
                           CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
    if TempFile = INVALID_HANDLE_VALUE
    then RAISE EDcc32Failure.Create(Format('Could not create file "%s".',[StrPas(TempName)]));
    // заполнить структуру, специфицирующую создание процесса:
    // скрывать окно и наследовать потоки ввода-вывода
    ZeroMemory(@StartupInfo, SizeOf(StartupInfo));
    with StartupInfo do begin
     cb          := SizeOf(StartupInfo);
     dwFlags     := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
     wShowWindow := SW_HIDE;
     hStdOutput  := TempFile;
    end;
    // создать и стартовать процесс
    if not CreateProcess(nil, myRemedy, @SecurityAtt, @SecurityAtt,
                         BOOL(True), 0, nil, StrPCopy(ProgDir,HomeDir),
                         StartupInfo, ProcessInfo)
    then RAISE EDcc32Failure.Create(Format('Could not CreateProcess("%s").',[RemedyCmd]));
    // ждать завершение неопределенное время
    WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    // получить результат
    ResultCode := 0;
    GetExitCodeProcess(ProcessInfo.hProcess, ResultCode);
    // Закрыть дескрипторы процеса и его потока
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
    // результат должен быть ноль
    if ResultCode <> 0
    then RAISE EDcc32Failure.Create(Format('Error executing "%s".',[RemedyCmd]));
    // теперь все в порядке
    Result:=CanCompile(aProject);
   finally
    // закрыть и удалить файл
    if TempFile <> INVALID_HANDLE_VALUE then begin
     CloseHandle(TempFile);
     FileErase(StrPas(TempName));
    end;
   end;
  finally
   // восстановление прежнего каталога
   SetCurrDir(CurrDir);
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TDcc32Wrapper.Compile(const aProject:ShortString;
                               const aDestDir:ShortString=''):Boolean;
var
 CurrDir     : ShortString;
 aProjExt    : ShortString;
 CmdLine     : packed array[0..255] of Char;
 TempFile    : THandle;
 TempName    : packed array[0..255] of Char;
 ResultCode  : Cardinal;
 StartupInfo : TStartupInfo;
 ProcessInfo : TProcessInformation;
 SecurityAtt : TSecurityAttributes;
 Src,Dst     : ShortString;
 Line        : Integer;
 Parse       : TParseDcc32Message;
begin
 Result:=False;
 if Assigned(Self) then
 try
  // сохранить текущий каталог, инициализировать переменные
  CurrDir:=GetCurrDir;
  TempFile:=INVALID_HANDLE_VALUE;
  StrPCopy(TempName,CreateTempFile);
  TmpCfg.Count:=0;
  StdOut.Count:=0;
  Hints.Count:=0;
  Warnings.Count:=0;
  Errors.Count:=0;
  Fatals.Count:=0;
  try
   // проверить задан ли каталог компилятора
   if StrLen(myDcc32Dir)=0 then FindDcc32Dir(myDcc32Dir);
   if StrLen(myDcc32Dir)=0 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
    // установить атрибуты безопасности,
    // разрешить наследование дочернему процессу
    ZeroMemory(@SecurityAtt, SizeOf(SecurityAtt));
    with SecurityAtt do begin
     nLength              := SizeOf(SecurityAtt);
     lpSecurityDescriptor := nil;
     bInheritHandle       := BOOL(True);
    end;
    // создать временный файл для перехвата сообщений компилятора
    TempFile := CreateFile(TempName, GENERIC_WRITE, 0, @SecurityAtt,
                           CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
    if TempFile = INVALID_HANDLE_VALUE
    then RAISE EDcc32Failure.Create(Format('Could not create file "%s".',[StrPas(TempName)]));
    // заполнить структуру, специфицирующую создание процесса:
    // скрывать окно компилятора и наследовать потоки ввода-вывода
    ZeroMemory(@StartupInfo, SizeOf(StartupInfo));
    with StartupInfo do begin
     cb          := SizeOf(StartupInfo);
     dwFlags     := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
     wShowWindow := SW_HIDE;
     hStdOutput  := TempFile;
    end;
    // создать и стартовать процесс компилятора
    StrPCopy(CmdLine,Format('%s %s %s',[Dcc32ExeName,CmdLineOptions,aProject]));
    if not CreateProcess(nil, CmdLine, @SecurityAtt, @SecurityAtt,
                         BOOL(True), 0, nil, myDcc32Dir, StartupInfo, ProcessInfo)
    then RAISE EDcc32Failure.Create(Format('Could not CreateProcess("%s").',[Dcc32ExeName]));
    // ждать завершение компиляции неопределенное время
    WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
    // получить результат компиляции
    ResultCode := 0;
    GetExitCodeProcess(ProcessInfo.hProcess, ResultCode);
    // Закрыть дескрипторы процеса и его потока
    CloseHandle(ProcessInfo.hProcess);
    CloseHandle(ProcessInfo.hThread);
    // при нормальной компиляции результат компиляции должен быть ноль
    if ResultCode <> 0
    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 TempFile <> INVALID_HANDLE_VALUE then begin
     CloseHandle(TempFile);
     StdOut.ReadFile(StrPas(TempName));
     FileErase(StrPas(TempName));
     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;

function ParseDcc32Message(const aMessage:ShortString):TParseDcc32Message;
var
 p,i : Integer;
 key : ShortString;
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:ShortString=''):TDcc32Wrapper;
begin
 Result:=nil;
 try
  Result:=TDcc32Wrapper.Create(aDcc32Dir);
 except
  on E:Exception do BugReport(E);
 end;
end;

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

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

const
 TheDcc32 : TDcc32Wrapper = nil;

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

initialization

finalization

 Kill(TheDcc32);

end.

