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

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

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Application modal window(s) handling services.                             //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20250902 - Created by A.K.                                                 //
////////////////////////////////////////////////////////////////////////////////

unit _crw_appmodal; // Application Modal Windows(s) handling

{$I _crw_sysdef.inc}

{$I _crw_sysmode.inc}

interface

uses
 //////////////////////////////////////////////////////
 {$I _crw_uses_first.inc} // NB: MUST BE FIRST USES !!!
 //////////////////////////////////////////////////////
 sysutils, classes, math,
forms, controls, lmessages, lcltype,
 _crw_alloc, _crw_ef, _crw_fio, _crw_str, _crw_wmctrl,
 _crw_rtc, _crw_proc, _crw_polling, _crw_dbglog,
 _crw_appforms, _crw_apptools, _crw_apputils;

 {
 TAppModal - service class to manipulate modal window(s).
 Periodically (5sec) search window(s) which is MODAL and HIDDEN.
 Then show found window(s) to avoid program blocking.
 }
type
 TAppModal = class(TMasterObject)
 private
  myLastPoll:Int64;
  myInterval:Integer;
  myPolling:TPolling;
  myWantFocus:Boolean;
  myGlobFocus:Boolean;
 private
  function  GetPolling:TPolling;
  function  GetUsesPolling:Boolean;
  procedure SetUsesPolling(arg:Boolean);
  function  GetWantFocus:Boolean;
  procedure SetWantFocus(arg:Boolean);
  function  GetGlobFocus:Boolean;
  procedure SetGlobFocus(arg:Boolean);
  function  GetInterval:Integer;
  procedure SetInterval(i:Integer);
  function  GetStarted:Boolean;
  procedure SetStarted(s:Boolean);
 public
  constructor Create(aInterval:Integer=5000);
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  property  Polling:TPolling read GetPolling;
  property  UsesPolling:Boolean read GetUsesPolling write SetUsesPolling;
  property  WantFocus:Boolean read GetWantFocus write SetWantFocus;
  property  GlobFocus:Boolean read GetGlobFocus write SetGlobFocus;
  property  Interval:Integer read GetInterval write SetInterval;
  property  Started:Boolean read GetStarted write SetStarted;
 public
  procedure Start;
  procedure Stop;
 public
  function  PollPulser:Boolean;
  function  CountModalWindows:Integer;
  function  AwakeModalWindows:Integer;
 public
  function  ApplicationModalLevel:Integer;
  procedure ActivateTopmostModalForm;
  function  FindTopmostModalForm:TCustomForm;
  function  GetModalFormZOrderIndex(Form:TCustomForm):Integer;
 end;

 {
 The only one instance of TAppModal.
 }
function AppModal:TAppModal;

 ////////////////////
 // DebugLog channels
 ////////////////////
function dlc_AppModalBug:Integer;
function dlc_AppModalLog:Integer;

implementation

//////////////////
// Common routines
//////////////////

function dlc_AppModalBug:Integer;
const dlc:Integer=0;
begin
 if (dlc=0) then dlc:=RegisterDebugLogChannel('_AppModalBug');
 Result:=dlc;
end;

function dlc_AppModalLog:Integer;
const dlc:Integer=0;
begin
 if (dlc=0) then dlc:=RegisterDebugLogChannel('_AppModalLog');
 Result:=dlc;
end;

procedure BugReport(E:Exception; O:TObject; const M:LongString);
var Msg:LongString;
begin
 _crw_alloc.BugReport(E,O,M);
 if DebugLogEnabled(dlc_AppModalBug) then begin
  Msg:='Exception';
  if Assigned(E) then Msg:=Msg+' '+E.ClassName;
  if Assigned(O) then Msg:=Msg+' from '+O.ClassName;
  Msg:=Msg+' note '+QArg(M);
  if Assigned(E) then Msg:=Msg+' - '+E.Message;
  DebugLog(dlc_AppModalBug,Msg);
 end;
end;

////////////////////////////////////////
// Timer callback to awake modal windows
////////////////////////////////////////

procedure Timer_AwakeModalWindows;
begin
 if AppModal.PollPulser
 then AppModal.AwakeModalWindows;
end;

procedure Polling_AwakeModal(aPolling:TPolling; var Terminate:Boolean);
var Obj:TObject; App:TAppModal;
begin
 if Assigned(aPolling) then
 try
  Obj:=aPolling.LinkObject;
  if (Obj is TAppModal) then begin
   App:=(Obj as TAppModal);
   if App.PollPulser
   then App.AwakeModalWindows;
  end;
 except
  on E:Exception do BugReport(E,aPolling,'Polling_AwakeModal');
 end;
end;

///////////////////////////
// TAppModal implementation
///////////////////////////

constructor TAppModal.Create(aInterval:Integer=5000);
begin
 inherited Create;
 Interval:=aInterval;
 myPolling:=nil;
end;

destructor TAppModal.Destroy;
begin
 Kill(myPolling);
 inherited Destroy;
end;

procedure TAppModal.AfterConstruction;
begin
 inherited AfterConstruction;
end;

procedure TAppModal.BeforeDestruction;
begin
 Stop;
 inherited BeforeDestruction;
