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

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

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Routines to organize thread polling.                                       //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20010712 - Creation (uses CRW16) & test                                    //
// 20030330 - Struggle for safety (add some try/except checks)...             //
// 20030406 - FullPollingList, TPolling.Name, TPolling.GetCpuLoad             //
// 20030409 - Wdt = Watchdog timer                                            //
// 20050221 - Awake                                                           //
// 20050222 - AwakeFlag                                                       //
// 20050420 - Histogram                                                       //
// 20050428 - Priority class                                                  //
// 20061213 - ThreadHandle                                                    //
// 20190319 - FindPollingRefByName                                            //
// 20221103 - Add CoInitialize/CoUninitialize to TPolling.Execute to use COM  //
// 20221106 - CoIntializeBalanceCount,CoIntializeFailureCount                 //
// 20221115 - UseMsgPump; MessagePump in TPolling.Execute                     //
//            required for COM STA                                            //
// 20230518 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_polling; // Thread based polling via callback.

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, baseunix, {$ENDIF}
 {$IFDEF WINDOWS} windows, messages,  activex, {$ENDIF}
 sysutils, classes, contnrs, math, lcltype, lmessages, syncobjs,
 _crw_alloc, _crw_dynar, _crw_fifo, _crw_str, _crw_rtc, _crw_proc;

{$IFNDEF WINDOWS}
 ///////////////////////////////////////////////////////
 // Simulate some Windows stuff, just to simplify code …
 ///////////////////////////////////////////////////////
const
 INFINITE                        = High(DWORD);
 NORMAL_PRIORITY_CLASS           = $00000020;
 IDLE_PRIORITY_CLASS             = $00000040;
 HIGH_PRIORITY_CLASS             = $00000080;
 REALTIME_PRIORITY_CLASS         = $00000100;
{$ENDIF  WINDOWS}

 {
 *******************************************************************************
 TPolling periodically calls Action procedure to do something you need.
 Be carefully to write Action, do not forget, that this procedure executes in
 another thread.
 To do something in main VCL thread, call Polling.Syncronize, this procedure
 call aSynchro procedure. Use LonkXXX to transfer data to and from main VCL
 thread or keep any other info.
 *******************************************************************************
 }
type
 TPolling = class;
 TPollingAction = procedure(aPolling:TPolling; var Terminate:Boolean);
 TPolling = class(TLatch)
 private
  myThread     : TThread;
  myEnabled    : Boolean;
  myAction     : TPollingAction;
  myDelay      : Integer;
  myLinkObject : TObject;
  myLinkCustom : Pointer;
  myLinkText   : LongString;
  myLinkParam  : array[0..15] of Double;
  myLoopCount  : Int64;
  myLoopTime   : Int64;
  myLoopEvent  : TEvent;
  myWakeEvent  : TEvent;
  myAwakeFlag  : Boolean;
  myCpuLoad    : packed record
   LastTick    : DWORD;
   LastLoop    : Int64;
   LastKTime   : Int64;
   LastUTime   : Int64;
   Request     : SizeInt;
   LastSumm    : Double;
   LastKern    : Double;
   LastUser    : Double;
   LastFreq    : Double;
   LastResult  : SizeInt;
  end;
  myName       : LongString;
  myWdt        : packed record
   Flag        : Boolean;
   LastTick    : Cardinal;
  end;
  myHist       : record
   Time        : Int64;
   Data        : array[0..511] of Int64;
  end;
  myUseMsgPump : Boolean;
  myRedirected : String[3];
  function    GetName:LongString;
  function    GetThreadID:THandle;
  function    GetThreadHandle:THandle;
  function    GetEnabled:Boolean;
  procedure   SetEnabled(aEnabled:Boolean);
  function    GetUseMsgPump:Boolean;
  procedure   SetUseMsgPump(aUse:Boolean);
  function    GetDelay:Integer;
  procedure   SetDelay(aDelay:Integer);
  function    GetPriority:TThreadPriority;
  procedure   SetPriority(aPriority:TThreadPriority);
  function    GetLinkObject:TObject;
  procedure   SetLinkObject(aObject:TObject);
  function    GetLinkCustom:Pointer;
  procedure   SetLinkCustom(aCustom:Pointer);
  function    GetLinkText:LongString;
  procedure   SetLinkText(const aText:LongString);
  function    GetLinkParam(Index:Integer):Double;
  procedure   SetLinkParam(Index:Integer; aParam:Double);
  function    GetLoopCount:Int64;
  function    GetLoopTime:Int64;
  function    GetHistStep:Integer;
  function    GetHistSize:Integer;
  function    GetHistData(Index:Integer):Int64;
  procedure   Histogram(const aTime:Int64);
  procedure   ExecuteAction(var Terminate:Boolean);
 public
  constructor Create(aAction   : TPollingAction;
                     aDelay    : Integer         = 10;
                     aPriority : TThreadPriority = tpNormal;
                     aEnabled  : Boolean         = false;
                     aName     : LongString     = 'NONAME');
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 protected
  procedure   OnEnterThread; virtual;
  procedure   OnLeaveThread; virtual;
  procedure   OnPollingLoopBefore; virtual;
  procedure   OnPollingLoopAfter; virtual;
 public
  class function    DefMsgPump:Boolean;
  class procedure   SetDefMsgPump(aUse:Boolean);
  class function    DefRedirectStdIo:LongString;
  class procedure   SetDefRedirectStdIo(aStreams:LongString);
 public
  property    Name                 : LongString      read GetName;
  property    ThreadID             : THandle         read GetThreadID;
  property    ThreadHandle         : THandle         read GetThreadHandle;
  property    Enabled              : Boolean         read GetEnabled    write SetEnabled;
  property    UseMsgPump           : Boolean         read GetUseMsgPump write SetUseMsgPump;
  property    Delay                : Integer         read GetDelay      write SetDelay;
  property    Priority             : TThreadPriority read GetPriority   write SetPriority;
  property    LinkObject           : TObject         read GetLinkObject write SetLinkObject;
  property    LinkCustom           : Pointer         read GetLinkCustom write SetLinkCustom;
  property    LinkText             : LongString      read GetLinkText   write SetLinkText;
  property    LinkParam[i:Integer] : Double          read GetLinkParam  write SetLinkParam;
  property    LoopCount            : Int64           read GetLoopCount;
  property    LoopTime             : Int64           read GetLoopTime;
  property    HistStep             : Integer         read GetHistStep;
  property    HistSize             : Integer         read GetHistSize;
  property    HistData[i:Integer]  : Int64           read GetHistData;
  function    WaitForLoop(aTimeOut:DWORD=INFINITE):TWaitResult;
  function    Enable(aEnabled:Boolean; aTimeOut:DWORD=INFINITE):Boolean;
  function    GetCpuLoad(var Summ,Kern,User,Freq:Double):Boolean;
  function    WdtAlert(aWdt:Cardinal):Boolean;
  procedure   WdtReset;
  procedure   Awake;
  function    AwakeFlag:Boolean;
  procedure   HistClear;
 end;

