////////////////////////////////////////////////////////////////////////////////
// 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.)                                         //
// 20230919 - Applied FPC Linux thread get/setpriority                        //
// 20230929 - Fix some thread get/setpriority bugs                            //
////////////////////////////////////////////////////////////////////////////////

unit _crw_polling; // Thread based polling via callback.

{$I _crw_sysdef}

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

{$WARN 5023 off : Unit "$1" not used in $2}

interface

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

const // Infinite waiting time …
 INFINITE = syncobjs.INFINITE; // = Cardinal(-1) = High(Cardinal) = $FFFFFFFF;

 {
 *******************************************************************************
 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 LinkXXX 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;
  myPriority   : TThreadPriority;
  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];
  myTid        : TPid;            // PID-like thread ID, see FpGetTid.
  function    GetName:LongString;
  function    GetTid:TPid;
  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    Tid                  : TPid            read GetTid;
  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    SyncLoop(aTimeOut:Integer; aNum:Integer):Int64;
  function    WaitForLoop(aTimeOut:DWORD=INFINITE):TWaitResult;
  function    Enable(aEnabled:Boolean; aTimeOut:DWORD=INFINITE):Boolean;
  function    GetCpuLoad(out 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;

const
 MinPollingPrioTimeout           = 0;    // Minimal timeout on ThreadSetPriority
 MaxPollingPrioTimeout           = 1000; // Maximal timeout on ThreadSetPriority
 DefPollingPrioTimeout : Integer = 100;  // Default timeout on ThreadSetPriority

 ///////////////////////////////////////////////////////////////////////////////
 // Process and Thread Priority manipulation functions.
 // Terminology:
 //  ProcessPriority - FPC logic process priority as TProcessPriority type.
 //  ThreadPriority  - FPC logic thread  priority as TThreadPriority  type.
 //  Priority Level  - Windows user-space absolute priority level [1..31].
 //  Priority Class  - Windows API flags uses to identify process priorities.
 //  Unix nice       - Unix nice value [-20..19] uses for SCHED_OTHER threads.
 //  Unix RLimit     - Unix rlimit=(20-nice) in [1..40] uses in some Unix API.
 //  Unix prio       - Unix absolute priority [0..140]. The values of prio are
 //                    inversed (lower prio corresponds to higher priorities).
 //                    Range [1..99]: uses for realtime threads SCHED_FIFO/RR.
 //                    Range [100..139]: uses for ordinary (SCHED_OTHER/BATCH)
 //                    threads with prio=(120+nice).
 ///////////////////////////////////////////////////////////////////////////////

const // Define some Windows stuff, just to simplify cross platform code …
 IDLE_PRIORITY_CLASS         = $00000040;   // Idle
 LOWER_PRIORITY_CLASS        = $00004000;   // Lower  Synonym
 BELOW_NORMAL_PRIORITY_CLASS = $00004000;   // Lower  General
 NORMAL_PRIORITY_CLASS       = $00000020;   // Normal
 ABOVE_NORMAL_PRIORITY_CLASS = $00008000;   // Higher General
 HIGHER_PRIORITY_CLASS       = $00008000;   // Higher Synonym
 HIGH_PRIORITY_CLASS         = $00000080;   // High
 REALTIME_PRIORITY_CLASS     = $00000100;   // RealTime
 PRIORITY_CLASS_MASK         = IDLE_PRIORITY_CLASS
                            or BELOW_NORMAL_PRIORITY_CLASS
                            or NORMAL_PRIORITY_CLASS
                            or ABOVE_NORMAL_PRIORITY_CLASS
                            or HIGH_PRIORITY_CLASS
                            or REALTIME_PRIORITY_CLASS;
 ProcessPriorityNamesList    = 'High,Idle,Normal,RealTime,Lower,Higher';
 ProcessPriorityNamesOrder   = 'Idle,Lower,Normal,Higher,High,RealTime';
 ThreadPiorityNamesList      = 'tpIdle,tpLowest,tpLower,tpNormal,tpHigher,tpHighest,tpTimeCritical';

const // Windows priority levels. Better use ProcessPriorityToLevel(..).
 NONE_PRIORITY_LEVEL         = 0;  // Reserved for system idle thread.
 IDLE_PRIORITY_LEVEL         = 4;  // Idle
 LOWER_PRIORITY_LEVEL        = 6;  // Lower
 NORMAL_PRIORITY_LEVEL       = 8;  // Normal
 HIGHER_PRIORITY_LEVEL       = 10; // Higher
 HIGH_PRIORITY_LEVEL         = 13; // High
 REALTIME_PRIORITY_LEVEL     = 24; // RealTime
 MIN_NORMAL_PRIORITY_LEVEL   = 1;  // Low  limit for normal   threads
 MAX_NORMAL_PRIORITY_LEVEL   = 15; // High limit for normal   threads
 MIN_REALTIME_PRIORITY_LEVEL = 16; // Low limit  for realtime threads
 MAX_REALTIME_PRIORITY_LEVEL = 31; // High limit for realtime threads

type // Type for table of Process/Thread priorities
 TThreadPriorityArray = array[TThreadPriority] of Integer;
 TThreadPriorityTable = array[TProcessPriority] of TThreadPriorityArray;
 TThreadPriorityFunct = function(pp:TProcessPriority;tp:TThreadPriority;def:Integer):Integer;

 {
 Convert process priority to string (name).
 Return (Idle,Lower,Normal,Higher,High,RealTime).
 }
function ProcessPriorityToString(pp:TProcessPriority):LongString;

 {
 Convert thread priority to string (name).
 Return (tpIdle,tpLowest,tpLower,tpNormal,tpHigher,tpHighest,tpTimeCritical).
 }
function ThreadPriorityToString(tp:TThreadPriority):LongString;

 { Convert process/thread priority to string (name). }
function GetPriorityName(pp:TProcessPriority):LongString; overload;
function GetPriorityName(tp:TThreadPriority):LongString; overload;

 {
 Convert string (name) to process priority or return default.
 }
function StringToProcessPriority(const aName:LongString; Def:TProcessPriority=ppNormal):TProcessPriority;

 {
 Convert string (name) to thread priority or return default.
 }
function StringToThreadPriority(const aName:LongString; Def:TThreadPriority=tpNormal):TThreadPriority;
function GetPriorityByName(const aName:LongString; Def:TThreadPriority=tpNormal):TThreadPriority;

 { Windows: Convert Process\Thread Priority to Priority level [1..31]. }
function WindowsPriorityToLevel(pp:TProcessPriority; tp:TThreadPriority; def:Integer=0):Integer;

 { Unix: Convert SHED_OTHER policy priority to rlimit value [1..40]. }
function SchedOtherPriorityToRLimit(pp:TProcessPriority; tp:TThreadPriority; def:Integer=0):Integer;

 { Unix: Convert SHED_OTHER policy priority to nice value value [-20..19]. }
function SchedOtherPriorityToNice(pp:TProcessPriority; tp:TThreadPriority; def:Integer=0):Integer;

 { Get table of priorities as text string. }
function PriorityTableAsText(Table:TThreadPriorityFunct; def:Integer=0):LongString;

 { Convert FPC ProcessPriority to Windows PriorityClass. }
function ProcessPriorityToClass(pp:TProcessPriority):Cardinal;

 { Convert Windows PriorityClass to FPC ProcessPriority. }
function ClassToProcessPriority(pc:Cardinal):TProcessPriority;

 { Convert process priority to nice vaalue. }
function ProcessPriorityToNice(pp:TProcessPriority):Integer;

 { Convert NICE value to process priority. }
function NiceToProcessPriority(n:Integer):TProcessPriority;

 { Convert NICE value to priority class. }
function GetPriorityClassByNice(aNice:Integer):DWORD;

 { Get priority of process (pid), default is current. }
function GetProcessPriority(pid:TPid=0):TProcessPriority;

 //
 // 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 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
 WantedPriorityClass   : DWORD = 0; // Wanted priority class for this process
 PeriodPriorityClass   : DWORD = 0; // Period to check & force wanted priority

 { Windows: Convert ProcessPriority to level [1..31]. }
function ProcessPriorityToLevel(pp:TProcessPriority):Integer;

 { Windows: Convert PriorityClass to level [1..31]. }
function GetPriorityClassLevel(aPriorityClass:DWORD):Integer;

 { Windows: Convert PriorityClass to string (name). }
function GetPriorityClassName(aPriorityClass:DWORD):LongString;

 { Windows: Get ProcessPriority by Level. }
function LevelToProcessPriority(aLevel:Integer):TProcessPriority;
function GetProcessPriorityByLevel(aLevel:Integer):TProcessPriority;

{ Windows: Get PriorityClass by level. }
function GetPriorityClassByLevel(aLevel:Integer):DWORD;

 { Windows: Get PriorityClass by name. }
function GetPriorityClassByName(const aName:LongString):DWORD;

 { Obsolete. Use WindowsPriorityToLevel(ClassToProcessPriority(*),*). }
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 ForceProcessPriority(aWantedPriority:TProcessPriority; aPollPeriod:DWORD);
procedure CheckPriorityClass; // Uses with SecondActions polling.

{$IFDEF UNIX}
function GetCurrentProcess:THandle;
function SetPriorityClass(hProcess:THandle; dwPriorityClass:DWORD): BOOL;
{$ENDIF ~UNIX}

 {
 Set current process priority according to current priority table.
 }
function SetCurrentProcessPriority(pp:TProcessPriority):Boolean;

 { Find polling object by name. }
function FindPollingRefByName(const Name:LongString):Integer;

 { Find polling object by ThreadID. }
function FindPollingByThreadID(ThreadId:THandle):TPolling;

 {
 Full list of all TPolling objects.
 }
function FullPollingList:TObjectStorage;

implementation

uses _crw_fio;

const
 CoIntializeBalanceCount : SizeInt = 0;
 CoIntializeFailureCount : SizeInt = 0;

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

function PeekMessage(out 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:THandle;
begin
 Result:=GetCurrentProcessID; // On Unix PID is same as process handle.
end;

function GetPriorityClass(hProcess:THandle):DWORD;
var nice:Integer; pp:TProcessPriority;
begin
 nice:=GetProcessNice(hProcess);
 pp:=NiceToProcessPriority(nice);
 Result:=ProcessPriorityToClass(pp);
end;

function SetPriorityClass(hProcess:THandle; dwPriorityClass:DWORD):BOOL;
var nice:Integer; pp:TProcessPriority;
begin
 pp:=ClassToProcessPriority(dwPriorityClass);
 nice:=ProcessPriorityToNice(pp);
 Result:=SetProcessNice(nice,hProcess);
end;
{$ENDIF  UNIX}

function SetCurrentProcessPriority(pp:TProcessPriority):Boolean;
var pClass:DWORD;
begin
 pClass:=ProcessPriorityToClass(pp);
 Result:=SetPriorityClass(GetCurrentProcess,pClass);
end;

{$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:{$IFDEF WINDOWS}Windows.{$ENDIF}TMsg;
 begin
  SafeFillChar(aMsg,SizeOf(aMsg),0);
  PeekMessage(aMsg,0,WM_USER,WM_USER,PM_NOREMOVE);
  iMSG:=true;
 end;
 procedure MessagePump; // Required for COM STA Marshaling
 var aMsg:{$IFDEF WINDOWS}Windows.{$ENDIF}TMsg;
 begin
  if not iWIN then Exit;
  SafeFillChar(aMsg,SizeOf(aMsg),0);
  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;
 myPriority:=aPriority;
 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);
 if IsUnix then Priority:=myPriority; // Required for uses ThreadManager
end;

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

procedure TPolling.OnEnterThread;
var r,s:LongString;
begin
 myTid:=FpGetTid;
 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.GetTid:TPid;
begin
 if Assigned(Self)
 then Result:=myTid
 else Result:=0;
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 Assigned(Self)
 then Result:=myUseMsgPump
 else Result:=false;
end;

procedure TPolling.SetUseMsgPump(aUse:Boolean);
begin
 // Message pumping is Windows only
 if Assigned(Self) 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 Result:=LockedGet(myDelay)
 else Result:=0;
end;

procedure TPolling.SetDelay(aDelay:Integer);
begin
 if Assigned(Self)
 then LockedSet(myDelay,Max(1,aDelay));
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) then begin
  if Assigned(myThread) then myThread.Priority:=aPriority;
  myPriority:=aPriority;
 end;
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 Assigned(myAction) then
  try
   myAction(Self,Terminate);
  except
   on E:Exception do BugReport(E,Self,'ExecuteAction');
  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.SyncLoop(aTimeOut:Integer; aNum:Integer):Int64;
begin
 Result:=0;
 if Assigned(Self) then begin
  if (aTimeOut>0) then
  while (aNum>0) do begin
   Awake; Dec(aNum);
   WaitForLoop(aTimeOut);
  end;
  Result:=LoopCount;
 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(out 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,nil,'NewPolling');
 end;
end;

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

 //////////////////////////////////////////////////////
 // Process and Thread Priority manipulation functions.
 //////////////////////////////////////////////////////

function ProcessPriorityToString(pp:TProcessPriority):LongString;
begin
 case pp of
  ppIdle         : Result:='Idle';
  ppBelowNormal  : Result:='Lower';
  ppNormal       : Result:='Normal';
  ppAboveNormal  : Result:='Higher';
  ppHigh         : Result:='High';
  ppRealTime     : Result:='RealTime';
  else             Result:='Normal';
 end;
end;

function ThreadPriorityToString(tp:TThreadPriority):LongString;
begin
 case tp 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 GetPriorityName(pp:TProcessPriority):LongString;
begin
 Result:=ProcessPriorityToString(pp);
end;

function GetPriorityName(tp:TThreadPriority):LongString;
begin
 Result:=ThreadPriorityToString(tp);
end;

function StringToProcessPriority(const aName:LongString; Def:TProcessPriority=ppNormal):TProcessPriority;
var pp:TProcessPriority;
begin
 Result:=Def;
 for pp:=Low(pp) to High(pp) do
 if SameText(aName,GetPriorityName(pp)) then begin
  Result:=pp;
  Break;
 end;
end;

function StringToThreadPriority(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 GetPriorityByName(const aName:LongString; Def:TThreadPriority=tpNormal):TThreadPriority;
begin
 Result:=StringToThreadPriority(aName,Def);
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;
 Data.D:=10; Data.P:='';
 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;

 ///////////////////////////////////////////////////////////////////////////////
 // Source: Operating system concepts, 9th edition, A.Silberschatz, 2012
 //         Figure 6.22 Windows thread priorities.
 ///////////////////////////////////////////////////////////////////////////////
 //        /Process  Real    High    Above    Normal    Below   Idle
 // Thread/          Time            Normal             Normal
 // tpTimeCritical   31      15      15       15        15      15
 // tpHighest        26      15      12       10        8       6
 // tpHigher         25      14      11       9         7       5
 // tpNormal         24      13      10       8         6       4
 // tpLower          23      12      9        7         5       3
 // tpLowest         22      11      8        6         4       2
 // tpIdle           16      1       1        1         1       1
 ///////////////////////////////////////////////////////////////////////////////
const WindowsThreadPriorities:TThreadPriorityTable            //
 = ( (   1,    11,   12,    13,    14,     15,        15 ),   // ppHigh
     (   1,     2,    3,     4,     5,      6,        15 ),   // ppIdle
     (   1,     6,    7,     8,     9,     10,        15 ),   // ppNormal
     (  16,    22,   23,    24,    25,     26,        31 ),   // ppRealTime
     (   1,     4,    5,     6,     7,      8,        15 ),   // ppBelowNormal
     (   1,     8,    9,    10,    11,     12,        15 ) ); // ppAboveNormal
 ///// Idle Lowest Lower Normal Higher Highest TimeCritical   //////////////////
 ///////////////////////////////////////////////////////////////////////////////
var SchedOtherRLimits:TThreadPriorityTable; // RLimit values for SCHED_OTHER

const // Process priority order list.
 ppOrder:array[0..5] of TProcessPriority=
 (ppIdle,ppBelowNormal,ppNormal,ppAboveNormal,ppHigh,ppRealTime);

function ExtractThreadPriorities(const Table:TThreadPriorityTable;
                pp:TProcessPriority; tp:TThreadPriority; def:Integer=0):Integer;
begin
 Result:=def;
 if InRange(Ord(pp),Ord(Low(pp)),Ord(High(pp))) then
 if InRange(Ord(tp),Ord(Low(tp)),Ord(High(tp))) then
 Result:=Table[pp][tp];
end;

function WindowsPriorityToLevel(pp:TProcessPriority; tp:TThreadPriority; def:Integer=0):Integer;
begin
 Result:=ExtractThreadPriorities(WindowsThreadPriorities,pp,tp,def);
end;

function SchedOtherPriorityToRLimit(pp:TProcessPriority; tp:TThreadPriority; def:Integer=0):Integer;
begin
 Result:=ExtractThreadPriorities(SchedOtherRLimits,pp,tp,def);
end;

function SchedOtherPriorityToNice(pp:TProcessPriority; tp:TThreadPriority; def:Integer=0):Integer;
begin
 Result:=ExtractThreadPriorities(SchedOtherRLimits,pp,tp,def);
 Result:=rlimit_to_nice(Result);
end;

procedure InitPriorityTables;
var dp:Integer;
 procedure InitTab(var Tab:TThreadPriorityTable; tp:TThreadPriority; p0,p1,p2,p3,p4,p5:Integer);
 var i:Integer; pv:array[0..5] of Integer;
 begin
  pv[0]:=p0; pv[1]:=p1; pv[2]:=p2; pv[3]:=p3; pv[4]:=p4; pv[5]:=p5;
  if (tp=tpNormal)
  then for i:=0 to 5 do Tab[ppOrder[i]][tp]:=pv[i]
  else for i:=0 to 5 do Tab[ppOrder[i]][tp]:=Tab[ppOrder[i]][tpNormal]+pv[i];
 end;
 procedure FixTab(var Tab:TThreadPriorityTable; pMin,pMax:Integer);
 var pp:TProcessPriority; tp:TThreadPriority;
 begin
  for pp:=Low(pp) to High(pp) do
  for tp:=Low(tp) to High(tp) do
  Tab[pp][tp]:=EnsureRange(Tab[pp][tp],pMin,pMax);
 end;
begin
 InitTab(SchedOtherRLimits,tpNormal,5,10,20,25,30,35);
 dp:=-1;        InitTab(SchedOtherRLimits,tpLower,dp,dp,dp,dp,dp,dp);
 dp:=+1;        InitTab(SchedOtherRLimits,tpHigher,dp,dp,dp,dp,dp,dp);
 dp:=-2;        InitTab(SchedOtherRLimits,tpLowest,dp,dp,dp,dp,dp,dp);
 dp:=+2;        InitTab(SchedOtherRLimits,tpHighest,dp,dp,dp,dp,dp,dp);
 dp:=-MAX_NICE; InitTab(SchedOtherRLimits,tpIdle,dp,dp,dp,dp,dp,dp);
 dp:=-MIN_NICE; InitTab(SchedOtherRLimits,tpTimeCritical,dp,dp,dp,dp,dp,dp);
 FixTab(SchedOtherRLimits,nice_to_rlimit(MAX_NICE),nice_to_rlimit(MIN_NICE));
end;

function PriorityTableAsText(Table:TThreadPriorityFunct; def:Integer=0):LongString;
 function GetLine(pp:TProcessPriority):LongString;
 var tp:TThreadPriority;
 begin
  Result:=Pad(ProcessPriorityToString(pp),8);
  for tp:=Low(tp) to High(tp) do
  Result:=Result+' '+LeftPad(IntToStr(Table(pp,tp,def)),5);
 end;
begin
 Result:='';
 if Assigned(Table) then
 try
  Result:=Result+GetLine(ppIdle)+EOL;
  Result:=Result+GetLine(ppBelowNormal)+EOL;
  Result:=Result+GetLine(ppNormal)+EOL;
  Result:=Result+GetLine(ppAboveNormal)+EOL;
  Result:=Result+GetLine(ppHigh)+EOL;
  Result:=Result+GetLine(ppRealTime)+EOL;
 except
  on E:Exception do BugReport(E,nil,'PriorityTableAsString');
 end;
end;

function ProcessPriorityToClass(pp:TProcessPriority):Cardinal;
begin
 case pp of
  ppHigh:        Result:=HIGH_PRIORITY_CLASS;
  ppIdle:        Result:=IDLE_PRIORITY_CLASS;
  ppNormal:      Result:=NORMAL_PRIORITY_CLASS;
  ppRealTime:    Result:=REALTIME_PRIORITY_CLASS;
  ppBelowNormal: Result:=BELOW_NORMAL_PRIORITY_CLASS;
  ppAboveNormal: Result:=ABOVE_NORMAL_PRIORITY_CLASS;
  else           Result:=NORMAL_PRIORITY_CLASS;
 end;
end;

function ClassToProcessPriority(pc:Cardinal):TProcessPriority;
begin
 case (pc and PRIORITY_CLASS_MASK) of
  HIGH_PRIORITY_CLASS:         Result:=ppHigh;
  IDLE_PRIORITY_CLASS:         Result:=ppIdle;
  NORMAL_PRIORITY_CLASS:       Result:=ppNormal;
  REALTIME_PRIORITY_CLASS:     Result:=ppRealTime;
  BELOW_NORMAL_PRIORITY_CLASS: Result:=ppBelowNormal;
  ABOVE_NORMAL_PRIORITY_CLASS: Result:=ppAboveNormal;
  else                         Result:=ppNormal;
 end;
end;

function ProcessPriorityToNice(pp:TProcessPriority):Integer;
begin
 Result:=SchedOtherPriorityToNice(pp,tpNormal,0);
end;

function NiceToProcessPriority(n:Integer):TProcessPriority;
const nn:array[0..5] of Integer=(0,0,0,0,0,0);
begin
 n:=EnsureRange(n,MIN_NICE,MAX_NICE);
 if (nn[0]=0) then begin
  nn[0]:=ProcessPriorityToNice(ppIdle);
  nn[1]:=ProcessPriorityToNice(ppBelowNormal);
  nn[2]:=ProcessPriorityToNice(ppNormal);
  nn[3]:=ProcessPriorityToNice(ppAboveNormal);
  nn[4]:=ProcessPriorityToNice(ppHigh);
  nn[5]:=ProcessPriorityToNice(ppRealtime);
 end;
 case Sign(n-nn[2]) of
  0:   Result:=ppNormal;
  +1:  begin
        Result:=ppBelowNormal;
        if (n>nn[1]) then Result:=ppIdle;
       end;
  -1:  begin
        Result:=ppAboveNormal;
        if (n<=nn[4]) then Result:=ppHigh;
        if (n<=nn[5]) then Result:=ppRealtime;
       end;
  else Result:=ppNormal;
 end;
end;

function GetPriorityClassByNice(aNice:Integer):DWORD;
begin
 Result:=ProcessPriorityToClass(NiceToProcessPriority(aNice));
end;

{$IFDEF WINDOWS}
function GetProcessPriority(pid:TPid=0):TProcessPriority;
var hProc:THandle; pClass:DWORD;
begin
 if (pid<>0) and (pid<>GetCurrentProcessId)
 then hProc:=OpenProcess(PROCESS_QUERY_INFORMATION,false,pid)
 else hProc:=GetCurrentProcess;
 pClass:=GetPriorityClass(hProc);
 Result:=ClassToProcessPriority(pClass);
 if (hProc<>GetCurrentProcess) then CloseHandle(hProc);
end;
{$ENDIF ~WINDOWS}
{$IFDEF UNIX}
function GetProcessPriority(pid:TPid=0):TProcessPriority;
var nice:Integer;
begin
 nice:=GetProcessNice(pid);
 Result:=NiceToProcessPriority(nice);
end;
{$ENDIF ~UNIX}

function ProcessPriorityToLevel(pp:TProcessPriority):Integer;
begin
 Result:=WindowsPriorityToLevel(pp,tpNormal);
end;

function GetPriorityClassLevel(aPriorityClass:DWORD):Integer;
begin
 Result:=ProcessPriorityToLevel(ClassToProcessPriority(aPriorityClass));
end;

function GetPriorityClassName(aPriorityClass:DWORD):LongString;
begin
 Result:=ProcessPriorityToString(ClassToProcessPriority(aPriorityClass));
end;

function LevelToProcessPriority(aLevel:Integer):TProcessPriority;
const nn:array[0..5] of Integer=(0,0,0,0,0,0); var n:Integer;
begin
 n:=EnsureRange(aLevel,1,31);
 if (nn[0]=0) then begin
  nn[0]:=ProcessPriorityToLevel(ppIdle);
  nn[1]:=ProcessPriorityToLevel(ppBelowNormal);
  nn[2]:=ProcessPriorityToLevel(ppNormal);
  nn[3]:=ProcessPriorityToLevel(ppAboveNormal);
  nn[4]:=ProcessPriorityToLevel(ppHigh);
  nn[5]:=ProcessPriorityToLevel(ppRealtime);
  nn[5]:=16; // Realtime threads level >=16.
 end;
 case Sign(n-nn[2]) of
  0:   Result:=ppNormal;
  -1:  begin
        Result:=ppBelowNormal;
        if (n<=nn[0]) then Result:=ppIdle;
       end;
  +1:  begin
        Result:=ppAboveNormal;
        if (n>=nn[4]) then Result:=ppHigh;
        if (n>=nn[5]) then Result:=ppRealtime;
       end;
  else Result:=ppNormal;
 end;
end;

function GetProcessPriorityByLevel(aLevel:Integer):TProcessPriority;
begin
 Result:=LevelToProcessPriority(aLevel);
end;

function GetPriorityClassByLevel(aLevel:Integer):DWORD;
begin
 Result:=ProcessPriorityToClass(GetProcessPriorityByLevel(aLevel));
end;

function GetPriorityClassByName(const aName:LongString):DWORD;
begin
 Result:=ProcessPriorityToClass(StringToProcessPriority(aName));
end;

function GetAbsolutePriority(PriorityClass:DWORD; ThreadPriority:TThreadPriority):Integer;
begin
 Result:=WindowsPriorityToLevel(ClassToProcessPriority(PriorityClass),ThreadPriority);
end;

function FindNearestThreadPriority(Table:TThreadPriorityFunct; pp:TProcessPriority; pv:Integer):TThreadPriority;
var tp:TThreadPriority; pt,dt,dm:Integer;
begin
 Result:=tpNormal;
 if Assigned(Table) then begin
  dm:=MaxInt;
  for tp:=low(tp) to High(tp) do begin
   pt:=Table(pp,tp,0); dt:=abs(pt-pv);
   if (dt<dm) then begin
    Result:=tp;
    dm:=dt;
   end;
  end;
 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,nil,'ForcePriorityClass');
 end;
end;

procedure ForceProcessPriority(aWantedPriority:TProcessPriority; aPollPeriod:DWORD);
begin
 ForcePriorityClass(ProcessPriorityToClass(aWantedPriority),aPollPeriod);
end;

procedure CheckPriorityClass;
var hProcess:THandle; TickCount:Int64;
const LastCheck:Int64=0;
begin
 try
  if (PeriodPriorityClass>0) then
  if (WantedPriorityClass>0) then begin
   TickCount:=GetTickCount64;
   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,nil,'CheckPriorityClass');
 end;
