mirror of
https://git.vladimir.cc/vladimir/ewsdr.git
synced 2026-08-25 19:45:09 +00:00
Задний фронт передачи ловился только по rfTransmitting, а выключение TUN гасит эфир изнутри SetTune: там SetMOX(False) шлёт rfTransmitting, пока FTuning ещё True (флаг сбрасывается строкой ниже, см. RadioController.SetTune), поэтому TxNow оставался True и ForgetTxOwner не звался. Следующий за этим Changed(rfTuning) обработчик игнорировал вовсе. Итог: клиент сделал «tune:0,true» и стал хозяином эфира, оператор выключил TUN кнопкой (тогда сброс в DispatchCommand не срабатывает — команды-то не было), позже нажал PTT сам, а когда сокет клиента закрылся, HandleDisconnect → StopTxOf всё ещё видел его хозяином и снимал ОПЕРАТОРСКУЮ передачу. Ровно то, что комментарий у ForgetTxOwner обещает не допускать. Теперь фронт ловится и по rfTuning. На стенде — сценарий целиком: клиент поднимает TUN, оператор гасит его сам и встаёт в эфир, уход клиента передачу не трогает (негативный контроль: с прежним условием проверка падает). Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2272 lines
102 KiB
ObjectPascal
2272 lines
102 KiB
ObjectPascal
program tcitest;
|
||
|
||
{
|
||
Стенд этапа 2 TCI: бинарные потоки (§3.4). Запуск: test/tci/run.sh
|
||
|
||
Проверяет слои по отдельности и сквозным прогоном:
|
||
A. формат блока и математика — TCIProtocol;
|
||
A2. пересчёт частоты — дециматор, каскад, интерполятор;
|
||
B. исходящий блок до сокета — TTCIStreamOut → TTCIClient → socketpair;
|
||
C. рекордер и WAV;
|
||
D. команды потоков в живом сервере с настоящим TRadioController;
|
||
E. сквозной прогон через ЖИВОЙ WDSP: синтетический IQ в движок → блоки
|
||
RX-аудио и IQ у настоящего WS-клиента, и обратно TX-аудио клиента →
|
||
блоки TX-IQ.
|
||
|
||
Внешних библиотек не требует: WS-клиент написан на сыром сокете. Для части E
|
||
нужен libwdsp (тот же, что и приложению); если он не поднялся, эта часть
|
||
сообщает о пропуске, а не валит прогон.
|
||
|
||
★Собирать только с -Mobjfpc (см. run.sh): в режиме Delphi выключаются
|
||
вложенные комментарии, и {$MODE Delphi} внутри шапки WebUtils.pas закрывает
|
||
комментарий раньше времени — компиляция падает на «illegal character».
|
||
}
|
||
|
||
{$MODE Delphi}
|
||
{$LONGSTRINGS ON}
|
||
|
||
uses
|
||
cthreads, Classes, SysUtils, Math, SyncObjs, Sockets, BaseUnix,
|
||
TCIProtocol, TCIStreams, TCIServer, TCIAdapter, RadioController,
|
||
WsClient, WebUtils, WDSPEngine, Settings, CWMorse;
|
||
|
||
var
|
||
Passed, Failed: Integer;
|
||
|
||
procedure Check(const Name: string; OK: Boolean; const Detail: string = '');
|
||
begin
|
||
if OK then
|
||
begin
|
||
Inc(Passed);
|
||
WriteLn(' ok ', Name);
|
||
end
|
||
else
|
||
begin
|
||
Inc(Failed);
|
||
WriteLn(' FAIL ', Name, ' ', Detail);
|
||
end;
|
||
end;
|
||
|
||
function Near(A, B, Eps: Double): Boolean;
|
||
begin
|
||
Result := Abs(A - B) <= Eps;
|
||
end;
|
||
|
||
function RMS(const A: array of Single; N: Integer): Double;
|
||
var i: Integer; S: Double;
|
||
begin
|
||
S := 0;
|
||
for i := 0 to N - 1 do S := S + A[i] * A[i];
|
||
if N = 0 then Result := 0 else Result := Sqrt(S / N);
|
||
end;
|
||
|
||
{ ═══════════════════════════════════════════════════════════════════════════
|
||
A. Протокол и математика
|
||
═══════════════════════════════════════════════════════════════════════════ }
|
||
|
||
procedure TestProtocol;
|
||
var
|
||
H: TTCIStreamHeader;
|
||
Src: array[0..7] of Single;
|
||
Dst: array[0..7] of Single;
|
||
Buf: array[0..63] of Byte;
|
||
N, i: Integer;
|
||
T: TTCISampleType;
|
||
Base: string;
|
||
begin
|
||
WriteLn('A. Протокол потоков');
|
||
|
||
Check('decim 48k→12k = 4', TCIDecimFactor(48000, 12000) = 4);
|
||
Check('decim 48k→8k = 6', TCIDecimFactor(48000, 8000) = 6);
|
||
Check('decim 48k→48k = 1', TCIDecimFactor(48000, 48000) = 1);
|
||
Check('decim 384k→48k = 8', TCIDecimFactor(384000, 48000) = 8);
|
||
Check('decim 192k→48k = 4', TCIDecimFactor(192000, 48000) = 4);
|
||
// Запрошено больше, чем есть, — вверх не тянем, отдаём как есть.
|
||
Check('decim 48k→96k = 1', TCIDecimFactor(48000, 96000) = 1);
|
||
// Нацело не делится: берём ближайший делитель, не опускаясь ниже просьбы.
|
||
Check('decim 50k→12k = 4', TCIDecimFactor(50000, 12000) = 4,
|
||
IntToStr(TCIDecimFactor(50000, 12000)));
|
||
|
||
Check('samples@48k = 2048', TCIDefaultAudioSamples(48000) = 2048);
|
||
Check('samples@12k = 512', TCIDefaultAudioSamples(12000) = 512);
|
||
Check('block float32×2', TCIMaxBlockSamples(tsyFloat32, 2) = 2048);
|
||
Check('block int16×1', TCIMaxBlockSamples(tsyInt16, 1) = 8192);
|
||
Check('bytes int24 = 3', TCISampleBytes(tsyInt24) = 3);
|
||
|
||
Check('type by name int24', TCISampleTypeByName('INT24', T) and (T = tsyInt24));
|
||
Check('type by name мусор', not TCISampleTypeByName('int8', T));
|
||
Check('type name float32', TCISampleTypeName(tsyFloat32) = 'float32');
|
||
|
||
TCIFillHeader(H, tstRXAudio, 2, 12000, tsyInt16, 512, 2);
|
||
Check('header receiver', H.Receiver = 2);
|
||
Check('header rate', H.SampleRate = 12000);
|
||
Check('header format', H.Format = LongWord(Ord(tsyInt16)));
|
||
// ★length — вещественные отсчёты ВСЕГО блока, и у аудио тоже: клиенты
|
||
// считают по нему число байт (MSHV: `cr2 = length*bit_s`). Объявишь «на
|
||
// канал» — у стерео разберётся половина блока, и звук пойдёт с дырами.
|
||
Check('header length аудио = ×каналы', H.DataLength = 1024);
|
||
Check('header type', H.StreamType = LongWord(Ord(tstRXAudio)));
|
||
Check('header channels', H.Channels = 2);
|
||
Check('header codec/crc', (H.Codec = 0) and (H.CRC = 0));
|
||
Check('header size 64', SizeOf(H) = TCI_STREAM_HDR_SIZE);
|
||
// ★IQ: а тут length — вещественные отсчёты, то есть вдвое больше
|
||
// комплексных (§3.4 прямо: комплексных = length/channels).
|
||
TCIFillHeader(H, tstIQ, 0, 48000, tsyFloat32, 512, 2);
|
||
Check('header length IQ = ×каналы', H.DataLength = 1024);
|
||
// Маркер времени TX_CHRONO живёт по тем же правилам: он называет клиенту
|
||
// размер блока, который тот пришлёт (§3.4).
|
||
TCIFillHeader(H, tstTXChrono, 0, 12000, tsyFloat32, 256, 2);
|
||
Check('header length chrono = ×каналы', H.DataLength = 512);
|
||
// Моно: отсчётов столько же, сколько сэмплов на канал.
|
||
TCIFillHeader(H, tstRXAudio, 0, 12000, tsyInt16, 512, 1);
|
||
Check('header length моно = сэмплы', H.DataLength = 512);
|
||
|
||
// Упаковка/распаковка: сквозной проход по всем форматам.
|
||
for i := 0 to 7 do Src[i] := (i - 4) / 8.0; // −0.5 … +0.375
|
||
for T := tsyInt16 to tsyFloat32 do
|
||
begin
|
||
N := TCIPackSamples(Src, 8, T, @Buf[0]);
|
||
Check('pack размер ' + TCISampleTypeName(T), N = 8 * TCISampleBytes(T));
|
||
N := TCIUnpackSamples(@Buf[0], N, T, Dst);
|
||
Check('unpack счёт ' + TCISampleTypeName(T), N = 8);
|
||
Check('round-trip ' + TCISampleTypeName(T),
|
||
Near(Dst[0], Src[0], 1E-4) and Near(Dst[7], Src[7], 1E-4),
|
||
Format('%.6f vs %.6f', [Dst[0], Src[0]]));
|
||
end;
|
||
|
||
// Клип: перегруз обязан упереться в шкалу, а не завернуться через знак.
|
||
Src[0] := 2.0;
|
||
Src[1] := -2.0;
|
||
TCIPackSamples(Src, 2, tsyInt16, @Buf[0]);
|
||
Check('клип int16 +', SmallInt(Word(Buf[0]) or (Word(Buf[1]) shl 8)) = 32767);
|
||
Check('клип int16 −', SmallInt(Word(Buf[2]) or (Word(Buf[3]) shl 8)) = -32767);
|
||
|
||
// ★Имя файла записи: каталог из просьбы клиента не берётся НИКОГДА —
|
||
// авторизации в TCI нет, и полный путь из сети означал бы запись в любой
|
||
// доступный процессу файл. Берём одно имя и кладём в свой каталог.
|
||
Base := IncludeTrailingPathDelimiter(GetTempDir) + 'tcirec';
|
||
Check('путь: простое имя',
|
||
TCIRecordPath(Base, 'rec.wav') =
|
||
IncludeTrailingPathDelimiter(Base) + 'rec.wav',
|
||
TCIRecordPath(Base, 'rec.wav'));
|
||
Check('путь: каталог из просьбы отброшен',
|
||
TCIRecordPath(Base, 'home/user/rec_dir/a.wav') =
|
||
IncludeTrailingPathDelimiter(Base) + 'a.wav',
|
||
TCIRecordPath(Base, 'home/user/rec_dir/a.wav'));
|
||
Check('путь: абсолютный не выводит наружу',
|
||
TCIRecordPath(Base, '/etc/passwd.wav') =
|
||
IncludeTrailingPathDelimiter(Base) + 'passwd.wav',
|
||
TCIRecordPath(Base, '/etc/passwd.wav'));
|
||
Check('путь: .. не выводит наружу',
|
||
TCIRecordPath(Base, '../../../home/vladimir/.bashrc.wav') =
|
||
IncludeTrailingPathDelimiter(Base) + '.bashrc.wav',
|
||
TCIRecordPath(Base, '../../../home/vladimir/.bashrc.wav'));
|
||
Check('путь: буква диска (| → :) не выводит наружу',
|
||
TCIRecordPath(Base, 'D|\\rec\\a.wav') =
|
||
IncludeTrailingPathDelimiter(Base) + 'a.wav',
|
||
TCIRecordPath(Base, 'D|\\rec\\a.wav'));
|
||
Check('путь: пусто — отказ', TCIRecordPath(Base, '') = '');
|
||
Check('путь: только каталог — отказ', TCIRecordPath(Base, 'a/b/') = '');
|
||
Check('путь: «..» — отказ', TCIRecordPath(Base, '..') = '');
|
||
Check('путь: не .wav — отказ', TCIRecordPath(Base, 'a.mp3') = '');
|
||
Check('путь: управляющий символ — отказ',
|
||
TCIRecordPath(Base, 'a' + #10 + 'b.wav') = '');
|
||
Check('путь: без каталога — отказ', TCIRecordPath('', 'a.wav') = '');
|
||
|
||
// Частоты Pluto (576…5760 кГц) на 384 делятся не все: клиенту обязана
|
||
// достаться ЗАКОННАЯ частота из набора протокола, а не 576/480 кГц.
|
||
Check('IQ rate 576к, просят 384к → 192к',
|
||
TCIPickIQRate(576000, 384000) = 192000,
|
||
IntToStr(TCIPickIQRate(576000, 384000)));
|
||
Check('IQ rate 960к, просят 384к → 192к',
|
||
TCIPickIQRate(960000, 384000) = 192000,
|
||
IntToStr(TCIPickIQRate(960000, 384000)));
|
||
Check('IQ rate 768к, просят 384к → 384к',
|
||
TCIPickIQRate(768000, 384000) = 384000);
|
||
Check('IQ rate 5760к, просят 48к → 48к',
|
||
TCIPickIQRate(5760000, 48000) = 48000);
|
||
Check('IQ rate 192к, просят 384к → 192к',
|
||
TCIPickIQRate(192000, 384000) = 192000);
|
||
Check('IQ rate чужой 50к → просьба как есть',
|
||
TCIPickIQRate(50000, 48000) = 48000);
|
||
end;
|
||
|
||
{ ═══════════════════════════════════════════════════════════════════════════
|
||
A2. Дециматор и интерполятор
|
||
═══════════════════════════════════════════════════════════════════════════ }
|
||
|
||
{ Прогон каскада: тон в полосе обязан пройти без потерь, тон за новой границей
|
||
Найквиста — исчезнуть. Кормим кусками по 4096, как это делает поток. }
|
||
procedure TestChain(M: Integer; SrcRate, PassHz, StopHz: Double;
|
||
const What: string);
|
||
const
|
||
NTOT = 65536;
|
||
var
|
||
C: TTCIDecimChain;
|
||
Src: array[0..4095] of Single;
|
||
Dst: array[0..4095] of Single;
|
||
i, off, n: Integer;
|
||
Acc: Double;
|
||
|
||
function RunTone(ToneHz: Double): Double;
|
||
var j: Integer;
|
||
begin
|
||
C := TTCIDecimChain.Create(M);
|
||
try
|
||
Acc := 0;
|
||
n := 0;
|
||
off := 0;
|
||
while off + 4096 <= NTOT do
|
||
begin
|
||
for j := 0 to 4095 do
|
||
Src[j] := Sin(2 * Pi * ToneHz * (off + j) / SrcRate);
|
||
i := C.Process(Src, 4096, Dst);
|
||
// Первую половину прогона пропускаем: там переходный процесс фильтра.
|
||
if off >= NTOT div 2 then
|
||
for j := 0 to i - 1 do
|
||
begin
|
||
Acc := Acc + Dst[j] * Dst[j];
|
||
Inc(n);
|
||
end;
|
||
Inc(off, 4096);
|
||
end;
|
||
if n = 0 then Result := 0 else Result := Sqrt(Acc / n);
|
||
finally
|
||
C.Free;
|
||
end;
|
||
end;
|
||
|
||
var
|
||
Pass, Stop: Double;
|
||
begin
|
||
Pass := RunTone(PassHz);
|
||
Stop := RunTone(StopHz);
|
||
Check(What + ': полоса цела', Abs(Pass - 0.707) < 0.03,
|
||
Format('%.4f', [Pass]));
|
||
Check(What + ': зеркало давится (>60 дБ)', Stop < 0.0007,
|
||
Format('%.6f', [Stop]));
|
||
end;
|
||
|
||
procedure TestResampling;
|
||
const
|
||
NIN = 8192;
|
||
var
|
||
D: TTCIDecimator;
|
||
I_: TTCIInterpolator;
|
||
Src: array[0..NIN-1] of Single;
|
||
Dst: array[0..NIN-1] of Single;
|
||
Out_: array[0..NIN*8-1] of Double;
|
||
i, n: Integer;
|
||
Ph, Lo, Hi: Double;
|
||
begin
|
||
WriteLn('A2. Пересчёт частоты');
|
||
|
||
// Постоянка: усиление на нуле обязано быть единичным, иначе поток тише/громче
|
||
// ровно на коэффициент прореживания.
|
||
D := TTCIDecimator.Create(4);
|
||
try
|
||
for i := 0 to NIN - 1 do Src[i] := 1.0;
|
||
n := D.Process(Src, NIN, Dst);
|
||
Check('децим счёт = N/M', n = NIN div 4, IntToStr(n));
|
||
Check('децим усиление 1.0', Near(Dst[n - 1], 1.0, 0.01),
|
||
Format('%.4f', [Dst[n - 1]]));
|
||
finally
|
||
D.Free;
|
||
end;
|
||
|
||
// Тон в полосе проходит, тон за новой границей Найквиста — давится.
|
||
D := TTCIDecimator.Create(4); // 48к → 12к, Найквист 6 кГц
|
||
try
|
||
Ph := 0;
|
||
for i := 0 to NIN - 1 do
|
||
begin
|
||
Src[i] := Sin(2 * Pi * 1000 * i / 48000);
|
||
Ph := Ph;
|
||
end;
|
||
n := D.Process(Src, NIN, Dst);
|
||
Check('децим 1 кГц проходит', Near(RMS(Dst, n), 0.707, 0.05),
|
||
Format('%.4f', [RMS(Dst, n)]));
|
||
finally
|
||
D.Free;
|
||
end;
|
||
|
||
D := TTCIDecimator.Create(4);
|
||
try
|
||
for i := 0 to NIN - 1 do Src[i] := Sin(2 * Pi * 20000 * i / 48000);
|
||
n := D.Process(Src, NIN, Dst);
|
||
Check('децим 20 кГц давится (>40 дБ)', RMS(Dst, n) < 0.007,
|
||
Format('%.5f', [RMS(Dst, n)]));
|
||
finally
|
||
D.Free;
|
||
end;
|
||
|
||
// Коэффициент 1 — сквозной проход без фильтра (иначе теряли бы верх полосы).
|
||
D := TTCIDecimator.Create(1);
|
||
try
|
||
for i := 0 to 15 do Src[i] := i / 16.0;
|
||
n := D.Process(Src, 16, Dst);
|
||
Check('децим ×1 прозрачен', (n = 16) and Near(Dst[15], 15 / 16.0, 1E-6));
|
||
finally
|
||
D.Free;
|
||
end;
|
||
|
||
// ★Каскад на коэффициентах Pluto. Одной ступенью это не берётся: замер до
|
||
// каскада дал на M=120 завал 1.3 дБ в полосе и подавление зеркала 16 дБ.
|
||
TestChain(4, 192000, 12000, 40000, 'HPSDR 192→48');
|
||
TestChain(8, 384000, 12000, 40000, 'HPSDR 384→48');
|
||
TestChain(12, 576000, 12000, 40000, 'Pluto 576→48');
|
||
TestChain(32, 1536000, 12000, 40000, 'Pluto 1536→48');
|
||
TestChain(120,5760000, 12000, 40000, 'Pluto 5760→48');
|
||
TestChain(15, 5760000, 100000, 300000, 'Pluto 5760→384');
|
||
|
||
// Интерполятор: счёт и отсутствие выбросов за пределы соседних отсчётов.
|
||
I_ := TTCIInterpolator.Create(4);
|
||
try
|
||
for i := 0 to 99 do Src[i] := Sin(2 * Pi * i / 25);
|
||
n := I_.Process(Src, 100, Out_);
|
||
Check('интерп счёт = N×M', n = 400, IntToStr(n));
|
||
// Смотрим ТОЛЬКО заполненную часть: хвост буфера — мусор со стека, и
|
||
// MaxValue по нему ловит сигнальный NaN (проверено: с -O2 прогон падал
|
||
// с EInvalidOp ровно здесь).
|
||
Lo := Out_[0];
|
||
Hi := Out_[0];
|
||
for i := 1 to n - 1 do
|
||
begin
|
||
if Out_[i] < Lo then Lo := Out_[i];
|
||
if Out_[i] > Hi then Hi := Out_[i];
|
||
end;
|
||
Check('интерп без выбросов', (Hi <= 1.0001) and (Lo >= -1.0001),
|
||
Format('%.4f..%.4f', [Lo, Hi]));
|
||
finally
|
||
I_.Free;
|
||
end;
|
||
|
||
I_ := TTCIInterpolator.Create(1);
|
||
try
|
||
for i := 0 to 9 do Src[i] := i;
|
||
n := I_.Process(Src, 10, Out_);
|
||
Check('интерп ×1 прозрачен', (n = 10) and Near(Out_[9], 9, 1E-9));
|
||
finally
|
||
I_.Free;
|
||
end;
|
||
end;
|
||
|
||
{ ═══════════════════════════════════════════════════════════════════════════
|
||
B. Блок до сокета: TTCIStreamOut → TTCIClient → socketpair
|
||
═══════════════════════════════════════════════════════════════════════════ }
|
||
|
||
type
|
||
{ Приёмник кадров с другого конца socketpair: разбирает WS-кадры сервера
|
||
(немаскированные, FIN=1) и отдаёт полезную нагрузку. }
|
||
TFrameSink = record
|
||
Fd: Integer;
|
||
Buf: array[0..262143] of Byte;
|
||
Len: Integer;
|
||
end;
|
||
|
||
procedure SinkDrain(var S: TFrameSink);
|
||
var R: Integer;
|
||
begin
|
||
repeat
|
||
R := fpRecv(S.Fd, @S.Buf[S.Len], SizeOf(S.Buf) - S.Len, MSG_DONTWAIT);
|
||
if R > 0 then Inc(S.Len, R);
|
||
until R <= 0;
|
||
end;
|
||
|
||
{ Достаёт следующий кадр. False — кадров больше нет. }
|
||
function SinkNext(var S: TFrameSink; out Opcode: Byte; out Payload: TBytes): Boolean;
|
||
var
|
||
PayLen, Need, i: Integer;
|
||
begin
|
||
Result := False;
|
||
Payload := nil;
|
||
if S.Len < 2 then Exit;
|
||
Opcode := S.Buf[0] and $0F;
|
||
PayLen := S.Buf[1] and $7F;
|
||
Need := 2;
|
||
if PayLen = 126 then
|
||
begin
|
||
if S.Len < 4 then Exit;
|
||
PayLen := (S.Buf[2] shl 8) or S.Buf[3];
|
||
Need := 4;
|
||
end
|
||
else if PayLen = 127 then
|
||
begin
|
||
if S.Len < 10 then Exit;
|
||
PayLen := (S.Buf[6] shl 24) or (S.Buf[7] shl 16) or (S.Buf[8] shl 8) or S.Buf[9];
|
||
Need := 10;
|
||
end;
|
||
if S.Len < Need + PayLen then Exit;
|
||
SetLength(Payload, PayLen);
|
||
for i := 0 to PayLen - 1 do Payload[i] := S.Buf[Need + i];
|
||
if S.Len > Need + PayLen then
|
||
Move(S.Buf[Need + PayLen], S.Buf[0], S.Len - Need - PayLen);
|
||
Dec(S.Len, Need + PayLen);
|
||
Result := True;
|
||
end;
|
||
|
||
procedure TestStreamOut;
|
||
var
|
||
Fds: array[0..1] of Integer;
|
||
Ws: TWsClient;
|
||
C: TTCIClient;
|
||
S: TTCIStreamOut;
|
||
Sink: TFrameSink;
|
||
L, R: array[0..8191] of Single;
|
||
i, Blocks: Integer;
|
||
Op: Byte;
|
||
Pay: TBytes;
|
||
H: TTCIStreamHeader;
|
||
IQI, IQQ: array[0..8191] of Double;
|
||
OkHdr: Boolean;
|
||
begin
|
||
WriteLn('B. Исходящий блок до сокета');
|
||
|
||
if fpSocketPair(AF_UNIX, SOCK_STREAM, 0, @Fds[0]) <> 0 then
|
||
begin
|
||
Check('socketpair', False, 'создать пару не удалось');
|
||
Exit;
|
||
end;
|
||
FillChar(Sink, SizeOf(Sink), 0);
|
||
Sink.Fd := Fds[1];
|
||
|
||
Ws := TWsClient.Create(Fds[0]);
|
||
Ws.State := wsOpen;
|
||
C := TTCIClient.Create(Ws);
|
||
try
|
||
// 48 кГц стерео → 12 кГц стерео float32, блок 512 сэмплов на канал.
|
||
S := TTCIStreamOut.Create(C, tstRXAudio, 0, 48000, 12000, 2, tsyFloat32, 512);
|
||
try
|
||
for i := 0 to 8191 do
|
||
begin
|
||
L[i] := Sin(2 * Pi * 1000 * i / 48000);
|
||
R[i] := L[i] * 0.5;
|
||
end;
|
||
S.FeedAudio(L, R, 8192); // 8192/4 = 2048 выходных = 4 блока по 512
|
||
Check('поток: частота на выходе', S.OutRate = 12000, IntToStr(S.OutRate));
|
||
finally
|
||
S.Free;
|
||
end;
|
||
OkHdr := C.Flush;
|
||
Check('аудио: flush socketpair', OkHdr,
|
||
'dead=' + BoolToStr(C.Dead, True) + ', errno=' + IntToStr(fpGetErrno) +
|
||
', txfd=' + IntToStr(Fds[0]) + ', rxfd=' + IntToStr(Fds[1]));
|
||
SinkDrain(Sink);
|
||
|
||
Blocks := 0;
|
||
OkHdr := True;
|
||
while SinkNext(Sink, Op, Pay) do
|
||
begin
|
||
if Op <> $02 then begin OkHdr := False; Continue; end;
|
||
if Length(Pay) < SizeOf(H) then begin OkHdr := False; Continue; end;
|
||
Move(Pay[0], H, SizeOf(H));
|
||
if (H.SampleRate <> 12000) or (H.Channels <> 2) or
|
||
(H.DataLength <> 1024) or // вещественных отсчётов = 512 × 2
|
||
(H.StreamType <> LongWord(Ord(tstRXAudio))) or
|
||
(H.Format <> LongWord(Ord(tsyFloat32))) or
|
||
// ★Правило, по которому живут клиенты: байт данных = length × размер
|
||
// отсчёта. Ровно так считает MSHV (`cr2 = length*bit_s`).
|
||
(Length(Pay) <> SizeOf(H) + Integer(H.DataLength) * 4) then OkHdr := False;
|
||
Inc(Blocks);
|
||
end;
|
||
Check('аудио: 4 блока', Blocks = 4, IntToStr(Blocks));
|
||
Check('аудио: заголовок и размер', OkHdr);
|
||
|
||
// IQ: 384 кГц → 48 кГц, блок 2048 комплексных.
|
||
S := TTCIStreamOut.Create(C, tstIQ, 1, 384000, 48000, 2, tsyFloat32, 2048);
|
||
try
|
||
Check('IQ: частота на выходе', S.OutRate = 48000, IntToStr(S.OutRate));
|
||
for i := 0 to 8191 do
|
||
begin
|
||
IQI[i] := Cos(2 * Pi * 1000 * i / 384000);
|
||
IQQ[i] := Sin(2 * Pi * 1000 * i / 384000);
|
||
end;
|
||
// 8192/8 = 1024 выходных — половина блока, отправки быть не должно.
|
||
S.FeedIQ(@IQI[0], @IQQ[0], 8192);
|
||
C.Flush;
|
||
SinkDrain(Sink);
|
||
Check('IQ: полблока не уходит', not SinkNext(Sink, Op, Pay));
|
||
S.FeedIQ(@IQI[0], @IQQ[0], 8192); // ещё половина — теперь блок целый
|
||
C.Flush;
|
||
SinkDrain(Sink);
|
||
OkHdr := SinkNext(Sink, Op, Pay);
|
||
if OkHdr then
|
||
begin
|
||
Move(Pay[0], H, SizeOf(H));
|
||
OkHdr := (H.Receiver = 1) and (H.SampleRate = 48000) and
|
||
(H.DataLength = 4096) and
|
||
(H.StreamType = LongWord(Ord(tstIQ))) and
|
||
(Length(Pay) = SizeOf(H) + 4096 * 4);
|
||
end;
|
||
Check('IQ: блок целиком и по формату', OkHdr);
|
||
|
||
// Смена частоты источника на ходу (сменили rate DDC).
|
||
S.SetSourceRate(192000);
|
||
Check('IQ: пересчёт после смены rate', S.OutRate = 48000);
|
||
finally
|
||
S.Free;
|
||
end;
|
||
|
||
// Моно: 1 канал = среднее двух.
|
||
S := TTCIStreamOut.Create(C, tstRXAudio, 0, 48000, 48000, 1, tsyInt16, 100);
|
||
try
|
||
for i := 0 to 199 do begin L[i] := 0.5; R[i] := -0.5; end;
|
||
S.FeedAudio(L, R, 200);
|
||
C.Flush;
|
||
SinkDrain(Sink);
|
||
OkHdr := SinkNext(Sink, Op, Pay);
|
||
if OkHdr then
|
||
begin
|
||
Move(Pay[0], H, SizeOf(H));
|
||
OkHdr := (H.Channels = 1) and (H.DataLength = 100) and
|
||
(H.Format = LongWord(Ord(tsyInt16))) and
|
||
(Length(Pay) = SizeOf(H) + 100 * 2);
|
||
end;
|
||
Check('моно int16: заголовок и размер', OkHdr);
|
||
finally
|
||
S.Free;
|
||
end;
|
||
|
||
// Переполнение кольца блоков: клиент не читает — теряем старые блоки,
|
||
// но соединение живо и команды по нему ходят.
|
||
S := TTCIStreamOut.Create(C, tstRXAudio, 0, 48000, 48000, 2, tsyFloat32, 100);
|
||
try
|
||
for i := 0 to 8191 do begin L[i] := 0.1; R[i] := 0.1; end;
|
||
for i := 0 to 99 do S.FeedAudio(L, R, 8192); // много блоков без Flush
|
||
Check('переполнение: блоки теряются', C.BinDropped > 0,
|
||
IntToStr(C.BinDropped));
|
||
Check('переполнение: клиент жив', not C.Dead);
|
||
finally
|
||
S.Free;
|
||
end;
|
||
finally
|
||
C.Free;
|
||
Ws.Free;
|
||
fpClose(Fds[1]);
|
||
end;
|
||
end;
|
||
|
||
{ ═══════════════════════════════════════════════════════════════════════════
|
||
C. Рекордер и WAV
|
||
═══════════════════════════════════════════════════════════════════════════ }
|
||
|
||
function FlatTake(const T: TTCIRecTake): TTCIPcm;
|
||
// Склейка кусков записи в один буфер. Живёт ТОЛЬКО в стенде: продовый путь
|
||
// сплошной копии не делает вовсе — писатель пишет куски подряд, иначе на
|
||
// полном бюджете рядом жили бы куски и их копия, то есть двойной пик.
|
||
var C, n, Left: Integer;
|
||
begin
|
||
Result := nil;
|
||
if T.Count <= 0 then Exit;
|
||
SetLength(Result, T.Count * 2);
|
||
Left := T.Count;
|
||
for C := 0 to High(T.Chunks) do
|
||
begin
|
||
if Left <= 0 then Break;
|
||
n := T.Chunk;
|
||
if n > Left then n := Left;
|
||
Move(T.Chunks[C][0], Result[(T.Count - Left) * 2], n * 2 * SizeOf(SmallInt));
|
||
Dec(Left, n);
|
||
end;
|
||
end;
|
||
|
||
function MakeTake(const Data: TTCIPcm; Reserved: Int64): TTCIRecTake;
|
||
// Одно задание писателю из готового куска: в проде куски приносит Take.
|
||
begin
|
||
Result.Chunks := nil;
|
||
SetLength(Result.Chunks, 1);
|
||
Result.Chunks[0] := Data;
|
||
Result.Chunk := Length(Data) div 2;
|
||
Result.Count := Result.Chunk;
|
||
Result.Reserved := Reserved;
|
||
end;
|
||
|
||
function Drained(W: TTCIWavWriter; TimeoutMs: Integer): Boolean;
|
||
// Ограниченное ожидание очереди — ТОЛЬКО для стенда: у писателя WaitDrained
|
||
// срока не имеет (см. TCIStopWriter), а зависший стенд ничего не сообщает.
|
||
var Waited: Integer;
|
||
begin
|
||
Waited := 0;
|
||
while (W.Pending > 0) and (Waited < TimeoutMs) do
|
||
begin
|
||
Sleep(5);
|
||
Inc(Waited, 5);
|
||
end;
|
||
Result := W.Pending = 0;
|
||
end;
|
||
|
||
function NextTempName(const Name: string): string;
|
||
// Имя «.part», следующее за данным: у писателя счётчик один на процесс, и
|
||
// стенду нужно занять именно то имя, которое он возьмёт после нашего вызова.
|
||
var i, p1, p2: Integer;
|
||
begin
|
||
p2 := Pos('.part', Name);
|
||
p1 := p2;
|
||
for i := p2 - 1 downto 1 do
|
||
if Name[i] = '-' then begin p1 := i; Break; end;
|
||
Result := Copy(Name, 1, p1) +
|
||
IntToStr(StrToIntDef(Copy(Name, p1 + 1, p2 - p1 - 1), 0) + 1) +
|
||
'.part';
|
||
end;
|
||
|
||
function PartFiles(const Path: string): Integer;
|
||
// Сколько временных файлов писателя осталось рядом с целью.
|
||
var SR: TSearchRec;
|
||
begin
|
||
Result := 0;
|
||
if FindFirst(Path + '.*', faAnyFile, SR) = 0 then
|
||
begin
|
||
repeat
|
||
Inc(Result);
|
||
until FindNext(SR) <> 0;
|
||
end;
|
||
FindClose(SR);
|
||
end;
|
||
|
||
procedure TestRecorder;
|
||
var
|
||
Rec: TTCIRecorder;
|
||
L, R: array[0..8191] of Single;
|
||
Data: TTCIPcm;
|
||
i, Total: Integer;
|
||
Path: string;
|
||
FS: TFileStream;
|
||
Hdr: array[0..43] of Byte;
|
||
Sz: LongWord;
|
||
W: TTCIWavWriter;
|
||
Was: Int64;
|
||
Tk: TTCIRecTake;
|
||
Big: TTCIPcm;
|
||
Refused, k, Bad: Integer;
|
||
Path2, Squat: string;
|
||
begin
|
||
WriteLn('C. Рекордер линейного выхода');
|
||
|
||
// Максимум записи — 1 секунда: подаём полторы, лишнее не берём. ★Именно НЕ
|
||
// берём: окно записи по §4.3 начинается со START, а не «последняя секунда».
|
||
Was := TCIRecBudgetUsed; // счёт бюджета ДО записи
|
||
Rec := TTCIRecorder.Create(0, 48000, 1, nil);
|
||
try
|
||
Total := 0;
|
||
for i := 0 to 8191 do begin L[i] := 0.25; R[i] := -0.25; end;
|
||
while Total < 72000 do
|
||
begin
|
||
Rec.Feed(L, R, 8192);
|
||
Inc(Total, 8192);
|
||
end;
|
||
Tk := Rec.Take; Data := FlatTake(Tk);
|
||
Check('рекордер: длина по максимуму', Length(Data) = 48000 * 2,
|
||
IntToStr(Length(Data)));
|
||
// ★Take отдаёт данные ВМЕСТЕ с их местом в бюджете: копия живёт дальше в
|
||
// писателе, и до конца записи она обязана оставаться учтённой. Иначе SAVE
|
||
// был бы дырой в потолке — куски вернулись бы сразу, а копия висела бы
|
||
// неучтённой, и очередь сохранений на медленном диске росла бы без границ.
|
||
// ★Куски отдаются КАК ЕСТЬ: сплошной копии нет ни на миг, поэтому и пика
|
||
// в два бюджета нет. Резерв переезжает вместе с ними — целиком.
|
||
Check('рекордер: Take отдаёт сами куски, не копию',
|
||
(Length(Tk.Chunks) > 0) and (Tk.Count = Length(Data) div 2),
|
||
IntToStr(Length(Tk.Chunks)));
|
||
Check('рекордер: резерв переехал целиком, счёт не изменился',
|
||
TCIRecBudgetUsed = Was + Tk.Reserved,
|
||
IntToStr(TCIRecBudgetUsed - Was) + '/' + IntToStr(Tk.Reserved));
|
||
Check('рекордер: резерва хватает на отданные куски',
|
||
Tk.Reserved >= Int64(Length(Data)) * SizeOf(SmallInt),
|
||
IntToStr(Tk.Reserved));
|
||
TCIRecBudgetFree(Tk.Reserved); // как это сделает писатель
|
||
Tk.Chunks := nil;
|
||
Check('рекордер: возврат резерва закрывает счёт',
|
||
TCIRecBudgetUsed = Was, IntToStr(TCIRecBudgetUsed - Was));
|
||
Check('рекордер: уровень сохранён',
|
||
(Data[0] = Round(0.25 * 32767)) and (Data[1] = -Round(0.25 * 32767)));
|
||
Check('рекордер: Take завершает запись', Length(FlatTake(Rec.Take)) = 0);
|
||
finally
|
||
Rec.Free;
|
||
end;
|
||
|
||
// ★Отдаются именно куски, а не свёрнутая в один буфер копия: 2.5 секунды
|
||
// при куске в секунду — это ТРИ куска. Если бы Take собирал сплошную копию
|
||
// (как было), кусок пришёл бы один, а пик памяти на полном бюджете вырос бы
|
||
// вдвое: 128 МБ кусков и 128 МБ копии рядом, при счётчике в 128.
|
||
Was := TCIRecBudgetUsed;
|
||
Rec := TTCIRecorder.Create(0, 48000, 3, nil);
|
||
try
|
||
for i := 0 to 8191 do begin L[i] := 0.25; R[i] := -0.25; end;
|
||
Total := 0;
|
||
while Total < 120000 do // 2.5 с при 48 кГц
|
||
begin
|
||
Rec.Feed(L, R, 8192);
|
||
Inc(Total, 8192);
|
||
end;
|
||
Tk := Rec.Take;
|
||
Check('рекордер: кусков ровно по секундам записи',
|
||
(Tk.Chunk = 48000) and (Length(Tk.Chunks) = 3) and
|
||
(Tk.Count >= 120000),
|
||
IntToStr(Length(Tk.Chunks)) + ' × ' + IntToStr(Tk.Chunk));
|
||
Check('рекордер: сплошной копии не появилось',
|
||
TCIRecBudgetUsed = Was + Tk.Reserved,
|
||
IntToStr(TCIRecBudgetUsed - Was));
|
||
Data := FlatTake(Tk);
|
||
Check('рекордер: куски склеиваются в непрерывный звук',
|
||
(Length(Data) = Tk.Count * 2) and
|
||
(Data[0] = Round(0.25 * 32767)) and
|
||
(Data[Length(Data) - 2] = Round(0.25 * 32767)));
|
||
Tk.Chunks := nil;
|
||
TCIRecBudgetFree(Tk.Reserved);
|
||
finally
|
||
Rec.Free;
|
||
end;
|
||
Check('рекордер: счёт закрыт', TCIRecBudgetUsed = Was);
|
||
|
||
// Порядок отсчётов: первым обязан идти самый ПЕРВЫЙ записанный.
|
||
Rec := TTCIRecorder.Create(0, 1000, 1, nil); // ёмкость 1000 отсчётов
|
||
try
|
||
for i := 0 to 1499 do
|
||
begin
|
||
L[0] := i / 4000.0;
|
||
R[0] := 0;
|
||
Rec.Feed(L, R, 1);
|
||
end;
|
||
Tk := Rec.Take; Data := FlatTake(Tk);
|
||
Check('рекордер: с начала записи, а не с конца',
|
||
(Length(Data) = 2000) and (Data[0] = 0) and
|
||
(Abs(Data[1998] - Round((999 / 4000.0) * 32767)) <= 1),
|
||
IntToStr(Data[1998]));
|
||
finally
|
||
Rec.Free;
|
||
end;
|
||
|
||
// ★Истечение срока: по документу «по истечении времени запись удаляется».
|
||
// Секунду ждать незачем — окно берём минимальное и смотрим на часы.
|
||
Rec := TTCIRecorder.Create(0, 48000, 1, nil);
|
||
try
|
||
for i := 0 to 8191 do begin L[i] := 0.25; R[i] := -0.25; end;
|
||
Rec.Feed(L, R, 8192);
|
||
Check('рекордер: до срока запись есть', Length(FlatTake(Rec.Take)) > 0);
|
||
finally
|
||
Rec.Free;
|
||
end;
|
||
Rec := TTCIRecorder.Create(0, 48000, 1, nil);
|
||
try
|
||
Rec.Feed(L, R, 8192);
|
||
Sleep(1100); // окно закрылось
|
||
Check('рекордер: после срока запись удалена', Length(FlatTake(Rec.Take)) = 0);
|
||
Rec.Feed(L, R, 8192); // и новое аудио уже не принимает
|
||
Check('рекордер: истёкший не оживает', Length(FlatTake(Rec.Take)) = 0);
|
||
finally
|
||
Rec.Free;
|
||
end;
|
||
|
||
// ★Бюджет памяти. Раньше конструктор выделял MaxSec × 48 кГц × 2 × int16
|
||
// СРАЗУ — 57.6 МБ на строку из сети, 403 МБ на семь приёмников, и держать их
|
||
// мог кто угодно (авторизации в TCI нет). Теперь START не стоит ни байта.
|
||
Was := TCIRecBudgetUsed;
|
||
Rec := TTCIRecorder.Create(0, 48000, TCI_RECORD_MAX_SEC, nil);
|
||
try
|
||
Check('бюджет: START не выделяет памяти', TCIRecBudgetUsed = Was,
|
||
IntToStr(TCIRecBudgetUsed - Was));
|
||
for i := 0 to 8191 do begin L[i] := 0.25; R[i] := -0.25; end;
|
||
Rec.Feed(L, R, 8192);
|
||
Check('бюджет: растёт по мере записи', TCIRecBudgetUsed > Was);
|
||
Check('бюджет: кусками, а не всей ёмкостью',
|
||
TCIRecBudgetUsed - Was <= 4 * 48000 * 2 * 2,
|
||
IntToStr(TCIRecBudgetUsed - Was));
|
||
finally
|
||
Rec.Free;
|
||
end;
|
||
Check('бюджет: возвращается по Free', TCIRecBudgetUsed = Was);
|
||
|
||
// Потолок общий на все рекордеры сразу — иначе семь живых приёмников по
|
||
// 300 с всё равно дали бы 403 МБ.
|
||
Check('бюджет: потолок берётся целиком',
|
||
TCIRecBudgetTake(TCI_RECORD_MAX_BYTES - TCIRecBudgetUsed));
|
||
Check('бюджет: сверх потолка отказ', not TCIRecBudgetTake(1));
|
||
Rec := TTCIRecorder.Create(0, 48000, 10, nil);
|
||
try
|
||
Rec.Feed(L, R, 8192);
|
||
Check('бюджет: при отказе запись не рушится, а стоит пустой',
|
||
Length(FlatTake(Rec.Take)) = 0);
|
||
finally
|
||
Rec.Free;
|
||
end;
|
||
TCIRecBudgetFree(TCI_RECORD_MAX_BYTES - Was);
|
||
Check('бюджет: после возврата снова можно брать', TCIRecBudgetTake(1));
|
||
TCIRecBudgetFree(1);
|
||
|
||
// ★Срок по ЧАСАМ спрашивает тик сервера: у мёртвого, молчащего или
|
||
// замьюченного приёмника Feed не зовут вовсе, и без этого вопроса память
|
||
// жила бы до остановки сервера.
|
||
Rec := TTCIRecorder.Create(0, 48000, 1, nil);
|
||
try
|
||
Rec.Feed(L, R, 8192);
|
||
Check('срок: до истечения окно открыто', not Rec.Expired);
|
||
Check('срок: память занята', TCIRecBudgetUsed > Was);
|
||
Sleep(1100);
|
||
Check('срок: истекло без единого Feed', Rec.Expired);
|
||
Check('срок: память отдана без Take и Free', TCIRecBudgetUsed = Was,
|
||
IntToStr(TCIRecBudgetUsed - Was));
|
||
finally
|
||
Rec.Free;
|
||
end;
|
||
|
||
// ═══ WAV и писатель ═══════════════════════════════════════════════════
|
||
// ★Писатель — ОДИН поток с очередью, которым владеет адаптер. Поток на
|
||
// каждый SAVE с FreeOnTerminate не держал никто: штатный выход из программы
|
||
// обрывал запись на полуслове (из 100000044 байт на диске оставалось
|
||
// 40960), а медленный каталог плодил сотни потоков мимо бюджета.
|
||
Path := GetTempDir + 'tcitest_rec.wav';
|
||
Path2 := GetTempDir + 'tcitest_rec2.wav';
|
||
DeleteFile(Path);
|
||
DeleteFile(Path2);
|
||
SetLength(Data, 2000);
|
||
for i := 0 to 1999 do Data[i] := i * 8;
|
||
W := TTCIWavWriter.Create;
|
||
|
||
Check('WAV: задание принято', W.Enqueue(Path, MakeTake(Data, 0), 48000));
|
||
Check('WAV: очередь дописана', Drained(W, 5000));
|
||
if not FileExists(Path) then
|
||
Check('WAV: файл создан', False)
|
||
else
|
||
begin
|
||
FS := TFileStream.Create(Path, fmOpenRead);
|
||
try
|
||
Check('WAV: размер', FS.Size = 44 + 2000 * 2, IntToStr(FS.Size));
|
||
FS.Read(Hdr[0], 44);
|
||
Check('WAV: RIFF/WAVE',
|
||
(Hdr[0] = Ord('R')) and (Hdr[1] = Ord('I')) and
|
||
(Hdr[8] = Ord('W')) and (Hdr[9] = Ord('A')));
|
||
Sz := LongWord(Hdr[24]) or (LongWord(Hdr[25]) shl 8) or
|
||
(LongWord(Hdr[26]) shl 16) or (LongWord(Hdr[27]) shl 24);
|
||
Check('WAV: частота 48000', Sz = 48000, IntToStr(Sz));
|
||
Check('WAV: 2 канала, 16 бит',
|
||
(Hdr[22] = 2) and (Hdr[34] = 16));
|
||
Sz := LongWord(Hdr[40]) or (LongWord(Hdr[41]) shl 8) or
|
||
(LongWord(Hdr[42]) shl 16) or (LongWord(Hdr[43]) shl 24);
|
||
Check('WAV: длина данных', Sz = 4000, IntToStr(Sz));
|
||
finally
|
||
FS.Free;
|
||
end;
|
||
// ★Данные пишутся во временный файл, а под целевым именем он появляется
|
||
// одним вызовом ядра и уже целым: по имени файла клиент считает запись
|
||
// готовой, и незаконченного содержимого он там видеть не должен. После
|
||
// удачи «.part» рядом не остаётся.
|
||
Check('WAV: временный файл убран', PartFiles(Path) = 0,
|
||
IntToStr(PartFiles(Path)));
|
||
|
||
// ★Писатель отпускает резерв, когда данные ему больше не нужны — иначе
|
||
// потолок памяти держал бы только сами записи, а очередь сохранений на
|
||
// медленном диске росла бы мимо него.
|
||
Was := TCIRecBudgetUsed;
|
||
Check('WAV: резерв под писателя взят', TCIRecBudgetTake(4096));
|
||
DeleteFile(Path);
|
||
W.Enqueue(Path, MakeTake(Data, 4096), 48000);
|
||
Drained(W, 5000);
|
||
Check('WAV: писатель вернул резерв по окончании',
|
||
TCIRecBudgetUsed = Was, IntToStr(TCIRecBudgetUsed - Was));
|
||
|
||
// ★Существующий файл не трогаем: имя приходит из сети, и fmCreate затирал
|
||
// бы любой доступный процессу файл. Публикация идёт без замены
|
||
// (renameat2(RENAME_NOREPLACE) → link), так что занятое имя = отказ. Пишем
|
||
// поверх заведомо другой длиной — файл обязан остаться прежним.
|
||
Tk := MakeTake(Copy(Data, 0, 10), 0);
|
||
W.Enqueue(Path, Tk, 48000);
|
||
Drained(W, 5000);
|
||
FS := TFileStream.Create(Path, fmOpenRead);
|
||
try
|
||
Check('WAV: существующий файл не перезаписан',
|
||
FS.Size = 44 + 2000 * 2, IntToStr(FS.Size));
|
||
finally
|
||
FS.Free;
|
||
end;
|
||
Check('WAV: отказ не оставил временного файла', PartFiles(Path) = 0);
|
||
DeleteFile(Path);
|
||
end;
|
||
|
||
// ★Имя «.part» уникально внутри процесса (pid + счётчик), но не между
|
||
// запусками: файл, оставшийся от прошлой жизни (публиковать было нечем),
|
||
// плюс повторно выданный системой pid дают EEXIST на создании — и задание
|
||
// пропадало бы молча. Занимаем ровно то имя, которое писатель возьмёт
|
||
// следующим, и убеждаемся, что запись всё равно легла.
|
||
DeleteFile(Path);
|
||
Squat := NextTempName(TCIRecTempName(Path));
|
||
FS := TFileStream.Create(Squat, fmCreate);
|
||
FS.Free;
|
||
W.Enqueue(Path, MakeTake(Data, 0), 48000);
|
||
Drained(W, 5000);
|
||
Check('WAV: занятое имя «.part» не теряет запись', FileExists(Path));
|
||
DeleteFile(Squat);
|
||
DeleteFile(Path);
|
||
|
||
// ★Запись не удалась на полпути — по имени не остаётся НИЧЕГО. Прежний код
|
||
// не смотрел на результат записи вовсе (FileWrite и THandleStream.Write при
|
||
// ошибке возвращают 0 и не поднимают исключения), и на полном диске
|
||
// оставался огрызок с заголовком на полную длину. Здесь тот же путь:
|
||
// счётчик обещает больше, чем есть в кусках.
|
||
Tk := MakeTake(Data, 0);
|
||
Tk.Count := Tk.Count * 3; // кусков под это нет
|
||
W.Enqueue(Path, Tk, 48000);
|
||
Drained(W, 5000);
|
||
Check('WAV: неудачная запись не оставила файла', not FileExists(Path));
|
||
Check('WAV: неудачная запись не оставила «.part»', PartFiles(Path) = 0);
|
||
|
||
// ★Целевого имени не существует, ПОКА запись не готова. Раньше по нему
|
||
// сразу появлялась пустышка на 0 байт (имя занималось эксклюзивно, а данные
|
||
// шли во временный файл), и на медленном диске клиент видел её всю запись —
|
||
// а по имени файла он вправе считать запись готовой. Пишем 32 МБ и всё это
|
||
// время следим за именем: увидели его непустым, но не полным, или пустым —
|
||
// проверка красная.
|
||
SetLength(Big, 16 * 1024 * 1024); // 32 МБ: заведомо дольше, чем цикл ниже
|
||
FillChar(Big[0], Length(Big) * SizeOf(SmallInt), 0);
|
||
DeleteFile(Path2);
|
||
W.Enqueue(Path2, MakeTake(Big, 0), 48000);
|
||
Bad := 0;
|
||
while W.Pending > 0 do
|
||
if FileExists(Path2) then
|
||
begin
|
||
FS := TFileStream.Create(Path2, fmOpenRead or fmShareDenyNone);
|
||
try
|
||
if FS.Size <> 44 + Int64(Length(Big)) * SizeOf(SmallInt) then Inc(Bad);
|
||
finally
|
||
FS.Free;
|
||
end;
|
||
end;
|
||
Check('WAV: незаконченной записи под целевым именем не видно', Bad = 0,
|
||
IntToStr(Bad));
|
||
Check('WAV: 32 МБ дописаны', Drained(W, 20000));
|
||
DeleteFile(Path2);
|
||
|
||
// ★Очередь ограничена. Раньше «сохранить» было равно «создать поток», и
|
||
// зависший сетевой каталог давал их сотни — память стеков в бюджет не
|
||
// входит. Занимаем писателя большой записью и стучимся сверх потолка.
|
||
W.Enqueue(Path2, MakeTake(Big, 0), 48000);
|
||
Refused := 0;
|
||
for k := 0 to TCI_RECORD_MAX_JOBS + 3 do
|
||
if not W.Enqueue(GetTempDir + Format('tcitest_q%d.wav', [k]),
|
||
MakeTake(Data, 0), 48000) then
|
||
Inc(Refused);
|
||
Check('очередь: сверх потолка заданий отказ', Refused > 0,
|
||
IntToStr(Refused));
|
||
Check('очередь: дописалась', Drained(W, 20000));
|
||
for k := 0 to TCI_RECORD_MAX_JOBS + 3 do
|
||
DeleteFile(GetTempDir + Format('tcitest_q%d.wav', [k]));
|
||
|
||
// Гасят — новых заданий не принимаем: место в бюджете остаётся на
|
||
// вызывающем, и он обязан его вернуть сам (так и делает CmdRecorder).
|
||
W.Close;
|
||
Check('очередь: после Close заданий не берём',
|
||
not W.Enqueue(Path, MakeTake(Data, 0), 48000));
|
||
TCIStopWriter(W);
|
||
Check('очередь: TCIStopWriter обнуляет ссылку', W = nil);
|
||
|
||
// ★★Главная проверка P1: закрытие программы ДОЖИДАЕТСЯ записи. Раньше
|
||
// FreeOnTerminate-поток никто не ждал, и файл обрывался там, где его застал
|
||
// выход. Здесь сразу после остановки писателя файл обязан быть целым.
|
||
// ★И не только первый: за хвостом очереди клиенту тоже сказано «сохранено»,
|
||
// поэтому ждём ВСЮ очередь (срок остановки считается от последнего
|
||
// продвижения, а не от её начала).
|
||
DeleteFile(Path2);
|
||
for k := 0 to 1 do DeleteFile(GetTempDir + Format('tcitest_tail%d.wav', [k]));
|
||
W := TTCIWavWriter.Create;
|
||
Check('выход: задание принято', W.Enqueue(Path2, MakeTake(Big, 0), 48000));
|
||
for k := 0 to 1 do
|
||
W.Enqueue(GetTempDir + Format('tcitest_tail%d.wav', [k]),
|
||
MakeTake(Data, 0), 48000);
|
||
TCIStopWriter(W);
|
||
Bad := 0;
|
||
for k := 0 to 1 do
|
||
begin
|
||
Path := GetTempDir + Format('tcitest_tail%d.wav', [k]);
|
||
if not FileExists(Path) then Inc(Bad)
|
||
else
|
||
begin
|
||
FS := TFileStream.Create(Path, fmOpenRead);
|
||
try
|
||
if FS.Size <> 44 + 2000 * 2 then Inc(Bad);
|
||
finally
|
||
FS.Free;
|
||
end;
|
||
DeleteFile(Path);
|
||
end;
|
||
end;
|
||
Check('выход: хвост очереди тоже дописан', Bad = 0, IntToStr(Bad));
|
||
if not FileExists(Path2) then
|
||
Check('выход: файл дописан до конца', False)
|
||
else
|
||
begin
|
||
FS := TFileStream.Create(Path2, fmOpenRead);
|
||
try
|
||
Check('выход: файл дописан до конца',
|
||
FS.Size = 44 + Int64(Length(Big)) * SizeOf(SmallInt),
|
||
IntToStr(FS.Size));
|
||
finally
|
||
FS.Free;
|
||
end;
|
||
DeleteFile(Path2);
|
||
end;
|
||
Big := nil;
|
||
end;
|
||
|
||
{ ═══════════════════════════════════════════════════════════════════════════
|
||
C2. Чужая манипуляция (KEYER, §4.3)
|
||
═══════════════════════════════════════════════════════════════════════════ }
|
||
|
||
type
|
||
{ Приёмник фронтов ключа: пишет, ЧТО и КОГДА пришло. }
|
||
TKeyLog = class
|
||
public
|
||
Down: array[0..63] of Boolean;
|
||
At: array[0..63] of QWord;
|
||
Count: Integer;
|
||
T0: QWord;
|
||
procedure Key(D: Boolean);
|
||
end;
|
||
|
||
procedure TKeyLog.Key(D: Boolean);
|
||
begin
|
||
if Count > High(Down) then Exit;
|
||
if Count = 0 then T0 := GetTickCount64;
|
||
Down[Count] := D;
|
||
At[Count] := GetTickCount64 - T0;
|
||
Inc(Count);
|
||
end;
|
||
|
||
procedure TestKeyPlayer;
|
||
// ★Смысл проигрывателя: длительности приходят ГОТОВЫМИ (клиент замерил свой
|
||
// ключ), и в эфир они обязаны лечь такими же, сколько бы ни болталась сеть.
|
||
// Поэтому проверяем не «дёрнулся ключ», а ДЛИНЫ интервалов между фронтами.
|
||
var
|
||
Log: TKeyLog;
|
||
P: TCWElemPlayer;
|
||
Ev: TCWKeyEvent;
|
||
i, Waited, Bad: Integer;
|
||
D1, D2, D3: Int64;
|
||
T0: QWord;
|
||
begin
|
||
WriteLn('C2. Чужая манипуляция (KEYER)');
|
||
Log := TKeyLog.Create;
|
||
Ev := Log.Key;
|
||
P := TCWElemPlayer.Create(Ev);
|
||
try
|
||
// Посылка 150 мс, пауза 60, посылка 150 — «точка-тире» чужим ключом.
|
||
P.Enqueue(True, 150);
|
||
P.Enqueue(False, 60);
|
||
P.Enqueue(True, 150);
|
||
Waited := 0;
|
||
while (P.Busy or (P.Pending > 0)) and (Waited < 3000) do
|
||
begin
|
||
Sleep(10);
|
||
Inc(Waited, 10);
|
||
end;
|
||
Sleep(50);
|
||
Check('KEYER: фронтов ровно четыре', Log.Count = 4, IntToStr(Log.Count));
|
||
if Log.Count = 4 then
|
||
begin
|
||
Check('KEYER: чередование вниз-вверх-вниз-вверх',
|
||
Log.Down[0] and (not Log.Down[1]) and Log.Down[2] and
|
||
(not Log.Down[3]));
|
||
D1 := Int64(Log.At[1]) - Int64(Log.At[0]);
|
||
D2 := Int64(Log.At[2]) - Int64(Log.At[1]);
|
||
D3 := Int64(Log.At[3]) - Int64(Log.At[2]);
|
||
// Допуск на планировщик — тот же порядок, что у дробного сна (5 мс).
|
||
Check('KEYER: длительность посылки сохранена',
|
||
(Abs(D1 - 150) < 30) and (Abs(D3 - 150) < 30),
|
||
Format('%d/%d', [D1, D3]));
|
||
Check('KEYER: длительность паузы сохранена', Abs(D2 - 60) < 30,
|
||
IntToStr(D2));
|
||
end
|
||
else
|
||
begin
|
||
Check('KEYER: чередование вниз-вверх-вниз-вверх', False);
|
||
Check('KEYER: длительность посылки сохранена', False);
|
||
Check('KEYER: длительность паузы сохранена', False);
|
||
end;
|
||
// ★Очередь опустела — ключ ОТПУЩЕН. Иначе оборвавшийся клиент оставил бы в
|
||
// эфире несущую, снять которую некому.
|
||
Check('KEYER: на пустой очереди ключ отпущен',
|
||
(Log.Count > 0) and (not Log.Down[Log.Count - 1]));
|
||
|
||
// Пачка после простоя начинается сразу, а не «догоняет» старый дедлайн.
|
||
Log.Count := 0;
|
||
Sleep(300);
|
||
P.Enqueue(True, 100);
|
||
Waited := 0;
|
||
while (Log.Count < 2) and (Waited < 2000) do
|
||
begin
|
||
Sleep(10);
|
||
Inc(Waited, 10);
|
||
end;
|
||
Check('KEYER: следующая пачка играется целиком',
|
||
(Log.Count = 2) and (Abs(Int64(Log.At[1]) - Int64(Log.At[0]) - 100) < 30),
|
||
IntToStr(Log.Count));
|
||
|
||
// Обрыв: очередь бросается, ключ отпускается.
|
||
Log.Count := 0;
|
||
for i := 0 to 9 do P.Enqueue(True, 400);
|
||
Sleep(60);
|
||
P.AbortPlay;
|
||
Sleep(120);
|
||
Bad := Log.Count;
|
||
Sleep(300);
|
||
Check('KEYER: обрыв гасит очередь', Log.Count = Bad, IntToStr(Log.Count - Bad));
|
||
Check('KEYER: после обрыва ключ отпущен',
|
||
(Log.Count > 0) and (not Log.Down[Log.Count - 1]));
|
||
|
||
// ★Обрыв нельзя отменить пакетом из сети. Клиент шлёт элементы пачками по
|
||
// несколько десятков в секунду; такой пакет, прилетевший в те миллисекунды,
|
||
// пока поток спит в Hold, раньше снимал флаг обрыва — оператор трогает
|
||
// манипулятор, а чужая манипуляция продолжает держать ключ до конца
|
||
// текущего элемента. Меряем задержку отпускания от момента обрыва.
|
||
for i := 0 to 4 do P.Enqueue(True, 400);
|
||
Sleep(60);
|
||
Log.Count := 0; // ключ уже замкнут — ждём именно отпускания
|
||
T0 := GetTickCount64;
|
||
P.AbortPlay;
|
||
P.Enqueue(True, 400); // «пакет пришёл следом за обрывом»
|
||
Waited := 0;
|
||
while (Log.Count = 0) and (Waited < 1000) do
|
||
begin
|
||
Sleep(5);
|
||
Inc(Waited, 5);
|
||
end;
|
||
// Отсчёт по стенным часам: Log.At отсчитывается от ПЕРВОГО фронта пачки,
|
||
// а нам нужна задержка от самого обрыва (опрос с шагом 5 мс).
|
||
D1 := Int64(GetTickCount64) - Int64(T0);
|
||
Check('KEYER: обрыв не отменяется пакетом следом',
|
||
(Log.Count > 0) and (not Log.Down[0]) and (D1 < 100),
|
||
Format('%d/%d', [Log.Count, D1]));
|
||
P.AbortPlay; // и хвост этого пакета тоже гасим
|
||
Sleep(120);
|
||
// Нулевые и отрицательные длительности не элементы: первое нажатие клиента
|
||
// (keyer:0,true,0) не должно порождать ни одного фронта.
|
||
Log.Count := 0;
|
||
P.Enqueue(True, 0);
|
||
P.Enqueue(False, -5);
|
||
Sleep(150);
|
||
Check('KEYER: нулевая длительность ничего не играет', Log.Count = 0,
|
||
IntToStr(Log.Count));
|
||
finally
|
||
P.Free;
|
||
Log.Free;
|
||
end;
|
||
end;
|
||
|
||
procedure TestTextSender;
|
||
// Передача текста (F1..F8, набор в терминале, CAT KY). Проверяем не «пошли
|
||
// фронты», а что ОБРЫВ работает: касание манипулятора и снятие MOX обязаны
|
||
// прекратить программную манипуляцию, чем бы её ни кормили.
|
||
var
|
||
Log: TKeyLog;
|
||
S: TCWSender;
|
||
Ev: TCWKeyEvent;
|
||
Waited: Integer;
|
||
D: Int64;
|
||
T0: QWord;
|
||
begin
|
||
WriteLn('C3. Передача текста (KY / F1..F8)');
|
||
Log := TKeyLog.Create;
|
||
Ev := Log.Key;
|
||
S := TCWSender.Create(Ev);
|
||
try
|
||
// 'E' на 20 WPM — одна точка длиной в один Dit (1200/20 = 60 мс).
|
||
S.SetSpeed(20, 50);
|
||
S.Enqueue('E');
|
||
Waited := 0;
|
||
while (Log.Count < 2) and (Waited < 2000) do
|
||
begin
|
||
Sleep(5);
|
||
Inc(Waited, 5);
|
||
end;
|
||
Sleep(50);
|
||
Check('KY: точка — два фронта', Log.Count = 2, IntToStr(Log.Count));
|
||
if Log.Count >= 2 then
|
||
begin
|
||
D := Int64(Log.At[1]) - Int64(Log.At[0]);
|
||
Check('KY: длительность точки по скорости', Abs(D - 60) < 30, IntToStr(D));
|
||
end
|
||
else
|
||
Check('KY: длительность точки по скорости', False);
|
||
|
||
// ★Обрыв нельзя отменить символом, набранным следом. Терминал шлёт текст
|
||
// ПО СИМВОЛУ на нажатие клавиши, логгер — кусками по 25 знаков в KY;
|
||
// такой символ, пришедший в те миллисекунды, пока поток спит в Hold,
|
||
// раньше снимал флаг обрыва — и в эфир уходил весь остаток сообщения,
|
||
// хотя оператор уже взял манипулятор. 5 WPM: тире длиной 720 мс, попасть
|
||
// в него легко.
|
||
S.SetSpeed(5, 50);
|
||
Log.Count := 0;
|
||
S.Enqueue('OOOO');
|
||
// Ждём не «появился фронт», а замыкания ключа ЭТИМ сообщением: предыдущее
|
||
// ещё доигрывает межзнаковую паузу, и его завершающий Key(False) прилетит
|
||
// сюда же.
|
||
Waited := 0;
|
||
while (Waited < 3000)
|
||
and not ((Log.Count > 0) and Log.Down[Log.Count - 1]) do
|
||
begin
|
||
Sleep(5);
|
||
Inc(Waited, 5);
|
||
end;
|
||
Check('KY: сообщение пошло',
|
||
(Log.Count > 0) and Log.Down[Log.Count - 1], IntToStr(Log.Count));
|
||
Sleep(100); // середина первого тире (720 мс на 5 WPM)
|
||
Log.Count := 0; // ключ уже замкнут — ждём именно отпускания
|
||
T0 := GetTickCount64;
|
||
S.AbortSending;
|
||
S.Enqueue('E'); // «символ пришёл следом за обрывом»
|
||
Waited := 0;
|
||
while (Log.Count = 0) and (Waited < 2000) do
|
||
begin
|
||
Sleep(5);
|
||
Inc(Waited, 5);
|
||
end;
|
||
D := Int64(GetTickCount64) - Int64(T0);
|
||
Check('KY: обрыв не отменяется символом следом',
|
||
(Log.Count > 0) and (not Log.Down[0]) and (D < 100),
|
||
Format('%d/%d', [Log.Count, D]));
|
||
S.AbortSending; // и хвост этого символа тоже гасим
|
||
Sleep(150);
|
||
|
||
// Обрыв не глушит передачу навсегда: следующее сообщение играется.
|
||
Log.Count := 0;
|
||
S.SetSpeed(20, 50);
|
||
S.Enqueue('E');
|
||
Waited := 0;
|
||
while (Log.Count < 2) and (Waited < 2000) do
|
||
begin
|
||
Sleep(5);
|
||
Inc(Waited, 5);
|
||
end;
|
||
Check('KY: после обрыва передача снова идёт', Log.Count = 2,
|
||
IntToStr(Log.Count));
|
||
finally
|
||
S.Free;
|
||
Log.Free;
|
||
end;
|
||
end;
|
||
|
||
{ ═══════════════════════════════════════════════════════════════════════════
|
||
D. Живой сервер: команды потоков
|
||
═══════════════════════════════════════════════════════════════════════════ }
|
||
|
||
type
|
||
{ Минимальный WS-клиент на сыром сокете: handshake, отправка команд с
|
||
маской (как обязан клиент), приём текста и бинарных блоков. }
|
||
TRawClient = class
|
||
private
|
||
FSock: Integer;
|
||
FIn: array[0..262143] of Byte;
|
||
FLen: Integer;
|
||
public
|
||
function Connect(Port: Word): Boolean;
|
||
procedure SendText(const S: string);
|
||
procedure SendBinary(const Data; Len: Integer);
|
||
{ Штатное прощание по RFC 6455: close-кадр с кодом 1000. Второй путь
|
||
отключения — просто закрыть сокет (Close_), и сервер обязан отпускать
|
||
слот в обоих. }
|
||
procedure SendClose;
|
||
procedure Pump(Ms: Integer);
|
||
function NextFrame(out Opcode: Byte; out Payload: TBytes): Boolean;
|
||
{ Ждать строку с подстрокой Needle не дольше Ms. }
|
||
function WaitText(const Needle: string; Ms: Integer): string;
|
||
function Alive: Boolean;
|
||
procedure Close_;
|
||
end;
|
||
|
||
function TRawClient.Connect(Port: Word): Boolean;
|
||
var
|
||
Addr: TInetSockAddr;
|
||
Req: string;
|
||
begin
|
||
Result := False;
|
||
FLen := 0;
|
||
FSock := fpSocket(AF_INET, SOCK_STREAM, 0);
|
||
if FSock < 0 then Exit;
|
||
FillChar(Addr, SizeOf(Addr), 0);
|
||
Addr.sin_family := AF_INET;
|
||
Addr.sin_port := htons(Port);
|
||
Addr.sin_addr.s_addr := htonl($7F000001);
|
||
if fpConnect(FSock, @Addr, SizeOf(Addr)) <> 0 then Exit;
|
||
Req := 'GET / HTTP/1.1'#13#10 +
|
||
'Host: 127.0.0.1'#13#10 +
|
||
'Upgrade: websocket'#13#10 +
|
||
'Connection: Upgrade'#13#10 +
|
||
'Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ=='#13#10 +
|
||
'Sec-WebSocket-Version: 13'#13#10#13#10;
|
||
fpSend(FSock, @Req[1], Length(Req), 0);
|
||
// Ответ handshake: ждём конца заголовков и выкидываем их из буфера.
|
||
Pump(1000);
|
||
Result := FLen > 0;
|
||
if Result then
|
||
begin
|
||
Req := '';
|
||
SetLength(Req, FLen);
|
||
Move(FIn[0], Req[1], FLen);
|
||
if Pos(#13#10#13#10, Req) = 0 then Exit(False);
|
||
Result := Pos('101', Copy(Req, 1, 20)) > 0;
|
||
FLen := FLen - (Pos(#13#10#13#10, Req) + 3);
|
||
if FLen > 0 then Move(FIn[Pos(#13#10#13#10, Req) + 3], FIn[0], FLen);
|
||
end;
|
||
end;
|
||
|
||
procedure TRawClient.SendText(const S: string);
|
||
var
|
||
Frame: array of Byte;
|
||
i, HLen, N: Integer;
|
||
Mask: array[0..3] of Byte;
|
||
begin
|
||
N := Length(S);
|
||
if N <= 125 then HLen := 2 else HLen := 4;
|
||
SetLength(Frame, HLen + 4 + N);
|
||
Frame[0] := $81;
|
||
if N <= 125 then Frame[1] := $80 or Byte(N)
|
||
else
|
||
begin
|
||
Frame[1] := $80 or 126;
|
||
Frame[2] := Byte(N shr 8);
|
||
Frame[3] := Byte(N);
|
||
end;
|
||
for i := 0 to 3 do Mask[i] := Byte(Random(256));
|
||
for i := 0 to 3 do Frame[HLen + i] := Mask[i];
|
||
for i := 0 to N - 1 do
|
||
Frame[HLen + 4 + i] := Byte(S[i + 1]) xor Mask[i and 3];
|
||
fpSend(FSock, @Frame[0], Length(Frame), 0);
|
||
end;
|
||
|
||
procedure TRawClient.SendClose;
|
||
var
|
||
Frame: array[0..7] of Byte;
|
||
i: Integer;
|
||
Mask: array[0..3] of Byte;
|
||
Code: array[0..1] of Byte;
|
||
begin
|
||
Code[0] := $03; Code[1] := $E8; // 1000 — normal closure
|
||
for i := 0 to 3 do Mask[i] := Byte(Random(256));
|
||
Frame[0] := $88;
|
||
Frame[1] := $80 or 2;
|
||
for i := 0 to 3 do Frame[2 + i] := Mask[i];
|
||
for i := 0 to 1 do Frame[6 + i] := Code[i] xor Mask[i];
|
||
fpSend(FSock, @Frame[0], SizeOf(Frame), 0);
|
||
end;
|
||
|
||
procedure TRawClient.SendBinary(const Data; Len: Integer);
|
||
var
|
||
Frame: array of Byte;
|
||
P: PByte;
|
||
i, HLen: Integer;
|
||
Mask: array[0..3] of Byte;
|
||
begin
|
||
if Len <= 125 then HLen := 2
|
||
else if Len <= 65535 then HLen := 4
|
||
else HLen := 10;
|
||
SetLength(Frame, HLen + 4 + Len);
|
||
Frame[0] := $82;
|
||
if Len <= 125 then Frame[1] := $80 or Byte(Len)
|
||
else if Len <= 65535 then
|
||
begin
|
||
Frame[1] := $80 or 126;
|
||
Frame[2] := Byte(Len shr 8);
|
||
Frame[3] := Byte(Len);
|
||
end
|
||
else
|
||
begin
|
||
Frame[1] := $80 or 127;
|
||
Frame[2] := 0; Frame[3] := 0; Frame[4] := 0; Frame[5] := 0;
|
||
Frame[6] := Byte(Len shr 24); Frame[7] := Byte(Len shr 16);
|
||
Frame[8] := Byte(Len shr 8); Frame[9] := Byte(Len);
|
||
end;
|
||
for i := 0 to 3 do Mask[i] := Byte(Random(256));
|
||
for i := 0 to 3 do Frame[HLen + i] := Mask[i];
|
||
P := @Data;
|
||
for i := 0 to Len - 1 do Frame[HLen + 4 + i] := P[i] xor Mask[i and 3];
|
||
fpSend(FSock, @Frame[0], Length(Frame), 0);
|
||
end;
|
||
|
||
procedure TRawClient.Pump(Ms: Integer);
|
||
var
|
||
R, Waited: Integer;
|
||
begin
|
||
Waited := 0;
|
||
repeat
|
||
R := fpRecv(FSock, @FIn[FLen], SizeOf(FIn) - FLen, MSG_DONTWAIT);
|
||
if R > 0 then Inc(FLen, R)
|
||
else
|
||
begin
|
||
Sleep(10);
|
||
Inc(Waited, 10);
|
||
end;
|
||
until Waited >= Ms;
|
||
end;
|
||
|
||
function TRawClient.NextFrame(out Opcode: Byte; out Payload: TBytes): Boolean;
|
||
var PayLen, Need, i: Integer;
|
||
begin
|
||
Result := False;
|
||
Payload := nil;
|
||
if FLen < 2 then Exit;
|
||
Opcode := FIn[0] and $0F;
|
||
PayLen := FIn[1] and $7F;
|
||
Need := 2;
|
||
if PayLen = 126 then
|
||
begin
|
||
if FLen < 4 then Exit;
|
||
PayLen := (FIn[2] shl 8) or FIn[3];
|
||
Need := 4;
|
||
end
|
||
else if PayLen = 127 then
|
||
begin
|
||
if FLen < 10 then Exit;
|
||
PayLen := (FIn[6] shl 24) or (FIn[7] shl 16) or (FIn[8] shl 8) or FIn[9];
|
||
Need := 10;
|
||
end;
|
||
if FLen < Need + PayLen then Exit;
|
||
SetLength(Payload, PayLen);
|
||
for i := 0 to PayLen - 1 do Payload[i] := FIn[Need + i];
|
||
if FLen > Need + PayLen then Move(FIn[Need + PayLen], FIn[0], FLen - Need - PayLen);
|
||
Dec(FLen, Need + PayLen);
|
||
Result := True;
|
||
end;
|
||
|
||
function TRawClient.WaitText(const Needle: string; Ms: Integer): string;
|
||
var
|
||
Op: Byte;
|
||
Pay: TBytes;
|
||
S: string;
|
||
Waited: Integer;
|
||
begin
|
||
Result := '';
|
||
Waited := 0;
|
||
repeat
|
||
while NextFrame(Op, Pay) do
|
||
if Op = $01 then
|
||
begin
|
||
S := '';
|
||
SetLength(S, Length(Pay));
|
||
if Length(Pay) > 0 then Move(Pay[0], S[1], Length(Pay));
|
||
if Pos(Needle, LowerCase(S)) > 0 then Exit(S);
|
||
end;
|
||
Pump(50);
|
||
Inc(Waited, 50);
|
||
until Waited >= Ms;
|
||
end;
|
||
|
||
function TRawClient.Alive: Boolean;
|
||
var R: Integer;
|
||
begin
|
||
R := fpSend(FSock, @R, 0, MSG_NOSIGNAL);
|
||
Result := R >= 0;
|
||
end;
|
||
|
||
procedure TRawClient.Close_;
|
||
begin
|
||
if FSock >= 0 then fpClose(FSock);
|
||
FSock := -1;
|
||
end;
|
||
|
||
type
|
||
{ Хост: маршалинг Invoke в наш поток не нужен — исполняем на месте, как
|
||
делает демон (у него тоже нет очереди главного потока в этом смысле). }
|
||
THost = class
|
||
procedure DoInvoke(M: TThreadMethod);
|
||
procedure OnTXIQ(const Buf: array of Double; Count: Integer);
|
||
end;
|
||
|
||
var
|
||
TXIQBlocks: Integer = 0;
|
||
|
||
procedure THost.DoInvoke(M: TThreadMethod);
|
||
begin
|
||
M();
|
||
end;
|
||
|
||
procedure THost.OnTXIQ(const Buf: array of Double; Count: Integer);
|
||
// Готовый блок TX-IQ: единственный наблюдаемый признак того, что аудио
|
||
// клиента прошло весь тракт (ринг микрофона вычерпывается быстрее, чем его
|
||
// успевает увидеть опрос).
|
||
begin
|
||
if Count > 0 then Inc(TXIQBlocks);
|
||
end;
|
||
|
||
procedure TestServer;
|
||
const
|
||
PORT = 40099;
|
||
var
|
||
Ctrl: TRadioController;
|
||
Ad: TTCIAdapter;
|
||
Host: THost;
|
||
Cfg: TTCISettings;
|
||
C, C2: TRawClient;
|
||
S: string;
|
||
WasConn, WasRun: Boolean;
|
||
Blk: array[0..1023] of Byte;
|
||
H: TTCIStreamHeader;
|
||
Op: Byte;
|
||
Pay: TBytes;
|
||
GotBinary, GotClose: Boolean;
|
||
Was: Int64;
|
||
begin
|
||
WriteLn('D. Команды потоков на живом сервере');
|
||
|
||
Host := THost.Create;
|
||
Ctrl := TRadioController.Create;
|
||
Ctrl.LocalAudioEnabled := False;
|
||
Ctrl.OnInvoke := Host.DoInvoke;
|
||
Ad := TTCIAdapter.Create(Ctrl, nil);
|
||
C := TRawClient.Create;
|
||
try
|
||
Cfg.Enabled := True;
|
||
Cfg.Port := PORT;
|
||
Cfg.BindAddr := '127.0.0.1';
|
||
if not Ad.ApplySettings(Cfg) then
|
||
begin
|
||
Check('сервер поднялся', False, 'порт занят?');
|
||
Exit;
|
||
end;
|
||
Check('сервер поднялся', Ad.Active);
|
||
|
||
if not C.Connect(PORT) then
|
||
begin
|
||
Check('клиент подключился', False);
|
||
Exit;
|
||
end;
|
||
Check('клиент подключился', True);
|
||
Check('пришёл ready', C.WaitText('ready;', 2000) <> '');
|
||
|
||
// Приёмник вне диапазона — отказ, а не молчание.
|
||
C.SendText('audio_start:9;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('audio_start:9 → ошибка', Pos('bad receiver', S) > 0, S);
|
||
|
||
C.SendText('iq_start:abc;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('iq_start:abc → ошибка', Pos('bad receiver', S) > 0, S);
|
||
|
||
// Пан 1: без подключённого радио его нет ни в потолке (TRX_COUNT=1), ни
|
||
// живьём — в обоих случаях клиент обязан получить отказ, а не тишину.
|
||
C.SendText('audio_start:1;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('audio_start на несуществующий пан → ошибка',
|
||
(Pos('not running', S) > 0) or (Pos('bad receiver', S) > 0), S);
|
||
|
||
// Главный тракт живой: старт обязан пройти молча.
|
||
C.SendText('audio_start:0;');
|
||
S := C.WaitText('tci_error', 400);
|
||
Check('audio_start:0 без ошибок', S = '', S);
|
||
|
||
// Параметры потока принимаются и подтверждаются.
|
||
C.SendText('audio_samplerate:12000;');
|
||
S := C.WaitText('audio_samplerate', 1500);
|
||
Check('audio_samplerate:12000 подтверждён', Pos('12000', S) > 0, S);
|
||
C.SendText('audio_samplerate:44100;');
|
||
S := C.WaitText('audio_samplerate', 1500);
|
||
Check('audio_samplerate:44100 отвергнут', Pos('12000', S) > 0, S);
|
||
C.SendText('iq_samplerate:96000;');
|
||
S := C.WaitText('iq_samplerate', 1500);
|
||
Check('iq_samplerate:96000 подтверждён', Pos('96000', S) > 0, S);
|
||
|
||
// ★Ответ обязан называть частоту, которую клиент РЕАЛЬНО получит.
|
||
// Контроллер сейчас на 192 кГц: просьба «384» невыполнима.
|
||
C.SendText('iq_samplerate:384000;');
|
||
S := C.WaitText('iq_samplerate', 1500);
|
||
Check('iq_samplerate:384к при 192к источника → 192к',
|
||
Pos('192000', S) > 0, S);
|
||
|
||
// Сменился rate устройства — та же просьба стала выполнимой, и клиенту
|
||
// обязано прийти переобъявление без всякого запроса.
|
||
Ctrl.SetSampleRate(384000);
|
||
S := C.WaitText('iq_samplerate', 1500);
|
||
Check('смена rate переобъявляет iq_samplerate', Pos('384000', S) > 0, S);
|
||
|
||
// Частоты Pluto: 576 кГц на 384 не делится — отдаём законные 192 кГц.
|
||
Ctrl.SetSampleRate(576000);
|
||
S := C.WaitText('iq_samplerate', 1500);
|
||
Check('Pluto 576к: просьба 384к → 192к', Pos('192000', S) > 0, S);
|
||
Ctrl.SetSampleRate(192000);
|
||
C.WaitText('iq_samplerate', 1000);
|
||
|
||
// IF_LIMITS привязаны к rate устройства (§4.1: «высылается при подключении
|
||
// и изменении частоты дискретизации»).
|
||
Ctrl.SetSampleRate(96000);
|
||
S := C.WaitText('if_limits', 1500);
|
||
Check('смена rate переобъявляет if_limits',
|
||
(Pos('-48000', S) > 0) and (Pos('48000', S) > 0), S);
|
||
Ctrl.SetSampleRate(192000);
|
||
C.WaitText('if_limits', 1000);
|
||
|
||
// ★Рекордер только на ЖИВОМ приёмнике. Раньше хватало номера в потолке, и
|
||
// семь строк подряд занимали 403 МБ, которые никто не освобождал: у
|
||
// мёртвого приёмника Feed не зовут, значит и срок никто не проверял.
|
||
Was := TCIRecBudgetUsed;
|
||
C.SendText('line_out_recorder_start:3,300;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('recorder start на мёртвом приёмнике → ошибка',
|
||
Pos('receiver is not running', S) > 0, S);
|
||
C.SendText('line_out_recorder_start:99,300;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('recorder start с чужим номером → ошибка',
|
||
Pos('bad receiver', S) > 0, S);
|
||
Check('recorder: отказ не стоил памяти', TCIRecBudgetUsed = Was,
|
||
IntToStr(TCIRecBudgetUsed - Was));
|
||
|
||
// Имя файла из сети: каталог из просьбы игнорируется целиком, наружу
|
||
// записи не выходят (подробный разбор имён — в части A).
|
||
C.SendText('line_out_recorder_start:0,10;');
|
||
C.SendText('line_out_recorder_save:0,..' + '/' + '..' + '/etc/passwd;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('save с чужим путём → отказ по имени', Pos('bad file name', S) > 0, S);
|
||
|
||
// Рекордер: сохранять нечего — честная ошибка вместо пустого файла.
|
||
C.SendText('line_out_recorder_save:0,' +
|
||
StringReplace(GetTempDir + 'tcitest_none.wav', ':', '|', [rfReplaceAll]) + ';');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('save без записи → ошибка', Pos('nothing recorded', S) > 0, S);
|
||
|
||
C.SendText('line_out_recorder_start:0,10;');
|
||
C.SendText('line_out_recorder_save:0,' +
|
||
StringReplace(GetTempDir + 'tcitest_none.mp3', ':', '|', [rfReplaceAll]) + ';');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('save в mp3 → ошибка', Pos('only wav', S) > 0, S);
|
||
C.SendText('line_out_recorder_break:0;');
|
||
|
||
// TRX с источником tci: без запущенного аудиопотока просьба не действует.
|
||
C.SendText('audio_stop:0;');
|
||
C.SendText('trx:0,true,tci;');
|
||
C.WaitText('trx:', 1000);
|
||
Check('trx tci без потока не берёт модуляцию',
|
||
not Ctrl.TCIMicRequested);
|
||
C.SendText('trx:0,false;');
|
||
C.WaitText('trx:', 1000);
|
||
|
||
C.SendText('audio_start:0;');
|
||
C.SendText('trx:0,true,tci;');
|
||
C.Pump(300);
|
||
Check('trx tci с потоком берёт модуляцию', Ctrl.TCIMicRequested);
|
||
// ★Проверяем и сам эфир, а не только флаг источника: раньше SetMOX по этой
|
||
// дороге падал в Access violation (SyncCWKeyer → SendDUCSpecificFromSettings
|
||
// при FNetwork = nil), ошибку глотал обработчик команды, и «передача» жила
|
||
// только в ответе клиенту.
|
||
Check('trx:0,true поднял передачу', Ctrl.FTransmitting);
|
||
|
||
// Второй TCI-клиент не должен перехватывать ни аудио, ни
|
||
// владение уже идущей TCI-передачей. Ждём истечения hold,
|
||
// иначе вторая команда будет отклонена ещё до этой проверки.
|
||
C2 := TRawClient.Create;
|
||
try
|
||
Check('конкурирующий клиент подключился', C2.Connect(PORT));
|
||
Check('конкурирующему пришёл ready', C2.WaitText('ready;', 2000) <> '');
|
||
C2.SendText('audio_start:0;');
|
||
Sleep(300);
|
||
C2.SendText('trx:0,true,tci;');
|
||
C2.Pump(300);
|
||
GotBinary := False;
|
||
while C2.NextFrame(Op, Pay) do
|
||
if Op = $02 then GotBinary := True;
|
||
Check('конкурирующий клиент не получил TX_CHRONO', not GotBinary);
|
||
C2.Close_;
|
||
Sleep(600);
|
||
Check('уход второго TCI-клиента не снял эфир первого',
|
||
Ctrl.FTransmitting);
|
||
Check('после ухода второго остался один клиент',
|
||
Ad.ClientCount = 1, IntToStr(Ad.ClientCount));
|
||
finally
|
||
C2.Close_;
|
||
C2.Free;
|
||
end;
|
||
|
||
C.SendText('trx:0,false;');
|
||
C.Pump(300);
|
||
Check('снятие TRX снимает источник', not Ctrl.TCIMicRequested);
|
||
Check('снятие TRX сняло передачу', not Ctrl.FTransmitting);
|
||
|
||
// ★arg1 у TRX/TUNE — номер передатчика, и он обязан разбираться, как всюду:
|
||
// раньше он игнорировался целиком, и клиент доп. приёмника уводил в эфир
|
||
// слайс оператора (чужая частота, а с кросс-бандом — чужой диапазон).
|
||
C.SendText('trx:9,true;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('trx:9 → ошибка, а не эфир', Pos('bad receiver', S) > 0, S);
|
||
Check('trx:9 не поднял передачу', not Ctrl.FTransmitting);
|
||
|
||
C.SendText('trx:abc,true;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('trx:abc → ошибка', Pos('bad receiver', S) > 0, S);
|
||
Check('trx:abc не поднял передачу', not Ctrl.FTransmitting);
|
||
|
||
// Приёмник 1 без подключённого радио: либо вне потолка, либо не запущен —
|
||
// но в эфир по нему уходить нельзя ни в каком случае.
|
||
C.SendText('trx:1,true;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('trx на несуществующий приёмник → ошибка',
|
||
(Pos('not running', S) > 0) or (Pos('bad receiver', S) > 0), S);
|
||
Check('trx на несуществующий приёмник не поднял передачу',
|
||
not Ctrl.FTransmitting);
|
||
|
||
C.SendText('tune:9,true;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('tune:9 → ошибка', Pos('bad receiver', S) > 0, S);
|
||
Check('tune:9 не включил TUN', not Ctrl.FTuning);
|
||
|
||
// ── KEYER (§4.3): чужой ключ ────────────────────────────────────────
|
||
// Номер передатчика разбирается так же, как у TRX: командой из сети в эфир
|
||
// по несуществующему приёмнику не уходят.
|
||
C.SendText('keyer:9,true,0;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('keyer:9 → ошибка', Pos('bad receiver', S) > 0, S);
|
||
C.SendText('keyer:abc,true,0;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('keyer:abc → ошибка', Pos('bad receiver', S) > 0, S);
|
||
C.SendText('keyer:1,true,0;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('keyer на незапущенный приёмник → ошибка',
|
||
(Pos('not running', S) > 0) or (Pos('bad receiver', S) > 0), S);
|
||
C.SendText('keyer:0,maybe,0;');
|
||
S := C.WaitText('tci_error', 1500);
|
||
Check('keyer с нечисловым состоянием → ошибка', Pos('bad state', S) > 0, S);
|
||
// Первое нажатие (arg3 = 0) — не ошибка и не звук: играть ещё нечего.
|
||
C.SendText('keyer:0,true,0;');
|
||
S := C.WaitText('tci_error', 400);
|
||
Check('keyer:0,true,0 не ошибка', S = '', S);
|
||
Check('keyer:0,true,0 не поднял манипуляцию', not Ctrl.CWXBusy);
|
||
|
||
// ★Сквозная проверка перевода: keyer:0,false,150 значит «посылка длилась
|
||
// 150 мс», и она обязана дойти до манипуляции. Без телеграфного режима
|
||
// трогать ключ нечем (CWTXActive), поэтому режим ставим сами.
|
||
Ctrl.SetMode(MODE_CWU);
|
||
if not Ctrl.CWTXActive then
|
||
WriteLn(' .. keyer: манипуляция недоступна (CWTXActive=false), пропуск')
|
||
else
|
||
begin
|
||
// ★Локальный генератор вооружается только при живом устройстве
|
||
// (FDevConnected/FRunning — без радио манипулировать некуда), а радио на
|
||
// стенде нет. Подставляем эти два флага на время проверки: нас интересует
|
||
// перевод «пришло false ⇒ кончилась ПОСЫЛКА», а не излучающая часть.
|
||
WasConn := Ctrl.FDevConnected;
|
||
WasRun := Ctrl.FRunning;
|
||
Ctrl.FDevConnected := True;
|
||
Ctrl.FRunning := True;
|
||
// Первое нажатие открывает передачу, второе сообщение говорит «кончилась
|
||
// ПАУЗА 300 мс» — ключ при этом замыкаться не должен.
|
||
C.SendText('keyer:0,true,0;');
|
||
C.SendText('keyer:0,true,300;');
|
||
C.Pump(120);
|
||
Check('keyer: манипуляция пошла', Ctrl.CWXBusy);
|
||
Check('keyer: пауза ключ не замыкает', not Ctrl.FCWLocalTX);
|
||
// «Кончилась ПОСЫЛКА 200 мс» — вот она и есть звук в эфире. Ждём конца
|
||
// паузы и смотрим в середину посылки.
|
||
C.SendText('keyer:0,false,200;');
|
||
C.Pump(250);
|
||
Check('keyer: посылка замыкает ключ', Ctrl.FCWLocalTX);
|
||
Ctrl.CWXAbort;
|
||
C.Pump(150);
|
||
Check('keyer: обрыв гасит манипуляцию', not Ctrl.CWXBusy);
|
||
Ctrl.FDevConnected := WasConn;
|
||
Ctrl.FRunning := WasRun;
|
||
Ctrl.SyncCWKeyer; // разоружить обратно
|
||
end;
|
||
Ctrl.SetMode(MODE_USB);
|
||
|
||
// Ответ называет приёмник, чей слайс реально в эфире. Без радио источник
|
||
// передачи — главный VFO, то есть 0.
|
||
C.SendText('trx:0;');
|
||
S := C.WaitText('trx:', 1000);
|
||
Check('ответ trx называет передающий приёмник', Pos('trx:0,', S) > 0, S);
|
||
C.SendText('tune:0;');
|
||
S := C.WaitText('tune:', 1000);
|
||
Check('ответ tune называет передающий приёмник', Pos('tune:0,', S) > 0, S);
|
||
|
||
// TUN через TCI: включается и гасится, и снятие возвращает всё на место.
|
||
// Ждём временем, а не WaitText: на каждую смену состояния уходит ДВА
|
||
// сообщения (ответ автору + рассылка по rfTuning), и WaitText поймал бы
|
||
// хвост предыдущей команды, не дождавшись текущей.
|
||
C.SendText('tune:0,true;');
|
||
C.Pump(300);
|
||
Check('tune:0,true включил TUN', Ctrl.FTuning);
|
||
C.SendText('tune:0,false;');
|
||
C.Pump(300);
|
||
Check('tune:0,false выключил TUN', not Ctrl.FTuning);
|
||
Check('после TUN передача снята', not Ctrl.FTransmitting);
|
||
|
||
// ★Передача, начатая ОПЕРАТОРОМ: клиент не вправе ни увести из неё
|
||
// микрофон, ни подмешать в неё настроечный тон. SetMOX(True) поверх уже
|
||
// идущей передачи не выходит рано — он заново выбирает источник модуляции,
|
||
// и «trx:0,true,tci» посреди чужой передачи уводил её в ринг TCI, не
|
||
// становясь при этом хозяином эфира.
|
||
// Пауза перед командой обязательна: смену состояния оператором адаптер
|
||
// тоже захватывает (§3.5, 200 мс), и без неё команду отклонили бы по
|
||
// совсем другой причине — проверка прошла бы вхолостую.
|
||
Ctrl.SetMOX(True);
|
||
Check('оператор в эфире', Ctrl.FTransmitting);
|
||
Sleep(300);
|
||
C.SendText('trx:0,true,tci;');
|
||
C.Pump(300);
|
||
Check('trx поверх чужой передачи не уводит микрофон',
|
||
not Ctrl.TCIMicRequested);
|
||
Check('trx поверх чужой передачи её не трогает', Ctrl.FTransmitting);
|
||
Sleep(300);
|
||
C.SendText('tune:0,true;');
|
||
C.Pump(300);
|
||
Check('tune поверх чужой передачи не включает тон', not Ctrl.FTuning);
|
||
Ctrl.SetMOX(False);
|
||
Check('передачу оператора снимает оператор', not Ctrl.FTransmitting);
|
||
|
||
// Бинарный блок не нашего типа обязан быть проигнорирован, а соединение —
|
||
// остаться рабочим (клиент шлёт их пачками, рвать связь нельзя).
|
||
TCIFillHeader(H, tstIQ, 0, 48000, tsyFloat32, 4, 2);
|
||
Move(H, Blk[0], SizeOf(H));
|
||
C.SendBinary(Blk[0], SizeOf(H) + 32);
|
||
C.SendText('iq_samplerate:48000;');
|
||
S := C.WaitText('iq_samplerate', 1500);
|
||
Check('чужой бинарный блок не рвёт связь', Pos('48000', S) > 0, S);
|
||
|
||
// Маркеров TX_CHRONO без передачи быть не должно.
|
||
C.Pump(200);
|
||
GotBinary := False;
|
||
while C.NextFrame(Op, Pay) do
|
||
if Op = $02 then GotBinary := True;
|
||
Check('без передачи маркеров нет', not GotBinary);
|
||
|
||
// ★Уход клиента снимает только ЕГО передачу. Ставим в эфир оператора,
|
||
// клиент безуспешно просит TRX поверх — и уходит: передача обязана остаться.
|
||
Ctrl.SetMOX(True);
|
||
Sleep(300);
|
||
C.SendText('trx:0,true,tci;');
|
||
C.Pump(300);
|
||
|
||
// ★Обычный TCP-разрыв БЕЗ close-кадра: так уходит и упавший клиент, и
|
||
// выдернутый кабель. recv отдаёт 0, и это EOF, а не таймаут — errno при
|
||
// нём не трогается и вполне может нести EAGAIN от прошлого истёкшего
|
||
// TCI_POLL_MS. Пока сервер спрашивал errno, слот не освобождался вовсе:
|
||
// после нескольких аварийных отключений новые клиенты не подключались.
|
||
C.Close_;
|
||
Sleep(300);
|
||
Check('уход клиента не снял чужую передачу', Ctrl.FTransmitting);
|
||
Ctrl.SetMOX(False);
|
||
Check('после ухода клиента источник снят', not Ctrl.TCIMicRequested);
|
||
Check('TCP-разрыв без close-кадра освобождает слот', Ad.ClientCount = 0,
|
||
IntToStr(Ad.ClientCount));
|
||
|
||
// Второй путь — штатное прощание по RFC: тоже слот, но через close-кадр.
|
||
C2 := TRawClient.Create;
|
||
try
|
||
Check('второй клиент подключился', C2.Connect(PORT));
|
||
Check('второму пришёл ready', C2.WaitText('ready;', 2000) <> '');
|
||
C2.SendClose;
|
||
// Сервер обязан ответить своим close-кадром (§5.5.1) и уйти.
|
||
GotClose := False;
|
||
C2.Pump(300);
|
||
while C2.NextFrame(Op, Pay) do
|
||
if Op = $08 then GotClose := True;
|
||
Check('на close-кадр отвечает close-кадром', GotClose);
|
||
Sleep(200);
|
||
Check('close-кадр освобождает слот', Ad.ClientCount = 0,
|
||
IntToStr(Ad.ClientCount));
|
||
finally
|
||
C2.Close_;
|
||
C2.Free;
|
||
end;
|
||
finally
|
||
C.Free;
|
||
Ad.Free;
|
||
Ctrl.Free;
|
||
Host.Free;
|
||
end;
|
||
end;
|
||
|
||
{ ═══════════════════════════════════════════════════════════════════════════
|
||
E. Сквозной прогон: живой движок → тап → блоки клиенту
|
||
|
||
Единственная часть, где проверяется сам маршрут данных: синтетический
|
||
24-битный IQ подаётся в WDSP, а на другом конце WebSocket ожидаются блоки
|
||
RX-аудио и IQ с верными заголовками.
|
||
═══════════════════════════════════════════════════════════════════════════ }
|
||
|
||
procedure TestEndToEnd;
|
||
const
|
||
PORT = 40098;
|
||
RATE = 48000;
|
||
PAIRS = 238; // как в пакете DDC openHPSDR
|
||
var
|
||
Ctrl: TRadioController;
|
||
Ad: TTCIAdapter;
|
||
Host: THost;
|
||
Cfg: TTCISettings;
|
||
C: TRawClient;
|
||
Pkt: array[0..PAIRS * 6 - 1] of Byte;
|
||
i, k, n, Phase: Integer;
|
||
V: LongInt;
|
||
Op: Byte;
|
||
Pay: TBytes;
|
||
H: TTCIStreamHeader;
|
||
AudioBlocks, IQBlocks, BadHdr, BadRx: Integer;
|
||
SliceId: Integer;
|
||
SV: TSliceView;
|
||
S: string;
|
||
Was: Int64;
|
||
C2: TRawClient;
|
||
begin
|
||
WriteLn('E. Сквозной прогон через движок');
|
||
|
||
Host := THost.Create;
|
||
Ctrl := TRadioController.Create;
|
||
Ctrl.LocalAudioEnabled := False;
|
||
Ctrl.OnInvoke := Host.DoInvoke;
|
||
Ctrl.FSampleRate := RATE;
|
||
Ctrl.CreateEngines(RATE);
|
||
// Линейный выход навешивает хост (в GUI и демоне — тоже он).
|
||
Ctrl.FDSPEngine.OnAudio := Ctrl.OnAudioReady;
|
||
Ctrl.FDSPEngine.OnTXIQ := Host.OnTXIQ;
|
||
C := nil;
|
||
Ad := nil;
|
||
try
|
||
if not Ctrl.FDSPEngine.Open then
|
||
begin
|
||
WriteLn(' -- движок не поднялся (', Ctrl.FDSPEngine.LastError,
|
||
') — сквозной прогон пропущен');
|
||
Exit;
|
||
end;
|
||
Ad := TTCIAdapter.Create(Ctrl, nil);
|
||
Cfg.Enabled := True;
|
||
Cfg.Port := PORT;
|
||
Cfg.BindAddr := '127.0.0.1';
|
||
if not Ad.ApplySettings(Cfg) then
|
||
begin
|
||
Check('сквозной: сервер поднялся', False);
|
||
Exit;
|
||
end;
|
||
|
||
C := TRawClient.Create;
|
||
if not C.Connect(PORT) then
|
||
begin
|
||
Check('сквозной: клиент подключился', False);
|
||
Exit;
|
||
end;
|
||
C.WaitText('ready;', 2000);
|
||
|
||
C.SendText('audio_samplerate:12000;');
|
||
C.WaitText('audio_samplerate', 1000);
|
||
C.SendText('audio_stream_samples:256;');
|
||
C.SendText('audio_start:0;');
|
||
C.SendText('iq_samplerate:48000;');
|
||
C.SendText('iq_start:0;');
|
||
C.Pump(200);
|
||
|
||
// Полсекунды тона 1 кГц пакетами по 238 пар.
|
||
Phase := 0;
|
||
for k := 0 to (RATE div 2) div PAIRS do
|
||
begin
|
||
for i := 0 to PAIRS - 1 do
|
||
begin
|
||
V := Round(Cos(2 * Pi * 1000 * Phase / RATE) * 4000000);
|
||
Pkt[i * 6] := Byte(V shr 16);
|
||
Pkt[i * 6 + 1] := Byte(V shr 8);
|
||
Pkt[i * 6 + 2] := Byte(V);
|
||
V := Round(Sin(2 * Pi * 1000 * Phase / RATE) * 4000000);
|
||
Pkt[i * 6 + 3] := Byte(V shr 16);
|
||
Pkt[i * 6 + 4] := Byte(V shr 8);
|
||
Pkt[i * 6 + 5] := Byte(V);
|
||
Inc(Phase);
|
||
end;
|
||
Ctrl.FDSPEngine.PushDDCPacket(Pkt, 0, PAIRS);
|
||
// Реальный темп: 238 пар при 48 кГц — это ~5 мс.
|
||
if (k mod 10) = 0 then Sleep(5);
|
||
end;
|
||
C.Pump(500);
|
||
|
||
AudioBlocks := 0;
|
||
IQBlocks := 0;
|
||
BadHdr := 0;
|
||
while C.NextFrame(Op, Pay) do
|
||
begin
|
||
if Op <> $02 then Continue;
|
||
if Length(Pay) < SizeOf(H) then begin Inc(BadHdr); Continue; end;
|
||
Move(Pay[0], H, SizeOf(H));
|
||
if H.StreamType = LongWord(Ord(tstRXAudio)) then
|
||
begin
|
||
Inc(AudioBlocks);
|
||
// length — вещественные отсчёты всего блока: просили 256 сэмплов на
|
||
// канал, каналов 2, значит 512 отсчётов и столько же × 4 байта.
|
||
if (H.SampleRate <> 12000) or (H.Receiver <> 0) or
|
||
(H.DataLength <> 256 * Integer(H.Channels)) or
|
||
(Length(Pay) <> SizeOf(H) + Integer(H.DataLength) * 4) then
|
||
Inc(BadHdr);
|
||
end
|
||
else if H.StreamType = LongWord(Ord(tstIQ)) then
|
||
begin
|
||
Inc(IQBlocks);
|
||
// А в IQ — вещественные отсчёты (комплексных вдвое меньше, §3.4).
|
||
if (H.SampleRate <> 48000) or (H.Channels <> 2) or
|
||
(Length(Pay) <> SizeOf(H) + Integer(H.DataLength) * 4) then Inc(BadHdr);
|
||
end;
|
||
end;
|
||
Check('сквозной: блоки RX-аудио пришли', AudioBlocks > 0, IntToStr(AudioBlocks));
|
||
Check('сквозной: блоки IQ пришли', IQBlocks > 0, IntToStr(IQBlocks));
|
||
Check('сквозной: заголовки верны', BadHdr = 0, IntToStr(BadHdr));
|
||
|
||
// ── ★Запись линейного выхода и уход клиента ──────────────────────────
|
||
// Рекордер живёт на приёмнике, но платит за него тот, кто нажал START.
|
||
// Раньше уход клиента его не трогал вовсе: пары «подключился, START,
|
||
// отключился» набивали память до потолка, и вернуть её было некому до
|
||
// остановки сервера. Тут это видно насквозь — по общему бюджету.
|
||
Was := TCIRecBudgetUsed;
|
||
C2 := TRawClient.Create;
|
||
try
|
||
Check('запись: второй клиент подключился', C2.Connect(PORT));
|
||
C2.WaitText('ready;', 2000);
|
||
C2.SendText('line_out_recorder_start:0,300;');
|
||
C2.Pump(100);
|
||
for k := 0 to 40 do
|
||
begin
|
||
for i := 0 to PAIRS - 1 do
|
||
begin
|
||
V := Round(Cos(2 * Pi * 1000 * Phase / RATE) * 4000000);
|
||
Pkt[i * 6] := Byte(V shr 16);
|
||
Pkt[i * 6 + 1] := Byte(V shr 8);
|
||
Pkt[i * 6 + 2] := Byte(V);
|
||
V := Round(Sin(2 * Pi * 1000 * Phase / RATE) * 4000000);
|
||
Pkt[i * 6 + 3] := Byte(V shr 16);
|
||
Pkt[i * 6 + 4] := Byte(V shr 8);
|
||
Pkt[i * 6 + 5] := Byte(V);
|
||
Inc(Phase);
|
||
end;
|
||
Ctrl.FDSPEngine.PushDDCPacket(Pkt, 0, PAIRS);
|
||
Sleep(2);
|
||
end;
|
||
C2.Pump(200);
|
||
Check('запись: набирает память по мере звука', TCIRecBudgetUsed > Was,
|
||
IntToStr(TCIRecBudgetUsed - Was));
|
||
finally
|
||
C2.Close_; // уход без close-кадра, как при обрыве
|
||
C2.Free;
|
||
end;
|
||
Sleep(400);
|
||
Check('запись: уход клиента освобождает её память',
|
||
TCIRecBudgetUsed = Was, IntToStr(TCIRecBudgetUsed - Was));
|
||
|
||
// ── ★Слайс главного пана = приёмник 1 ────────────────────────────────
|
||
// Ровно случай Pluto: панов больше одного там не бывает, и «второй
|
||
// приёмник» существует только как слайс. Приёмник = слот слайса, поэтому
|
||
// первый созданный слайс (слот 0, буква B) обязан стать приёмником 1 —
|
||
// единственным номером сверх нулевого, который умеют клиенты вроде MSHV.
|
||
SliceId := Ctrl.AddSlice(Ctrl.FCenterFreq + 3000, MODE_USB, 200, 2800,
|
||
agcMedium, 0.5, -1, '', 0);
|
||
Check('слайс на главном пане создан', SliceId > 0, IntToStr(SliceId));
|
||
C.Pump(300);
|
||
while C.NextFrame(Op, Pay) do ; // выгребаем рассылку о появлении
|
||
|
||
// Инициализация MSHV — это ровно один запрос и ровно один ответ
|
||
// (network.cpp, Network::initAll: `vfo:<rx>,0;` пять раз, потом
|
||
// «Error To Initialize TCI Server»).
|
||
C.SendText('vfo:1,0;');
|
||
S := C.WaitText('vfo:1,0,', 1500);
|
||
Check('слайс отвечает на vfo:1,0 (инициализация MSHV)', S <> '', S);
|
||
Check('слайс отдаёт свою частоту',
|
||
Pos(IntToStr(Round(Ctrl.FCenterFreq + 3000)), S) > 0, S);
|
||
|
||
// Управление: то, чего от слайса и хотят.
|
||
C.SendText('vfo:1,0,' + IntToStr(Round(Ctrl.FCenterFreq + 5000)) + ';');
|
||
C.Pump(300);
|
||
Check('слайсом можно управлять по TCI',
|
||
Ctrl.GetSliceView(SliceId, SV) and
|
||
(Abs(SV.TargetHz - (Ctrl.FCenterFreq + 5000)) < 2),
|
||
FloatToStr(SV.TargetHz));
|
||
|
||
// Аудиопоток приёмника 1 — это звук слайса, и в заголовке стоит его номер
|
||
// (MSHV отбрасывает блоки с чужим receiver: network.cpp:231).
|
||
C.SendText('audio_start:1;');
|
||
C.Pump(100);
|
||
for k := 0 to 40 do
|
||
begin
|
||
Ctrl.FDSPEngine.PushDDCPacket(Pkt, 0, PAIRS);
|
||
Sleep(2);
|
||
end;
|
||
C.Pump(400);
|
||
n := 0;
|
||
while C.NextFrame(Op, Pay) do
|
||
if (Op = $02) and (Length(Pay) >= SizeOf(H)) then
|
||
begin
|
||
Move(Pay[0], H, SizeOf(H));
|
||
if (H.StreamType = LongWord(Ord(tstRXAudio))) and (H.Receiver = 1) then
|
||
Inc(n);
|
||
end;
|
||
Check('аудио слайса идёт под номером 1', n > 0, IntToStr(n));
|
||
|
||
// ── ★TX со слайса: маркер обязан нести НОМЕР ЭТОГО приёмника ─────────
|
||
// MSHV шлёт TX-аудио только в ответ на маркер TX_CHRONO и отбрасывает
|
||
// ЛЮБОЙ входящий блок с чужим receiver (network.cpp:231 — `if
|
||
// (pStream->receiver != tci_trx) return;`, ветка TxChrono — network.cpp:288
|
||
// и далее). С жёстким нулём в заголовке клиент, сидящий на втором слайсе
|
||
// (tci_trx = 1), поднимал эфир и молчал: маркеры до него не доходили, а
|
||
// без них он не отправляет ни одного блока. Ровно это и наблюдалось на
|
||
// живом железе с MSHV.
|
||
Ctrl.FWDSPReady := True;
|
||
Ctrl.SetSliceSlotAutoTx(Ctrl.SliceSlotOf(SliceId), True);
|
||
C.SendText('trx:1,true,tci;');
|
||
C.WaitText('trx:', 1500);
|
||
Check('TX слайса: модуляция из TCI взята', Ctrl.TCIMicActive);
|
||
C.Pump(400);
|
||
n := 0;
|
||
BadRx := 0;
|
||
while C.NextFrame(Op, Pay) do
|
||
if (Op = $02) and (Length(Pay) >= SizeOf(H)) then
|
||
begin
|
||
Move(Pay[0], H, SizeOf(H));
|
||
if H.StreamType = LongWord(Ord(tstTXChrono)) then
|
||
begin
|
||
Inc(n);
|
||
if H.Receiver <> 1 then Inc(BadRx);
|
||
end;
|
||
end;
|
||
Check('TX слайса: маркеры TX_CHRONO идут', n > 0, IntToStr(n));
|
||
Check('TX слайса: маркер назван номером приёмника (MSHV фильтрует)',
|
||
(n > 0) and (BadRx = 0), IntToStr(BadRx));
|
||
|
||
// ★Команда, которая ничего не сделала, не должна перебивать пару
|
||
// «клиент + приёмник»: передатчик занят своей же передачей, SyncSetTRX
|
||
// на неё не отвечает ничем — а если запомнить номер заранее, маркеры
|
||
// идущей передачи уедут под чужим номером, и клиент замолчит.
|
||
C.SendText('trx:0,true,tci;');
|
||
C.WaitText('trx:', 1000);
|
||
C.Pump(300);
|
||
n := 0;
|
||
BadRx := 0;
|
||
while C.NextFrame(Op, Pay) do
|
||
if (Op = $02) and (Length(Pay) >= SizeOf(H)) then
|
||
begin
|
||
Move(Pay[0], H, SizeOf(H));
|
||
if H.StreamType = LongWord(Ord(tstTXChrono)) then
|
||
begin
|
||
Inc(n);
|
||
if H.Receiver <> 1 then Inc(BadRx);
|
||
end;
|
||
end;
|
||
Check('TX слайса: пустая команда не сменила номер приёмника',
|
||
(n > 0) and (BadRx = 0), IntToStr(BadRx));
|
||
|
||
C.SendText('trx:1,false;');
|
||
C.WaitText('trx:', 1000);
|
||
Ctrl.SetSliceSlotAutoTx(Ctrl.SliceSlotOf(SliceId), False);
|
||
|
||
C.SendText('audio_stop:1;');
|
||
C.Pump(200);
|
||
|
||
// Удалили слайс — приёмник исчез, и врать про его частоту нельзя.
|
||
Ctrl.RemoveSlice(SliceId);
|
||
C.Pump(300);
|
||
while C.NextFrame(Op, Pay) do ;
|
||
C.SendText('vfo:1,0;');
|
||
S := C.WaitText('vfo:1,0,', 800);
|
||
Check('после удаления слайса приёмник 1 молчит', S = '', S);
|
||
|
||
// Остановка потока обязана прекратить подачу.
|
||
C.SendText('audio_stop:0;');
|
||
C.SendText('iq_stop:0;');
|
||
C.Pump(200);
|
||
while C.NextFrame(Op, Pay) do ; // выгребаем хвост
|
||
for k := 0 to 40 do
|
||
begin
|
||
Ctrl.FDSPEngine.PushDDCPacket(Pkt, 0, PAIRS);
|
||
Sleep(1);
|
||
end;
|
||
C.Pump(300);
|
||
n := 0;
|
||
while C.NextFrame(Op, Pay) do
|
||
if Op = $02 then Inc(n);
|
||
Check('сквозной: после STOP блоков нет', n = 0, IntToStr(n));
|
||
|
||
// ── TX: маркеры времени и приём аудио клиента ──
|
||
// Радио не подключено, поэтому передачу поднимаем «на движке»: нам важен
|
||
// маршрут TCI → ринг микрофона, а не сама излучающая часть.
|
||
Ctrl.FWDSPReady := True;
|
||
C.SendText('audio_samplerate:12000;');
|
||
C.WaitText('audio_samplerate', 1000);
|
||
C.SendText('audio_stream_samples:256;');
|
||
C.SendText('audio_start:0;');
|
||
C.SendText('trx:0,true,tci;');
|
||
C.WaitText('trx:', 1000);
|
||
Check('TX: модуляция из TCI взята', Ctrl.TCIMicActive);
|
||
|
||
C.Pump(400);
|
||
n := 0;
|
||
while C.NextFrame(Op, Pay) do
|
||
if (Op = $02) and (Length(Pay) >= SizeOf(H)) then
|
||
begin
|
||
Move(Pay[0], H, SizeOf(H));
|
||
if H.StreamType = LongWord(Ord(tstTXChrono)) then
|
||
begin
|
||
Inc(n);
|
||
if (H.SampleRate <> 12000) or
|
||
(H.DataLength <> 256 * Integer(H.Channels)) then
|
||
Inc(BadHdr);
|
||
end;
|
||
end;
|
||
Check('TX: маркеры TX_CHRONO идут', n > 0, IntToStr(n));
|
||
|
||
// Блок TX-аудио 12 кГц float32 моно: в ринг микрофона должно попасть
|
||
// вчетверо больше отсчётов (12 → 48 кГц).
|
||
TCIFillHeader(H, tstTXAudio, 0, 12000, tsyFloat32, 256, 1);
|
||
Move(H, Pkt[0], SizeOf(H));
|
||
for i := 0 to 255 do
|
||
PSingle(@Pkt[SizeOf(H) + i * 4])^ := Sin(2 * Pi * 700 * i / 12000) * 0.5;
|
||
C.SendBinary(Pkt[0], SizeOf(H) + 256 * 4);
|
||
// Наблюдаем не ринг (его вычерпывает TX-поток быстрее опроса), а выход
|
||
// тракта: блоки TX-IQ появляются только если аудио клиента дошло.
|
||
for i := 0 to 7 do C.SendBinary(Pkt[0], SizeOf(H) + 256 * 4);
|
||
Sleep(400);
|
||
Check('TX: аудио клиента прошло тракт', TXIQBlocks > 0, IntToStr(TXIQBlocks));
|
||
|
||
// Обрыв прямо во время клиентской TRX: здесь движок и FNetwork
|
||
// созданы, но радиобэкенд не подключён — RF-выхода нет.
|
||
Check('перед обрывом TRX активен', Ctrl.FTransmitting);
|
||
C.Close_;
|
||
Sleep(300);
|
||
Check('после ухода клиента источник снят', not Ctrl.TCIMicRequested);
|
||
Check('после ухода клиента MOX снят', not Ctrl.FTransmitting);
|
||
|
||
// ── TUN: хозяин эфира забывается и на выключении TUNE ──
|
||
// Клиент поднял TUN, оператор погасил его САМ (кнопкой, не командой TCI),
|
||
// а потом сам же встал на передачу. Уход клиента не имеет права снять эту
|
||
// чужую передачу: хозяина эфира обязано было забыть ещё выключение TUN.
|
||
// ★Задний фронт ловился только по rfTransmitting, а SetTune(False) шлёт
|
||
// его, пока FTuning ещё True, — владелец оставался протухшим навсегда.
|
||
C2 := TRawClient.Create;
|
||
try
|
||
Check('TUN: клиент подключился', C2.Connect(PORT));
|
||
C2.WaitText('ready;', 2000);
|
||
C2.SendText('tune:0,true;');
|
||
C2.WaitText('tune:', 1000);
|
||
Check('TUN: эфир поднят клиентом', Ctrl.FTuning and Ctrl.FTransmitting);
|
||
Ctrl.SetTune(False); // оператор гасит TUN сам
|
||
Ctrl.SetMOX(True); // и сам встаёт на передачу
|
||
Check('TUN: оператор в эфире', Ctrl.FTransmitting);
|
||
C2.Close_;
|
||
Sleep(300);
|
||
Check('TUN: уход клиента не снял чужую передачу', Ctrl.FTransmitting);
|
||
Ctrl.SetMOX(False);
|
||
finally
|
||
C2.Close_;
|
||
C2.Free;
|
||
end;
|
||
|
||
Ctrl.FWDSPReady := False;
|
||
finally
|
||
if C <> nil then begin C.Close_; C.Free; end;
|
||
Ad.Free;
|
||
Ctrl.Free;
|
||
Host.Free;
|
||
end;
|
||
end;
|
||
|
||
begin
|
||
Randomize;
|
||
Passed := 0;
|
||
Failed := 0;
|
||
WriteLn('=== Стенд TCI, этап 2 (бинарные потоки) ===');
|
||
TestProtocol;
|
||
TestResampling;
|
||
TestStreamOut;
|
||
TestRecorder;
|
||
TestKeyPlayer;
|
||
TestTextSender;
|
||
TestServer;
|
||
TestEndToEnd;
|
||
WriteLn;
|
||
WriteLn(Format('Итого: %d проверок, провалено %d', [Passed + Failed, Failed]));
|
||
if Failed > 0 then Halt(1);
|
||
end.
|