end;

function TAppModal.GetPolling:TPolling;
begin
 if Assigned(Self)
 then Result:=myPolling
 else Result:=nil;
end;

function TAppModal.GetUsesPolling:Boolean;
begin
 if Assigned(Self)
 then Result:=Assigned(myPolling)
 else Result:=False;
end;

procedure TAppModal.SetUsesPolling(arg:Boolean);
var SaveStarted:Boolean;
begin
 if Assigned(Self) then
 try
  SaveStarted:=Started; Stop;
  if not arg then Kill(myPolling);
  if arg and not Assigned(myPolling) then begin
   myPolling:=NewPolling(Polling_AwakeModal,1000,tpNormal,False,'System.AwakeModal');
   myPolling.Master:=@myPolling;
   myPolling.LinkObject:=Self;
  end;
  Started:=SaveStarted;
 except
  on E:Exception do BugReport(E,Self,'SetUsesPolling');
 end;
end;

function TAppModal.GetWantFocus:Boolean;
begin
 if Assigned(Self)
 then Result:=myWantFocus
 else Result:=False;
end;

procedure TAppModal.SetWantFocus(arg:Boolean);
begin
 if Assigned(Self)
 then myWantFocus:=arg;
end;

function TAppModal.GetGlobFocus:Boolean;
begin
 if Assigned(Self)
 then Result:=myGlobFocus
 else Result:=False;
end;

procedure TAppModal.SetGlobFocus(arg:Boolean);
begin
 if Assigned(Self)
 then myGlobFocus:=arg;
end;

function TAppModal.GetInterval:Integer;
begin
 if Assigned(Self)
 then Result:=myInterval
 else Result:=0;
end;

procedure TAppModal.SetInterval(i:Integer);
begin
 if Assigned(Self)
 then myInterval:=Max(0,i);
end;

function TAppModal.PollPulser:Boolean;
var ms,dt:Int64;
begin
 Result:=False;
 if Assigned(Self) then
 if (myInterval>0) then begin
  ms:=IntMsecNow; dt:=ms-myLastPoll;
  if (dt>=myInterval) then begin
   myLastPoll:=ms;
   Result:=True;
  end;
 end;
end;

function TAppModal.GetStarted:Boolean;
begin
 if Assigned(Self)
 then Result:=(UsesPolling and Polling.Enabled) or SecondActions.HasAction(Timer_AwakeModalWindows)
 else Result:=False;
end;

procedure TAppModal.SetStarted(s:Boolean);
begin
 if Assigned(Self) then begin
  if s then Start else Stop;
 end;
end;

procedure TAppModal.Start;
begin
 if Assigned(Self) then begin
  if UsesPolling
  then Polling.Enabled:=True
  else SecondActions.Add(Timer_AwakeModalWindows);
 end;
end;

procedure TAppModal.Stop;
begin
 if Assigned(Self) then begin
  if UsesPolling then Polling.Enabled:=False;
  SecondActions.Remove(Timer_AwakeModalWindows);
 end;
end;

type
 PModalIterRec = ^TModalIterRec;
 TModalIterRec = record Wnd:HWND; wsf:QWord; Count:Integer; end;

function cmwIter(n:SizeInt; Line:LongString; Custom:Pointer):Boolean;
var Wnd:HWND; wsf:QWord; PR:PModalIterRec;
begin
 Result:=True; PR:=Custom;
 if Assigned(Custom) and IsNonEmptyStr(Line) then begin
  Wnd:=wmctrl.StrToWnd(ExtractWord(1,Line,ScanSpaces));
  if wmctrl.IsWindow(Wnd) then begin
   wsf:=wmctrl.WindowStateFlags(Wnd);
   if HasFlags(wsf,WSF_MODAL) then begin
    PR.Wnd:=Wnd; PR.wsf:=wsf;
    Inc(PR.Count);
   end;
  end;
 end;
end;

function TAppModal.CountModalWindows:Integer;
var R:TModalIterRec; wList,wClass,wTitle,msg:LongString; mks:Double;
begin
 Result:=0;
 if Assigned(Self) then
 try
  R:=Default(TModalIterRec);
  mks:=0; wClass:=''; wTitle:='';
  if DebugLogEnabled(dlc_AppModalLog) then mks:=mksecnow;
  wList:=wmctrl.ListWindows(GetCurrentProcessId,wClass,wTitle);
  if (ForEachStringLine(wList,cmwIter,@R)>0) then Result:=R.Count;
  if DebugLogEnabled(dlc_AppModalLog) then begin
   mks:=mksecnow-mks;
   msg:=Format('CountModalWindows: found %d, takes %1.3f mks',[R.Count,mks]);
   DebugLog(dlc_AppModalLog,msg);
  end;
 except
  on E:Exception do BugReport(E,Self,'CountModalWindows');
 end;
end;