end;

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

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

type pgFindTidRec=packed record Polling:TPolling; ThreadId:THandle; end;
procedure pgFindTid(Index:LongInt; const aObject:TObject; var Terminate:Boolean; CustomData:Pointer);
begin
 if Assigned(CustomData) then
 if (aObject is TPolling) then with pgFindTidRec(CustomData^) do
 if (TPolling(aObject).ThreadID=ThreadId) then Polling:=TPolling(aObject);
end;

function FindPollingByThreadID(ThreadId:THandle):TPolling;
var R:pgFindTidRec;
begin
 Result:=nil;
 if (ThreadId<>0) then begin
  R.Polling:=nil; R.ThreadId:=ThreadId;
  FullPollingList.ForEach(pgFindTid,@R);
  Result:=R.Polling;
 end;
end;

const
 // The stupid values uses in FPC UNIX threads to mark priorities.
 // This values may be changed in future versions of FPC, so be care.
 FakePriorities:array[TThreadPriority] of Integer=(-20,-19,-10,0,9,18,19);

function PollingPrioTimeout:Integer;
begin
 Result:=EnsureRange(DefPollingPrioTimeout,MinPollingPrioTimeout,MaxPollingPrioTimeout);
end;

function PollingTid(Polling:TPolling):TPid;
begin
 Result:=Polling.Tid;
 if (Result<=0) and (Polling.LoopCount=0) and (PollingPrioTimeout>0) then begin
  Polling.Awake; Polling.WaitForLoop(PollingPrioTimeout);
  Result:=Polling.Tid;
 end;
