ewsdr/TCIStreams.pas

unit TCIStreams;

{
  TCIStreams.pas — бинарные потоки TCI (§3.4): нарезка сэмплов на блоки,
  пересчёт частоты дискретизации, запись линейного выхода в файл.

  Чистый слой обработки: ни контроллера, ни движка тут нет — только TCIProtocol
  (формат блока) и TCIServer (очередь клиента). Кто и откуда кормит эти объекты,
  решает TCIAdapter.

  ★Главное про потоки исполнения. Feed* зовёт DSP-ПОТОК (тап аудио/IQ), то есть
  тот самый, который считает WDSP. Поэтому здесь нет ни одного вызова, который
  может ждать: блок уходит в кольцо клиента (микросекунды под его локом), а в
  сокет его пишет собственный поток клиента. Отставший клиент теряет свои блоки
  (TTCIClient.SendBin выбрасывает самый старый) и никого больше не задерживает.

  Пересчёт частоты:
    • вниз (RX-аудио 48 кГц → 8/12/24, IQ 384 → 48/96/192) — FIR-дециматор с
      целым коэффициентом. Без фильтра тут нельзя: широкий ФМ-канал или шум за
      полосой сложились бы в звуковую полосу зеркалом;
    • вверх (TX-аудио клиента 8/12/24 кГц → 48 кГц тракта) — линейная
      интерполяция. Образы от неё лежат на 8..12 кГц и выше, то есть заведомо
      за полосой TX-фильтра (максимум 4 кГц), а завал в полосе — 0.2 дБ на
      3 кГц. Городить ради этого второй FIR смысла нет.
}

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

interface

uses
  // ★Windows идёт ПЕРВЫМ намеренно: он объявляет свой TCriticalSection (запись,
  // а не класс), и стоя последним перекрыл бы SyncObjs — на win64 это уже
  // ловилось в DX-кластере. Порядок здесь и есть лечение.
  {$IFDEF WINDOWS}Windows,{$ENDIF}
  {$IFDEF UNIX}BaseUnix,{$ENDIF}
  // renameat2 обёртки в RTL нет, а нужен именно он (см. TCIPublishFile).
  {$IFDEF LINUX}syscall,{$ENDIF}
  Classes, SysUtils, Math, SyncObjs, TCIProtocol, TCIServer;

const
  // Длина FIR на каждую ступень прореживания. Ntaps = TCI_FIR_PER_FACTOR×M+1
  // ⇒ стоимость на ВХОДНОЙ сэмпл постоянна (≈8 умножений) независимо от M.
  TCI_FIR_PER_FACTOR = 8;
  TCI_FIR_MAX_TAPS   = 257;
  // Кусок, которым поток перемалывает подачу от движка. Все рабочие буферы
  // заведены под него в конструкторе: SetLength в DSP-потоке на каждый блок
  // аудио — это тысячи обращений к куче в секунду на ровном месте.
  TCI_FEED_CHUNK     = 4096;
  // ★Очередь писателя WAV. Заданий больше этого числа не копим: клиент
  // услышит отказ, а не будет молча наполнять память сохранениями, которые
  // медленный диск разгребёт неизвестно когда. Каждое задание держит своё
  // место в общем бюджете (TCI_RECORD_MAX_BYTES), так что памятью очередь
  // ограничена и без счётчика — этот потолок про сами задания.
  TCI_RECORD_MAX_JOBS = 16;

