Recent

Author Topic: Runcommand/Tprocess with timeout  (Read 1632 times)

marcov

  • Administrator
  • Hero Member
  • *
  • Posts: 9713
  • FPC developer.
Runcommand/Tprocess with timeout
« on: July 10, 2020, 06:32:40 pm »
Today, at work I attacked a long running nuisance in a minor application. An old application/script written by somebody else sometimes hangs, specially if the files it is supposed to parse have been hand edited. 

It is a low prio item, and I worked around this by cleaning up and restarting, but today got fed up and decided to tackle it once and for all, so I tried quickly create a simple and easy tprocess derivate with a simple timeout, and since it is also  a demonstration of some of the new FPC 3.2.0+ TProcess features, I thought I should share:

Code: Pascal  [Select][+][-]
  1. {$mode delphi}
  2. uses classes,sysutils,process,dateutils;
  3. Type
  4. { TProcessTimeout }
  5.  TProcessTimeout = class(TProcess)
  6.                             public
  7.                             timeoutperiod: TTime;
  8.                             timedout : boolean;
  9.                             started : TDateTime;
  10.                             procedure LocalnIdleSleep(Sender,Context : TObject;status:TRunCommandEventCode;const message:string);
  11.                           end;
  12.  
  13. procedure TProcessTimeout.LocalnIdleSleep(Sender,Context : TObject;status:TRunCommandEventCode;const message:string);
  14. begin
  15.    if status=RunCommandIdle then
  16.     begin
  17.       if (now-started)>timeoutperiod then
  18.          begin
  19.            timedout:=true;
  20.            Terminate(255);
  21.            exit;
  22.          end;
  23.       sleep(RunCommandSleepTime);
  24.     end;
  25. end;
  26.  
  27. function RunCommandTimeout(const exename:TProcessString;const commands:array of TProcessString;out outputstring:string; Options : TProcessOptions = [];SWOptions:TShowWindowOptions=swoNone;timeout:integer=60):boolean;
  28. Var
  29.     p : TProcessTimeout;
  30.     i,
  31.     exitstatus : integer;
  32.     ErrorString : String;
  33. begin
  34.   p:=TProcessTimeout.create(nil);
  35.   p.OnRunCommandEvent:=p.LocalnIdleSleep;
  36.   p.timeoutperiod:=timeout/SecsPerDay;
  37.   if Options<>[] then
  38.     P.Options:=Options - [poRunSuspended,poWaitOnExit];
  39.   p.options:=p.options+[poRunIdle]; // needed to run the RUNIDLE event. See User Changes 3.2.0
  40.  
  41.   P.ShowWindow:=SwOptions;
  42.   p.Executable:=exename;
  43.   if high(commands)>=0 then
  44.    for i:=low(commands) to high(commands) do
  45.      p.Parameters.add(commands[i]);
  46.   p.timedout:=false;
  47.   p.started:=now;
  48.   try
  49.     // the core loop of runcommand() variants, originally based on the "large output" scenario in the wiki, but continously expanded over 5 years.
  50.     result:=p.RunCommandLoop(outputstring,errorstring,exitstatus)=0;
  51.     if p.timedout then
  52.       result:=false;
  53.   finally
  54.     p.free;
  55.   end;
  56.   if exitstatus<>0 then result:=false;
  57. end;                                      
  58.  
  59. // example use:
  60.  
  61. var s : string;
  62. begin
  63.   for s in FileList do
  64.     begin
  65.        if not RunCommandTimeout('someexe',['-v',s,'--output','dest\'+s],err,[],swoNone,60) then
  66.           begin
  67.             // failed to run or timeout. Set it apart by movefile to a failed dir.
  68.          end
  69.       else
  70.         begin
  71.          // ok, move file to done directory.
  72.         end;
  73.     end;
  74. end;
  75.  

The moving of the files uses winapi movefileex() with several retries in case the file is locked (getlasterror=32). A bit like many operations to remove files and directories in fpmkunit are guarded with retries.

I only tested in on Windows, but most of it should be portable. The only potential problem is if the process being Terminate()'d cause problems in p.RunCommandLoop on some targets. It might need extra checks on e.g. p.running.

af0815

  • Hero Member
  • *****
  • Posts: 779
Re: Runcommand/Tprocess with timeout
« Reply #1 on: July 10, 2020, 07:00:43 pm »
thank you for sharing.

but its better a good sample for the wiki ?! i think it will be found better there.
regards
Andreas

marcov

  • Administrator
  • Hero Member
  • *
  • Posts: 9713
  • FPC developer.
Re: Runcommand/Tprocess with timeout
« Reply #2 on: July 10, 2020, 10:58:59 pm »
When validated, somebody can add it. I think the forum is better for early days functionality.

phuji

  • Newbie
  • Posts: 1
Re: Runcommand/Tprocess with timeout
« Reply #3 on: October 07, 2021, 12:13:52 pm »
Thank you marcov, that is exactly what I am looking for. I have modified for my own needs and confirm that it runs on Linux (Fedora). Here is the class I implemented in case that is helpful.

Code: Pascal  [Select][+][-]
  1. uses
  2.   process, Classes, SysUtils;
  3.  
  4. type
  5.  
  6.   { TTimedProcess }
  7.   //Code from marcov
  8.   //Link: https://forum.lazarus.freepascal.org/index.php/topic,50525.msg368880.html#msg368880
  9.  
  10.   TTimedProcess = class
  11.   private
  12.     FProcess: TProcess;
  13.     FTimeoutSeconds: Integer;
  14.     FTimedOut: Boolean;
  15.     FResponse: string;
  16.     FStarted: TDateTime;
  17.     procedure CommandEvent(Sender, Context: TObject; Status: TRunCommandEventCode; const Message: string);
  18.   public
  19.     constructor Create(const ProcessName: string; const Commands: array of string; const TimeoutSeconds: Integer);
  20.     destructor Destroy; override;
  21.     property TimedOut: Boolean read FTimedOut;
  22.     property Response: string read FResponse;
  23.     function Run: Boolean;
  24.   end;
  25.  
  26. implementation
  27.  
  28. constructor TTimedProcess.Create(const ProcessName: string; const Commands: array of string; const TimeoutSeconds: Integer);
  29. var
  30.   command: string;
  31. begin
  32.   FProcess := TProcess.Create(nil);
  33.   FTimeoutSeconds := TimeoutSeconds;
  34.   FProcess.Executable := ProcessName;
  35.   FProcess.Options := [poRunIdle];
  36.   FProcess.OnRunCommandEvent := @CommandEvent;
  37.   for command in Commands do
  38.     FProcess.Parameters.Add(command);
  39. end;
  40.  
  41. destructor TTimedProcess.Destroy;
  42. begin
  43.   FProcess.Free;
  44.   inherited Destroy;
  45. end;
  46.  
  47. function TTimedProcess.Run: Boolean;
  48. var
  49.   error: string;
  50.   exitStatus: Integer;
  51. begin
  52.   FStarted := Now;
  53.   FTimedOut := False;
  54.   FResponse := '';
  55.   Result := FProcess.RunCommandLoop(FResponse, error, exitStatus) = 0;
  56.   if FTimedOut then Result := False;
  57. end;
  58.  
  59. procedure TTimedProcess.CommandEvent(Sender, Context: TObject; Status: TRunCommandEventCode; const Message: string);
  60. begin
  61.   if Status = RunCommandIdle then
  62.   begin
  63.     if 24 * 60 * 60 * (Now - FStarted) > FTimeoutSeconds then
  64.     begin
  65.       FTimedOut := True;
  66.       FProcess.Terminate(255);
  67.       Exit;
  68.     end;
  69.     Sleep(FProcess.RunCommandSleepTime);
  70.   end;
  71. end;
  72.  
  73. end.

[Edited to add code tags :-]
« Last Edit: October 12, 2021, 08:27:01 am by trev »

 

TinyPortal © 2005-2018