function NewPolling(aAction   : TPollingAction;
                    aDelay    : Integer         = 10;
                    aPriority : TThreadPriority = tpNormal;
                    aEnabled  : Boolean         = false;
                    aName     : LongString      = 'NONAME'
                            ) : TPolling;
procedure Kill(var TheObject:TPolling); overload;

 //
 // Functions to get priority (by) name and to read Polling delay and priority
 // from ini -  file. For example, to read
 //     [System]
 //     UartPolling = 50, tpNormal
 // uses ReadIniFilePolling(SysIniFile,'[System]','UartPolling',Delay,Priority);
 //
function GetPriorityName(aPriority : TThreadPriority):LongString;
function GetPriorityByName(const aName:LongString; Def:TThreadPriority=tpNormal):TThreadPriority;
function ReadIniFilePolling(const IniFile,Section,Name:LongString;
                        var Delay:Integer; var Priority:TThreadPriority):Boolean;

 //
 // Functions to get priority class (by) name and to read priority class
 // from ini -  file. For example, to read
 //     [System]
 //     PriorityClass = RealTime, 100
 // uses ReadIniFilePriorityClass(SysIniFile,'[System]','PriorityClass',PriorityClass,CheckPeriod);
 // Priopity class table are:
 // Level  Class                   Name
 // 4      IDLE_PRIORITY_CLASS     'Idle'
 // 6      LOWER_PRIORITY_CLASS    'Lower'
 // 8      NORMAL_PRIORITY_CLASS   'Normal'
 // 10     HIGHER_PRIORITY_CLASS   'Higher'
 // 13     HIGH_PRIORITY_CLASS     'High'
 // 24     REALTIME_PRIORITY_CLASS 'RealTime'
 //
const
 LOWER_PRIORITY_CLASS  = $4000;     // Not defined in Windows.pas
 HIGHER_PRIORITY_CLASS = $8000;     // Not defined in Windows.pas
 WantedPriorityClass   : DWORD = 0; // Wanted priority class for this process
 PeriodPriorityClass   : DWORD = 0; // Period to check & force wanted priority

