////////////////////////////////////////////////////////////////////////////////
// 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:                                                                   //
// Process and thread related routines.                                       //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20230507 - Created for FPC (A.K.)                                          //
////////////////////////////////////////////////////////////////////////////////

unit _crw_proc; //  Process & thread routines.

{$I _crw_sysdef}

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

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, baseunix, unix, {$ENDIF}
 {$IFDEF UNIX} unixcp, unixtype, {$ENDIF}
 {$IFDEF LINUX} termio, {$ENDIF}
 {$IFDEF WINDOWS} windows, {$ENDIF}
 {$IFDEF WINDOWS} ShellApi, Registry, {$ENDIF}
 {$IFDEF WINDOWS} JwaWinUser, JwaTlHelp32, JwaPsApi, JwaWinBase, {$ENDIF}
 sysutils, classes, math, process, strutils, ctypes, lazfileutils,
 _crw_alloc;

{$IFDEF UNIX}
function sched_getaffinity(pid:Ptruint; cpusetsize:longint; cpuset:pointer):cint; cdecl;
function sched_setaffinity(pid:Ptruint; cpusetsize:longint; cpuset:pointer):cint; cdecl;
function pthread_getaffinity_np(pid:TThreadID; cpusetsize:longint; cpuset:pointer):cint; cdecl;
function pthread_setaffinity_np(pid:TThreadID; cpusetsize:longint; cpuset:pointer):cint; cdecl;
{$ENDIF}

 // Get number of CPU's.
function cpu_count:Integer;

 // CPU frequency, MHz, by source id.
 // id=(0:default,1:nominal,2:eastimated).
 // Non-zero newMHz uses to update the value.
function cpu_mhz(id:Integer=0; newMHz:Double=0):Double;

const // Default cpu_mhz source id.
 cpu_mhz_default_source_id:Integer=0;

 // Readout nominal CPU frequency MHz from registry (Windows) or /proc (Unix).
function ReadNominalCpuFrequencyMhz:Double;

{$IFDEF UNIX}
 // Read /proc/cpuinfo (What field) for CPU`s in CpuMask (1=CPU0,2=CPU1,etc).
function ReadProcCpuInfo(CpuMask:Int64; What:LongString):LongString;
{$ENDIF UNIX}

 // Return true if handle is terminal.
function IsATTY(var F:Text):Boolean; overload;
function IsATTY(Handle:LongInt):Boolean; overload;

// Get process (pid) affinity mask.
// By default, PID 0 means the current process.
function GetProcessAffinityMask(pid:SizeInt=0):QWord;

// Get thread (tid) affinity mask.
// By default, TID 0 means the current thread.
function GetThreadAffinityMask(tid:SizeInt=0):QWord;

// Get/Set thread (tid) affinity mask.
// Tid 0 means the current thread, Mask=0 uses to Get only.
function SetThreadAffinityMask(tid:SizeInt; Mask:QWord):QWord;

 // Return list of running processes as lines of: PID, PPID, PRIO, NAME.
 // On Unix systems the /proc filesystem uses, so /proc support required.
function GetListOfProcesses(aPid,aPPid:SizeInt; const aName:LongString;
                            Detail:Boolean=false):LongString;

// Get Process Name with PID specified.
// By default, PID 0 means the current process.
function GetProcessName(pid:SizeInt=0):LongString;

// Get Parent Process ID and Name.
function GetParentProcessID:SizeInt;
function GetParentProcessName:LongString;

// On Unix systems parent PID may change (when parent process die).
// So let`s make parent process snapshot for future to detect "zombie".
procedure MakeParentSnapshot;
procedure FreeParentSnapshot;
function GetSnapshotParentProcessID:SizeInt;
function GetSnapshotParentProcessName:LongString;

// getrusage - resource usage.
{$IFDEF UNIX}
const
 RUSAGE_SELF     = 0;   // the process
 RUSAGE_CHILDREN = -1;  // his childrens
 RUSAGE_BOTH     = -2;  // sys_wait4() uses this
 RUSAGE_THREAD   = 1;   // only the calling thread
