Форум программистов [Powered by Invision Power Board]

Код


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

TProgramResult = record
  TimeoutFailed: boolean;
  RuntimeError: boolean;
  RuntimeErrorCode: Cardinal;
  ReturnResult: Cardinal;
end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

Function RunProgram(CmdLine: String; Timeout: Cardinal):TProgramResult;
var
  tick, eCode: Cardinal;
  si: TStartupInfo;
  pi: TProcessInformation;
  dbg: _DEBUG_EVENT;
begin
  with si do
  begin
    cb := sizeof(si);
    lpReserved := nil;
    lpDesktop := nil;
    lpTitle := PChar('External program "' + CmdLine + '"');
    dwFlags := 0;
    cbReserved2 := 0;
    lpReserved2 := nil;
  end;

  tick:=GetTickCount;

  SetCurrentDirectory(PChar(ExtractFilePath(Application.ExeName)+'pool\'));

  CreateProcessA(
        nil,
        PChar(CmdLine),
        nil,
        nil,
        LongBool(false),
        DEBUG_PROCESS or DEBUG_ONLY_THIS_PROCESS,
        nil,
        nil,
        si,
        pi
        );

  Result.TimeoutFailed:=false;
  Result.RuntimeError:=false;

  while true do
  begin

     if getTickCount - tick > Timeout then
     begin
        Result.TimeoutFailed := true;
        TerminateProcess(pi.hProcess,0);
     end;

     if not WaitForDebugEvent(dbg, 20) then continue;

     ContinueDebugEvent(dbg.dwProcessId, dbg.dwThreadId, DBG_CONTINUE);

     if (dbg.dwDebugEventCode = EXCEPTION_DEBUG_EVENT) and
     (dbg.Exception.ExceptionRecord.ExceptionCode <> EXCEPTION_SINGLE_STEP) and
     (dbg.Exception.ExceptionRecord.ExceptionCode <> EXCEPTION_BREAKPOINT) then
     begin
        Result.RuntimeErrorCode := dbg.Exception.ExceptionRecord.ExceptionCode;
        Result.RuntimeError := true;
        TerminateProcess(pi.hProcess, 0);
     end;

     if dbg.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT then
      break;
  end;

  eCode := 0;

 repeat
  WaitForDebugEvent(dbg, 5);
  ContinueDebugEvent(dbg.dwProcessId, dbg.dwThreadId, DBG_CONTINUE);

   GetExitCodePRocess(pi.hProcess, eCode);
  until eCode<>STILL_ACTIVE;

  Result.ReturnResult:=eCode;

  CloseHandle(pi.hThread);
  CloseHandle(pi.hProcess);
end;

Function Compile(CompilerCmdLine: String; Filename: string):TProgramResult;
var
  p: Integer;
begin
  p:=pos('%1', CompilerCmdLine);
  while p<>0 do
  begin
    Delete(CompilerCmdLine, p, 2);
    Insert(Filename, CompilerCmdLine, p);
    p:=pos('%1', CompilerCmdLine);
  end;
  Result:=RunProgram(CompilerCmdLine, 400000);
end;

const
  rGood = 'good';
  rNotCompiled = 'not compiled';
  rRuntime = 'runtime';
  rTimeout = 'timeout';

Function CompileAndRun(Filename: string): string;
var
  res: TProgramResult;
begin

  if Compile('dcc32 "%1.dpr"', Filename).ReturnResult<>0 then
  begin
    Result:=rNotCompiled;
    exit;
  end;

  res:=RunProgram(Filename+'.exe',4000);

  if res.TimeoutFailed then
  begin
    Result:=rTimeout;
    exit;
  end;

  if res.RuntimeError then
  begin
    Result:=rRuntime;
    exit;
  end;

  Result:= rGood;

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Caption:=CompileAndRun('con_prog');

end;

end.

Цитата

hProcess
[in] A handle to the process to be terminated.
The handle must have the PROCESS_TERMINATE access right. For more information, see Process Security and Access Rights.

Код


unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs;

type
  TForm2 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

function DebugSetProcessKillOnExit(bKillOnExit: LongBool): DWORD; stdcall; external 'Kernel32.dll';
function DebugActiveProcessStop(dwProcessId: DWORD): LongBool; stdcall; external 'Kernel32.dll';


implementation

{$R *.dfm}

procedure TForm2.FormCreate(Sender: TObject);
var
  si: TStartupInfo;
  pi: TProcessInformation;
  lExitCode: DWORD;
  hProcess: DWORD;
begin
  with si do
  begin
    cb := SizeOf(TStartupInfo);
    lpReserved := nil;
    lpDesktop := nil;
    lpTitle := PChar('Test Debug Run: "' + CmdLine + '"');
    dwFlags := 0;
    cbReserved2 := 0;
    lpReserved2 := nil;
  end;

  if not CreateProcess(nil, PChar('c:\WINDOWS\system32\mspaint.exe'), nil, nil,
    LongBool(False), DEBUG_PROCESS or DEBUG_ONLY_THIS_PROCESS, nil, nil, si, pi) then
    RaiseLastOSError(GetLastError);

  WaitForSingleObject(pi.hProcess, 2000);

  CloseHandle(pi.hProcess);
  CloseHandle(pi.hThread);

  DebugActiveProcessStop(pi.dwProcessId);

  hProcess := OpenProcess(PROCESS_TERMINATE or PROCESS_QUERY_INFORMATION, False, pi.dwProcessId);

  if hProcess = 0 then
    RaiseLastOSError(GetLastError);

  if not TerminateProcess(hProcess, lExitCode) then
  begin
    CloseHandle(hProcess);
    RaiseLastOSError(GetLastError);
  end;

  if not GetExitCodeProcess(hProcess, lExitCode) then
  begin
    CloseHandle(hProcess);
    RaiseLastOSError(GetLastError);
  end;

  if lExitCode = STILL_ACTIVE then
    MessageDlg('Process not Terminated', mtInformation, [mbOK], 0)
  else
    MessageDlg('Process Terminated: ExitCode', mtInformation, [mbOK], 0);

  CloseHandle(hProcess);
end;

end.

Цитата(Rennigth @ 26.4.2007, 11:31

)

vertex_ua, Вообщем перед TerminateProcess надо отладку ведь останавливать Вот этим к примеру DebugActiveProcessStop.

Код


  DebugActiveProcessStop

Код


  CloseHandle(pi.hProcess);
  CloseHandle(pi.hThread);