ModalProtection.pas

unit ModalProtection;

interface

uses
  Windows, Messages, SysUtils, Types, UITypes, Classes, Controls, Forms;

type
  TAppModalProtection = record
  strict private
    const
      N = 1024;
      TimeGap = 2;
      CountLimit = 5;
      TimeLimit = 20;
    type
      TModalityEvent = record
        Time: TDateTime;
        Modal: Boolean;
      end;
      TModalityHistory = array[0..N - 1] of TModalityEvent;
      TModalSpan = record
        Duration: Double;
        Count: Integer;
      end;
    class var
      FModalityHistory: TModalityHistory;
      FIdx: Integer;
      FModal: Integer;
      FOnWarning: TNotifyEvent;
      FSuspend: Boolean;
    class procedure AddEvent(AModal: Boolean); static;
    class function GetLastModalSpan: TModalSpan; static;
    class procedure DoWarning; static;
  public
    class procedure ModalBegun; static;
    class procedure ModalEnded; static;
    class property OnWarning: TNotifyEvent read FOnWarning write FOnWarning;
  end;

implementation

uses
  Math, DateUtils, StrUtils;

{ TAppModalProtection }

class procedure TAppModalProtection.AddEvent(AModal: Boolean);
begin
  FIdx := Succ(FIdx) mod N;
  FModalityHistory[FIdx].Time  := Now;
  FModalityHistory[FIdx].Modal := AModal;
end;

class procedure TAppModalProtection.DoWarning;
begin
  if Assigned(FOnWarning) then
    FOnWarning(nil);
end;

class function TAppModalProtection.GetLastModalSpan: TModalSpan;
begin

  Result := Default(TModalSpan);

  var LTime := Now;

  for var i := 0 to N - 1 do
  begin
    var LIdx := (FIdx - i + N) mod N;
    var LItem := FModalityHistory[LIdx];
    if LItem.Time = 0.0 then
      Exit;
    if LItem.Modal then
    begin
      Result.Duration := SecondSpan(LItem.Time, Now);
      Inc(Result.Count);
      LTime := LItem.Time;
    end
    else if SecondSpan(LItem.Time, LTime) >= TimeGap then
      Exit;
  end;

  // Entire buffer used. Don't know the actual duration.
  Result.Duration := TimeLimit + 1;

end;

class procedure TAppModalProtection.ModalBegun;
begin
  if FSuspend then
    Exit;
  Inc(FModal);
  if FModal = 1 then
    AddEvent(True);
end;

class procedure TAppModalProtection.ModalEnded;
begin
  if FSuspend then
    Exit;
  Dec(FModal);
  if FModal = 0 then
    AddEvent(False);
  var LMS := GetLastModalSpan;
  if (LMS.Count > CountLimit) and (LMS.Duration > TimeLimit) then
  begin
    FSuspend := True;
    try
      DoWarning;
    finally
      FSuspend := False;
    end;
  end;
end;

end.