function GetPriorityClassLevel(aPriorityClass:DWORD):Integer;
function GetPriorityClassName(aPriorityClass:DWORD):LongString;
function GetPriorityClassByLevel(aLevel:Integer):DWORD;
function GetPriorityClassByName(const aName:LongString):DWORD;
function GetPriorityClassByNice(aNice:Integer):DWORD;
function GetAbsolutePriority(PriorityClass:DWORD; ThreadPriority:TThreadPriority):Integer;
function ReadIniFilePriorityClass(const IniFile,Section,Name:LongString;
                        var aPriorityClass:DWORD; var aPeriod:DWORD):Boolean;
procedure ForcePriorityClass(aWantedPriorityClass:DWORD; aPeriodPriorityClass:DWORD);
procedure CheckPriorityClass;

function FindPollingRefByName(const Name:LongString):Integer;

function FullPollingList:TObjectStorage;

implementation

uses _crw_fio;

const
 CoIntializeBalanceCount : Int64 = 0;
 CoIntializeFailureCount : Int64 = 0;

{$IFDEF UNIX}
 ///////////////////////////////////////////////////////
 // Simulate some Windows stuff, just to simplify code …
 ///////////////////////////////////////////////////////

function PeekMessage(var lpMsg:TMsg; Handle:HWND; wMsgFilterMin:UINT;
                     wMsgFilterMax:UINT; wRemoveMsg:UINT):Boolean; inline;
begin
 Result:=false;
end;

function DispatchMessage(const M:TMsg):LResult; inline;
begin
 Result:=0;
end;

function Succeeded(Res:HResult):Boolean;
begin
 Result:=((Res and $80000000)=0);
end;

function CoInitialize(pvReserved:Pointer):HResult; inline;
begin
 Result:=0;
end;

procedure CoUninitialize; inline;
begin
end;

type
 TFileTime=record dwLowDateTime,dwHighDateTime:DWORD; end;

 // Use getrusage on Linux to measure CPU Load.
 // Note that getrusage works only for calling thread.
function GetThreadTimes(aThread:THandle; var CT,ET,KT,UT:TFileTime):Boolean;
begin
 Int64(CT):=0; Int64(ET):=0; // Don`t need, ignored
 Result:=GetThreadTimesAsFileTime(Int64(KT),Int64(UT));
end;

function GetCurrentProcess:SizeInt;
begin
 Result:=GetProcessID;
end;

function GetPriorityClass(hProcess:THandle):DWORD;
var nice:Integer;
begin
 nice:=fpGetPriority(Prio_Process,hProcess);
 Result:=GetPriorityClassByNice(nice);
end;

function SetPriorityClass(hProcess:THandle; dwPriorityClass:DWORD): BOOL;
begin
 Result:=false;
end;
{$ENDIF  UNIX}

{$IFDEF SKIP_DRAFT}
TODO: PriorityClass on Linux
{$ENDIF SKIP_DRAFT}

 {
 *******************************************************************************
 TPollingThread implementation
 *******************************************************************************
 }
type
 TPollingThread = class(TThread)
 private
  myPolling : TPolling;
 public
  constructor Create(aPolling:TPolling);
  procedure   Execute; override;
 end;

constructor TPollingThread.Create(aPolling:TPolling);
begin
 inherited Create(true);
 myPolling:=aPolling;
end;

procedure TPollingThread.Execute;
var
 Term : Boolean;
 iCOM : Boolean;
 iMSG : Boolean;
 iWIN : Boolean;
 procedure CreateMessageQueue;
 var aMsg:TMsg;
 begin
  PeekMessage(aMsg,0,WM_USER,WM_USER,PM_NOREMOVE);
  iMSG:=true;
 end;
 procedure MessagePump; // Required for COM STA Marshaling
 var aMsg:TMsg;
 begin
  if not iWIN then Exit;
  if not iMSG then CreateMessageQueue;
  while PeekMessage(aMsg,0,0,0,PM_REMOVE) do DispatchMessage(aMsg);
 end;
begin
 try
  iMSG:=false;
  iWIN:=IsWindows;
  iCOM:=iWIN and Succeeded(CoInitialize(nil));
  try
   if iWIN then // COM is Windows only
   if iCOM then LockedInc(CoIntializeBalanceCount) else LockedInc(CoIntializeFailureCount);
   // Main Execution Loop
   myPolling.OnEnterThread;
   while not Terminated do
   try
    Term:=false;
    myPolling.WdtReset;
    myPolling.OnPollingLoopBefore;
    myPolling.ExecuteAction(Term);
    myPolling.OnPollingLoopAfter;
    if iWIN and myPolling.UseMsgPump then MessagePump;
    if Term then Terminate;
   except
    on E:Exception do BugReport(E,Self,'ExecuteLoop');
   end;
  finally
   if iCOM then CoUninitialize;
   if iCOM then LockedDec(CoIntializeBalanceCount);
   myPolling.OnLeaveThread;
  end;
 except
  on E:Exception do BugReport(E,Self,'Execute');
 end;