type
  { Накопленная запись: 16-битный PCM с чередованием L/R. }
  TTCIPcm = array of SmallInt;
  TTCIPcmChunks = array of TTCIPcm;

  { ★Забранная запись — КУСКИ КАК ЕСТЬ, без сплошной копии. Копия удваивала бы
    пик памяти ровно в тот момент, когда её меньше всего: при полном бюджете
    рядом жили бы 128 МБ кусков и 128 МБ копии, а счётчик показывал бы 128.
    Куски переезжают к писателю вместе со своим местом в бюджете (Reserved),
    и WAV собирается из них подряд — данные в нём и так лежат встык.
      Chunk — сэмплов на канал в ПОЛНОМ куске (последний бывает неполным),
      Count — сколько их занято всего. }
  TTCIRecTake = record
    Chunks:   TTCIPcmChunks;
    Chunk:    Integer;
    Count:    Integer;
    Reserved: Int64;
  end;

  { Дециматор с целым коэффициентом. Прямая свёртка по линии задержки: выход
    считается только на нужной фазе, поэтому цена не зависит от M. }
  TTCIDecimator = class
  private
    FTaps:   array of Single;
    FHist:   array of Single;   // линия задержки, кольцо
    FN:      Integer;           // длина FIR
    FHalf:   Integer;           // FN div 2 — число симметричных пар
    FPos:    Integer;
    FPhase:  Integer;
    FFactor: Integer;
  public
    { Одиночный дециматор: полоса 0.45 от новой частоты Найквиста, длина FIR
      по коэффициенту. Для одной ступени этого достаточно. }
    constructor Create(AFactor: Integer);
    { Ступень каскада: полосу и длину задаёт вызывающий — ранним ступеням
      узкая переходная полоса не нужна (см. TTCIDecimChain). }
    constructor CreateDesigned(AFactor, ATaps: Integer; ACutoff: Double);
    procedure Reset;
    { N входных сэмплов → до N/Factor выходных. Dst обязан вмещать столько. }
    function  Process(const Src: array of Single; N: Integer;
                      var Dst: array of Single): Integer;
    property Factor: Integer read FFactor;
    property Taps: Integer read FN;
  end;

  { Каскад дециматоров. Одной ступенью большие коэффициенты не берутся: длина
    FIR растёт вместе с коэффициентом, а упираясь в потолок TCI_FIR_MAX_TAPS,
    одноступенчатый дециматор перестаёт быть фильтром вовсе. Замерено на
    5760→48 кГц (коэффициент 120, верхний rate Pluto): завал 1.3 дБ в полосе и
    подавление зеркала всего 16 дБ — то есть поток IQ с мусором.

    Поэтому коэффициент раскладывается на множители (по убыванию — самая
    дорогая ступень первой). Спецификацию фильтра каждой ступени задаёт
    ИТОГОВАЯ полоса, а не её собственная: ранняя ступень обязана убрать лишь
    те узкие зоны, которые в конце сложатся в полезную полосу, поэтому её
    переходная полоса шире в десятки раз, а фильтр во столько же короче.
    Итог замера: −83 дБ по зеркалу на любом коэффициенте, цена ≈10% ядра на
    потоке 5.76 МГц (было 20% и мусор). Свёртка идёт со сложением симметричных
    пар — умножений вдвое меньше при том же результате. }
  TTCIDecimChain = class
  private
    FStages: array of TTCIDecimator;
    FTmp:    array[0..1] of array of Single;
    FFactor: Integer;
  public
    constructor Create(AFactor: Integer);
    destructor  Destroy; override;
    procedure Reset;
    function  Process(const Src: array of Single; N: Integer;
                      var Dst: array of Single): Integer;
    property Factor: Integer read FFactor;
  end;

  { Интерполятор для TX-аудио: целое отношение, линейная интерполяция. }
  TTCIInterpolator = class
  private
    FFactor: Integer;
    FPrev:   Single;
    FHas:    Boolean;
  public
    constructor Create(AFactor: Integer);
    procedure Reset;
    function  Process(const Src: array of Single; N: Integer;
                      var Dst: array of Double): Integer;
    property Factor: Integer read FFactor;
  end;

  { Исходящий поток одного клиента: один тип, один приёмник. Живёт от START до
    STOP (или до ухода клиента) и владеет своими дециматорами и накопителем. }
  TTCIStreamOut = class
  private
    FClient:   TTCIClient;
    FKind:     TTCIStreamType;
    FRx:       Integer;
    FSrcRate:  Integer;
    FOutRate:  Integer;
    FChannels: Integer;
    FSampleT:  TTCISampleType;
    FBlock:    Integer;              // сэмплов НА КАНАЛ в блоке
    FDec:      array[0..1] of TTCIDecimChain;
    FTmp:      array[0..1] of array of Single;   // выход дециматора
    FIn:       array of Single;                  // вход одного канала, кусок

    FWantRate: Integer;              // о чём просил клиент (для пересборки)
    FAcc:      array of Single;      // накопитель с чередованием каналов
    FAccCount: Integer;              // сэмплов на канал в накопителе
    FPacked:   array of Byte;
    procedure EmitFull;
    procedure PushPair(A, B: Single);
  public
    constructor Create(AClient: TTCIClient; AKind: TTCIStreamType;
                       ARx, ASrcRate, AWantRate, AChannels: Integer;
                       ASampleT: TTCISampleType; ABlock: Integer);
    destructor  Destroy; override;

    { Аудио 48 кГц: стерео от движка. Один канал — усреднение (моно). }
    procedure FeedAudio(const L, R: array of Single; N: Integer);
    { IQ: комплексные отсчёты, всегда два канала. }
    procedure FeedIQ(PI_, PQ_: PDouble; N: Integer);

    { Совпадает ли поток с (клиент, тип, приёмник) — для поиска в списке. }
    function  Matches(AClient: TTCIClient; AKind: TTCIStreamType;
                      ARx: Integer): Boolean;

    { Частота источника сменилась на ходу (другой sample rate устройства или
      rate DDC пана). Пересобирает прореживание; накопленный блок бросаем —
      склеивать в один блок сэмплы двух разных частот нельзя. }
    procedure SetSourceRate(ANewRate: Integer);

    property Client:  TTCIClient read FClient;
    property Kind:    TTCIStreamType read FKind;
    property Rx:      Integer read FRx;
    property OutRate: Integer read FOutRate;
    property SrcRate: Integer read FSrcRate;
  end;

  { Запись линейного выхода (LINE_OUT_RECORDER_*, §4.3). Буфер на MaxSec секунд
    48 кГц стерео в int16: во-первых, ровно то, что уйдёт в WAV, а во-вторых,
    float32 на предельных 300 с — это 115 МБ вместо 57.

    ★Не кольцо. Документ говорит про arg2 «максимальное время записи», и дальше
    прямо: «по истечении времени запись УДАЛЯЕТСЯ, чтобы сохранить запись в файл
    необходимо в заданном временном интервале выслать LINE_OUT_RECORDER_SAVE».
    То есть START открывает окно длиной MaxSec, и всё, что не сохранили внутри
    него, пропадает. Кольцо «последние N секунд» вело себя иначе в обе стороны:
    начало активной записи затирало само себя, а SAVE через час после START
    отдавал файл, которого у ExpertSDR3 давно бы не было.

    Срок считаем по ЧАСАМ, а не по накопленным сэмплам: линейный выход молчит
    (мьют, пауза приёмника), а время записи всё равно идёт. }
  { ★Память набирается КУСКАМИ по мере записи, а не вся сразу на START.
    Раньше конструктор выделял MaxSec × 48 кГц × 2 канала × int16 — до 57.6 МБ
    на одну строку из сети; семь приёмников давали 403 МБ, и удержать их мог
    любой клиент (авторизации в TCI нет). Теперь START не стоит ни байта:
    молчащий, мёртвый или замьюченный приёмник не занимает ничего, а растущая
    запись спрашивает разрешения на каждый кусок у общего бюджета
    TCI_RECORD_MAX_BYTES. Куски не перевыделяются (никакого realloc в
    DSP-потоке) и НЕ склеиваются вовсе: Take отдаёт их писателю как есть, а тот
    пишет их в файл подряд — сплошная копия удваивала бы пик памяти ровно
    там, где её меньше всего. }
  TTCIRecorder = class
  private
    FLock:    TCriticalSection;
    FChunks:  TTCIPcmChunks;       // куски по FChunk сэмплов на канал, L/R вперемешку
    FChunk:   Integer;             // сэмплов на канал в куске
    FCap:     Integer;             // потолок в сэмплах на канал
    FCount:   Integer;             // накоплено сэмплов на канал
    FBytes:   Int64;               // занято под FChunks (столько же взято у бюджета)
    FRate:    Integer;
    FRx:      Integer;
    FOwner:   TObject;             // клиент, попросивший START (для его ухода)
    FExpired: Boolean;             // окно записи закрылось, данные удалены
    FStarved: Boolean;             // бюджет не дал расти — пишем сколько влезло
    FEndsAt:  QWord;               // GetTickCount64 конца окна
    procedure DropData;            // под FLock
    function  EnsureRoom: Boolean; // под FLock: место под ещё один сэмпл
  public
    constructor Create(ARx, ARateHz, AMaxSec: Integer; AOwner: TObject);
    destructor  Destroy; override;
    procedure Feed(const L, R: array of Single; N: Integer);
    { Забрать накопленное и завершить запись. Count = 0 — либо не записано
      ничего, либо окно уже истекло (по документу это одно и то же: записи
      нет). ★Вместе с кусками уходит и их место в бюджете (Reserved): пока
      писатель их не отпустит, они обязаны оставаться учтёнными. Вызывающий
      передаёт запись писателю — или сам возвращает Reserved через
      TCIRecBudgetFree, если писателя не будет. }
    function  Take: TTCIRecTake;
    { Окно закрылось по часам. Спрашивает тик сервера: у мёртвого приёмника
      Feed не зовут вовсе, и без этого вопроса память жила бы до Stop. }
    function  Expired: Boolean;
    property Rx:   Integer read FRx;
    property Rate: Integer read FRate;
    property Owner: TObject read FOwner;
  end;

  { Одно задание писателю: куда писать и что. }
  TTCIRecJob = record
    Path: string;
    Rec:  TTCIRecTake;
    Rate: Integer;
  end;

  { Писатель WAV: ОДИН поток с очередью, которым владеет адаптер. Пишет не
    вызывающий (файл до 60 МБ, а зовут сохранение из потока клиента), но и не
    кто попало.

    ★Раньше на каждый SAVE заводился отдельный поток с FreeOnTerminate: его
    никто не держал и никто не ждал. Отсюда две беды.
    (1) Штатный выход из программы обрывал запись на полуслове — замерено: из
        ожидаемых 100000044 байт на диске оставалось 40960 (то, что успел
        сбросить буфер ФС), а заголовок при этом заявлял полную длину.
    (2) На медленном или зависшем каталоге идущие подряд SAVE плодили сотни
        потоков, и память их стеков в 128-МБ бюджет не входила вовсе.

    Теперь очередь ограничена (TCI_RECORD_MAX_JOBS — дальше клиент слышит
    отказ), поток один, а адаптер при своей гибели дожидается ВСЕЙ очереди и
    делает WaitFor (TCIStopWriter) — ни брошенных потоков, ни выброшенных
    записей после нас не остаётся. Данные каждого задания держат своё место в
    общем бюджете (TTCIRecTake.Reserved) до конца записи — так потолок держит
    и очередь сохранений, а не только сами записи. }
  TTCIWavWriter = class(TThread)
  private
    FLock:   TCriticalSection;
    FWake:   PRTLEvent;
    FJobs:   array of TTCIRecJob;    // очередь, FIFO
    FBusy:   Boolean;                // задание на руках у Execute
    FClosed: Boolean;                // идёт остановка: новых не принимаем
    function  Pop(out J: TTCIRecJob): Boolean;
    procedure Done;
    procedure WriteJob(const J: TTCIRecJob);
    class procedure ReleaseJob(var J: TTCIRecJob);
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor  Destroy; override;
    { Поставить запись в очередь. False — очередь полна или писатель гасится;
      тогда куски и их место в бюджете остаются на вызывающем (он обязан
      вернуть Reserved сам). }
    function  Enqueue(const APath: string; const ARec: TTCIRecTake;
                      ARateHz: Integer): Boolean;
    { Сколько заданий ещё не дописано (вместе с тем, что пишется сейчас). }
    function  Pending: Integer;
    { Больше не принимать заданий (первый шаг остановки). }
    procedure Close;
    { Ждать, пока очередь опустеет — БЕЗ СРОКА. Всякий срок здесь оказался
      обманом: остановить поток, стоящий в write/fsync, изнутри процесса всё
      равно нечем (Terminate ему не указ, а Free обязан сделать WaitFor),
      поэтому срок не спасал от зависания — он только терял хвост очереди на
      медленном каталоге, который потом оживал. За каждую запись в очереди
      клиенту уже сказано «сохранено», так что ждём столько, сколько нужно. }
    procedure WaitDrained;
  end;