end;

function PollingGetPriority(Polling:TPolling):LongInt;
var nice:Integer; pp:TProcessPriority; tp:TThreadPriority; tid:TPid;
begin
 pp:=GetProcessPriority;
 tid:=PollingTid(Polling);
 nice:=GetProcessNice(tid);
 tp:=FindNearestThreadPriority(SchedOtherPriorityToNice,pp,nice);
 Result:=FakePriorities[tp];
end;

function PollingSetPriority(Polling:TPolling; Prio:LongInt):Boolean;
var nice,i,n:Integer; pp:TProcessPriority; tp,ip:TThreadPriority; tid:TPid;
begin
 i:=0; tp:=tpNormal;
 for ip:=Low(tp) to High(tp) do
 if (FakePriorities[ip]=Prio) then begin tp:=ip; Break; end else inc(i);
 n:=Ord(High(tp))-Ord(Low(tp)); if (i>n) then Exit(false);
 pp:=GetProcessPriority;
 tid:=PollingTid(Polling);
 nice:=SchedOtherPriorityToNice(pp,tp);
 Result:=SetProcessNice(nice,tid);
end;

 ///////////////////////////////////////////////////////////////////////////////
 // Thread Manager for Unix should be updated to apply thread priority features.
 ///////////////////////////////////////////////////////////////////////////////
