ewsdr/PlatformUtils.pas

unit PlatformUtils;

{
  PlatformUtils.pas - small helpers for desktop/runtime platform checks.
}

{$IFDEF FPC}
  {$MODE Delphi}
{$ENDIF}

interface

{$IFNDEF HEADLESS}
uses
  Controls;
{$ENDIF}

function HasOpenGLSpectrumSwitch: Boolean;
function CurrentScreenDPI: Integer;
// Целочисленный масштаб канвы экрана: 2 на Retina, 1 везде остальном.
// Windows/Linux всегда получают 1 ⇒ умножение на него ничего не меняет.
function GetScreenScale: Integer;
// То же, но для канвы конкретного контрола: на macOS масштаб берётся у окна,
// которому контрол принадлежит, а не у главного экрана. Это то самое число, в
// котором Cocoa рисует эту канву, и оно меняется, когда окно перетаскивают на
// монитор с другим масштабом. Так и надо считать размер offscreen-битмапа.
{$IFNDEF HEADLESS}
function GetControlScale(AControl: TControl): Integer;
{$ENDIF}
// Монотонные микросекунды одного источника для всех потоков. Нужны там, где
// интервалы считает не человек, а код: пейсинг запросов TX-аудио по TCI ведёт
// абсолютные дедлайны, и часы, способные прыгнуть от NTP, там не годятся.
function MonotonicUs: Int64;

// Тики счётчика → микросекунды, без переполнения. ★Наивное (Ticks * 1000000)
// div Freq переполняет Int64, когда Ticks переваливает за 2^63/10^6 = 9.223e12:
// при типовой для Windows 8+ частоте QPC 10 МГц это 10.7 суток аптайма, дальше
// разрыв повторяется каждые 21.35 суток (2^64/10^6 тиков). В момент разрыва
// время прыгает в большой минус, и код на абсолютных дедлайнах встаёт намертво:
// планировщик TX_CHRONO перестаёт слать маркеры, пейсинг отправителя DUC
// выпускает пакеты без выдержки. Считаем через частное и остаток: остаток
// меньше частоты, поэтому второе слагаемое не переполняется, а первое упирается
// в потолок Int64 через сотни тысяч лет. Функция вынесена в интерфейс, чтобы
// стенд мог проверить её на граничных значениях там, где Windows нет.
function TicksToUs(Ticks, Freq: Int64): Int64;

// Возвращает каталог для хранения конфигурации (с завершающим разделителем).
// macOS:   ~/Library/Application Support/ewsdr/
// Linux:   ~/.config/ewsdr/
// Windows: %APPDATA%\ewsdr\
function GetAppCfgDir: string;

implementation

uses
  SysUtils {$IFNDEF HEADLESS}, Forms{$ENDIF}
  {$IFDEF WINDOWS}, Windows{$ENDIF}
  {$IFDEF LINUX}, Linux, UnixType{$ENDIF}
  {$IF DEFINED(UNIX) AND NOT DEFINED(LINUX)}, BaseUnix{$ENDIF}
  {$IF DEFINED(DARWIN) AND NOT DEFINED(HEADLESS)}, MacScale{$ENDIF};

{$IFDEF WINDOWS}
var
  // ★ОДНО слово на всё состояние часов, и вот почему. Публикуется оно обычной
  // записью, без барьера, а читают его все потоки. Пара «значение + флаг
  // готовности» здесь недопустима: на слабой модели памяти (Windows ARM)
  // читатель вправе увидеть выставленный флаг раньше самого значения, получить
  // частоту 0 и вернуть время 0 — единичный НОЛЬ в монотонных часах, то есть
  // прыжок на десятки лет назад в бухгалтерии TX. С одним словом такого
  // расхождения не бывает: выровненная запись Int64 атомарна, а читатель
  // снимает её РОВНО ОДИН РАЗ в локальную переменную.
  //   0 — источник ещё не выбран;
  //  >0 — частота QPC;
  //  -1 — QPC непригоден, считаем по GetTickCount64 (выбор защёлкнут навсегда:
  //       смена источника на ходу — это тот же скачок времени).
  QPCFreq: Int64 = 0;