function amwIter(n:SizeInt; Line:LongString; Custom:Pointer):Boolean;
var Wnd:HWND; wsf:QWord; PR:PModalIterRec;
begin
 Result:=True; PR:=Custom;
 if Assigned(Custom) and IsNonEmptyStr(Line) then begin
  Wnd:=wmctrl.StrToWnd(ExtractWord(1,Line,ScanSpaces));
  if wmctrl.IsWindow(Wnd) then begin
   wsf:=wmctrl.WindowStateFlags(Wnd);
   if HasFlags(wsf,WSF_MODAL) then begin
    if HasFlags(wsf,WSF_HIDDEN)
    then wmctrl.SetWindowStateFlags(Wnd,WSC_REMOVE,WSF_HIDDEN);
    PR.Wnd:=Wnd; PR.wsf:=wsf;
    Inc(PR.Count);
   end;
  end;
 end;
end;

 // On Unix/GTK: if desktop active window belong to current process,
 // but not modal, activate target (modal) window (rWnd).
procedure CheckAndSetFocus(rWsf:QWord; rWnd:HWND; glob:Boolean);
var aWnd:HWnd; aPid:TPid; aWsf:QWord;
begin
 if not IsUnix then Exit;
 aPid:=0; aWnd:=0; aWsf:=0;
 if not wmctrl.IsWindow(rWnd) then Exit;
 if not HasFlags(rWsf,WSF_MODAL) then Exit;
 if (wmctrl.ActiveDesktop<>wmctrl.WindowDesktop(rWnd)) then Exit;
 aWnd:=wmctrl.ActiveWindow; if (aWnd=rWnd) then Exit; // Already done
 if wmctrl.IsWindow(aWnd) then aWsf:=wmctrl.WindowStateFlags(aWnd) else Exit;
 if HasFlags(aWsf,WSF_MODAL) and not HasFlags(aWsf,WSF_HIDDEN) then Exit;
 if glob then aPid:=GetCurrentProcessId else // Check window PID ?
 if wmctrl.IsWindow(aWnd) then aPid:=wmctrl.WindowPid(aWnd) else Exit;
 if (aPid<>GetCurrentProcessId) and not glob then Exit; // Another PID is active
 if not wmctrl.ActivateWindow(rWnd,False) then Exit; // Activation fail
 if DebugLogEnabled(dlc_AppModalLog)
 then DebugLog(dlc_AppModalLog,'Activated: '+wmctrl.WindowTitle(rWnd));
end;

function TAppModal.AwakeModalWindows:Integer;
var R:TModalIterRec; wList,wClass,wTitle,msg:LongString; mks:Double;
begin
 Result:=0;
 if Assigned(Self) then
 try
  R:=Default(TModalIterRec);
  mks:=0; wClass:=''; wTitle:='';
  if DebugLogEnabled(dlc_AppModalLog) then mks:=mksecnow;
  wList:=wmctrl.ListWindows(GetCurrentProcessId,wClass,wTitle);
  if (ForEachStringLine(wList,amwIter,@R)>0) then Result:=R.Count;
  if (R.Count=1) and WantFocus then CheckAndSetFocus(R.wsf,R.Wnd,GlobFocus);
  if DebugLogEnabled(dlc_AppModalLog) then begin
   mks:=mksecnow-mks;
   msg:=Format('AwakeModalWindows: found %d, takes %1.3f mks',[R.Count,mks]);
   DebugLog(dlc_AppModalLog,msg);
  end;
 except
  on E:Exception do BugReport(E,Self,'AwakeModalWindows');
 end;
end;

function TAppModal.ApplicationModalLevel:Integer;
begin
 if Assigned(Self) and Assigned(Application)
 then Result:=Application.ModalLevel
 else Result:=0;
end;

function TAppModal.FindTopmostModalForm:TCustomForm;
begin
 if Assigned(Self) and Assigned(Screen)
 then Result:=Screen.GetCurrentModalForm
 else Result:=nil;
end;

function TAppModal.GetModalFormZOrderIndex(Form:TCustomForm):Integer;
begin
 if Assigned(Self) and Assigned(Screen)
 then Result:=Screen.GetCurrentModalFormZIndex
 else Result:=-1;
end;

procedure TAppModal.ActivateTopmostModalForm;
var CForm:TCustomForm;
begin
 if IsMainThread then
 if Assigned(Self) then
 try
  CForm:=FindTopmostModalForm;
  if Assigned(CForm) then begin
   if (CForm.WindowState=wsMinimized)
   or (GetModalFormZOrderIndex(CForm)>0)
   or not CForm.Visible
   then CForm.ShowOnTop;
  end;
 except
  on E:Exception do BugReport(E,Self,'ActivateTopmostModalForm');
 end;
end;

//////////////////////////
// AppModal implementation
//////////////////////////
const
 TheAppModal:TAppModal=nil;

function AppModal:TAppModal;
begin
 if not Assigned(TheAppModal) then begin
  TheAppModal:=TAppModal.Create;
  TheAppModal.Master:=@TheAppModal;
 end;
 Result:=TheAppModal;
end;

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

procedure Init_crw_appmodal;
begin
 dlc_AppModalBug;
 dlc_AppModalLog;
 AppModal.Ok;
end;

procedure Free_crw_appmodal;
begin
 Kill(TObject(TheAppModal));
end;

initialization

 Init_crw_appmodal;

finalization

 Free_crw_appmodal;

end.

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