type
 Prusage = ^Trusage;
 Trusage = record        // from linux headers:
  ru_utime    : timeval; // user time used
  ru_stime    : timeval; // system time used
  ru_maxrss   : longint; // maximum resident set size
  ru_ixrss    : longint; // integral shared memory size
  ru_idrss    : longint; // integral unshared data size
  ru_isrss    : longint; // integral unshared stack size
  ru_minflt   : longint; // page reclaims
  ru_majflt   : longint; // page faults
  ru_nswap    : longint; // swaps
  ru_inblock  : longint; // block input operations
  ru_oublock  : longint; // block output operations
  ru_msgsnd   : longint; // messages sent
  ru_msgrcv   : longint; // messages received
  ru_nsignals : longint; // signals received
  ru_nvcsw    : longint; // voluntary context switches
  ru_nivcsw   : longint; // involuntary
  reserved    : array[0..15] of longint; // added just for safety
 end;
function FPgetrusage(who:longint; usage:Prusage):longint;
{$ENDIF}

 // Current Process/Thread times (system s, user u) as FileTime (100 ns units).
function GetProcessTimesAsFileTime(var s,u:Int64):Boolean; // Current process
function GetThreadTimesAsFileTime(var s,u:Int64):Boolean;  // Calling thread

const
 RunCommandSleepTimeMin = 1;             // Minimal RunCommand SleepTime
 RunCommandSleepTimeMax = 10000;         // Maximal RunCommand SleepTime
 RunCommandSleepTimeDef : Integer = 10;  // Default RunCommand SleepTime

 // Run command (CmdLine) in directory, wait in Idle loop with given SleepTime
 /////////////////////////////////////////////////////////////////////////////
function RunCommandInDirIdle(const CurDir,CmdLine:LongString;
                  out OutStr,ErrStr:LongString; SleepTime:Integer=0):Boolean;

implementation

{$IFDEF UNIX}
function sched_getaffinity(pid:Ptruint; cpusetsize:longint; cpuset:pointer):cint; cdecl; external 'c' name 'sched_getaffinity';
function sched_setaffinity(pid:Ptruint; cpusetsize:longint; cpuset:pointer):cint; cdecl; external 'c' name 'sched_setaffinity';
function pthread_getaffinity_np(pid:TThreadID; cpusetsize:longint; cpuset:pointer):cint; cdecl; external 'c' name 'pthread_getaffinity_np';
function pthread_setaffinity_np(pid:TThreadID; cpusetsize:longint; cpuset:pointer):cint; cdecl; external 'c' name 'pthread_setaffinity_np';
{$ENDIF}

{$IFDEF UNIX}
function get_nprocs:longint; cdecl; external 'c' name 'get_nprocs';
{$ENDIF}

function cpu_count:Integer;
begin
 {$IFDEF UNIX}
 Result:=get_nprocs;
 {$ELSE}
 Result:=System.GetCPUCount;
 {$ENDIF UNIX}
end;

{$IFDEF WINDOWS}
////////////////////////////////////////////////////////////////////////////////
// Readout CPU frequency from registry
// HKEY_LOCAL_MACHINE\HARDWARE\DESCRIPTION\System\CentralProcessor\0\~MHZ:DWORD
////////////////////////////////////////////////////////////////////////////////
function ReadNominalCpuFrequencyMhz:Double;
var reg:TRegistry;
begin
 Result:=0;
 try
  reg:=TRegistry.Create;
  try
   reg.RootKey:=HKEY_LOCAL_MACHINE;
   if Reg.OpenKeyReadOnly('HARDWARE\DESCRIPTION\System\CentralProcessor\0')
   then Result:=reg.ReadInteger('~MHZ')
   else Result:=0;
  finally
   reg.CloseKey;
   reg.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'ReadNominalCpuFrequencyMhz');
 end;
