PureBasic Forums - English

Posted: **Wed Aug 26, 2015 1:56 am**

Hi!

RunWithTimeout module helps to call procedures with a timeout, and to receive the returned value.

Run(*RProc, Timeout, Argument) - starts performance of the specified procedure with a timeout.
Wait(Info) - waits for end of RWT
Free(Info) - frees the used resources
LifeTime(Info) - returns time of performance of the called procedure
GetResult(Info) - returns the result of the called procedure
Below is an example of use.

This code was tested only for Windows 10 x64, but I will be glad if you help to optimize it for other OS.

Code: Select all

;======================================================================
; Module:          RunWithTimeout.pbi
;
; Author:          Grigory Lyapin (aka Gemorg)
; Date:            Aug 26, 2015
; Version:         0.1
; Target Compiler: PureBasic 5.3
; Target OS:       Windows
; License:         Free, unrestricted, no warranty whatsoever
;                  Use at your own risk
;======================================================================

CompilerIf #PB_Compiler_Thread = 0
  CompilerError "Requires multi-threading support!"
CompilerEndIf

CompilerIf #PB_Compiler_OS <> #PB_OS_Windows
  CompilerError "This code was tested only on Windows!"
CompilerEndIf

DeclareModule RWT
  Declare Run(*RProc, _Timeout.q = 0, _Argument.i = 0)
  Declare Wait(Info)
  Declare Free(Info)
  Declare LifeTime(Info)
  Declare GetResult(Info)
EndDeclareModule

Module RWT
  
  Structure RunWTInfo
    *RequiredProc
    Timeout.q
    Argument.i
    LeadThreadID.l
    ChildThreadID.l 
    StartTime.l
    EndTime.l
    Result.l
  EndStructure
  
  Procedure Free(*Info.RunWTInfo)
    ; Free() освобождает используемые ресурсы
    ; *Info - идентификатор RWT
    
    If IsThread(*Info\ChildThreadID) : KillThread(*Info\ChildThreadID) : EndIf
    If IsThread(*Info\LeadThreadID) : KillThread(*Info\LeadThreadID) : EndIf
    ClearStructure(*Info, RunWTInfo)
    FreeStructure(*Info)
  EndProcedure
  
  Procedure LeadThread(*Info.RunWTInfo)
    ; LeadThreadWT() для использования внутри модуля
    
    *Info\ChildThreadID = CreateThread(*Info\RequiredProc, *Info\Argument)
    Protected IsCThreadEnd = #False, ChildThreadExitCode.l = -1, ChildThreadHandle = ThreadID(*Info\ChildThreadID)
    Protected EndTime = ElapsedMilliseconds() + *Info\Timeout
    If *Info\ChildThreadID
      Repeat
        Delay(50)
        If IsThread(*Info\ChildThreadID) = #False
          If GetExitCodeThread_(ChildThreadHandle, @ChildThreadExitCode) <> 0
            *Info\Result = ChildThreadExitCode
          EndIf
          IsCThreadEnd = #True
        ElseIf ElapsedMilliseconds() >= EndTime And *Info\Timeout <> 0
          If IsThread(*Info\ChildThreadID) : KillThread(*Info\ChildThreadID) : EndIf
          IsCThreadEnd = #True
        Else
        EndIf
      Until IsCThreadEnd = #True
      *Info\EndTime = ElapsedMilliseconds()
    EndIf
    
  EndProcedure
  
  Procedure Run(*RProc, _Timeout.q = 0, _Argument.i = 0)
    ; RunWT() запускает выполнение указанной процедуры с таймаутом
    ; *RProc - Указатель на процедуру
    ; _Timeout - Таймаут в миллисекундах (если таймаут равен 0, то процедура будет выполнятся пока не завершится сама)
    ; _Argument - Аргумент передаваемый процедуре
    ; Возращаемое значение - идентификатор RWT, или 0 при ошибке
    
    Protected *Info.RunWTInfo = AllocateStructure(RunWTInfo)
    If *Info = 0 : ProcedureReturn 0 : EndIf
    *Info\Argument = _Argument
    *Info\Timeout = _Timeout
    *Info\RequiredProc = *RProc
    *Info\LeadThreadID = CreateThread(@LeadThread(), *Info)
    *Info\StartTime = ElapsedMilliseconds()
    *Info\EndTime = 0
    *Info\Result = -1
    If *Info\LeadThreadID
      ProcedureReturn *Info
    Else
      FreeStructure(*Info)
      ProcedureReturn 0
    EndIf
  EndProcedure
  
  Procedure Wait(*Info.RunWTInfo)
    ; Wait() ждет завершения RWT
    ; *Info - идентификатор RWT
    
    If IsThread(*Info\LeadThreadID)
      WaitThread(*Info\LeadThreadID)
    EndIf
    Delay(10)
  EndProcedure
  
  Procedure LifeTime(*Info.RunWTInfo)
    ; LifeTime() возвращает время выполнения вызываемой процедуры
    ; *Info - идентификатор RWT
    ; Возращаемое значение - время в мс. или -1 если процедура еще не завершилась
    
    If *Info\EndTime <> 0
      ProcedureReturn *Info\EndTime - *Info\StartTime
    Else
      ProcedureReturn -1
    EndIf
  EndProcedure
  
  Procedure GetResult(*Info.RunWTInfo)
    ; GetResult() возвращает результат выполнения вызываемой процедуры
    ; Результат или -1 в при ошибке
    
    ProcedureReturn *Info\Result 
  EndProcedure
  
EndModule

CompilerIf #PB_Compiler_IsMainFile
  
  Macro TestResult(_rwn)
    Select RWT::GetResult(_rwn)
      Case #PB_MessageRequester_Yes
        Debug "User clicked: Yes"
      Case #PB_MessageRequester_No
        Debug "User clicked: No"
      Case #PB_MessageRequester_Cancel
        Debug "User clicked: Cancel"
      Default
        Debug "The user made nothing"
    EndSelect
  EndMacro
  
  Procedure Test(*Arg)
    *Title.String = @*Arg
    ProcedureReturn MessageRequester("Timeout: " + *Title\s, "MessageRequester with timeout.", #PB_MessageRequester_YesNoCancel)
  EndProcedure
  
  rwt1 = RWT::Run(@Test(), 3000, @"3 sec") ; Create RWT
  rwt2 = RWT::Run(@Test(), 6000, @"6 sec")
  rwt3 = RWT::Run(@Test(), 9000, @"9 sec")
  
  RWT::Wait(rwt1) ; Wait for RWT end
  Debug "rwt1 stop after " + Str(RWT::LifeTime(rwt1)) + " ms." ; Display of lifetime RWT
  TestResult(rwt1)                                             ; Processing results
  RWT::Wait(rwt2)
  Debug "rwt2 stop after " + Str(RWT::LifeTime(rwt2)) + " ms."
  TestResult(rwt2)
  RWT::Wait(rwt3)
  Debug "rwt3 stop after " + Str(RWT::LifeTime(rwt3)) + " ms."
  TestResult(rwt3)
  
  RWT::Free(rwt1) ; Free RWT
  RWT::Free(rwt2)
  RWT::Free(rwt3)
  
CompilerEndIf

Sorry for my English

Posted: **Wed Aug 26, 2015 12:15 pm**

Works very well on W7

Thanks for sharing

PureBasic Forums - English

Execution of the procedure with a timeout (Module)

Execution of the procedure with a timeout (Module)

Re: Execution of the procedure with a timeout (Module)