Recent

Author Topic: [LAZARUS 3.2] TIHelp32 not found  (Read 1566 times)

wp

  • Hero Member
  • *****
  • Posts: 12122
Re: [LAZARUS 3.2] TIHelp32 not found
« Reply #15 on: May 22, 2024, 03:45:26 pm »
Quote
Code: Pascal  [Select][+][-]
  1.   function FindMainWindow(PID: DWORD): DWORD;
  2.   var EI: TEnumInfo;
  3.   begin
  4.     EI.ProcessID := PID;
  5.     EI.HWND := 0;
  6.     EnumWindows(@EnumWindowsProc, Integer(@EI));
  7.     Result := EI.HWND;
  8.   end;
This is the classical issue when converting 32-bit code to 64-bit: castring pointers to integers... The problem is: in 32-bit pointers and integers have 32-bit, but in 64-bit pointers have 64 bits while "integer" is kept at 32bit. So, when you cast a pointer to integer, the upper 32 bits are lost. The remedy is to cast to PtrUInt rather than to integer. PtrUInt is an unsigned integer which always has the same size as a pointer:
Code: Pascal  [Select][+][-]
  1.     EnumWindows(@EnumWindowsProc, PtrUInt(@EI));

The other change that you should apply to your code is to add the directive {$mode Delphi} at the top of the unit (or project file here) to instruct fpc to use the Delphi dialect of Pascal.

440bx

  • Hero Member
  • *****
  • Posts: 4304
Re: [LAZARUS 3.2] TIHelp32 not found
« Reply #16 on: May 22, 2024, 03:51:50 pm »
It would also be prudent for him to ensure the function that enumerates the windows isn't using "bitness-challenged" parameter definitions either.
(FPC v3.0.4 and Lazarus 1.8.2) or (FPC v3.2.2 and Lazarus v3.2) on Windows 7 SP1 64bit.

Fibonacci

  • Sr. Member
  • ****
  • Posts: 453
  • Internal Error Hunter