procedure InitWinClock;
// Идемпотентна. Зовётся из initialization — то есть ДО старта потоков.
var F: Int64;
begin
  if QPCFreq <> 0 then Exit;
  if QueryPerformanceFrequency(F) and (F > 0) then
    QPCFreq := F
  else
    // Счётчика нет — часы обязаны хотя бы ИДТИ: замершее время для кода на
    // абсолютных дедлайнах означает мёртвую передачу, а не потерю точности.
    QPCFreq := -1;
end;
{$ENDIF}

function TicksToUs(Ticks, Freq: Int64): Int64;
begin
  if Freq <= 0 then Exit(0);
  Result := (Ticks div Freq) * 1000000 + ((Ticks mod Freq) * 1000000) div Freq;
end;

{$IFDEF DARWIN}
// ★macOS: gettimeofday — СТЕННЫЕ часы, шаг NTP или правка руками уводят их
// вперёд и назад. Для абсолютных дедлайнов это негодный источник: назад —
// планировщик замирает до недостижимого срока, вперёд — выдаёт пачку и
// начисляет фиктивный долг. mach_absolute_time монотонен и есть на любой
// версии системы (в отличие от clock_gettime, появившегося в 10.12).
type
  TMachTimebase = record
    Numer: LongWord;
    Denom: LongWord;
  end;

function mach_absolute_time: QWord; cdecl; external 'c' name 'mach_absolute_time';
function mach_timebase_info(var Info: TMachTimebase): Integer; cdecl;
  external 'c' name 'mach_timebase_info';

var
  // ★Тоже ОДНО слово: numer в старшей половине, denom в младшей. Раздельные
  // numer/denom дали бы ту же гонку публикации, что и на Windows (Apple Silicon
  // — слабая модель памяти), а делить на прочитанный ноль нельзя вовсе.
  MachBase: Int64 = 0;

procedure InitMachClock;
// Идемпотентна. Зовётся из initialization — то есть ДО старта потоков.
var
  Info: TMachTimebase;
begin
  if MachBase <> 0 then Exit;
  Info.Numer := 0;
  Info.Denom := 0;
  if (mach_timebase_info(Info) <> 0) or (Info.Denom = 0) or (Info.Numer = 0) then
  begin
    // Тайминг-базы нет (быть такого не должно) — считаем тики наносекундами,
    // как на Intel, где numer = denom = 1.
    Info.Numer := 1;
    Info.Denom := 1;
  end;
  MachBase := (Int64(Info.Numer) shl 32) or Int64(Info.Denom);
end;
{$ENDIF}

function MonotonicUs: Int64;
{$IFDEF WINDOWS}
var
  V, F: Int64;
begin
  F := QPCFreq;                 // снимок ОДНОГО слова: см. объявление
  if F = 0 then
  begin
    InitWinClock;               // страховка: сюда доходит только вызов раньше
    F := QPCFreq;               // initialization, чего в норме не бывает
  end;
  if F < 0 then Exit(Int64(GetTickCount64) * 1000);
  QueryPerformanceCounter(V);
  Result := TicksToUs(V, F);
end;
{$ELSE}
  {$IFDEF LINUX}
var
  TS: TTimeSpec;
begin
  if clock_gettime(CLOCK_MONOTONIC, @TS) <> 0 then Exit(0);
  Result := Int64(TS.tv_sec) * 1000000 + TS.tv_nsec div 1000;
end;
  {$ELSE}
    {$IFDEF DARWIN}
var
  T, Ns, MachNumer, MachDenom: QWord;
  B: Int64;
begin
  B := MachBase;                // снимок ОДНОГО слова: см. объявление
  if B = 0 then
  begin
    InitMachClock;              // страховка: сюда доходит только вызов раньше
    B := MachBase;              // initialization, чего в норме не бывает
  end;
  MachNumer := QWord(B) shr 32;
  MachDenom := QWord(B) and $FFFFFFFF;
  if (MachNumer = 0) or (MachDenom = 0) then Exit(0);
  T := mach_absolute_time;
  // Через частное и остаток по той же причине, что и на Windows: на Apple
  // Silicon numer/denom = 125/3, и произведение тиков на 125 растёт быстро.
  Ns := (T div MachDenom) * MachNumer + ((T mod MachDenom) * MachNumer) div MachDenom;
  Result := Int64(Ns div 1000);