end;

 {
 *******************************************************************************
 TPolling implementation
 *******************************************************************************
 }
constructor TPolling.Create(aAction   : TPollingAction;
                            aDelay    : Integer         = 10;
                            aPriority : TThreadPriority = tpNormal;
                            aEnabled  : Boolean         = false;
                            aName     : LongString      = 'NONAME');
begin
 inherited Create;
 myThread:=TPollingThread.Create(Self);
 myEnabled:=aEnabled;
 myAction:=aAction;
 myThread.Priority:=aPriority;
 myDelay:=aDelay;
 myLinkObject:=nil;
 myLinkCustom:=nil;
 myLinkText:='';
 SafeFillChar(myLinkParam,sizeof(myLinkParam),0);
 myLoopCount:=0;
 myLoopTime:=0;
 myLoopEvent:=TEvent.Create(nil,True,False,'');
 myWakeEvent:=TEvent.Create(nil,False,False,'');
 myAwakeFlag:=false;
 myThread.Suspended:=false;
 SafeFillChar(myCpuLoad,sizeof(myCpuLoad),0);
 myName:=Trim(aName);
 myWdt.Flag:=false;
 myWdt.LastTick:=0;
 myUseMsgPump:=DefMsgPump and IsWindows;
 myRedirected:='';
 HistClear;
end;

destructor TPolling.Destroy;
begin
 Enabled:=false;
 myThread.Terminate;
 myThread.WaitFor;
 Kill(TObject(myThread));
 Kill(TObject(myLoopEvent));
 Kill(TObject(myWakeEvent));
 LinkText:=''; myName:='';
 myRedirected:='';
 inherited Destroy;
end;

procedure TPolling.AfterConstruction;
begin
 inherited AfterConstruction;
 FullPollingList.Add(Self);
end;

procedure TPolling.BeforeDestruction;
begin
 FullPollingList.Remove(Self);
 inherited BeforeDestruction;
end;

procedure TPolling.OnEnterThread;
var r,s:LongString;
begin
 myRedirected:=''; r:=RedirectedStdIo; s:=TPolling.DefRedirectStdIo;
 if HasChars(s,StdInpMarkers) and not HasChars(r,StdInpMarkers) then myRedirected:=myRedirected+StdInpMarker;
 if HasChars(s,StdOutMarkers) and not HasChars(r,StdOutMarkers) then myRedirected:=myRedirected+StdOutMarker;
 if HasChars(s,StdErrMarkers) and not HasChars(r,StdErrMarkers) then myRedirected:=myRedirected+StdErrMarker;
 if (myRedirected<>'') then RedirectStdIo(myRedirected,true);
end;

procedure TPolling.OnLeaveThread;
begin
 if (myRedirected<>'') then RedirectStdIo(myRedirected,false);
end;

procedure TPolling.OnPollingLoopBefore;
begin
end;

procedure TPolling.OnPollingLoopAfter;
var S,K,U,F:Double; R:SizeInt;
begin
 with myCpuLoad do
 if (LockedExchange(Request,0)<>0) then begin
  R:=Ord(GetCpuLoad(S,K,U,F));
  Lock;
  try
   LastSumm:=S;
   LastKern:=K;
   LastUser:=U;
   LastFreq:=F;
   LastResult:=R;
  finally
   Unlock;
  end;
 end;
end;

function TPolling.GetName:LongString;
begin
 if Assigned(Self) then Result:=myName else Result:='';
end;

function TPolling.GetThreadID:THandle;
begin
 if Assigned(Self) and Assigned(myThread)
 then Result:=myThread.ThreadID
 else Result:=0;
end;

function TPolling.GetThreadHandle:THandle;
begin
 if Assigned(Self) and Assigned(myThread)
 then Result:=myThread.Handle
 else Result:=0;
end;

function TPolling.GetEnabled:Boolean;
begin
 if Assigned(Self) then begin
  Lock;
  Result:=myEnabled;
  Unlock;
 end else Result:=false;
end;

procedure TPolling.SetEnabled(aEnabled:Boolean);
begin
 if Assigned(Self) then begin
  Lock;
  myEnabled:=aEnabled;
  myHist.Time:=0;
  Unlock;
 end;
end;

function TPolling.GetUseMsgPump:Boolean;
begin
 if (Self<>nil)
 then Result:=myUseMsgPump
 else Result:=false;
end;

procedure TPolling.SetUseMsgPump(aUse:Boolean);
begin
 // Message pumping is Windows only
 if (Self<>nil) then myUseMsgPump:=aUse and IsWindows;