Re: [LAZARUS 3.2] TIHelp32 not found
« Reply #17 on: May 22, 2024, 04:17:53 pm »
Code: Pascal  [Select][+][-]
  1. program superviseprocess;
  2.  
  3. {$APPTYPE CONSOLE}
  4.  
  5. uses
  6.   Windows,
  7.   SysUtils,
  8.   Classes,
  9.   JwaTlHelp32,
  10.   DateUtils;
  11.  
  12. type
  13.   TSupervisorThread = class(TThread)
  14.   private
  15.     { Private declarations }
  16.     StartCommandline,RestartCommandline:string;
  17.     LastAppResponseTime:TDateTime;
  18.     UpdateLog:boolean;
  19.     procedure Synchronization;
  20.   public
  21.     { Public declarations }
  22.   protected
  23.     procedure Execute; override;
  24.   end;
  25.  
  26. type
  27.   TWorkerThread = class(TThread)
  28.   private
  29.     Commandline:string;
  30.     ProcessCommandLine:string;
  31.     ProcessID:cardinal;
  32.     procedure RunProcess(CMD:String;Priority_:cardinal;WindowStatus:Word);
  33.     procedure OutputSynchronizationWhite;
  34.     { Private declarations }
  35.   public
  36.     { Public declarations }
  37.   protected
  38.     procedure Execute; override;
  39.   end;
  40.  
  41. var SupervisorThread:TSupervisorThread;
  42.     WorkerThread:TWorkerThread;
  43.     CriticalSection: TRTLCriticalSection;
  44.     ApplicationFinishedGracefully:boolean;
  45.     Log:TStringList;
  46.     ProcessIDtoSupervise:cardinal;
  47.  
  48. function GetTempDirectory:String;
  49. var tempFolder: array[0..MAX_PATH] of Char;
  50. begin
  51.   GetTempPath(MAX_PATH, @tempFolder);
  52.   result:=StrPas(tempFolder);
  53. end;
  54.  
  55. function SaveLog(var Log:TStringList):boolean;
  56. var OldLog:TStringList;
  57.     TempPath,LogFile:string;
  58. begin
  59.  
  60.   OldLog:=TStringList.Create;
  61.   TempPath:=GetTempDirectory;
  62.   LogFile:=TempPath+'\SuperviseProcessLog.txt';
  63.   try
  64.     if FileExists(LogFile)=true then OldLog.LoadFromFile(LogFile);
  65.     OldLog.AddStrings(Log);
  66.     while OldLog.Count>100000 do OldLog.Delete(0); //remove the oldest entries
  67.     OldLog.SaveToFile(LogFile);
  68.     Log.Clear;
  69.     Result:=true;
  70.   except
  71.     Result:=false;
  72.   end;
  73.  
  74.   OldLog.Free;
  75.  
  76. end;
  77.  
  78.  
  79. function ExtractFileNameEx(path:string):string;
  80. begin
  81.  
  82.   Result:=ExtractFileName( Copy(Path,0,Pos('.exe',AnsiLowerCase(path))+3) );
  83.  
  84. end;  
  85.  
  86. type
  87.   PEnumInfo = ^TEnumInfo;
  88.   TEnumInfo = record
  89.   ProcessID: DWORD;
  90.   HWND: THandle;
  91.   end;
  92.  
  93. function EnumWindowsProc(Wnd: HWND; EI: LPARAM): Bool; stdcall;
  94. var PID: DWORD;
  95. begin
  96.   GetWindowThreadProcessID(Wnd, @PID);
  97.   Result := (PID <> PEnumInfo(EI)^.ProcessID) {or (not IsWindowVisible(WND)) or (not IsWindowEnabled(WND))};
  98.   if not Result then PEnumInfo(EI)^.HWND := WND; //break on return FALSE
  99. end;
  100.  
  101. function GetHWndByPID(const hPID: THandle): THandle;
  102.   function FindMainWindow(PID: DWORD): DWORD;
  103.   var EI: TEnumInfo;
  104.   begin
  105.     EI.ProcessID := PID;
  106.     EI.HWND := 0;
  107.     EnumWindows(@EnumWindowsProc, LPARAM(@EI));
  108.     Result := EI.HWND;
  109.   end;
  110.  
  111. begin
  112.  
  113.   if hPID<>0 then Result:=FindMainWindow(hPID)
  114.   else Result:=0;
  115.  
  116. end;
  117.  
  118.  
  119. function IsAppRespondingNT(wnd: HWND): Boolean;
  120. type TIsHungAppWindow = function(wnd:hWnd): BOOL; stdcall;
  121. var hUser32: THandle;
  122.     IsHungAppWindow: TIsHungAppWindow;
  123. begin
  124.  
  125.   Result := True;
  126.   hUser32 := GetModuleHandle('user32.dll');
  127.   if (hUser32 > 0) then
  128.   begin
  129.     pointer(IsHungAppWindow) := GetProcAddress(hUser32, 'IsHungAppWindow');
  130.     if Assigned(IsHungAppWindow) then
  131.     begin
  132.       Result := not IsHungAppWindow(wnd);
  133.     end;
  134.   end;
  135.  
  136. end;
  137.  
  138. procedure FindChildPID(ParentPID:cardinal;var PIDlist:TStringlist);
  139. var bFound : Boolean;
  140.     SnapshotHandle : THandle;
  141.     ProcessEntry32 : TProcessEntry32;
  142. begin
  143.   SnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
  144.   ProcessEntry32.dwSize := Sizeof(ProcessEntry32);
  145.   bFound := Process32First(SnapshotHandle,ProcessEntry32);
  146.   while bFound do
  147.   begin
  148.     if ProcessEntry32.th32ParentProcessID = ParentPID then PIDlist.Add( inttostr(ProcessEntry32.th32ProcessID) );
  149.     bFound := Process32Next(SnapshotHandle,ProcessEntry32);
  150.   end;
  151.   CloseHandle(SnapshotHandle);
  152. end;
  153.  
  154. function KillProcess(PID:cardinal;KillParentProcess,KillChildProcess:boolean):boolean;
  155. var PIDList:TStringList;
  156.     x:integer;
  157.     ProcessHandle,CurrentPID:cardinal;
  158. begin
  159.  
  160.   if (KillParentProcess=false) and (KillChildProcess=false) then
  161.   begin
  162.     Result:=false;
  163.     exit;
  164.   end;
  165.  
  166.   PIDList:=TStringList.Create;
  167.  
  168.   try
  169.     PIDList.Add(IntToStr(PID));   //parent PID first on list
  170.  
  171.     if KillChildProcess=true then
  172.     begin
  173.       x:=0;
  174.       while x<PIDList.Count do
  175.       begin
  176.         FindChildPID(StrToInt(PIDList.Strings[x]),PIDList);
  177.         inc(x);
  178.       end;
  179.     end;
  180.  
  181.     if KillParentProcess=false then PIDList.Delete(0); //delete parent PID from list
  182.  
  183.     if PIDList.Count>0 then
  184.     begin
  185.  
  186.       for x:=0 to PIDList.Count-1 do
  187.       begin
  188.         CurrentPID:=StrToInt(PIDList.Strings[x]);
  189.         ProcessHandle:=OpenProcess(PROCESS_TERMINATE,False,CurrentPID);
  190.         TerminateProcess(ProcessHandle,0);
  191.         CloseHandle(ProcessHandle);
  192.       end;
  193.  
  194.       Result:=true;
  195.     end
  196.     else Result:=false;
  197.  
  198.   except
  199.     Result:=false;
  200.   end;
  201.  
  202.   PIDList.Free;
  203.  
  204. end;
  205.  
  206.  
  207.  
  208. procedure TWorkerThread.RunProcess(CMD:String;Priority_:cardinal;WindowStatus:Word);
  209. const ReadBuffer = 2400;
  210. var
  211.    Security : TSecurityAttributes;
  212.    ReadPipe,WritePipe : THandle;
  213.    start_ : TStartUpInfo;
  214.    ProcessInfo : TProcessInformation;
  215.    Buffer : Pchar;
  216.    BytesRead : DWord;
  217.    Apprunning : DWord;
  218. begin
  219.  
  220.   With Security do
  221.   begin
  222.  
  223.     nlength := SizeOf(TSecurityAttributes) ;
  224.     binherithandle := true;
  225.     lpsecuritydescriptor := nil;
  226.  
  227.   end;
  228.  
  229.   if Createpipe (ReadPipe, WritePipe, @Security, 0) then
  230.   begin
  231.  
  232.     Buffer := AllocMem(ReadBuffer + 1) ;
  233.     FillChar(start_,Sizeof(start_),#0) ;
  234.     start_.cb := SizeOf(start_) ;
  235.     start_.dwFlags := STARTF_USESHOWWINDOW;
  236.     start_.wShowWindow := WindowStatus;
  237.  
  238.     if CreateProcess(nil,PChar(CMD),nil,nil,true,Priority_,nil,nil,start_,ProcessInfo) then
  239.     begin
  240.       ProcessCommandLine:=CMD;
  241.       ProcessID:=ProcessInfo.dwProcessId;
  242.       Synchronize(@OutputSynchronizationWhite);
  243.       repeat
  244.         Apprunning := WaitForSingleObject(ProcessInfo.hProcess,100);
  245.       until (Apprunning <> WAIT_TIMEOUT);
  246.  
  247.     end;
  248.  
  249.     FreeMem(Buffer);
  250.     CloseHandle(ProcessInfo.hProcess);
  251.     CloseHandle(ProcessInfo.hThread);
  252.     CloseHandle(ReadPipe);
  253.     CloseHandle(WritePipe);
  254.  
  255.   end;
  256.  
  257. end;
  258.  
  259. procedure TWorkerThread.OutputSynchronizationWhite;
  260. var text:string;
  261. begin
  262.  
  263.   ProcessIDtoSupervise:=ProcessID;
  264.   SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),15);
  265.   text:='['+DateTimeToStr(Now)+'] '+ProcessCommandLine+' (PID:'+IntToStr(ProcessID)+') executed.';
  266.   WriteLn(text);
  267.   Log.Add(text);
  268.  
  269. end;
  270.  
  271. procedure TWorkerThread.Execute;
  272. begin
  273.  
  274.   RunProcess(CommandLine,GetPriorityClass(GetCurrentProcess),SW_SHOW);
  275.  
  276. end;
  277.  
  278. procedure TSupervisorThread.Execute;
  279. var WaitStatus:cardinal;
  280.     WorkerThreadHandlesArray: array of THandle;
  281. begin
  282.  
  283.   ApplicationFinishedGracefully:=true;
  284.  
  285.   SetLength(WorkerThreadHandlesArray,1);
  286.  
  287.   WorkerThread:=TWorkerThread.Create(true);
  288.   WorkerThreadHandlesArray[0]:=WorkerThread.Handle;
  289.   WorkerThread.FreeOnTerminate:=false;
  290.   WorkerThread.Commandline:=StartCommandline;
  291.   WorkerThread.Resume;
  292.  
  293.   repeat
  294.     Synchronize(@Synchronization);
  295.     WaitStatus:=WaitForMultipleObjects(1, @WorkerThreadHandlesArray[0], True, 1000);
  296.   until WaitStatus<>WAIT_TIMEOUT;
  297.  
  298.   if Assigned(WorkerThread)=true then FreeAndNil(WorkerThread);
  299.  
  300. end;
  301.  
  302. procedure TSupervisorThread.Synchronization;
  303. var x:integer;
  304.     h:HWND;
  305.     text:string;
  306. begin
  307.  
  308.   if ProcessIDtoSupervise>0 then
  309.   begin
  310.  
  311.     h:=GetHWndByPID(ProcessIDtoSupervise);
  312.     if h<>0 then
  313.     begin
  314.       if IsAppRespondingNT(h)=true then
  315.       begin
  316.         LastAppResponseTime:=Now;
  317.         SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),FOREGROUND_GREEN or FOREGROUND_INTENSITY);
  318.         WriteLn('['+DateTimeToStr(Now)+'] '+ExtractFileNameEx(StartCommandline)+' (PID:'+IntToStr(ProcessIDtoSupervise)+') is responding.');
  319.       end
  320.       else
  321.       begin
  322.         SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),FOREGROUND_RED or FOREGROUND_INTENSITY);
  323.         text:='['+DateTimeToStr(Now)+'] '+ExtractFileNameEx(StartCommandline)+' (PID:'+IntToStr(ProcessIDtoSupervise)+') is NOT responding.';
  324.         WriteLn(text);
  325.         Log.Add(text);
  326.         UpdateLog:=true;
  327.  
  328.         if Now>=IncMinute(LastAppResponseTime) then
  329.         begin
  330.           KillProcess(ProcessIDtoSupervise,true,true);
  331.           ApplicationFinishedGracefully:=false;
  332.           SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),FOREGROUND_RED or FOREGROUND_INTENSITY);
  333.           text:='['+DateTimeToStr(Now)+'] '+ExtractFileNameEx(StartCommandline)+' (PID:'+IntToStr(ProcessIDtoSupervise)+') has been killed. No response for 1 minute.';
  334.           WriteLn(text);
  335.           Log.Add(text);
  336.           UpdateLog:=true;
  337.         end;
  338.       end;
  339.     end
  340.     else
  341.     begin
  342.       SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),8);
  343.       text:='['+DateTimeToStr(Now)+'] '+ExtractFileNameEx(StartCommandline)+' (PID:'+IntToStr(ProcessIDtoSupervise)+') has no window.';
  344.       WriteLn(text);
  345.     end;
  346.  
  347.     if (UpdateLog=true) and (SaveLog(Log)=true) then UpdateLog:=false;
  348.   end;
  349.  
  350. end;
  351.  
  352.  
  353.  
  354. begin
  355.   { TODO -oUser -cConsole Main : Insert code here }
  356.  
  357.   DateSeparator:='-';
  358.   TimeSeparator:=':';
  359.   ShortDateFormat:='yyyy/mm/dd';
  360.   LongTimeFormat:='hh:mm:ss';
  361.   Log:=TStringList.Create;
  362.  
  363.   if ParamCount>0 then
  364.   begin
  365.  
  366.     repeat
  367.       //InitializeCriticalSection(CriticalSection);
  368.       ProcessIDtoSupervise:=0;
  369.  
  370.       SupervisorThread:=TSupervisorThread.Create(true);
  371.       SupervisorThread.FreeOnTerminate:=false;
  372.       SupervisorThread.StartCommandline:=ParamStr(1);
  373.       if ParamCount>1 then SupervisorThread.RestartCommandline:=ParamStr(2)
  374.       else SupervisorThread.RestartCommandline:='';
  375.       SupervisorThread.Resume;
  376.       SupervisorThread.WaitFor;
  377.       if Assigned(SupervisorThread)=true then FreeAndNil(SupervisorThread);
  378.  
  379.       //DeleteCriticalSection(CriticalSection);
  380.  
  381.     until ApplicationFinishedGracefully=true;
  382.  
  383.   end;
  384.  
  385.   Log.Free;
  386.   SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),7);
  387.  
  388. end.
  389.  

Atak_Snajpera

  • New Member
  • *
  • Posts: 31
Re: [LAZARUS 3.2] TIHelp32 not found
« Reply #18 on: May 22, 2024, 06:02:11 pm »
Once again thank you for all your help! I'm going to redesign that program. Instead of checking if main window is marked by OS as "not responding" I will focus on CPU cycles, Kernel time and User time of the process instead.

 

TinyPortal © 2005-2018