{ Copyright (C) 2026 - Uladzimir Karpenka, EW8BAK This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. } 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, PlatformUtils; 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 — вещественные отсчёты ВСЕГО блока, и у аудио тоже: клиенты // считают по нему число байт. Объявишь «на // канал» — у стерео разберётся половина блока, и звук пойдёт с дырами. 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 × размер // отсчёта. Так клиент определяет размер полезной нагрузки. (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); { ★То же, но с шагом сна в 1 мс. Обычный Pump спит по 10 мс, и для проверок ПЕЙСИНГА он не годится вовсе: квант запроса — 10.7 мс, то есть клиент отвечал бы раз в 10 мс и сам создавал бы те самые «длинные интервалы», которые тест ищет. } procedure PumpFine(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.PumpFine(Ms: Integer); var R: Integer; Deadline: QWord; begin Deadline := GetTickCount64 + QWord(Ms); repeat R := fpRecv(FSock, @FIn[FLen], SizeOf(FIn) - FLen, MSG_DONTWAIT); if R > 0 then Inc(FLen, R) else Sleep(1); until GetTickCount64 >= Deadline; 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); procedure OnTap(Kind: TRadioAudioKind; PanId, SliceId: Integer; const Left, Right: array of Single; Count: Integer); end; var TXIQBlocks: Integer = 0; DemodBlocks: Integer = 0; // блоки rakDemod со слайса WatchSlice WatchSlice: Integer = 0; procedure THost.DoInvoke(M: TThreadMethod); begin M(); end; procedure THost.OnTap(Kind: TRadioAudioKind; PanId, SliceId: Integer; const Left, Right: array of Single; Count: Integer); // Наблюдатель за выходом демодулятора слайса. Сам по себе считать слайс не // заставляет: тап — это слушатель, а не заказчик (см. TapWanted). begin if (Kind = rakDemod) and (SliceId = WatchSlice) and (Count > 0) then Inc(DemodBlocks); 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 с верными заголовками. ═══════════════════════════════════════════════════════════════════════════ } { ═══════════════════════════════════════════════════════════════════════════ F. Пейсинг TX: квант запроса, окно в полёте, потери ответов ═══════════════════════════════════════════════════════════════════════════ } { Обслуживает маркеры TX_CHRONO Ms миллисекунд, отвечая на каждый блоком нужного размера. Skip первых N маркеров остаются БЕЗ ответа — это и есть «замороженный кредит», ради которого всё затевалось: конвейер продолжает отдавать звук, но медленнее реального времени, и сторож по одному лишь молчанию клиента такого не видит. Возвращает число маркеров и раскладку интервалов между ними. } procedure ServeChrono(C: TRawClient; Ms, Skip: Integer; out Markers, Answered, Quantum, LongGaps, MaxGapMs: Integer; out MinReserve: Integer); var Deadline, Now_, Prev, Start: QWord; Delivered, Reserve: Int64; Op: Byte; Pay: TBytes; H, HA: TTCIStreamHeader; Frames, i, Gap: Integer; Blk: array[0..40000] of Byte; Skipped: Integer; begin Markers := 0; Answered := 0; Quantum := 0; LongGaps := 0; MaxGapMs := 0; Skipped := 0; Prev := 0; Delivered := 0; MinReserve := 0; Start := GetTickCount64; Deadline := Start + QWord(Ms); while GetTickCount64 < Deadline do begin C.PumpFine(1); while C.NextFrame(Op, Pay) do begin if (Op <> $02) or (Length(Pay) < SizeOf(H)) then Continue; Move(Pay[0], H, SizeOf(H)); if H.StreamType <> LongWord(Ord(tstTXChrono)) then Continue; Now_ := GetTickCount64; Inc(Markers); if H.Channels = 0 then H.Channels := 1; Frames := Integer(H.DataLength) div Integer(H.Channels); Quantum := Frames; if Prev > 0 then begin Gap := Integer(Now_ - Prev); if Gap > MaxGapMs then MaxGapMs := Gap; // Порог — полтора номинальных периода кванта (10.667 мс при 512/48к). if Gap > 16 then Inc(LongGaps); end; Prev := Now_; if Skipped < Skip then begin Inc(Skipped); Continue; // кредит завис навсегда end; TCIFillHeader(HA, tstTXAudio, H.Receiver, H.SampleRate, tsyFloat32, Frames, H.Channels); Move(HA, Blk[0], SizeOf(HA)); for i := 0 to Frames * Integer(H.Channels) - 1 do PSingle(@Blk[SizeOf(HA) + i * 4])^ := 0.1; C.SendBinary(Blk[0], SizeOf(HA) + Frames * Integer(H.Channels) * 4); Inc(Answered); // ★Мера годности — не ровность интервалов, а НАКОПЛЕННЫЙ РЕЗЕРВ: подушка // отправителя интегрирующая, и два подряд «почти в допуске» интервала // сушат очередь не хуже одного грубого. Пачка маркеров сама по себе // безвредна — она приносит звук ВПЕРЁД реального времени, и следующая за // ней пауза оплачена этим запасом. Считаем в кадрах 48 кГц от начала // фазы: сколько отдано минус сколько утекло по часам. Inc(Delivered, Frames); Reserve := Delivered - Int64(GetTickCount64 - Start) * Int64(H.SampleRate) div 1000; if Reserve < MinReserve then MinReserve := Reserve; end; end; end; procedure TestTxPacing; const PORT = 40099; RATE = 48000; TCI_TX_LEAD_MAX_MS_CHK = 120; // потолок аванса, копия TCI_TX_LEAD_MAX_MS RESTART_CYCLES = 6; // повторных передач в последней фазе var Ctrl: TRadioController; Ad: TTCIAdapter; Host: THost; Cfg: TTCISettings; C: TRawClient; Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve: Integer; N, MinStart, SumStart, StaleRuns, i, FillBefore: Integer; DbgOwed, DbgFlight: Double; DbgWin, DbgQ, DbgLead, SeedLead: Integer; begin WriteLn('F. Пейсинг TX: квант запроса и потери ответов'); Host := THost.Create; Ctrl := TRadioController.Create; Ctrl.LocalAudioEnabled := False; Ctrl.OnInvoke := Host.DoInvoke; Ctrl.FSampleRate := RATE; Ctrl.CreateEngines(RATE); Ctrl.FWDSPReady := True; // движок не открываем: тракт тут не проверяется C := nil; Ad := nil; try 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); // Клиент запросил 48 кГц, два канала и блок 2048. C.SendText('audio_samplerate:48000;'); C.SendText('audio_stream_channels:2;'); C.SendText('audio_stream_samples:2048;'); C.SendText('tx_stream_audio_buffering:50;'); // ★Без поднятого аудиопотока просьба «модулируй из TCI» отклоняется // (§4.2, HasAudioStream): модулировать было бы нечем. C.SendText('audio_start:0;'); C.Pump(200); C.SendText('trx:0,true,tci;'); C.WaitText('trx:', 1500); Check('пейсинг: модуляция из TCI взята', Ctrl.TCIMicActive); // ── Повторный MOX поверх идущей передачи ── // ★Прислать MOX=True второй раз вправе и CAT, и web, и TCI, а SetMOX этого // не отсекает. Перезапускать по нему TX-тракт нельзя: сброс индексов // mic-кольца гоняется с чтением из TX-потока, и в худшем случае поток // дописывает свой tail поверх обнулённого — кольцо выглядит почти полным // СТАРЫХ данных, которые уходят в эфир пачкой. for i := 1 to 3000 do Ctrl.FDSPEngine.PushTXMicSampleD(0.25); FillBefore := Ctrl.FDSPEngine.TXMicFill; Ctrl.SetMOX(True); Check('повтор MOX: передача не перезапускается', Ctrl.FDSPEngine.TXActive); Check('повтор MOX: mic-кольцо не обнуляется', Ctrl.FDSPEngine.TXMicFill >= FillBefore - 512, Format('было %d, стало %d', [FillBefore, Ctrl.FDSPEngine.TXMicFill])); // ── Здоровый клиент ── // Прогрев: пока шёл разбор команды и проверки выше, клиент не отвечал, и // окно в полёте успело набиться маркерами. Плюс за это время адаптер выдаёт // разовый аванс под зернистость клиента — он тоже приходит пачкой. Меряем // установившийся режим, а не этот стартовый ком, иначе в замер попадёт // чужой долг: аванс отдан ДО окна замера, а расходуется уже внутри него. ServeChrono(C, 1000, 0, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); ServeChrono(C, 900, 0, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); WriteLn(Format(' .. фаза 1: маркеров %d, квант %d ⇒ %d кадров/с, ' + 'просадка резерва %d кадров (%.1f мс), длинных интервалов %d, макс %d мс', [Markers, Quantum, Round(Answered * Quantum / 0.9), MinReserve, MinReserve / 48.0, LongGaps, MaxGapMs])); Check('пейсинг: маркеры идут', Markers > 20, IntToStr(Markers)); // ★Главное число всей правки. Просить блок клиента целиком (2048 отсчётов = // 42.7 мс) нельзя: подушка отправителя DUC — 10.42 мс, и на каждом запросе // длиннее её очередь пересыхает. Квант обязан быть одним блоком TXA. Check('пейсинг: квант = один блок TXA, а не блок клиента', Quantum = 512, IntToStr(Quantum)); // ★Зернистость: раньше маркеры выходили через 40 или 60 мс (тик 20 мс не // делится на 42.7), и каждый трёхтактный интервал давал осушение. // Порог: подушка отправителя DUC (2000 отсчётов @192 кГц = 500 кадров // @48 кГц) ПЛЮС аванс, который клиент попросил сам через // TX_STREAM_AUDIO_BUFFERING (здесь 50 мс = 2400 кадров). Считать от нуля // нельзя: этот аванс реально лежит в очереди и на то и дан. ★В эфире к нему // добавляется ещё и нулевой pre-roll под зернистость клиента, но стенд // работает без радио, и в нём этого слагаемого нет. // Систематическую просадку порог не пропустит: она накапливается линейно и // за 900 мс уходит далеко за любую константу. Check('пейсинг: резерв не проседает ниже подушки DUC плюс аванс клиента', MinReserve > -2900, Format('%d кадров (%.1f мс)', [MinReserve, MinReserve / 48.0])); // ── Посев аванса и его сползание ── // ★Посев нужен потому, что первая передача после подключения физически не // может знать зернистость клиента: аванс появляется только после первого // ответа, а осушение случается раньше. Но посев обязан уметь сползать — // иначе клиент с мелкой гранулой (как здесь: отвечает сразу) навсегда // получит чужие 50 мс задержки. Ad.TxDbgState(DbgOwed, DbgFlight, DbgWin, DbgQ, SeedLead); Check('пейсинг: аванс посеян до первого ответа', SeedLead >= 2000, IntToStr(SeedLead)); ServeChrono(C, 5200, 0, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); Ad.TxDbgState(DbgOwed, DbgFlight, DbgWin, DbgQ, DbgLead); WriteLn(Format(' .. аванс: посев %d кадров (%.1f мс) → %d (%.1f мс), ' + 'худшая пауза клиента %d мс', [SeedLead, SeedLead / 48.0, DbgLead, DbgLead / 48.0, MaxGapMs])); // ★Проверяем не «аванс уменьшился», а то, чем он обязан быть: запасом под // САМУЮ ХУДШУЮ наблюдённую паузу клиента. Оценка нарочно несимметрична // (вверх сразу, вниз по выдержке), поэтому редкий выброс её и держит — и // это правильно: запас на то и нужен, чтобы такой выброс пережить. Стенд // сам даёт выбросы под 60 мс (его клиент живёт в одном потоке с проверками), // так что «сползание» здесь не наблюдаемо в принципе — оно проверяется // конструкцией: путь снижения общий с путём роста, см. TCI_TX_LEAD_DOWN_MS. Check('пейсинг: аванс покрывает худшую паузу клиента', (DbgLead >= MaxGapMs * 48) and (DbgLead <= (TCI_TX_LEAD_MAX_MS_CHK * 48)), Format('%d кадров при худшей паузе %d мс', [DbgLead, MaxGapMs])); // ── Замороженные кредиты: два ответа не приходят никогда ── // Конвейер сужается, но продолжает работать — молчания клиента нет, и // поймать это можно только по одновременному насыщению долга и окна. ServeChrono(C, 1500, 2, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); Check('пейсинг: замороженные кредиты не остановили выдачу', Markers > 40, IntToStr(Markers)); Check('пейсинг: после прощения кредита выдача вернулась к темпу', MaxGapMs < 400, IntToStr(MaxGapMs)); // ── Полная защёлка: четыре ответа подряд пропали ── ServeChrono(C, 800, 4, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); Ad.TxDbgState(DbgOwed, DbgFlight, DbgWin, DbgQ, DbgLead); WriteLn(Format(' .. после потерь: долг %.0f, в полёте %.0f, окно %d кв., квант %d', [DbgOwed, DbgFlight, DbgWin, DbgQ])); // Потери позади. Даём сторожу время простить зависшие кредиты (по одному // за выдержку), и лишь потом меряем: вернулась ли выдача к реальному темпу. ServeChrono(C, 1500, 0, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); ServeChrono(C, 1000, 0, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); WriteLn(Format(' .. фаза 3: после четырёх потерь маркеров %d, ' + 'просадка резерва %d кадров (%.1f мс)', [Markers, MinReserve, MinReserve / 48.0])); // Четыре потерянных ответа — это 43 мс звука, которых уже не будет: долг // ограничен потолком, и «догонять» его пачкой мы намеренно не даём. // Требование здесь одно: полной защёлки быть не должно — маркеры обязаны // идти дальше, а не прекратиться до конца передачи. // ★ОТКРЫТО: возврат к полному темпу после нескольких подряд потерянных // ответов идёт медленно (прощение по одному кредиту за выдержку). В эфире // это редкость, но // строка ниже печатает просадку, чтобы регресс был виден. WriteLn(Format(' .. фаза 3: возврат к темпу пока неполный — %d маркеров ' + 'из ~94/с, просадка %d кадров', [Markers, MinReserve])); Check('пейсинг: защёлки нет, маркеры идут дальше', Markers > 40, IntToStr(Markers)); // ── Повторные передачи: бухгалтерия не переезжает в следующую ── // ★Регресс с железа. Штатный конец посылки (`trx:N,false`) // обнулял FTxClient, но НЕ FTxRunning, а сбрасывать // флаг умел только тик планировщика — и только пока видел ЖИВОГО FTxClient // с уже снятым TCIMicActive. Окно этой гонки — хвост SetMOX, пара // миллисекунд против шага тика в полкванта, так что промах выпадал через // раз. Промах означал, что СЛЕДУЮЩАЯ передача идёт мимо TxResetAccounting: // долг сразу у потолка, в полёте чужие кредиты прошлой посылки, выдача // маркеров заблокирована до срабатывания сторожа (выдержка до 250 мс). В // эфире это пересохшая очередь DUC с первых миллисекунд — голая несущая // гетеродина DUC рядом с сигналом. // Одиночный промах случаен, поэтому гоняем пачкой: до правки хоть один из // шести циклов ловится практически всегда. MinStart := MaxInt; SumStart := 0; StaleRuns := 0; for N := 1 to RESTART_CYCLES do begin C.SendText('trx:0,false;'); C.WaitText('trx:0,false', 1500); // ★Инвариант проверяем сразу по подтверждению команды, не дожидаясь тика: // флаг обязан опускаться под тем же FTxLock, что и FTxClient, то есть до // ответа клиенту. В этом и смысл правки. if Ad.TxDbgState(DbgOwed, DbgFlight, DbgWin, DbgQ, DbgLead) then Inc(StaleRuns); C.SendText('trx:0,true,tci;'); // Отвечаем СРАЗУ, не дожидаясь текстового подтверждения: WaitText спит по // 50 мс и выбрасывает бинарные кадры, а брошенный без ответа маркер — это // зависший кредит, который сам придушит выдачу и смажет измерение старта. ServeChrono(C, 200, 0, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); if Markers < MinStart then MinStart := Markers; Inc(SumStart, Markers); // Тело передачи: к её концу часть кредитов остаётся в полёте — именно их // и наследовала следующая посылка. ServeChrono(C, 150, 0, Markers, Answered, Quantum, LongGaps, MaxGapMs, MinReserve); end; WriteLn(Format(' .. повторы: %d передач подряд, маркеров в первые 200 мс ' + 'минимум %d, в среднем %d; флаг протухал %d раз', [RESTART_CYCLES, MinStart, SumStart div RESTART_CYCLES, StaleRuns])); Check('повторы: конец передачи опускает флаг идущей передачи', StaleRuns = 0, Format('%d из %d', [StaleRuns, RESTART_CYCLES])); // 200 мс / 10.67 мс = около 18 маркеров в здоровом старте; отравленный // старт не даёт ни одного, пока не сработает сторож. Check('повторы: маркеры идут с первых миллисекунд КАЖДОЙ передачи', MinStart >= 8, Format('минимум %d маркеров за 200 мс', [MinStart])); C.SendText('trx:0,false;'); C.Pump(300); finally if C <> nil then C.Free; if Ad <> nil then Ad.Free; Ctrl.Free; Host.Free; end; end; type // Читатель монотонных часов для проверки контракта «один источник на все // потоки»: каждый поток следит за СВОЕЙ последовательностью. TClockReader = class(TThread) private FBack: Integer; // сколько раз время пошло назад FZero: Integer; // сколько раз вернулся ноль (непроинициализированный источник) FReads: Integer; FMs: Integer; protected procedure Execute; override; public constructor Create(Ms: Integer); property Back: Integer read FBack; property Zero: Integer read FZero; property Reads: Integer read FReads; end; constructor TClockReader.Create(Ms: Integer); begin FMs := Ms; inherited Create(False); end; procedure TClockReader.Execute; var Deadline: QWord; Prev, Cur: Int64; begin Prev := MonotonicUs; Deadline := GetTickCount64 + QWord(FMs); while GetTickCount64 < Deadline do begin Cur := MonotonicUs; Inc(FReads); if Cur = 0 then Inc(FZero); if Cur < Prev then Inc(FBack); Prev := Cur; end; end; procedure TestMonotonicTicks; // Пересчёт тиков счётчика в микросекунды (PlatformUtils.TicksToUs). // ★Проверять это на Linux можно и нужно: сама функция платформы не знает, а // ветки, которые её зовут (QPC на Windows, mach на macOS), на стенде не // исполняются вовсе. Считаем моделью, по граничным значениям. // ★Чего стенд НЕ покрывает: сами ветки MonotonicUs под Windows и Darwin здесь // даже не компилируются (кросс-RTL не установлен). Их тела проверялись // отдельно — вырезанием из PlatformUtils.pas в пробную программу с подставным // API (QueryPerformance*/mach_*): синтаксис и арифметика сходятся, живой вызов // системного счётчика остаётся непроверенным до прогона на той платформе. const US_PER_S = 1000000; // Частоты, которые встречаются живьём: 10 МГц — типовая для Windows 8+ на // x86, 3.579545 МГц — старые чипсеты, 24 МГц — часть ARM, 1 МГц — «круглый» // случай. FREQS: array[0..3] of Int64 = (10000000, 3579545, 24000000, 1000000); var i, k: Integer; F, V, Prev, Cur, Old, Want, Days: Int64; Mono, Exact: Boolean; Readers: array of TClockReader; Total, Zeros, Backs: Integer; begin WriteLn('H. Монотонные часы: пересчёт тиков в микросекунды'); Check('часы: секунда счётчика = 1 000 000 мкс', TicksToUs(10000000, 10000000) = US_PER_S, IntToStr(TicksToUs(10000000, 10000000))); Check('часы: нулевая частота не роняет и не врёт временем', TicksToUs(123456789, 0) = 0); // ── Совпадение со старой формулой ТАМ, ГДЕ ТА ЕЩЁ РАБОТАЛА ── // Правка не имеет права менять показания на нормальных значениях: это тот же // пересчёт, только без промежуточного произведения. Exact := True; F := 10000000; V := 0; for k := 0 to 200 do begin Old := (V * US_PER_S) div F; // прежняя форма, ниже порога верна if TicksToUs(V, F) <> Old then Exact := False; V := V + 37 * 1000 * 1000 * 1000; // шагаем по ~час аптайма end; Check('часы: ниже порога переполнения показания те же, что и раньше', Exact); // ── Порог, на котором ломалась старая форма ── // 2^63 / 10^6 = 9223372036854.775 тиков; первый тик ЗА ним — 9223372036855, // при 10 МГц это 10.67 суток аптайма. V := 9223372036855; // первый тик за порогом Old := (V * US_PER_S) div F; // ★старая форма: уже переполнилась Cur := TicksToUs(V, F); Days := Cur div (Int64(86400) * US_PER_S); WriteLn(Format(' .. порог: тик %d при 10 МГц = %d суток; старая форма даёт ' + '%d мкс, новая %d мкс', [V, Days, Old, Cur])); Check('часы: старая форма на пороге уходила в минус (негативный контроль)', Old < 0, IntToStr(Old)); // При 10 МГц микросекунда — это десять тиков. Check('часы: новая форма на пороге считает верно', (Cur > 0) and (Abs(Cur - V div 10) <= 1), IntToStr(Cur)); // ── Монотонность через разрыв старой формулы ── // Ради этого всё и делалось: планировщик TX ведёт АБСОЛЮТНЫЕ дедлайны, и один // скачок времени назад останавливает выдачу маркеров до перезапуска. Mono := True; Prev := TicksToUs(V - 1000, F); for k := -999 to 1000 do begin Cur := TicksToUs(V + k, F); if Cur < Prev then Mono := False; Prev := Cur; end; Check('часы: через прежний разрыв время не идёт назад', Mono); // ── Сто суток аптайма на всех живых частотах ── Exact := True; Mono := True; for i := 0 to High(FREQS) do begin F := FREQS[i]; Days := 100; V := Days * 86400 * F; Want := Days * 86400 * US_PER_S; if Abs(TicksToUs(V, F) - Want) > 1 then Exact := False; // И заодно шаг: на любой частоте время обязано расти, а не прыгать. Prev := TicksToUs(V, F); for k := 1 to 500 do begin Cur := TicksToUs(V + Int64(k) * (F div 1000), F); // шаг 1 мс if (Cur < Prev) or (Cur - Prev > 1100) then Mono := False; Prev := Cur; end; end; Check('часы: 100 суток аптайма считаются точно на всех живых частотах', Exact); Check('часы: шаг 1 мс остаётся шагом 1 мс на всех живых частотах', Mono); // Год аптайма при 24 МГц — заведомо за пределами всего, что бывает. F := 24000000; V := Int64(365) * 86400 * F; Check('часы: год аптайма при 24 МГц не переполняется', Abs(TicksToUs(V, F) - Int64(365) * 86400 * US_PER_S) <= 1, IntToStr(TicksToUs(V, F))); // Живой источник платформы обязан идти вперёд и не стоять. Prev := MonotonicUs; Sleep(30); Cur := MonotonicUs; Check('часы: живой MonotonicUs идёт вперёд', (Cur > Prev) and (Cur - Prev >= 20000) and (Cur - Prev < 2000000), Format('%d мкс за 30 мс сна', [Cur - Prev])); // ── Контракт «один источник на все потоки» ── // ★Ленивая инициализация часов из рабочего потока публиковала бы состояние // обычной записью, и сосед на слабой модели памяти вправе увидеть её // частично: результат — единичный НОЛЬ, то есть прыжок времени на десятки // лет назад в бухгалтерии TX. Поэтому источник поднимается в initialization, // а состояние держится в ОДНОМ слове. Здесь проверяем сам контракт: ни нулей, // ни хода назад под нагрузкой из нескольких потоков. // (На Linux это ветка clock_gettime, состояния у неё нет вовсе — проверка // страхует от регресса, если ленивое состояние заведут и здесь.) SetLength(Readers, 4); for i := 0 to High(Readers) do Readers[i] := TClockReader.Create(150); Total := 0; Zeros := 0; Backs := 0; for i := 0 to High(Readers) do begin Readers[i].WaitFor; Inc(Total, Readers[i].Reads); Inc(Zeros, Readers[i].Zero); Inc(Backs, Readers[i].Back); Readers[i].Free; end; WriteLn(Format(' .. четыре потока: %d чтений часов, нулей %d, ходов назад %d', [Total, Zeros, Backs])); Check('часы: из нескольких потоков не возвращают ноль', Zeros = 0, IntToStr(Zeros)); Check('часы: из нескольких потоков не идут назад', Backs = 0, IntToStr(Backs)); end; 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 — // первым номером приёмника после нулевого. 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 ; // выгребаем рассылку о появлении // Инициализация совместимого клиента — это один запрос и один ответ. C.SendText('vfo:1,0;'); S := C.WaitText('vfo:1,0,', 1500); Check('слайс отвечает на vfo:1,0 при инициализации', 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 — это звук слайса, и в заголовке стоит его номер // Клиенты могут отбрасывать блоки с чужим receiver. 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)); // ── ★Мьют слайса и стоимость молчащих слайсов ──────────────────────── // RX_AUDIO снимается ДО громкости и мьюта, поэтому слайс, у которого // оператор убрал звук в комнате, обязан продолжать кормить клиента. Но // считается он ровно пока его кто-то качает: разрешение послайсовое // (TapWanted), а не «поднят TCI-сервер» — иначе шесть молчащих слайсов // жгли бы WDSP и без единого клиента. WatchSlice := SliceId; Ctrl.AddAudioTap(Host.OnTap); Ctrl.SetSliceMute(SliceId, True); C.Pump(100); while C.NextFrame(Op, Pay) do ; // выгребаем хвост DemodBlocks := 0; n := 0; for k := 0 to 40 do begin Ctrl.FDSPEngine.PushDDCPacket(Pkt, 0, PAIRS); Sleep(2); end; C.Pump(400); 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('мьют слайса не глушит RX_AUDIO по TCI', n > 0, IntToStr(n)); // Поток убрали — молчащий слайс не должен считаться вовсе. Тап при этом // остаётся навешенным: он наблюдатель и права требовать демодуляции не // имеет (раньше именно он её и включал — на все слайсы разом). C.SendText('audio_stop:1;'); C.Pump(200); DemodBlocks := 0; for k := 0 to 40 do begin Ctrl.FDSPEngine.PushDDCPacket(Pkt, 0, PAIRS); Sleep(2); end; Sleep(100); Check('без потока молчащий слайс не считается', DemodBlocks = 0, IntToStr(DemodBlocks)); // И обратно: попросили поток — слайс снова в работе. C.SendText('audio_start:1;'); C.Pump(200); DemodBlocks := 0; for k := 0 to 40 do begin Ctrl.FDSPEngine.PushDDCPacket(Pkt, 0, PAIRS); Sleep(2); end; Sleep(100); Check('поток вернулся — слайс снова считается', DemodBlocks > 0, IntToStr(DemodBlocks)); Ctrl.RemoveAudioTap(Host.OnTap); Ctrl.SetSliceMute(SliceId, False); C.Pump(200); while C.NextFrame(Op, Pay) do ; // ── ★TX со слайса: маркер обязан нести НОМЕР ЭТОГО приёмника ───────── // Совместимый клиент шлёт TX-аудио только в ответ на маркер TX_CHRONO и // может отбрасывать входящий блок с чужим receiver. С жёстким нулём в // заголовке клиент, сидящий на втором слайсе // (tci_trx = 1), поднимал эфир и молчал: маркеры до него не доходили, а // без них он не отправляет ни одного блока. 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 слайса: маркер назван номером приёмника', (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; TestTxPacing; // ★Часы идут ПОСЛЕ тяжёлых частей намеренно: они создают потоки, а брошенный // TX-поток движка когда-то лишал процесс этой возможности вовсе (лечение — в // WDSPEngine.Close, остановка потока вынесена до гейта FInitialized). Порядок // сохраняет ту проверку живой: упадёт снова — увидим здесь. TestMonotonicTicks; WriteLn; WriteLn(Format('Итого: %d проверок, провалено %d', [Passed + Failed, Failed])); if Failed > 0 then Halt(1); end.