end;

const TPollingDefMsgPump : Boolean = false;

class function TPolling.DefMsgPump:Boolean;
begin
 Result:=TPollingDefMsgPump;
end;

class procedure TPolling.SetDefMsgPump(aUse:Boolean);
begin
 // Message pumping is Windows only
 TPollingDefMsgPump:=aUse and IsWindows;
end;

const TPollingDefRedirectStdIo:String[3]=''; // '012' to redirect StdIn/Out/Err

class function TPolling.DefRedirectStdIo:LongString;
begin
 Result:=TPollingDefRedirectStdIo;
end;

class procedure TPolling.SetDefRedirectStdIo(aStreams:LongString);
var s:LongString;
begin
 s:='';
 if HasChars(aStreams,StdInpMarkers) then s:=s+StdInpMarker;
 if HasChars(aStreams,StdOutMarkers) then s:=s+StdOutMarker;
 if HasChars(aStreams,StdErrMarkers) then s:=s+StdErrMarker;
 TPollingDefRedirectStdIo:=s;
end;

function TPolling.GetDelay:Integer;
begin
 if Assigned(Self) then begin
  Lock;
  Result:=myDelay;
  Unlock;
 end else Result:=0;
end;

procedure TPolling.SetDelay(aDelay:Integer);
begin
 if Assigned(Self) then begin
  Lock;
  myDelay:=Max(1,aDelay);
  Unlock;
 end;
end;

function TPolling.GetPriority:TThreadPriority;
begin
 if Assigned(Self) and Assigned(myThread)
 then Result:=myThread.Priority
 else Result:=tpNormal;
end;

procedure TPolling.SetPriority(aPriority:TThreadPriority);
begin
 if Assigned(Self) and Assigned(myThread)
 then myThread.Priority:=aPriority;
end;

function TPolling.GetLinkObject:TObject;
begin
 if Assigned(Self) then Result:=myLinkObject else Result:=nil;
end;

procedure TPolling.SetLinkObject(aObject:TObject);
begin
 if Assigned(Self) then myLinkObject:=aObject;
end;

function TPolling.GetLinkCustom:Pointer;
begin
 if Assigned(Self) then Result:=myLinkCustom else Result:=nil;
end;

procedure TPolling.SetLinkCustom(aCustom:Pointer);
begin
 if Assigned(Self) then myLinkCustom:=aCustom;
end;

function TPolling.GetLinkText:LongString;
begin
 if Assigned(Self) then Result:=myLinkText else Result:='';
end;

procedure TPolling.SetLinkText(const aText:LongString);
begin
 if Assigned(Self) then myLinkText:=aText;
end;

function TPolling.GetLinkParam(Index:Integer):Double;
begin
 if Assigned(Self) and (Index>=Low(myLinkParam)) and (Index<=High(myLinkParam))
 then Result:=myLinkParam[Index]
 else Result:=0;
end;

procedure TPolling.SetLinkParam(Index:Integer; aParam:Double);
begin
 if Assigned(Self) and (Index>=Low(myLinkParam)) and (Index<=High(myLinkParam))
 then myLinkParam[Index]:=aParam;
end;

function TPolling.GetLoopCount:Int64;
begin
 if Assigned(Self) then begin
  Lock;
  Result:=myLoopCount;
  Unlock;
 end else Result:=0;
end;

function TPolling.GetLoopTime:Int64;
begin
 if Assigned(Self) then begin
  Lock;
  Result:=myLoopTime;
  Unlock;
 end else Result:=0;
end;

function TPolling.GetHistStep:Integer;
begin
 Result:=10;
end;

function TPolling.GetHistSize:Integer;
begin
 if Assigned(Self) then Result:=High(myHist.Data)-Low(myHist.Data)+1 else Result:=0;
end;

function TPolling.GetHistData(Index:Integer):Int64;
begin
 Result:=0;
 if Assigned(Self) then
 if Index>=Low(myHist.Data) then
 if Index<=High(myHist.Data) then begin
  Lock;
  Result:=myHist.Data[Index];
  Unlock;
 end;
end;

procedure TPolling.Histogram(const aTime:Int64);
var dt:Integer;
begin
 if Assigned(Self) then begin
  if myHist.Time<>0 then begin
   dt:=aTime-myHist.Time;
   dt:=dt div HistStep;
   if dt<Low(myHist.Data) then dt:=Low(myHist.Data);
   if dt>High(myHist.Data) then dt:=High(myHist.Data);
   inc(myHist.Data[dt]);
  end;
  myHist.Time:=aTime;
 end;
end;

procedure TPolling.HistClear;
begin
 if Assigned(Self) then begin
  Lock;
  SafeFillChar(myHist,SizeOf(myHist),0);
  Unlock;
 end;