{ Коэффициент прореживания SrcRate → WantRate: наибольший целый делитель,
  дающий не меньше запрошенного. Апсемплинг наружу не делаем никогда —
  клиенту уходит настоящая частота (она же в заголовке блока). }
function TCIDecimFactor(SrcRate, WantRate: Integer): Integer;

{ Частота IQ, которую реально можно отдать: наибольшая ЗАКОННАЯ по протоколу
  (48/96/192/384 кГц), не выше запрошенной и делящая частоту источника нацело.
  Нужна из-за частот дискретизации Pluto: 576 и 960 кГц на 384 не делятся, и
  без этого выбора клиент, попросивший 384 кГц, получал бы поток на 576/480 —
  и не по протоколу, и вчетверо толще, чем он ждёт. Если законной не нашлось
  вовсе (чужой rate), возвращаем просьбу как есть: дальше её обработает
  TCIDecimFactor, а настоящая частота уйдёт в заголовке блока. }
function TCIPickIQRate(SrcRate, WantRate: Integer): Integer;

{ ═══ Общий бюджет памяти рекордеров ═══════════════════════════════════════
  Взять/вернуть можно из любого потока (Take зовёт DSP-поток, Free — тик,
  поток клиента и поток контроллера). TCIRecBudgetTake возвращает False, если
  запрошенное не влезает в TCI_RECORD_MAX_BYTES. }
function TCIRecBudgetTake(Bytes: Int64): Boolean;
procedure TCIRecBudgetFree(Bytes: Int64);
function TCIRecBudgetUsed: Int64;      // для стенда и диагностики

{ ═══ Имя файла записи ═════════════════════════════════════════════════════
  ★Из строки LINE_OUT_RECORDER_SAVE берётся ТОЛЬКО имя файла, а каталог —
  всегда настроенный каталог записей. Причина простая: авторизации в TCI нет
  (§3.1), а bind наружу разрешён, поэтому любой, кто дотянулся до порта, писал
  бы файлы от имени EWSDR куда угодно — путь уходил в fmCreate почти как
  пришёл, вместе с '..' и абсолютными путями. Документ (§4.3) в примерах даёт
  полный путь, но полный путь на СЕРВЕРЕ клиенту всё равно бесполезен: файл
  ложится не на его машину, а на нашу. Поэтому каталог из просьбы отбрасываем
  молча (клиент получает разумный файл, а не ошибку), а имя проверяем: пусто,
  '.', '..', управляющие символы и слишком длинное — отказ; расширение обязано
  быть .wav (кодировать MP3 нам нечем). Выйти за каталог после ExtractFileName
  нечем — разделителей в имени уже не осталось.
  Result = '' — имя не годится; иначе полный путь внутри BaseDir. }
function TCIRecordPath(const BaseDir, Req: string): string;

{ Создать файл, НЕ перезаписывая существующий и не идя по симлинку. Отдельно
  от TFileStream: fmCreate молча затирает то, что уже лежит по этому пути, а
  имя приходит из сети. THandle(-1) — не вышло. }
function TCICreateNewFile(const Path: string): THandle;

{ Очередное имя временного файла рядом с целью: <путь>.<pid>-<N>.part. Каждый
  вызов даёт следующее. Наружу открыто ради стенда — ему нужно занять ровно то
  имя, которое возьмёт писатель. }
function TCIRecTempName(const Path: string): string;

{ Погасить писателя: закрыть приём заданий, дождаться ВСЕЙ очереди и
  освободить объект (Destroy = Terminate + WaitFor). Зовут при гибели
  адаптера, ради этого писатель и стал управляемым. W обнуляется в любом
  случае.
  ★Срока здесь нет намеренно — см. WaitDrained и комментарий в реализации. }
procedure TCIStopWriter(var W: TTCIWavWriter);

implementation

{ ═══════════════════════════════════════════════════════════════════════════
  Дециматор
  ═══════════════════════════════════════════════════════════════════════════ }

constructor TTCIDecimator.Create(AFactor: Integer);
var N: Integer;
begin
  if AFactor < 1 then AFactor := 1;
  N := TCI_FIR_PER_FACTOR * AFactor + 1;
  CreateDesigned(AFactor, N, 0.45 / AFactor);
end;

constructor TTCIDecimator.CreateDesigned(AFactor, ATaps: Integer;
  ACutoff: Double);
var
  i, C: Integer;
  X, W, Sum: Double;
begin
  inherited Create;
  if AFactor < 1 then AFactor := 1;
  FFactor := AFactor;
  FN := ATaps;
  if FN < 9 then FN := 9;
  if FN > TCI_FIR_MAX_TAPS then FN := TCI_FIR_MAX_TAPS;
  if (FN and 1) = 0 then Inc(FN);          // нечётная длина: линейная фаза и
                                            // целая задержка
  FHalf := FN div 2;
  SetLength(FTaps, FN);
  SetLength(FHist, FN);

  // Окно Блэкмана поверх sinc. Оно, в отличие от Хэмминга, даёт −74 дБ вместо
  // −53 в полосе задержания, а платим за это только длиной — и как раз длину
  // многоступенчатая схема экономит (см. TTCIDecimChain).
  C   := FN div 2;
  Sum := 0;
  for i := 0 to FN - 1 do
  begin
    X := i - C;
    if Abs(X) < 1E-9 then W := 2 * ACutoff
    else W := Sin(2 * Pi * ACutoff * X) / (Pi * X);
    W := W * (0.42 - 0.5 * Cos(2 * Pi * i / (FN - 1))
                   + 0.08 * Cos(4 * Pi * i / (FN - 1)));
    FTaps[i] := W;
    Sum := Sum + W;
  end;
  // Нормировка по единичному усилению на постоянном токе: без неё уровень
  // аудио гулял бы на доли дБ от коэффициента прореживания.
  if Abs(Sum) > 1E-12 then
    for i := 0 to FN - 1 do FTaps[i] := FTaps[i] / Sum;
  Reset;
end;

procedure TTCIDecimator.Reset;
var i: Integer;
begin
  for i := 0 to FN - 1 do FHist[i] := 0;
  FPos   := 0;
  FPhase := 0;
end;

function TTCIDecimator.Process(const Src: array of Single; N: Integer;
  var Dst: array of Single): Integer;
var
  i, k, t, a, b: Integer;
  Acc: Double;
begin
  Result := 0;
  if N > Length(Src) then N := Length(Src);
  if FFactor = 1 then
  begin
    // Прореживать нечего — фильтр в этом случае только съел бы верх полосы.
    k := N;
    if k > Length(Dst) then k := Length(Dst);
    for i := 0 to k - 1 do Dst[i] := Src[i];
    Exit(k);
  end;

  k := 0;
  for i := 0 to N - 1 do
  begin
    FHist[FPos] := Src[i];
    Inc(FPos);
    if FPos >= FN then FPos := 0;

    Inc(FPhase);
    if FPhase < FFactor then Continue;
    FPhase := 0;
    if k >= Length(Dst) then Break;   // переполнение приёмника — молча режем

    // Свёртка со сложением симметричных пар: фильтр линейнофазовый, значит
    // FTaps[t] = FTaps[N-1-t], и умножений вдвое меньше при том же результате.
    // На 5.76 МГц (верхний rate Pluto) это разница между 16% и 10% ядра.
    Acc := 0;
    a := FPos;                        // самый старый отсчёт (это отвод N-1)
    b := FPos + FN - 1;               // самый свежий (это отвод 0)
    if b >= FN then Dec(b, FN);
    for t := 0 to FHalf - 1 do
    begin
      Acc := Acc + FTaps[t] * (FHist[a] + FHist[b]);
      Inc(a); if a >= FN then a := 0;
      Dec(b); if b < 0 then b := FN - 1;
    end;
    Dst[k] := Acc + FTaps[FHalf] * FHist[a];   // центральный отвод
    Inc(k);
  end;
  Result := k;
end;

{ ═══════════════════════════════════════════════════════════════════════════
  Каскад дециматоров
  ═══════════════════════════════════════════════════════════════════════════ }