end;
{$ENDIF WINDOWS}
{$IFDEF UNIX}
function ReadProcCpuInfo(CpuMask:Int64; What:LongString):LongString;
var Lines:TStringList; Line,Name,Value:LongString; i,p:Integer;
begin
 Result:='';
 if FileExists('/proc/cpuinfo') then
 try
  if (CpuMask=0)
  then CpuMask:=-1;
  What:=Trim(What);
  if (What='') then Exit;
  Lines:=TStringList.Create;
  try
   Lines.LoadFromFile('/proc/cpuinfo');
   for i:=0 to Lines.Count-1 do begin
    Line:=Lines[i]; p:=Pos(':',Line);
    if (p=0) then continue;
    Name:=Copy(Line,1,p-1);
    Value:=Copy(Line,p+1,Length(Line)-p);
    Name:=Trim(Name); Value:=Trim(Value);
    if SameText(Name,What) then begin
     if ((CpuMask and 1)<>0) then begin
      Result:=Result+Value+EOLN;
     end;
     CpuMask:=CpuMask shr 1;
     if (CpuMask=0) then Break;
    end;
   end;
   Result:=Trim(Result);
  finally
   Lines.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'ReadProcCpuInfo');
 end;
end;
{$ENDIF UNIX}
{$IFDEF UNIX}
function ReadNominalCpuFrequencyMhz:Double;
var Model,Freq:LongString; p:Integer;
begin
 Result:=0;
 try
  Model:=ReadProcCpuInfo(1,'model name');
  Model:=Copy(Model,Pos('@',Model)+1,255);
  Model:=Trim(UpperCase(Model));
  p:=Pos('GHZ',Model);
  if (p>0) then begin
   Freq:=Trim(Copy(Model,1,p-1));
   Result:=StrToFloatDef(Freq,0)*1000;
   Exit;
  end;
  p:=Pos('MHZ',Model);
  if (p>0) then begin
   Freq:=Trim(Copy(Model,1,p-1));
   Result:=StrToFloatDef(Freq,0);
   Exit;
  end;
 except
  on E:Exception do BugReport(E,nil,'ReadNominalCpuFrequencyMhz');
 end;
end;
{$ENDIF UNIX}

var // CPU frequency MHz: 0-default, 1-nominal, 2-eastimated.
 cpu_mhz_list:packed array[1..2] of Double;

function cpu_mhz(id:Integer=0; newMHz:Double=0):Double;
var i:Integer;
begin
 Result:=0;
 if IsNan(newMHz) or IsInfinite(newMHz) then Exit;
 if not InRange(id,0,High(cpu_mhz_list)) then Exit;
 if (id>0) and (newMHz<>0) then cpu_mhz_list[id]:=Max(0,newMHz);
 if (id=0) then id:=cpu_mhz_default_source_id;
 if (id=0) then begin
  for i:=Low(cpu_mhz_list) to High(cpu_mhz_list) do
  if (id=0) and (cpu_mhz_list[i]>0) then begin
   id:=i; cpu_mhz_default_source_id:=i; Break;
  end;
 end;
 id:=EnsureRange(id,Low(cpu_mhz_list),High(cpu_mhz_list));
 Result:=cpu_mhz_list[id];
end;

procedure InitCpuMhzList;
begin
 SafeFillChar(cpu_mhz_list,SizeOf(cpu_mhz_list),0);
 cpu_mhz(1,ReadNominalCpuFrequencyMhz);
end;

function IsATTY(Handle:LongInt):Boolean;
begin
 {$IFDEF LINUX}
 Result:=(Termio.IsATTY(Handle)=1);
 {$ELSE}
 Result:=0;
 {$ENDIF LINUX}
end;

function IsATTY(var F:Text):Boolean;
begin
 {$IFDEF LINUX}
 Result:=(Termio.IsATTY(F)=1);
 {$ELSE}
 Result:=0;
 {$ENDIF LINUX}
end;

function GetProcessAffinityMask(pid:SizeInt=0):QWord;
{$IFDEF WINDOWS}var a1,a2:DWORD;{$ENDIF}
begin
 Result:=0;
 {$IFDEF WINDOWS}
 if (pid=0) then pid:=GetCurrentProcess;
 if GetProcessAffinityMask(pid,a1,a2) then Result:=a1;
 {$ENDIF}
 {$IFDEF LINUX}
 if (pid=0) then pid:=GetProcessId;
 if sched_getaffinity(pid,SizeOf(Result),@Result)<>0
 then Result:=0;
 {$ENDIF}
