mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 18:43:51 +00:00
ew8bakandClaude Opus 5
3dc7035f9e
SAVE запускал поток на каждую запись с FreeOnTerminate: его никто не держал
и никто не ждал. Замерено отдельным процессом — при штатном выходе сразу
после сохранения от ожидаемых 100000044 байт на диске оставалось 40960, а
заголовок заявлял полную длину; на медленном каталоге идущие подряд SAVE
плодили сотни потоков, чья память стеков в 128-МБ бюджет не входила.
Теперь писатель один и принадлежит адаптеру (лениво на первом SAVE), очередь
ограничена TCI_RECORD_MAX_JOBS = 16 (сверх — клиенту writer busy и возврат
резерва), а деструктор адаптера гасит его через TCIStopWriter: Close →
WaitDrained (без срока) → Free. Срока здесь нет намеренно: поток, стоящий в
write/fsync, изнутри процесса не останавливается (Terminate не указ, Free
обязан WaitFor, бросить живой TThread нельзя — он ходит в общий бюджет),
поэтому срок не ограничивал выход, а только терял подтверждённые клиенту
записи. Ограниченный выход = писатель отдельным процессом, одним TThread не
делается; это записано в коде и в доке.
Результат записи больше не игнорируется: FileWrite возвращает число байт и
при ошибке даёт 0/-1 без исключения, поэтому на полном диске файл спокойно
дописывался до конца огрызком. TCIWriteAll — цикл с проверкой каждого вызова,
плюс FileFlush перед публикацией (на ext4 с отложенным размещением ENOSPC
приходит именно там).
Файл появляется под целевым именем целиком или не появляется вовсе: данные
пишутся во временный файл рядом (эксклюзивно, не по симлинку), а публикует
их TCIPublishFile — renameat2(RENAME_NOREPLACE) напрямую через Do_SysCall,
если его нет — link + unlink, если нет и ссылок (FAT/exFAT, часть CIFS/SMB и
FUSE) — отказ с сохранением данных в .part. FileExists + rename не делается
нигде: это тот самый TOCTOU. На Windows — MoveFileW без REPLACE_EXISTING.
doc/TCI.md: §2.5 переписан (писатель-очередь, остановка, публикация); заодно
исправлено устаревшее описание склейки кусков в Take (её нет с 7aae0fd).
Стенд test/tci: 214 проверок (было 199), все зелёные. Новое — временный файл
убирается после удачи, неудачная запись не оставляет ни файла, ни .part, за
всё время записи 32 МБ целевое имя ни разу не видно незаконченным, отказ
сверх потолка заданий, после Close заданий не берут, TCIStopWriter дожидается
и самой записи, и хвоста очереди за ней. Все новые гарантии прогнаны
негативным контролем; путь link проверен сборкой с выключенным renameat2,
сам renameat2 — под strace.
Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
1480 lines
69 KiB
ObjectPascal
1480 lines
69 KiB
ObjectPascal
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;
|
||
|
||
{ Погасить писателя: закрыть приём заданий, дождаться ВСЕЙ очереди и
|
||
освободить объект (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 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;
|
||
Tmp := TCIRecTempName(J.Path);
|
||
HT := TCICreateNewFile(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.
|