constructor TTCIDecimChain.Create(AFactor: Integer);
var
  Rest, F, i, N: Integer;
  Cur, FPass, FStop: Double;
  Fac: array of Integer;

  procedure AddFactor(V: Integer);
  begin
    SetLength(Fac, Length(Fac) + 1);
    Fac[High(Fac)] := V;
  end;

begin
  inherited Create;
  if AFactor < 1 then AFactor := 1;
  FFactor := AFactor;
  Rest := AFactor;
  // Раскладываем на простые. Всё, что не разложилось (простое число больше
  // семи — у частот дискретизации не встречается, но бывает у чужого железа),
  // остаётся одной ступенью: она хотя бы не хуже прежнего поведения.
  for F in [2, 3, 5, 7] do
    while (Rest mod F = 0) and (Rest > 1) do
    begin
      AddFactor(F);
      Rest := Rest div F;
    end;
  if Rest > 1 then AddFactor(Rest);

  // По убыванию: первая ступень самая «дорогая», и после неё частота, на
  // которой работают остальные, уже сбита.
  for i := 0 to High(Fac) - 1 do
    for F := 0 to High(Fac) - 1 - i do
      if Fac[F] < Fac[F + 1] then
      begin
        Rest       := Fac[F];
        Fac[F]     := Fac[F + 1];
        Fac[F + 1] := Rest;
      end;

  // Спецификация фильтра каждой ступени считается от ИТОГОВОЙ полосы, а не от
  // её собственной. Ранняя ступень отдаёт наверх широкий поток, и всё, что она
  // обязана убрать, — те узкие зоны, которые в конце сложатся в полезную
  // полосу; переходная полоса у неё получается в десятки раз шире, а значит и
  // фильтр во столько же раз короче. Ради этого многоступенчатую схему и
  // делают: на 5760→48 кГц первая ступень обходится 30 отводами вместо 257,
  // которых всё равно не хватало.
  SetLength(FStages, Length(Fac));
  Cur := 1.0;                    // доля от исходной частоты на входе ступени
  for i := 0 to High(Fac) do
  begin
    // Полоса, которую обязаны сохранить, — 0.45 от итоговой Найквиста,
    // в единицах ВХОДНОЙ частоты этой ступени.
    FPass := (0.45 * 0.5 / FFactor) / Cur;
    FStop := (1.0 / Fac[i]) - FPass;    // сюда сложится всё лишнее
    if FStop <= FPass * 1.05 then       // последняя ступень: запаса уже нет
    begin
      FPass := 0.45 / Fac[i];
      FStop := 0.55 / Fac[i];
    end;
    // Ширина переходной полосы ↔ длина окна Блэкмана: N ≈ 5.5/Δf.
    N := Ceil(5.5 / (FStop - FPass)) + 1;
    FStages[i] := TTCIDecimator.CreateDesigned(Fac[i], N,
                                               (FPass + FStop) * 0.5);
    Cur := Cur / Fac[i];
  end;
  SetLength(FTmp[0], TCI_FEED_CHUNK);
  SetLength(FTmp[1], TCI_FEED_CHUNK);
end;

destructor TTCIDecimChain.Destroy;
var i: Integer;
begin
  for i := 0 to High(FStages) do FStages[i].Free;
  inherited;
end;

procedure TTCIDecimChain.Reset;
var i: Integer;
begin
  for i := 0 to High(FStages) do FStages[i].Reset;
end;

function TTCIDecimChain.Process(const Src: array of Single; N: Integer;
  var Dst: array of Single): Integer;
var
  i, Cur: Integer;
begin
  if N > Length(Src) then N := Length(Src);
  if Length(FStages) = 0 then
  begin
    if N > Length(Dst) then N := Length(Dst);
    for i := 0 to N - 1 do Dst[i] := Src[i];
    Exit(N);
  end;
  if Length(FStages) = 1 then
    Exit(FStages[0].Process(Src, N, Dst));

  // Пинг-понг между двумя буферами; последняя ступень пишет сразу в Dst.
  Cur := 0;
  N := FStages[0].Process(Src, N, FTmp[0]);
  for i := 1 to High(FStages) - 1 do
  begin
    N := FStages[i].Process(FTmp[Cur], N, FTmp[1 - Cur]);
    Cur := 1 - Cur;
  end;
  Result := FStages[High(FStages)].Process(FTmp[Cur], N, Dst);
end;

{ ═══════════════════════════════════════════════════════════════════════════
  Интерполятор (TX-аудио клиента → 48 кГц тракта)
  ═══════════════════════════════════════════════════════════════════════════ }

constructor TTCIInterpolator.Create(AFactor: Integer);
begin
  inherited Create;
  if AFactor < 1 then AFactor := 1;
  FFactor := AFactor;
  Reset;
end;

procedure TTCIInterpolator.Reset;
begin
  FPrev := 0;
  FHas  := False;
end;

function TTCIInterpolator.Process(const Src: array of Single; N: Integer;
  var Dst: array of Double): Integer;
var
  i, p, k: Integer;
  A, B: Single;
begin
  if N > Length(Src) then N := Length(Src);
  k := 0;
  if FFactor = 1 then
  begin
    for i := 0 to N - 1 do
    begin
      if k >= Length(Dst) then Break;
      Dst[k] := Src[i];
      Inc(k);
    end;
    Exit(k);
  end;

  for i := 0 to N - 1 do
  begin
    B := Src[i];
    if FHas then A := FPrev else A := B;   // самый первый блок: без скачка от нуля
    for p := 0 to FFactor - 1 do
    begin
      if k >= Length(Dst) then Break;
      Dst[k] := A + (B - A) * (p / FFactor);
      Inc(k);
    end;
    FPrev := B;
    FHas  := True;
  end;
  Result := k;
end;

{ ═══════════════════════════════════════════════════════════════════════════
  Исходящий поток
  ═══════════════════════════════════════════════════════════════════════════ }

constructor TTCIStreamOut.Create(AClient: TTCIClient; AKind: TTCIStreamType;
  ARx, ASrcRate, AWantRate, AChannels: Integer; ASampleT: TTCISampleType;
  ABlock: Integer);
var
  F, MaxB, i: Integer;
begin
  inherited Create;
  FClient   := AClient;
  FKind     := AKind;
  FRx       := ARx;
  FSrcRate  := ASrcRate;
  FWantRate := AWantRate;
  FChannels := EnsureRange(AChannels, 1, 2);
  FSampleT  := ASampleT;

  if FKind = tstIQ then AWantRate := TCIPickIQRate(ASrcRate, AWantRate);
  F := TCIDecimFactor(ASrcRate, AWantRate);
  FOutRate := ASrcRate div F;

  // Блок не имеет права вылезти за data[16384]: столько ExpertSDR3 объявил
  // потолком, и клиенты держат приёмный буфер ровно под него.
  MaxB := TCIMaxBlockSamples(FSampleT, FChannels);
  FBlock := EnsureRange(ABlock, 1, MaxB);

  for i := 0 to FChannels - 1 do
  begin
    FDec[i] := TTCIDecimChain.Create(F);
    SetLength(FTmp[i], TCI_FEED_CHUNK);
  end;
  SetLength(FIn, TCI_FEED_CHUNK);
  SetLength(FAcc, FBlock * FChannels);
  SetLength(FPacked, FBlock * FChannels * TCISampleBytes(FSampleT));
  FAccCount := 0;
end;

destructor TTCIStreamOut.Destroy;
var i: Integer;
begin
  for i := 0 to 1 do FreeAndNil(FDec[i]);
  inherited;
end;

function TTCIStreamOut.Matches(AClient: TTCIClient; AKind: TTCIStreamType;
  ARx: Integer): Boolean;
begin
  Result := (FClient = AClient) and (FKind = AKind) and (FRx = ARx);
end;