end;
    {$ELSE}
var
  TV: TTimeVal;
begin
  // Прочие Unix: монотонного источника под рукой нет, остаются стенные часы.
  // ★Знать об этом обязан тот, кто ведёт абсолютные дедлайны (см. TCIServer).
  fpgettimeofday(@TV, nil);
  Result := Int64(TV.tv_sec) * 1000000 + TV.tv_usec;
end;
    {$ENDIF}
  {$ENDIF}
{$ENDIF}

function HasOpenGLSpectrumSwitch: Boolean;
var
  I: Integer;
  S: string;
begin
  Result := False;
  for I := 1 to ParamCount do
  begin
    S := LowerCase(ParamStr(I));
    if (S = '--opengl') or (S = '-opengl') or (S = '/opengl') then
      Exit(True);
  end;
  // Бандл под LaunchServices не может передать argv, поэтому тот же
  // переключатель читается из окружения (Info.plist -> LSEnvironment).
  S := LowerCase(Trim(GetEnvironmentVariable('EWSDR_OPENGL')));
  if (S = '1') or (S = 'true') or (S = 'yes') or (S = 'on') then
    Exit(True);
end;

function GetScreenScale: Integer;
begin
{$IF DEFINED(DARWIN) AND NOT DEFINED(HEADLESS)}
  // Cocoa рисует канву в физических пикселях, а TBitmap всегда 1x. Кто рисует
  // через offscreen-битмап, должен растить его в GetScreenScale раз.
  Result := MacBackingScale;
{$ELSE}
  Result := 1;
{$ENDIF}
end;

{$IFNDEF HEADLESS}
function GetControlScale(AControl: TControl): Integer;
{$IF DEFINED(DARWIN)}
var
  Host: TWinControl;
begin
  // У TPaintBox и прочих TGraphicControl своего NSView нет — рисуют они на
  // канве ближайшего родителя с хендлом, его окно и спрашиваем.
  if AControl is TWinControl then
    Host := TWinControl(AControl)
  else if AControl <> nil then
    Host := AControl.Parent
  else
    Host := nil;
  while (Host <> nil) and not Host.HandleAllocated do
    Host := Host.Parent;

  if Host <> nil then
    Result := MacBackingScaleForView(Pointer(Host.Handle))
  else
    Result := 0;

  // Контрола ещё нет на экране: до первой отрисовки сгодится главный экран.
  if Result < 1 then
    Result := GetScreenScale;
{$ELSE}
begin
  Result := 1;
{$ENDIF}
end;
{$ENDIF}

function CurrentScreenDPI: Integer;
begin
{$IFNDEF HEADLESS}
  Result := Screen.PixelsPerInch;
  if Result <= 0 then Result := 96;
{$ELSE}
  Result := 96;   // headless-демон без LCL: экрана нет, дефолт DPI
{$ENDIF}
end;

function GetAppCfgDir: string;
begin
{$IFDEF WINDOWS}
  Result := GetEnvironmentVariable('APPDATA');
  if Result = '' then
    Result := GetEnvironmentVariable('LOCALAPPDATA');
  if Result = '' then
    Result := ExtractFilePath(ParamStr(0));
  Result := IncludeTrailingPathDelimiter(Result) + 'ewsdr' + PathDelim;
{$ELSE}
  Result := IncludeTrailingPathDelimiter(GetAppConfigDir(False));
{$ENDIF}
  if not DirectoryExists(Result) then
    ForceDirectories(Result);
end;

// ★Часы инициализируем ЗДЕСЬ, до старта любых потоков: ленивая инициализация
// из рабочего потока публиковала бы состояние обычной записью, а на слабой
// модели памяти сосед вправе увидеть её частично. Одного нуля в монотонных
// часах хватает, чтобы бухгалтерия TX получила скачок времени.
initialization
{$IFDEF WINDOWS}
  InitWinClock;
{$ENDIF}
{$IFDEF DARWIN}
  InitMachClock;
{$ENDIF}

end.