end;

procedure TPolling.ExecuteAction(var Terminate:Boolean);
var
 aTime    : Int64;
 aDelay   : Integer;
 aEnabled : Boolean;
begin
 if Assigned(Self) then begin
  aDelay:=Delay;
  aEnabled:=Enabled;
  aTime:=IntMSecNow;
  if aEnabled and (@myAction<>nil) then
  try
   myAction(Self,Terminate);
  except
   on E:Exception do BugReport(E,Self);
  end;
  Lock;
  Histogram(aTime);
  inc(myLoopCount);
  myLoopTime:=aTime;
  Unlock;
  myLoopEvent.SetEvent;
  if aDelay>=0
  then myAwakeFlag:=(myWakeEvent.WaitFor(aDelay)=wrSignaled)
  else myAwakeFlag:=false;
 end;
end;

function TPolling.WaitForLoop(aTimeOut:DWORD=INFINITE):TWaitResult;
begin
 Result:=wrError;
 if Assigned(Self) then
 if Assigned(myThread) then
 if (GetCurrentThreadID <> myThread.ThreadID) then
 if not myThread.Suspended then begin
  myLoopEvent.ResetEvent;
  Awake;
  Result:=myLoopEvent.WaitFor(aTimeout);
 end;
end;

function TPolling.Enable(aEnabled:Boolean; aTimeOut:DWORD=INFINITE):Boolean;
begin
 Result:=false;
 if Assigned(Self) then begin
  Enabled:=aEnabled;
  Result:=(WaitForLoop(aTimeOut)=wrSignaled);
 end;
end;

function TPolling.GetCpuLoad(var Summ,Kern,User,Freq:Double):Boolean;
var
 CurrTick  : QWORD;
 CurrLoop  : Int64;
 CurrCTime : Int64;
 CurrETime : Int64;
 CurrKTime : Int64;
 CurrUTime : Int64;
begin
 Result:=false;
 Summ:=0;
 Kern:=0;
 User:=0;
 Freq:=0;
 try
  if Assigned(Self) and Assigned(myThread) then with myCpuLoad do begin
   if IsUnix and (GetCurrentThreadId<>myThread.ThreadID) then begin
    LockedExchange(Request,1);    // To call later in myThread context
    if (LastResult<>0) then begin // Take data from last request
     Lock;
     try
      Summ:=LastSumm; Kern:=LastKern;
      User:=LastUser; Freq:=LastFreq;
      Result:=(LastResult<>0);
     finally
      Unlock;
     end;
    end;
    Exit;
   end;
   CurrLoop:=myLoopCount;
   CurrTick:=GetTickCount64;
   if (CurrTick>LastTick) then begin
    CurrCTime:=0; CurrETime:=0; CurrKTime:=0; CurrUTime:=0;
    if GetThreadTimes(myThread.Handle,
                      TFileTime(CurrCTime),TFileTime(CurrETime),
                      TFileTime(CurrKTime),TFileTime(CurrUTime))
    then begin
     Kern:=Max(0,Min(100,0.01*(CurrKTime-LastKTime)/(CurrTick-LastTick)));
     User:=Max(0,Min(100,0.01*(CurrUTime-LastUTime)/(CurrTick-LastTick)));
     Summ:=Max(0,Min(100,Kern+User));
    end else begin
     CurrKTime:=0;
     CurrUTime:=0;
    end;
    Freq:=Max(0,1e3*(CurrLoop-LastLoop)/(CurrTick-LastTick));
   end;
   LastKTime:=CurrKTime;
   LastUTime:=CurrUTime;
   LastTick:=CurrTick;
   LastLoop:=CurrLoop;
   Result:=true;
  end;
 except
  on E:Exception do BugReport(E,Self,'GetCpuLoad');
 end;
end;

function TPolling.WdtAlert(aWdt:Cardinal):Boolean;
var
 CurrTick : QWord;
begin
 Result:=false;
 if aWdt>0 then
 if Assigned(Self) then begin
  CurrTick:=GetTickCount64;
  if myWdt.Flag then begin
   if CurrTick - myWdt.LastTick > aWdt then Result:=true;
  end else begin
   myWdt.Flag:=true;
   myWdt.LastTick:=CurrTick;
  end;
 end;
end;

procedure TPolling.WdtReset;
begin
 if Assigned(Self) then myWdt.Flag:=false;
end;

procedure TPolling.Awake;
begin
 if Assigned(Self) then myWakeEvent.SetEvent;
end;

function TPolling.AwakeFlag:Boolean;
begin
 if Assigned(Self) then Result:=myAwakeFlag else Result:=false;