procedure TTCIStreamOut.SetSourceRate(ANewRate: Integer);
var i, F, W: Integer;
begin
  if (ANewRate <= 0) or (ANewRate = FSrcRate) then Exit;
  FSrcRate := ANewRate;
  // Просьбу клиента храним как есть, а законную частоту пересчитываем: у
  // нового источника делители другие (576 кГц Pluto не делится на 384).
  if FKind = tstIQ then W := TCIPickIQRate(FSrcRate, FWantRate)
  else W := FWantRate;
  F := TCIDecimFactor(FSrcRate, W);
  FOutRate := FSrcRate div F;
  for i := 0 to FChannels - 1 do
  begin
    FDec[i].Free;
    FDec[i] := TTCIDecimChain.Create(F);
  end;
  FAccCount := 0;
end;

procedure TTCIStreamOut.EmitFull;
var
  H: TTCIStreamHeader;
  Bytes: Integer;
begin
  TCIFillHeader(H, FKind, FRx, FOutRate, FSampleT, FBlock, FChannels);
  Bytes := TCIPackSamples(FAcc, FBlock * FChannels, FSampleT, @FPacked[0]);
  FClient.SendBin(H, @FPacked[0], Bytes);
  FAccCount := 0;
end;

procedure TTCIStreamOut.PushPair(A, B: Single);
begin
  if FChannels = 1 then
    FAcc[FAccCount] := A
  else
  begin
    FAcc[FAccCount * 2]     := A;
    FAcc[FAccCount * 2 + 1] := B;
  end;
  Inc(FAccCount);
  if FAccCount >= FBlock then EmitFull;
end;

procedure TTCIStreamOut.FeedAudio(const L, R: array of Single; N: Integer);
var
  i, n0, n1, Chunk, Off: Integer;
begin
  if (N <= 0) or (FClient = nil) then Exit;
  if N > Length(L) then N := Length(L);
  if N > Length(R) then N := Length(R);

  Off := 0;
  while Off < N do
  begin
    // Кусками по TCI_FEED_CHUNK: движок вправе отдать блок любой длины, а
    // рабочие буферы у нас фиксированные (см. константу).
    Chunk := N - Off;
    if Chunk > TCI_FEED_CHUNK then Chunk := TCI_FEED_CHUNK;

    if FChannels = 1 then
    begin
      for i := 0 to Chunk - 1 do FIn[i] := (L[Off + i] + R[Off + i]) * 0.5;
      n0 := FDec[0].Process(FIn, Chunk, FTmp[0]);
      for i := 0 to n0 - 1 do PushPair(FTmp[0][i], 0);
    end
    else
    begin
      for i := 0 to Chunk - 1 do FIn[i] := L[Off + i];
      n0 := FDec[0].Process(FIn, Chunk, FTmp[0]);
      for i := 0 to Chunk - 1 do FIn[i] := R[Off + i];
      n1 := FDec[1].Process(FIn, Chunk, FTmp[1]);
      if n1 < n0 then n0 := n1;
      for i := 0 to n0 - 1 do PushPair(FTmp[0][i], FTmp[1][i]);
    end;

    Inc(Off, Chunk);
  end;
end;

procedure TTCIStreamOut.FeedIQ(PI_, PQ_: PDouble; N: Integer);
var
  i, n0, n1, Chunk, Off: Integer;
  SI, SQ: PDouble;
begin
  if (N <= 0) or (FClient = nil) or (PI_ = nil) or (PQ_ = nil) then Exit;
  Off := 0;
  while Off < N do
  begin
    Chunk := N - Off;
    if Chunk > TCI_FEED_CHUNK then Chunk := TCI_FEED_CHUNK;

    SI := PI_; Inc(SI, Off);
    for i := 0 to Chunk - 1 do begin FIn[i] := SI^; Inc(SI); end;
    n0 := FDec[0].Process(FIn, Chunk, FTmp[0]);

    if FChannels >= 2 then
    begin
      // Q считаем ТЕМ ЖЕ проходом, что и I: разошедшиеся по длине выходы
      // означали бы сдвиг фазы между каналами, то есть поворот спектра.
      SQ := PQ_; Inc(SQ, Off);
      for i := 0 to Chunk - 1 do begin FIn[i] := SQ^; Inc(SQ); end;
      n1 := FDec[1].Process(FIn, Chunk, FTmp[1]);
      if n1 < n0 then n0 := n1;
      for i := 0 to n0 - 1 do PushPair(FTmp[0][i], FTmp[1][i]);
    end
    else
      for i := 0 to n0 - 1 do PushPair(FTmp[0][i], 0);

    Inc(Off, Chunk);
  end;
end;

{ ═══════════════════════════════════════════════════════════════════════════
  Рекордер линейного выхода
  ═══════════════════════════════════════════════════════════════════════════ }

constructor TTCIRecorder.Create(ARx, ARateHz, AMaxSec: Integer; AOwner: TObject);
begin
  inherited Create;
  FLock  := TCriticalSection.Create;
  FRx    := ARx;
  FRate  := ARateHz;
  FOwner := AOwner;
  if AMaxSec < 1 then AMaxSec := 1;
  if AMaxSec > TCI_RECORD_MAX_SEC then AMaxSec := TCI_RECORD_MAX_SEC;
  FCap   := ARateHz * AMaxSec;
  FChunk := ARateHz * TCI_RECORD_CHUNK_SEC;
  if FChunk < 1 then FChunk := 1;
  if FChunk > FCap then FChunk := FCap;
  // ★Ни одного байта под звук здесь не выделяется — см. шапку объявления.
  FCount   := 0;
  FBytes   := 0;
  FExpired := False;
  FStarved := False;
  // Окно открывается прямо здесь: клиент отсчитывает его от своей команды
  // START, и ждать первого блока аудио, чтобы завести часы, нельзя.
  FEndsAt := GetTickCount64 + QWord(AMaxSec) * 1000;
end;

destructor TTCIRecorder.Destroy;
begin
  // Бюджет возвращаем и на аварийном пути: рекордер освобождают и по уходу
  // клиента, и по исчезновению приёмника, и на Stop — DropData зовут не все.
  TCIRecBudgetFree(FBytes);
  FBytes := 0;
  FLock.Free;
  inherited;
end;

function TTCIRecorder.EnsureRoom: Boolean;
// Под FLock. True — в последнем куске есть место хотя бы под один сэмпл.
var
  Need: Int64;
  N:    Integer;
begin
  Result := False;
  if FCount >= FCap then Exit;               // набрали свои MaxSec
  N := Length(FChunks);
  if FCount < N * FChunk then Exit(True);    // место в текущем куске
  if FStarved then Exit;                     // бюджет уже отказал — не долбим его
  Need := Int64(FChunk) * 2 * SizeOf(SmallInt);
  if not TCIRecBudgetTake(Need) then
  begin
    // Отказ не рушит запись: то, что успели набрать, остаётся сохраняемым.
    FStarved := True;
    Exit;
  end;
  SetLength(FChunks, N + 1);
  SetLength(FChunks[N], FChunk * 2);
  Inc(FBytes, Need);
  Result := True;
end;

procedure TTCIRecorder.DropData;
// Под FLock. Память отдаём сразу: истёкшая запись на 300 с держала бы 57 МБ
// до тех пор, пока клиент не вспомнит про BREAK.
var i: Integer;
begin
  FCount   := 0;
  FExpired := True;
  for i := 0 to High(FChunks) do FChunks[i] := nil;
  FChunks := nil;
  TCIRecBudgetFree(FBytes);
  FBytes := 0;
end;

function TTCIRecorder.Expired: Boolean;
begin
  FLock.Enter;
  try
    if (not FExpired) and (GetTickCount64 >= FEndsAt) then DropData;
    Result := FExpired;
  finally
    FLock.Leave;
  end;
end;

procedure TTCIRecorder.Feed(const L, R: array of Single; N: Integer);
// DSP-поток. Пишем линейно до конца окна; истекло — данных больше нет (§4.3).
var
  i, j, C: Integer;
  A, B: Single;