end;

function GetThreadAffinityMask(tid:SizeInt):QWord;
begin
 Result:=SetThreadAffinityMask(tid,0);
end;

function SetThreadAffinityMask(tid:SizeInt; Mask:QWord):QWord;
begin
 Result:=0;
 {$IFDEF WINDOWS}
 if (tid=0) then tid:=GetCurrentThread;
 Result:=SetThreadAffinityMask(tid,Mask);
 {$ENDIF}
 {$IFDEF LINUX}
 if sched_getaffinity(tid,SizeOf(Result),@Result)<>0 then Result:=0;
 if (Mask=0) then Exit; // Mask cannot be 0, use it for read only
 if sched_setaffinity(tid,SizeOf(Mask),@Mask)=0 then {Ok};
 {$ENDIF}
end;

{$IFDEF UNIX}
{$PUSH}
{$IOCHECKS OFF}
// List processes as PID, PPID, Priority, EXE, CmdLine
function GetListOfProcesses(aPid,aPPid:SizeInt; const aName:LongString;
                            Detail:Boolean=false):LongString;
var Rec:TSearchRec; Pid,PPid:SizeInt; i,Prio:SizeInt;
var Proc,List:TStringList; ProgName,CmdLine:LongString;
 function GetParamName(const Line:LongString):LongString;
 begin
  Result:=Trim(ExtractWord(1,Line,[':']));
 end;
 function GetParamValue(const Line:LongString):LongString;
 begin
  Result:=Trim(ExtractWord(2,Line,[':']));
 end;
 function GetProcStatus(Pid:SizeInt; var PPid:SizeInt; var Prio:SizeInt; var ProgName,CmdLine:LongString):Boolean;
 var i,n:SizeInt; Line,sn,sv:LongString; F:Text;
 begin
  Result:=false;
  PPid:=0; Prio:=0; ProgName:=''; CmdLine:=''; n:=0;
  if (Pid=0) then Exit;
  IoResult;
  Assign(F,'/proc/'+IntToStr(Pid)+'/status');
  Reset(F);
  try
   while not Eof(F) and (n<2) do begin
    Readln(F,Line);
    sn:=GetParamName(Line);
    sv:=GetParamValue(Line);
    if (IOResult<>0) then Exit;
    if SameText(sn,'Pid') and (StrToInt64Def(sv,0)=0) then Exit;
    if SameText(sn,'Name') then begin ProgName:=sv; inc(n); end else
    if SameText(sn,'PPid') then begin PPid:=StrToInt64Def(sv,0); inc(n); end;
   end;
  finally
   Close(F);
   IoResult;
  end;
  Assign(F,'/proc/'+IntToStr(Pid)+'/sched');
  Reset(F);
  try
   while not Eof(F) and (n<3) do begin
    Readln(F,Line);
    sn:=GetParamName(Line);
    sv:=GetParamValue(Line);
    if (IOResult<>0) then Exit;
    if SameText(sn,'prio') then begin Prio:=StrToIntDef(sv,0); inc(n); end;
   end;
  finally
   Close(F);
   IoResult;
  end;
  Result:=(n>=3);
  if not Detail then Exit;
  Assign(F,'/proc/'+IntToStr(Pid)+'/cmdline');
  Reset(F);
  try
   Readln(F,Line);
   if (IoResult=0) then begin
    for i:=1 to Length(Line) do
    if (Line[i]=#0) then Line[i]:=' ';
    CmdLine:=Trim(Line);
   end;
  finally
   Close(F);
   IoResult;
  end;
 end;
begin
 Result:='';
 try
  // Single PID requested
  if (aPid<>0) then begin
   if FileExists('/proc/'+IntToStr(aPid)+'/status') then begin
    Pid:=aPid; PPid:=0; Prio:=0; ProgName:=''; CmdLine:='';
    if GetProcStatus(Pid,PPid,Prio,ProgName,CmdLine) then
    if (aPPid=0) or (aPPid=PPid) then
    if (aName='') or SameText(aName,ProgName) then
    if (CmdLine='')
    then Result:=Format('%d, %d, %d, %s',[Pid,PPid,Prio,ProgName])
    else Result:=Format('%d, %d, %d, %s, %s',[Pid,PPid,Prio,ProgName,CmdLine]);
   end;
   Exit;
  end;
  // Process list requested
  Proc:=TStringList.Create;
  List:=TStringList.Create;
  try
   IOResult;
   // Read /proc/pid to Proc list
   if (FindFirstUTF8('/proc/*',faDirectory,Rec)=0) then
   repeat
    Pid:=StrToIntDef(Rec.Name,0);
    if (Pid<>0) then Proc.Add(IntToStr(Pid));
   until (FindNextUTF8(Rec)<>0);
   FindCloseUTF8(Rec);
   // Select pid's by filter
   for i:=0 to Proc.Count-1 do begin
    Pid:=StrToIntDef(Proc[i],0);
    if (Pid=0) then Continue else
    if (aPid=0) or (aPid=Pid) then begin
     PPid:=0; Prio:=0; ProgName:=''; CmdLine:='';
     if GetProcStatus(Pid,PPid,Prio,ProgName,CmdLine) then
     if (aPPid=0) or (aPPid=PPid) then
     if (aName='') or SameText(aName,ProgName) then
     if (CmdLine='')
     then List.Add(Format('%d, %d, %d, %s',[Pid,PPid,Prio,ProgName]))
     else List.Add(Format('%d, %d, %d, %s, %s',[Pid,PPid,Prio,ProgName,CmdLine]));
    end;
   end;
   Result:=List.Text;
  finally
    List.Free;
    Proc.Free;
    IoResult;
  end;
 except
  on E:Exception do BugReport(E,nil,'GetListOfProcesses');
 end;
end;
{$POP}
{$ENDIF UNUX}

{$IFDEF WINDOWS}
// List processes as PID, PPID, Priority, EXE
function GetListOfProcesses(aPid,aPPid:SizeInt; const aName:LongString;
                            Detail:Boolean=false):LongString;
var hProcessSnap:THandle; pe32:PROCESSENTRY32; List:TStringList;
begin
 Result:='';
 try
  List:=TStringList.Create;
  try
   hProcessSnap:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
   if(hProcessSnap<>0) and (hProcessSnap<>INVALID_HANDLE_VALUE) then
   try
    ZeroMemory(@pe32,sizeof(pe32));
    pe32.dwSize:=sizeof(pe32);
    if Process32First(hProcessSnap,pe32) then
    repeat
      if (aPID=0) or (aPID=pe32.th32ProcessID) then
      if (aPPID=0) or (aPPID=pe32.th32ParentProcessID) then
      if (aName='') or SameText(aName,pe32.szExeFile) then
      List.Add(Format('%d, %d, %d, %s',[pe32.th32ProcessID,pe32.th32ParentProcessID,pe32.pcPriClassBase,pe32.szExeFile]));
    until not Process32Next(hProcessSnap,pe32);
   finally
    CloseHandle(hProcessSnap);
   end;
   if (List.Count>0) then Result:=List.Text;
  finally
   List.Free;
  end;
 except
  on E:Exception do BugReport(E,nil,'GetListOfProcesses');
 end;
end;
{$ENDIF WINDOWS}

{$IFDEF UNIX}
function GetParentProcessID:SizeInt;
begin
 Result:=FpGetppid;
end;
{$ENDIF UNUX}

{$IFDEF WINDOWS}
function GetParentProcessID:SizeInt;
var list,item:LongString;
begin
 list:=GetListOfProcesses(GetProcessID,0,'');
 item:=ExtractWord(2,list,[' ',',']);
 Result:=StrToInt64Def(item,0);
end;
{$ENDIF WINDOWS}

function GetProcessName(pid:SizeInt=0):LongString;
var list:LongString;
begin
 if (pid=0) then pid:=GetProcessID;
 list:=GetListOfProcesses(pid,0,'');
 Result:=Trim(ExtractWord(4,list,[',']));
end;

function GetParentProcessName:LongString;
var ppid:SizeInt;
begin
 ppid:=GetParentProcessID;
 if (ppid<>0) then Result:=GetProcessName(ppid) else Result:='';
end;

var
 TheParentSnapshot:record PID:SizeInt; Name:LongString; end = (PID:0;Name:'');

procedure MakeParentSnapshot;
begin
 TheParentSnapshot.PID:=GetParentProcessID;
 TheParentSnapshot.Name:=GetParentProcessName;
end;

procedure FreeParentSnapshot;
begin
 TheParentSnapshot.PID:=0;
 TheParentSnapshot.Name:='';
end;

function GetSnapshotParentProcessID:SizeInt;
begin
 Result:=TheParentSnapshot.PID;
end;

function GetSnapshotParentProcessName:LongString;
begin
 Result:=TheParentSnapshot.Name;
end;

 ////////////////////
 // getrusage related
 ////////////////////

{$IFDEF UNIX}
function getrusage(who:longint; usage:Prusage):longint;cdecl;external 'c' name 'getrusage';

function FPgetrusage(who:longint; usage:Prusage):longint;
begin
 Result:=getrusage(who,usage);
end;

function GetRusageTimesAsFileTime(who:LongInt; var s,u:Int64):Boolean; inline;
const c1=1000*1000; c2=10;
var usage:Trusage;
begin
 Result:=false; s:=0; u:=0;
 if (getrusage(who,@usage)=0) then begin
  s:=(usage.ru_stime.tv_sec*c1+usage.ru_stime.tv_usec)*c2;
  u:=(usage.ru_utime.tv_sec*c1+usage.ru_utime.tv_usec)*c2;
  Result:=true;
 end;
end;

function GetProcessTimesAsFileTime(var s,u:Int64):Boolean;
begin
 Result:=GetRusageTimesAsFileTime(RUSAGE_SELF,s,u);
end;

function GetThreadTimesAsFileTime(var s,u:Int64):Boolean;
begin
 Result:=GetRusageTimesAsFileTime(RUSAGE_THREAD,s,u);
end;
{$ENDIF UNIX}

function RunCommandInDirIdle(const CurDir,CmdLine:LongString;
                  out OutStr,ErrStr:LongString; SleepTime:Integer=0):Boolean;
var p:TProcess; ExitStatus:Integer; OutputString,ErrorString:String;
begin
 Result:=False;
 OutStr:=''; ErrStr:='';
 if (Trim(CmdLine)<>'') then
 try
  p:=DefaultTProcess.Create(nil);
  try
   p.Options:=p.Options+[poRunIdle]; // NB!
   if (CurDir<>'') then p.CurrentDirectory:=Trim(CurDir);
   if (SleepTime<=0) then SleepTime:=RunCommandSleepTimeDef;
   if InRange(SleepTime,RunCommandSleepTimeMin,RunCommandSleepTimeMax)
   then p.RunCommandSleepTime:=SleepTime;
   {$PUSH}
   {$WARN SYMBOL_DEPRECATED OFF}
   p.CommandLine:=Trim(CmdLine);
   {$POP}
   Result:=(p.RunCommandLoop(OutputString,ErrorString,ExitStatus)=0);
   if (ExitStatus<>0) then Result:=False;
   OutStr:=OutputString;
   ErrStr:=ErrorString;
  finally
   p.Free; OutStr:=''; ErrStr:='';
  end;
 except
  on E:Exception do BugReport(E,nil,'RunCommandInDirIdle');
 end;
end;

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

procedure Init_crw_proc;
begin
 MakeParentSnapshot;
 InitCpuMhzList;
end;

procedure Free_crw_proc;
begin
 FreeParentSnapshot;
end;

initialization

 Init_crw_proc;

finalization

 Free_crw_proc;

end.

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