end;

function NewPolling(aAction   : TPollingAction;
                    aDelay    : Integer         = 10;
                    aPriority : TThreadPriority = tpNormal;
                    aEnabled  : Boolean         = false;
                    aName     : LongString      = 'NONAME'
                            ) : TPolling;
begin
 Result:=nil;
 try
  Result:=TPolling.Create(aAction, aDelay, aPriority, aEnabled, aName);
 except
  on E:Exception do BugReport(E);
 end;
end;

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

function GetPriorityName(aPriority : TThreadPriority):LongString;
begin
 case aPriority of
  tpIdle         : Result:='tpIdle';
  tpLowest       : Result:='tpLowest';
  tpLower        : Result:='tpLower';
  tpNormal       : Result:='tpNormal';
  tpHigher       : Result:='tpHigher';
  tpHighest      : Result:='tpHighest';
  tpTimeCritical : Result:='tpTimeCritical';
  else             Result:='tpNormal';
 end;
end;

function GetPriorityByName(const aName:LongString; Def:TThreadPriority=tpNormal):TThreadPriority;
var
 tp : TThreadPriority;
begin
 Result:=Def;
 for tp:=Low(tp) to High(tp) do
 if SameText(aName,GetPriorityName(tp)) then begin
  Result:=tp;
  Break;
 end;
end;

function ReadIniFilePolling(const IniFile,Section,Name:LongString;
                        var Delay:Integer; var Priority:TThreadPriority):Boolean;
var
 Data : packed record
  D   : Integer;
  P   : ShortString;
 end;
begin
 Result:=false;
 if ReadIniFileVariable(IniFile,Section,UnifyAlias(Name)+'%i;%a',Data) then begin
  Delay:=Data.D;
  Priority:=GetPriorityByName(Data.P);
  Result:=true;
 end else begin
  Delay:=10;
  Priority:=tpNormal;
 end;
end;

const
 PriorityClassTable : array[0..5] of
  record prLevel,prNice:Integer; prClass:DWORD; prName:PChar end = (
  (prLevel:4;  prNice:15;  prClass:IDLE_PRIORITY_CLASS;     prName:'Idle'),
  (prLevel:6;  prNice:10;  prClass:LOWER_PRIORITY_CLASS;    prName:'Lower'),
  (prLevel:8;  prNice:0;   prClass:NORMAL_PRIORITY_CLASS;   prName:'Normal'),
  (prLevel:10; prNice:-5;  prClass:HIGHER_PRIORITY_CLASS;   prName:'Higher'),
  (prLevel:13; prNice:-10; prClass:HIGH_PRIORITY_CLASS;     prName:'High'),
  (prLevel:24; prNice:-15; prClass:REALTIME_PRIORITY_CLASS; prName:'RealTime')
  );

function GetPriorityClassLevel(aPriorityClass:DWORD):Integer;
var
 i : Integer;
begin
 Result:=0;
 for i:=Low(PriorityClassTable) to High(PriorityClassTable) do
 if aPriorityClass=PriorityClassTable[i].prClass then begin
  Result:=PriorityClassTable[i].prLevel;
  Exit;
 end;
end;

function GetPriorityClassName(aPriorityClass:DWORD):LongString;
var
 i : Integer;
begin
 Result:='';
 for i:=Low(PriorityClassTable) to High(PriorityClassTable) do
 if aPriorityClass=PriorityClassTable[i].prClass then begin
  Result:=PriorityClassTable[i].prName;
  Exit;
 end;
end;

function GetPriorityClassByLevel(aLevel:Integer):DWORD;
var
 i : Integer;
begin
 Result:=IDLE_PRIORITY_CLASS;
 for i:=Low(PriorityClassTable) to High(PriorityClassTable) do
 if aLevel>=PriorityClassTable[i].prLevel
 then Result:=PriorityClassTable[i].prClass
 else Exit;
end;

function GetPriorityClassByName(const aName:LongString):DWORD;
var
 i : Integer;
begin
 Result:=0;
 if not IsEmptyStr(aName) then
 if Str2Long(aName,i) then Result:=GetPriorityClassByLevel(i) else
 for i:=Low(PriorityClassTable) to High(PriorityClassTable) do
 if IsSameText(aName,PriorityClassTable[i].prName) then begin
  Result:=PriorityClassTable[i].prClass;
  Exit;
 end;
end;

function GetPriorityClassByNice(aNice:Integer):DWORD;
var
 i : Integer;
begin
 Result:=IDLE_PRIORITY_CLASS;
 for i:=Low(PriorityClassTable) to High(PriorityClassTable) do
 if aNice>=-PriorityClassTable[i].prNice
 then Result:=PriorityClassTable[i].prClass
 else Exit;