begin
  if (N <= 0) or (FCap <= 0) then Exit;
  if N > Length(L) then N := Length(L);
  if N > Length(R) then N := Length(R);
  FLock.Enter;
  try
    if FExpired then Exit;
    // Часы и ёмкость закрывают окно вместе: ёмкость — это те же MaxSec звука,
    // но при паузе в аудио доживёт до конца только счёт по часам.
    if GetTickCount64 >= FEndsAt then
    begin
      DropData;
      Exit;
    end;
    if N > FCap - FCount then N := FCap - FCount;
    for i := 0 to N - 1 do
    begin
      // Место спрашиваем на каждый сэмпл: кусок мог кончиться посередине
      // блока, а бюджет — отказать (тогда дописываем ровно до его границы).
      if not EnsureRoom then Break;
      A := L[i]; B := R[i];
      if A >  1.0 then A :=  1.0;  if A < -1.0 then A := -1.0;
      if B >  1.0 then B :=  1.0;  if B < -1.0 then B := -1.0;
      C := FCount div FChunk;
      j := (FCount mod FChunk) * 2;
      FChunks[C][j]     := Round(A * 32767);
      FChunks[C][j + 1] := Round(B * 32767);
      Inc(FCount);
    end;
  finally
    FLock.Leave;
  end;
end;

function TTCIRecorder.Take: TTCIRecTake;
begin
  Result.Chunks   := nil;
  Result.Chunk    := FChunk;
  Result.Count    := 0;
  Result.Reserved := 0;
  FLock.Enter;
  try
    // Проверка срока и здесь: аудио могло не идти вовсе (мьют, стоящий
    // приёмник), и тогда Feed часы не смотрел ни разу.
    if (not FExpired) and (GetTickCount64 >= FEndsAt) then DropData;
    if FExpired or (FCount <= 0) then
    begin
      DropData;          // SAVE завершает запись в любом случае (§4.3)
      Exit;
    end;
    // ★Куски отдаём КАК ЕСТЬ — ни одного лишнего байта. Сплошная копия жила бы
    // рядом с ними до самого DropData и удваивала пик (см. TTCIRecTake).
    Result.Chunks   := FChunks;
    Result.Count    := FCount;
    Result.Reserved := FBytes;
    // Дальше — то же, что делает DropData, но БЕЗ возврата бюджета и без
    // освобождения кусков: и то и другое переехало к писателю.
    FChunks  := nil;
    FBytes   := 0;
    FCount   := 0;
    FExpired := True;
  finally
    FLock.Leave;
  end;
end;

{ ═══════════════════════════════════════════════════════════════════════════
  WAV
  ═══════════════════════════════════════════════════════════════════════════ }

{ ─── вспомогательное для записи файла ──────────────────────────────────── }

var
  RecTmpSeq: LongInt = 0;

function TCIRecTempName(const Path: string): string;
// Имя временного файла. Уникальное: застрявший от прошлого падения «.part» не
// должен запирать сохранение под тем же именем навсегда.
begin
  Result := Format('%s.%d-%d.part',
    [Path, Integer(GetProcessID), InterLockedIncrement(RecTmpSeq)]);
end;

function TCILastErrorIsExists: Boolean;
// «Такое имя уже есть» — единственная ошибка создания, которую лечит другое имя.
begin
{$IFDEF UNIX}
  Result := fpGetErrno = ESysEEXIST;
{$ELSE}
  Result := (GetLastError = ERROR_ALREADY_EXISTS) or
            (GetLastError = ERROR_FILE_EXISTS);
{$ENDIF}
end;

function TCICreateTempNear(const Path: string; out Tmp: string): THandle;
// Временный файл рядом с целью, с перебором имён.
// ★pid + счётчик уникальны внутри процесса, но не между запусками: «.part»,
// оставшийся от прошлой жизни (публиковать было нечем — см. TCIPublishFile),
// плюс повторно выданный системой pid дают EEXIST, и задание пропадало бы
// молча. Занятое имя — не повод терять запись, берём следующее.
var i: Integer;
begin
  for i := 1 to 64 do
  begin
    Tmp    := TCIRecTempName(Path);
    Result := TCICreateNewFile(Tmp);
    if Result <> THandle(-1) then Exit;
    // Не «имя занято» (нет прав, нет каталога) — перебор не поможет.
    if not TCILastErrorIsExists then Break;
  end;
  Tmp    := '';
  Result := THandle(-1);
end;

function TCIWriteAll(H: THandle; const Buf; Count: Integer): Boolean;
// ★Результат записи проверяем, и не «= Count», а циклом. FileWrite (как и
// THandleStream.Write под ним) возвращает ЧИСЛО записанных байт и при ошибке
// отдаёт 0 или -1, не поднимая исключения: на полном диске прежний код
// спокойно дописывал WAV до конца, оставляя огрызок с заголовком на полную
// длину. Короткая запись без ошибки тоже законна (сигнал, лимит ФС) — её
// дописываем, а не считаем провалом.
var
  P: PByte;
  n: Integer;
begin
  P := @Buf;
  while Count > 0 do
  begin
    n := FileWrite(H, P^, Count);
    if n <= 0 then Exit(False);
    Inc(P, n);
    Dec(Count, n);
  end;
  Result := True;
end;

{ Чем кончилась публикация: легло под целевым именем / имя занято /
  публиковать нечем — на этой ФС нет ни одной безопасной операции. }
type
  TTCIPubResult = (tpubDone, tpubTaken, tpubNoWay);

{$IF DEFINED(LINUX) and (DEFINED(CPUX86_64) or DEFINED(CPUI386) or
                         DEFINED(CPUAARCH64) or DEFINED(CPUARM))}
  {$DEFINE TCI_HAS_RENAMEAT2}
{$IFEND}

{$IFDEF TCI_HAS_RENAMEAT2}
const
  // Обёртки в RTL нет, зовём напрямую. Номера — стабильная часть ABI ядра.
  {$IFDEF CPUX86_64}  TCI_SYS_RENAMEAT2 = 316; {$ENDIF}
  {$IFDEF CPUI386}    TCI_SYS_RENAMEAT2 = 353; {$ENDIF}
  {$IFDEF CPUAARCH64} TCI_SYS_RENAMEAT2 = 276; {$ENDIF}
  {$IFDEF CPUARM}     TCI_SYS_RENAMEAT2 = 382; {$ENDIF}
  TCI_AT_FDCWD         = -100;
  TCI_RENAME_NOREPLACE = 1;
{$ENDIF}

{$IFDEF UNIX}
function TCIRenameNoReplace(const Src, Dst: string; out Err: Integer): Boolean;
// «Переименовать, если имя свободно» — одним вызовом ядра. Нет такого вызова
// (старое ядро, другая архитектура, ФС не умеет флаг) — Err = ENOSYS/EINVAL, и
// вызывающий идёт дальше по списку.
begin
  Result := False;
  Err    := ESysENOSYS;
{$IFDEF TCI_HAS_RENAMEAT2}
  if Do_SysCall(TSysParam(TCI_SYS_RENAMEAT2),
                TSysParam(TCI_AT_FDCWD), TSysParam(PtrUInt(PChar(Src))),
                TSysParam(TCI_AT_FDCWD), TSysParam(PtrUInt(PChar(Dst))),
                TSysParam(TCI_RENAME_NOREPLACE)) = 0 then
    Exit(True);
  Err := fpGetErrno;
{$ENDIF}
end;
{$ENDIF}

function TCIPublishFile(const Src, Dst: string): TTCIPubResult;
// ★Публикация готового файла: целевое имя появляется ОДНИМ вызовом ядра, сразу
// с полным содержимым, и только если оно свободно. Замены нет ни в каком виде.
//
// Портируемо получить сразу три свойства — атомарное появление, запрет замены
// и работу на любой ФС — нельзя, поэтому идём по списку и на последнем шаге
// честно отказываемся:
//   1) renameat2(RENAME_NOREPLACE) — то, что нужно, одним вызовом;
//   2) нет его — link(2) + unlink: новое имя обязано не существовать (EEXIST),
//      на симлинк по этому имени link тоже не пойдёт. Каталог у Src и Dst один
//      (записи лежат в tci.record_dir), так что EXDEV тут не бывает;
//   3) нет и жёстких ссылок (FAT/exFAT, часть CIFS/SMB и FUSE) — публиковать
//      нечем. ★FileExists + rename здесь НЕ годится: rename затирает то, что
//      лежит по имени сейчас, а между проверкой и переносом туда может попасть
//      что угодно — это ровно то окно (TOCTOU), ради закрытия которого всё и
//      затевалось. Отвечаем tpubNoWay; данные при этом не пропадают — писатель
//      оставляет их во временном файле (см. WriteJob).
// На Windows MoveFileW без MOVEFILE_REPLACE_EXISTING уже обладает нужной
// семантикой: существующее имя = отказ.
{$IFDEF UNIX}
var Err: Integer;
{$ENDIF}
begin
{$IFDEF UNIX}
  if TCIRenameNoReplace(Src, Dst, Err) then Exit(tpubDone);
  if Err = ESysEEXIST then Exit(tpubTaken);
  if FpLink(PChar(Src), PChar(Dst)) = 0 then
  begin
    // Временное имя убираем: данные уже живут под целевым (это тот же inode).
    FpUnlink(PChar(Src));
    Exit(tpubDone);
  end;
  if fpGetErrno = ESysEEXIST then Exit(tpubTaken);
  Result := tpubNoWay;
{$ELSE}
  // WINBOOL — не Boolean: сравнение делает приведение явным.
  if MoveFileW(PWideChar(UnicodeString(Src)),
               PWideChar(UnicodeString(Dst))) <> False then
    Exit(tpubDone);
  if (GetLastError = ERROR_ALREADY_EXISTS) or
     (GetLastError = ERROR_FILE_EXISTS) then
    Exit(tpubTaken);
  Result := tpubNoWay;
{$ENDIF}
end;