var
 HasThreadManager:Boolean=false;
 NewThreadManager:Boolean=false;
 OldThreadManager:TThreadManager;

function UnixThreadGetPriority(threadHandle:TThreadID):LongInt;
var Polling:TPolling;
begin
 Result:=0;
 try
  Polling:=FindPollingByThreadID(threadHandle);
  if Assigned(Polling)
  then Result:=PollingGetPriority(Polling)
  else Result:=OldThreadManager.ThreadGetPriority(threadHandle);
 except
  on E:Exception do BugReport(E,nil,'UnixThreadGetPriority');
 end;
end;

function UnixThreadSetPriority(threadHandle:TThreadID; Prio:LongInt):Boolean;
var Polling:TPolling;
begin
 Result:=false;
 try
  Polling:=FindPollingByThreadID(threadHandle);
  if Assigned(Polling)
  then Result:=PollingSetPriority(Polling,Prio)
  else Result:=OldThreadManager.ThreadSetPriority(threadHandle,Prio);
 except
  on E:Exception do BugReport(E,nil,'UnixThreadSetPriority');
 end;
end;

procedure InitThreadManager;
var TM:TThreadManager;
begin
 if IsLinux then
 if not HasThreadManager then
 if not NewThreadManager then
 if GetThreadManager(OldThreadManager) then begin
  TM:=OldThreadManager;
  TM.ThreadGetPriority:=UnixThreadGetPriority;
  TM.ThreadSetPriority:=UnixThreadSetPriority;
  NewThreadManager:=SetThreadManager(TM);
  HasThreadManager:=True;
 end;
end;

procedure FreeThreadManager;
begin
 if IsLinux then
 if HasThreadManager then
 if NewThreadManager then begin
  if SetThreadManager(OldThreadManager) then begin
   NewThreadManager:=false;
   HasThreadManager:=false;
  end;
 end;
end;

const
 TheFullPollingList:TObjectStorage=nil;

function FullPollingList:TObjectStorage;
begin
 if not Assigned(TheFullPollingList) then begin
  TheFullPollingList:=NewObjectStorage(false);
  TheFullPollingList.Master:=@TheFullPollingList;
  TheFullPollingList.OwnsObjects:=false;
 end;
 Result:=TheFullPollingList;
end;

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

procedure Init_crw_polling;
begin
 InitThreadManager;
 FullPollingList.Ok;
 InitPriorityTables;
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]));
 FreeThreadManager;
end;

initialization

 Init_crw_polling;

finalization

 Free_crw_polling;

end.

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