end;

function GetAbsolutePriority(PriorityClass:DWORD; ThreadPriority:TThreadPriority):Integer;
var pmin,pmax,pri:Integer;
begin
 Result:=0;
 pri:=GetPriorityClassLevel(PriorityClass);
 if pri>0 then begin
  if pri<16 then begin
   pmin:=1; pmax:=15;
  end else begin
   pmin:=16; pmax:=31;
  end;
  case ThreadPriority of
   tpIdle         : Result:=pmin;
   tpLowest       : Result:=pri-2;
   tpLower        : Result:=pri-1;
   tpNormal       : Result:=pri;
   tpHigher       : Result:=pri+1;
   tpHighest      : Result:=pri+2;
   tpTimeCritical : Result:=pmax;
  end;
  if Result<pmin then Result:=pmin;
  if Result>pmax then Result:=pmax;
 end;
end;

function ReadIniFilePriorityClass(const IniFile,Section,Name:LongString;
                        var aPriorityClass:DWORD; var aPeriod:DWORD):Boolean;
var
 Data : packed record
  p   : ShortString;
  t   : Integer;
 end;
begin
 Result:=false;
 Data.p:='';
 Data.t:=0;
 ReadIniFileVariable(IniFile,Section,UnifyAlias(Name)+'%a;%i',Data);
 aPriorityClass:=GetPriorityClassByName(Data.p);
 if aPriorityClass>0 then begin
  aPeriod:=Data.t;
  Result:=true;
 end else begin
  aPriorityClass:=0;
  aPeriod:=0;
 end;
end;

procedure ForcePriorityClass(aWantedPriorityClass:DWORD; aPeriodPriorityClass:DWORD);
var
 hProcess : THandle;
begin
 try
  WantedPriorityClass:=aWantedPriorityClass;
  PeriodPriorityClass:=aPeriodPriorityClass;
  if WantedPriorityClass>0 then
  if GetPriorityClassLevel(WantedPriorityClass)>0 then begin
   hProcess:=GetCurrentProcess;
   if GetPriorityClass(hProcess)<>WantedPriorityClass
   then SetPriorityClass(hProcess,WantedPriorityClass);
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure CheckPriorityClass;
const
 LastCheck : Cardinal = 0;
var
 hProcess  : THandle;
 TickCount : Cardinal;
begin
 try
  if PeriodPriorityClass>0 then
  if WantedPriorityClass>0 then begin
   TickCount:=GetTickCount;
   if TickCount-LastCheck>PeriodPriorityClass then begin
    if GetPriorityClassLevel(WantedPriorityClass)>0 then begin
     hProcess:=GetCurrentProcess;
     if GetPriorityClass(hProcess)<>WantedPriorityClass
     then SetPriorityClass(hProcess,WantedPriorityClass);
    end;
    LastCheck:=TickCount;
   end;
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

type TPollingFindRec=packed record RefToFind:Integer; NameToFind:ShortString; end;
procedure PollingFind(Index:LongInt; const aObject:TObject; var Terminate:Boolean; CustomData:Pointer);
begin
 if aObject is TPolling then with aObject as TPolling do
 if Assigned(CustomData) then with TPollingFindRec(CustomData^) do
 if SameText(Name,NameToFind) then begin
  Terminate:=true;
  RefToFind:=Ref;
 end;
end;

function FindPollingRefByName(const Name:LongString):Integer;
var PFR:TPollingFindRec;
begin
 Result:=0;
 if not IsEmptyStr(Name) then begin
  PFR.RefToFind:=0;
  PFR.NameToFind:=Name;
  FullPollingList.ForEach(PollingFind,@PFR);
  Result:=PFR.RefToFind;
 end;
end;

const
 TheFullPollingList : TObjectStorage = nil;

function FullPollingList:TObjectStorage;
begin
 Result:=TheFullPollingList;
end;

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

procedure Init_crw_polling;
begin
 TheFullPollingList:=NewObjectStorage(false);
 TheFullPollingList.Master:=@TheFullPollingList;
 TheFullPollingList.OwnsObjects:=false;
end;

procedure Free_crw_polling;
begin
 ResourceLeakageLog(Format('%-60s = %d',['FullPollingList.Count', TheFullPollingList.Count]));
 Kill(TheFullPollingList);
 ResourceLeakageLog(Format('%-60s = %d',['TPolling.CoIntializeBalance.Count', CoIntializeBalanceCount]));
 ResourceLeakageLog(Format('%-60s = %d',['TPolling.CoIntializeFailure.Count', CoIntializeFailureCount]));
end;

initialization

 Init_crw_polling;

finalization

 Free_crw_polling;

end.

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