{ ─── писатель ─────────────────────────────────────────────────────────── }

constructor TTCIWavWriter.Create;
begin
  inherited Create(True);
  FLock := TCriticalSection.Create;
  FWake := RTLEventCreate;
  Start;
end;

destructor TTCIWavWriter.Destroy;
var J: TTCIRecJob;
begin
  Terminate;
  RTLEventSetEvent(FWake);
  WaitFor;
  // Недописанное (гасят, не дождавшись очереди) — данные всё равно вернуть в
  // бюджет: объект умирает, а счётчик общий и переживёт нас.
  while Pop(J) do ReleaseJob(J);
  Done;
  RTLEventDestroy(FWake);
  FLock.Free;
  inherited;
end;

class procedure TTCIWavWriter.ReleaseJob(var J: TTCIRecJob);
// Данные и их место в бюджете уходят вместе и ровно один раз — сколько бы
// путей выхода ни было у записи.
var i: Integer;
begin
  for i := 0 to High(J.Rec.Chunks) do J.Rec.Chunks[i] := nil;
  J.Rec.Chunks := nil;
  TCIRecBudgetFree(J.Rec.Reserved);
  J.Rec.Reserved := 0;
  J.Rec.Count    := 0;
end;

function TTCIWavWriter.Enqueue(const APath: string; const ARec: TTCIRecTake;
  ARateHz: Integer): Boolean;
var n: Integer;
begin
  Result := False;
  FLock.Enter;
  try
    if FClosed or Terminated then Exit;
    n := Length(FJobs);
    if n >= TCI_RECORD_MAX_JOBS then Exit;
    SetLength(FJobs, n + 1);
    FJobs[n].Path := APath;
    FJobs[n].Rec  := ARec;
    FJobs[n].Rate := ARateHz;
    Result := True;
  finally
    FLock.Leave;
  end;
  RTLEventSetEvent(FWake);
end;

function TTCIWavWriter.Pop(out J: TTCIRecJob): Boolean;
var i: Integer;
begin
  Result := False;
  FillChar(J.Rec, SizeOf(J.Rec), 0);
  J.Path := '';
  J.Rate := 0;
  FLock.Enter;
  try
    if Length(FJobs) = 0 then Exit;
    J := FJobs[0];
    for i := 1 to High(FJobs) do FJobs[i - 1] := FJobs[i];
    FJobs[High(FJobs)].Path := '';               // строку из хвоста отпускаем
    FJobs[High(FJobs)].Rec.Chunks := nil;
    SetLength(FJobs, Length(FJobs) - 1);
    FBusy  := True;
    Result := True;
  finally
    FLock.Leave;
  end;
end;

procedure TTCIWavWriter.Done;
begin
  FLock.Enter;
  try
    FBusy := False;
  finally
    FLock.Leave;
  end;
end;

function TTCIWavWriter.Pending: Integer;
begin
  FLock.Enter;
  try
    Result := Length(FJobs);
    if FBusy then Inc(Result);
  finally
    FLock.Leave;
  end;
end;

procedure TTCIWavWriter.Close;
begin
  FLock.Enter;
  try
    FClosed := True;
  finally
    FLock.Leave;
  end;
end;

procedure TTCIWavWriter.WaitDrained;
begin
  while Pending <> 0 do Sleep(5);
end;

procedure TTCIWavWriter.Execute;
var J: TTCIRecJob;
begin
  while True do
  begin
    if Pop(J) then
    begin
      try
        // ★Взятое из очереди пишем ВСЕГДА, даже если уже идёт остановка: за
        // каждое задание клиенту сказано «сохранено», и молча выбросить его
        // нельзя. Остановка до этого места и не доходит — TCIStopWriter
        // сперва дожидается пустой очереди.
        WriteJob(J);
      except
        // Исключение из потока утащило бы за собой процесс. Сказать о беде
        // всё равно некому: SAVE давно подтверждён клиенту.
      end;
      ReleaseJob(J);
      Done;
      Continue;
    end;
    if Terminated then Break;
    // Таймаут, а не голое ожидание: Terminate между Pop и сюда не потеряется.
    RTLEventWaitFor(FWake, 200);
  end;
end;

procedure TTCIWavWriter.WriteJob(const J: TTCIRecJob);
// Заголовок собираем в буфере: WAV — это фиксированные 44 байта, и городить
// два десятка отдельных записей ради них незачем (а строковые литералы в
// нетипизированный Write в FPC ещё и передаются не тем, чем кажутся).
var
  HT: THandle;
  Tmp: string;
  Hdr: array[0..43] of Byte;
  DataBytes: LongWord;
  i, n, Left: Integer;
  Ok: Boolean;
  Pub: TTCIPubResult;

  procedure PutTag(Ofs: Integer; const Tag: string);
  var i: Integer;
  begin
    for i := 1 to Length(Tag) do Hdr[Ofs + i - 1] := Byte(Tag[i]);
  end;

  procedure PutU32(Ofs: Integer; V: LongWord);
  begin
    Hdr[Ofs]     := Byte(V);         Hdr[Ofs + 1] := Byte(V shr 8);
    Hdr[Ofs + 2] := Byte(V shr 16);  Hdr[Ofs + 3] := Byte(V shr 24);
  end;

  procedure PutU16(Ofs: Integer; V: Word);
  begin
    Hdr[Ofs] := Byte(V);  Hdr[Ofs + 1] := Byte(V shr 8);
  end;

begin
  DataBytes := LongWord(Int64(J.Rec.Count) * 2 * SizeOf(SmallInt));
  FillChar(Hdr, SizeOf(Hdr), 0);
  PutTag(0,  'RIFF');
  PutU32(4,  36 + DataBytes);
  PutTag(8,  'WAVE');
  PutTag(12, 'fmt ');
  PutU32(16, 16);                        // размер fmt-блока
  PutU16(20, 1);                         // PCM
  PutU16(22, 2);                         // каналов
  PutU32(24, LongWord(J.Rate));
  PutU32(28, LongWord(J.Rate) * 2 * 2);  // байт в секунду
  PutU16(32, 4);                         // выравнивание блока
  PutU16(34, 16);                        // бит на сэмпл
  PutTag(36, 'data');
  PutU32(40, DataBytes);

  // ★Целевого имени до конца записи не существует ВООБЩЕ. Пишем во временный
  // файл рядом (эксклюзивно и не по симлинку — имя пришло из сети), и только
  // когда всё сошлось, публикуем его под целевым именем одним вызовом ядра.
  // Так клиент, увидевший файл, всегда прав: раньше по имени сначала
  // появлялась пустышка на 0 байт, и на медленном диске её было видно всю
  // запись, а до того — огрызок с заголовком на полную длину.
  Ok := False;
  HT := TCICreateTempNear(J.Path, Tmp);
  if HT <> THandle(-1) then
  begin
    try
      Ok   := TCIWriteAll(HT, Hdr, SizeOf(Hdr));
      Left := J.Rec.Count;
      i    := 0;
      // Куски пишем подряд: в WAV сэмплы и так лежат встык, а хвост
      // последнего куска за Count — не наши данные.
      while Ok and (Left > 0) and (i <= High(J.Rec.Chunks)) do
      begin
        n := J.Rec.Chunk;
        if n > Left then n := Left;
        Ok := TCIWriteAll(HT, J.Rec.Chunks[i][0], n * 2 * SizeOf(SmallInt));
        Dec(Left, n);
        Inc(i);
      end;
      // Данных меньше, чем обещано заголовком, — это тот же огрызок.
      if Left > 0 then Ok := False;
      // ★Сброс на диск ДО переименования: на ext4 с отложенным размещением
      // «нет места» приходит не в write, а вот здесь.
      if Ok then Ok := FileFlush(HT);
    finally
      FileClose(HT);
    end;
    // Публикуем только целое.
    Pub := tpubTaken;
    if Ok then Pub := TCIPublishFile(Tmp, J.Path);
    // Не дописали или имя занято — ни огрызка, ни временного файла.
    // ★А вот tpubNoWay (на этой ФС публиковать нечем) временный файл ОСТАВЛЯЕТ:
    // сказать клиенту уже нечем (SAVE подтверждён давно), и молча стереть его
    // десятки мегабайт из-за нашей неспособности переименовать — хуже, чем
    // оставить их под именем «<файл>.<pid>-<n>.part».
    if (not Ok) or (Pub = tpubTaken) then DeleteFile(Tmp);
  end;
end;

procedure TCIStopWriter(var W: TTCIWavWriter);
var Left: TTCIWavWriter;
begin
  Left := W;
  W    := nil;
  if Left = nil then Exit;
  Left.Close;         // очередь больше не растёт
  Left.WaitDrained;   // дожидаемся ВСЕЙ очереди
  Left.Free;          // Terminate + wake + WaitFor уже пустого потока
end;

{ ★Почему здесь нет никакого срока — история двух неверных попыток.
  Внутрипроцессный поток, стоящий в write(2) или fsync, остановить нечем:
  Terminate ему не указ, а Free обязан сделать WaitFor (бросить живой TThread
  нельзя — он ходит в общий бюджет, RecBudgetLock, который финализация юнита
  освобождает). Значит, срок НЕ ограничивает выход: на мёртвом каталоге
  программа всё равно ждёт syscall. Ограничивал он ровно одно — сколько записей
  мы выбросим по дороге: сперва весь остаток очереди по общему сроку, потом (с
  отсчётом от последнего продвижения) остаток очереди на каталоге, который
  тормозил дольше срока и оживал. То есть срок не покупал ничего и стоил
  подтверждённых клиенту записей. Убран.
  Кому действительно нужен ограниченный выход — писателя придётся выносить в
  отдельный процесс, который гасится средствами ОС; одним TThread это не
  делается. }

{ ═══════════════════════════════════════════════════════════════════════════
  Утилиты
  ═══════════════════════════════════════════════════════════════════════════ }

function TCIDecimFactor(SrcRate, WantRate: Integer): Integer;
var F: Integer;
begin
  Result := 1;
  if (SrcRate <= 0) or (WantRate <= 0) or (WantRate >= SrcRate) then Exit;
  // Идём от большего прореживания к меньшему и берём первое, которое делит
  // входную частоту нацело и не опускает нас ниже запрошенной.
  F := SrcRate div WantRate;
  while F > 1 do
  begin
    if (SrcRate mod F = 0) and (SrcRate div F >= WantRate) then Exit(F);
    Dec(F);
  end;
end;

function TCIPickIQRate(SrcRate, WantRate: Integer): Integer;
const
  LEGAL: array[0..3] of Integer = (384000, 192000, 96000, 48000);
var i: Integer;
begin
  Result := WantRate;
  if (SrcRate <= 0) or (WantRate <= 0) then Exit;
  for i := 0 to High(LEGAL) do
    if (LEGAL[i] <= WantRate) and (LEGAL[i] <= SrcRate) and
       (SrcRate mod LEGAL[i] = 0) then
      Exit(LEGAL[i]);
end;

{ ═══════════════════════════════════════════════════════════════════════════
  Бюджет памяти рекордеров
  ═══════════════════════════════════════════════════════════════════════════ }

var
  RecBudgetLock: TCriticalSection = nil;
  RecBudgetUsed: Int64 = 0;

function TCIRecBudgetTake(Bytes: Int64): Boolean;
begin
  Result := False;
  if Bytes <= 0 then Exit(True);
  if RecBudgetLock = nil then Exit;
  RecBudgetLock.Enter;
  try
    if RecBudgetUsed + Bytes > TCI_RECORD_MAX_BYTES then Exit;
    Inc(RecBudgetUsed, Bytes);
    Result := True;
  finally
    RecBudgetLock.Leave;
  end;
end;

procedure TCIRecBudgetFree(Bytes: Int64);
begin
  if (Bytes <= 0) or (RecBudgetLock = nil) then Exit;
  RecBudgetLock.Enter;
  try
    Dec(RecBudgetUsed, Bytes);
    if RecBudgetUsed < 0 then RecBudgetUsed := 0;
  finally
    RecBudgetLock.Leave;
  end;
end;

function TCIRecBudgetUsed: Int64;
begin
  Result := 0;
  if RecBudgetLock = nil then Exit;
  RecBudgetLock.Enter;
  try
    Result := RecBudgetUsed;
  finally
    RecBudgetLock.Leave;
  end;
end;

{ ═══════════════════════════════════════════════════════════════════════════
  Имя файла записи
  ═══════════════════════════════════════════════════════════════════════════ }

function TCIRecordPath(const BaseDir, Req: string): string;
const
  MAX_NAME = 120;
var
  S, Name: string;
  i: Integer;
begin
  Result := '';
  if BaseDir = '' then Exit;
  S := Req;
  // ':' в протоколе запрещён и заменён на '|' (§4.3) — возвращаем на место,
  // иначе 'D|\rec\a.wav' стало бы каталогом с именем 'D|'. Слэши допускаются
  // любые, приводим к своему: без этого ExtractFileName на Linux не увидит
  // разделителя в 'D:\rec\a.wav' и примет всю строку за имя файла.
  for i := 1 to Length(S) do
    if S[i] = '|' then S[i] := ':';
  for i := 1 to Length(S) do
    if (S[i] = '/') or (S[i] = '\') then S[i] := PathDelim;
  // ★Каталог из просьбы отбрасываем целиком — вместе с '..', абсолютным путём
  // и буквой диска. Именно здесь закрывается запись в произвольный файл.
  Name := ExtractFileName(S);
  if (Name = '') or (Name = '.') or (Name = '..') then Exit;
  if Length(Name) > MAX_NAME then Exit;
  for i := 1 to Length(Name) do
    if (Name[i] < ' ') or (Name[i] = ':') then Exit;
  // Пишем мы только WAV, а расширение — единственное, по чему клиент потом
  // узнает файл. Чужое расширение здесь честнее молчаливой подмены.
  if not SameText(ExtractFileExt(Name), '.wav') then Exit;
  Result := IncludeTrailingPathDelimiter(BaseDir) + Name;
end;

function TCICreateNewFile(const Path: string): THandle;
begin
{$IFDEF UNIX}
  // O_EXCL — не трогать существующий файл, O_NOFOLLOW — не идти по симлинку,
  // подложенному вместо него. Обе проверки делает ядро одним вызовом: FileExists
  // перед FileCreate оставлял бы окно между проверкой и созданием.
  Result := THandle(FpOpen(PChar(Path),
              O_WRONLY or O_CREAT or O_EXCL or O_NOFOLLOW, &644));
{$ELSE}
  // CREATE_NEW = «создать, только если файла нет»; симлинки в Windows без прав
  // администратора не создаются, отдельной защиты от них не нужно.
  Result := CreateFileW(PWideChar(UnicodeString(Path)), GENERIC_WRITE, 0, nil,
                        CREATE_NEW, FILE_ATTRIBUTE_NORMAL, 0);
{$ENDIF}
end;

initialization
  RecBudgetLock := TCriticalSection.Create;

finalization
  FreeAndNil(RecBudgetLock);

end.