feat(serial): своя обёртка последовательного порта — macOS собирается

RTL-модуль Serial собирается только для [android, linux, netbsd, openbsd,
win32, win64] — Darwin в списке нет (rtl-extra/fpmake.pp). Из-за этого под
macOS CAT по последовательному порту стоял заглушкой, а CWKeyer не собирался
вовсе.

★Скопировать чужой исходник было нельзя. Serial.SerSetParams кладёт B-константу
скорости прямо в c_cflag — идиома Linux, где это битовая маска. На BSD и macOS
B115200 это просто ЧИСЛО 115200, и в c_cflag прилетает $1C200: CLOCAL | HUPCL |
CCTS_OFLOW плюс мусор в поле CSIZE. Молча включается аппаратный CTS-flow, и
передача встаёт, если железка не держит CTS, — а ошибки никакой, порт
«открылся».

Новый SerialPort.pas:
* Unix — termios напрямую, Linux и macOS ОДНИМ путём (разница спрятана в
  константах RTL; Darwin даёт и termio, и все TIOCM_*). Скорость только через
  CFSetISpeed/CFSetOSpeed, c_cflag собирается с нуля чистой SerCFlags;
  CRTSCTS — исключительно по явной просьбе; сырой режим и VMIN/VTIME явные;
  open с O_NONBLOCK и снятием флага сразу после (часть USB-драйверов, как и
  tty-устройство на маке, висит в open до DCD).
* Windows — тонкая переадресация в RTL Serial: там он есть и в termios не лезет.
* Неуспех SerOpen на ВСЕХ платформах даёт SER_INVALID_HANDLE (RTL возвращал 0
  под Windows и −1 под Unix, из-за чего вызывающие держали свои развилки).
  Проверка — SerValid.

Точки вызова: CATSerial и CWKeyer переведены на обёртку, заглушка
CAT_SERIAL_STUB и платформенные {$IFDEF} вокруг хендлов убраны. Имена портов по
умолчанию и подсказка в настройках теперь платформенные (SerDefaultPortName /
SerPortNameHint): на маке порт зовётся /dev/cu.usbserial-XXXX, и '/dev/ttyS0'
там — заведомо неверная подсказка; осмысленного умолчания не существует,
поэтому пусто.

Новый стенд test/serial (36 проверок) — на псевдотерминале: открытие, termios
обратным чтением, ★«CRTSCTS сам не включился», ★«в c_cflag нет ничего, кроме
наших флагов», формат через чистую SerCFlags (обратным чтением его не
проверить: pty восьмибитно-чистый и молча меняет CS7 на CS8), обмен, срок
таймаута, CR не превращается в CR+LF, эха нет, и сквозной прогон CAT через
обёртку. Негативный контроль: с `or Cardinal(BitsPerSec)` в SerSetParams (та
самая идиома, что ломает RTL на BSD) проверка c_cflag падает — «1CAB0 против
8B0».

test/platform расширен: теперь сим-компилирует и SerialPort, для его
Windows-ветки добавлена заглушка модуля Serial с теми же сигнатурами.

Модемные линии (DTR/RTS/CTS/DSR/CD/RI) на pty не проверяются — ioctl TIOCM*
там не работает; это остаётся на живой порт.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01Bkwwyj7xVRrqnSVEseTRfV
This commit is contained in:
2026-08-24 22:09:44 +03:00
co-authored by Claude Opus 5
parent f2ecd63fe1
commit 05ba39fdad
11 changed files with 943 additions and 122 deletions
+15 -58
View File
@@ -8,28 +8,23 @@ unit CATSerial;
3. Передаёт команду в TCATEngine.Parse() 3. Передаёт команду в TCATEngine.Parse()
4. Отправляет ответ обратно в порт 4. Отправляет ответ обратно в порт
Платформы: Платформы (имя порта вводится вручную, подсказка — SerPortNameHint):
• Linux : /dev/ttyS0..3, /dev/ttyUSB0, etc. • Linux : /dev/ttyS0..3, /dev/ttyUSB0, /dev/ttyACM0
Windows: COM1..COM4 (имя порта вводится вручную) macOS : /dev/cu.usbserial-XXXX
• Windows: COM1..COM4
Зависимости: CATEngine, Serial (FPC fcl-serial RTL unit) Зависимости: CATEngine, SerialPort (наша обёртка; RTL-модуль Serial под macOS
не собирается вовсе — см. шапку SerialPort.pas).
} }
{$IFDEF FPC} {$IFDEF FPC}
{$MODE Delphi} {$MODE Delphi}
{$ENDIF} {$ENDIF}
{$IFDEF DARWIN}
{$DEFINE CAT_SERIAL_STUB}
{$ENDIF}
interface interface
uses uses
Classes, SysUtils, Classes, SysUtils,
{$IFNDEF CAT_SERIAL_STUB} SerialPort,
Serial, // FPC cross-platform serial unit
{$ENDIF}
{$IFDEF MSWINDOWS}Windows,{$ENDIF}
SyncObjs, SyncObjs,
CATEngine; CATEngine;
@@ -50,10 +45,6 @@ type
Andromeda: Boolean; // порт — передняя панель Andromeda/G2 (push ZZZI наружу) Andromeda: Boolean; // порт — передняя панель Andromeda/G2 (push ZZZI наружу)
end; end;
{$IFDEF CAT_SERIAL_STUB}
TSerialHandle = PtrInt;
{$ENDIF}
TCATSerialPort = class; TCATSerialPort = class;
{ TCATSerialThread — per-port listener thread } { TCATSerialThread — per-port listener thread }
@@ -150,9 +141,6 @@ var
ch: Byte; ch: Byte;
n: LongInt; n: LongInt;
begin begin
{$IFDEF CAT_SERIAL_STUB}
Exit;
{$ELSE}
FHandle := FOwner.Handle; FHandle := FOwner.Handle;
while not Terminated do begin while not Terminated do begin
n := SerReadTimeout(FHandle, ch, 50); n := SerReadTimeout(FHandle, ch, 50);
@@ -161,7 +149,6 @@ begin
if ch = Ord(';') then ProcessBuffer; if ch = Ord(';') then ProcessBuffer;
end; end;
end; end;
{$ENDIF}
end; end;
{ ── TCATSerialPort ────────────────────────────────────────────────────────── } { ── TCATSerialPort ────────────────────────────────────────────────────────── }
@@ -171,11 +158,7 @@ begin
inherited Create; inherited Create;
FEngine := AEngine; FEngine := AEngine;
FConfig := ACfg; FConfig := ACfg;
{$IFDEF MSWINDOWS} FHandle := SER_INVALID_HANDLE;
FHandle := INVALID_HANDLE_VALUE;
{$ELSE}
FHandle := -1;
{$ENDIF}
FLock := TCriticalSection.Create; FLock := TCriticalSection.Create;
FActive := False; FActive := False;
end; end;
@@ -188,52 +171,34 @@ begin
end; end;
function TCATSerialPort.OpenPort: Boolean; function TCATSerialPort.OpenPort: Boolean;
{$IFNDEF CAT_SERIAL_STUB}
var var
h: TSerialHandle; h: TSerialHandle;
par: TParityType; par: TParityType;
{$ENDIF}
begin begin
Result := False; Result := False;
{$IFDEF CAT_SERIAL_STUB}
FLastError := 'serial support not built on this platform';
{$ELSE}
h := SerOpen(FConfig.PortName); h := SerOpen(FConfig.PortName);
{$IFDEF MSWINDOWS} if not SerValid(h) then
if h = TSerialHandle(INVALID_HANDLE_VALUE) then
{$ELSE}
if h < 0 then
{$ENDIF}
begin begin
FLastError := 'не удалось открыть ' + FConfig.PortName; FLastError := 'не удалось открыть ' + FConfig.PortName;
Exit; Exit;
end; end;
case FConfig.Parity of case FConfig.Parity of
cspNone: par := Serial.NoneParity; cspOdd: par := OddParity;
cspOdd: par := Serial.OddParity; cspEven: par := EvenParity;
cspEven: par := Serial.EvenParity; else par := NoneParity;
else par := Serial.NoneParity;
end; end;
SerSetParams(h, FConfig.BaudRate, FConfig.DataBits, par, FConfig.StopBits, []); SerSetParams(h, FConfig.BaudRate, FConfig.DataBits, par, FConfig.StopBits, []);
FHandle := h; FHandle := h;
FLastError := ''; FLastError := '';
Result := True; Result := True;
{$ENDIF}
end; end;
procedure TCATSerialPort.ClosePort; procedure TCATSerialPort.ClosePort;
begin begin
{$IFNDEF CAT_SERIAL_STUB} if SerValid(FHandle) then SerClose(FHandle);
{$IFDEF MSWINDOWS} FHandle := SER_INVALID_HANDLE;
if FHandle <> INVALID_HANDLE_VALUE then SerClose(FHandle);
FHandle := INVALID_HANDLE_VALUE;
{$ELSE}
if FHandle >= 0 then SerClose(FHandle);
FHandle := -1;
{$ENDIF}
{$ENDIF}
end; end;
procedure TCATSerialPort.Start; procedure TCATSerialPort.Start;
@@ -262,14 +227,7 @@ end;
procedure TCATSerialPort.SendStr(const S: string); procedure TCATSerialPort.SendStr(const S: string);
var buf: AnsiString; var buf: AnsiString;
begin begin
{$IFDEF CAT_SERIAL_STUB} if not SerValid(FHandle) then Exit;
Exit;
{$ELSE}
{$IFDEF MSWINDOWS}
if FHandle = INVALID_HANDLE_VALUE then Exit;
{$ELSE}
if FHandle < 0 then Exit;
{$ENDIF}
FLock.Acquire; FLock.Acquire;
try try
buf := AnsiString(S); buf := AnsiString(S);
@@ -279,7 +237,6 @@ begin
// ignore write errors (port may have been closed) // ignore write errors (port may have been closed)
end; end;
FLock.Release; FLock.Release;
{$ENDIF}
end; end;
{ ── TCATSerialManager ─────────────────────────────────────────────────────── } { ── TCATSerialManager ─────────────────────────────────────────────────────── }
+8 -8
View File
@@ -39,7 +39,7 @@ unit CWKeyer;
interface interface
uses uses
Classes, SysUtils, SyncObjs, Math, Serial, CWMorse; Classes, SysUtils, SyncObjs, Math, SerialPort, CWMorse;
const const
CW_SIDETONE_RATE = 48000; // rate огибающей сайдтона (аудиотракт PC) CW_SIDETONE_RATE = 48000; // rate огибающей сайдтона (аудиотракт PC)
@@ -912,7 +912,7 @@ end;
constructor TCWKeyPort.Create; constructor TCWKeyPort.Create;
begin begin
FLock := TCriticalSection.Create; FLock := TCriticalSection.Create;
FHandle := 0; FHandle := SER_INVALID_HANDLE;
FreeOnTerminate := False; FreeOnTerminate := False;
inherited Create(False); inherited Create(False);
end; end;
@@ -972,13 +972,13 @@ end;
procedure TCWKeyPort.ClosePort; procedure TCWKeyPort.ClosePort;
begin begin
if FHandle > 0 then if SerValid(FHandle) then
begin begin
SerSetDTR(FHandle, False); SerSetDTR(FHandle, False);
SerSetRTS(FHandle, False); SerSetRTS(FHandle, False);
SerClose(FHandle); SerClose(FHandle);
end; end;
FHandle := 0; FHandle := SER_INVALID_HANDLE;
end; end;
function TCWKeyPort.OpenPort(const C: TCWKeyPortConfig): Boolean; function TCWKeyPort.OpenPort(const C: TCWKeyPortConfig): Boolean;
@@ -986,9 +986,9 @@ begin
Result := False; Result := False;
if C.Port = '' then Exit; if C.Port = '' then Exit;
FHandle := SerOpen(C.Port); FHandle := SerOpen(C.Port);
if FHandle <= 0 then if not SerValid(FHandle) then
begin begin
FHandle := 0; FHandle := SER_INVALID_HANDLE;
SetErr('cannot open ' + C.Port); SetErr('cannot open ' + C.Port);
Exit; Exit;
end; end;
@@ -1039,12 +1039,12 @@ begin
if not C.Enabled then if not C.Enabled then
begin begin
if FHandle > 0 then begin Release; ClosePort; end; if SerValid(FHandle) then begin Release; ClosePort; end;
Sleep(100); Sleep(100);
Continue; Continue;
end; end;
if FHandle <= 0 then if not SerValid(FHandle) then
begin begin
// Переоткрытие раз в 2 с: адаптер могли воткнуть уже после старта. // Переоткрытие раз в 2 с: адаптер могли воткнуть уже после старта.
if GetTickCount64 < Retry then begin Sleep(100); Continue; end; if GetTickCount64 < Retry then begin Sleep(100); Continue; end;
+2 -6
View File
@@ -40,7 +40,7 @@ uses
PanZoomBar, PanafallPanel, PanDisplayPopup, PureSignalPopup, FlatPopupMenu, PanZoomBar, PanafallPanel, PanDisplayPopup, PureSignalPopup, FlatPopupMenu,
WidebandView, WidebandView,
StatusBar, StatusBar,
PlatformUtils, PlatformUtils, SerialPort,
RadioModes, RadioModes,
WinFirewall, WinFirewall,
BoardUtils, WisdomBuilder, UISync, BoardUtils, WisdomBuilder, UISync,
@@ -1230,11 +1230,7 @@ begin
FCATLastGlobal.CATSerialBaud[i] := 9600; FCATLastGlobal.CATSerialBaud[i] := 9600;
FCATLastGlobal.CATSerialDataBits[i] := 8; FCATLastGlobal.CATSerialDataBits[i] := 8;
FCATLastGlobal.CATSerialStopBits[i] := 1; FCATLastGlobal.CATSerialStopBits[i] := 1;
{$IFDEF MSWINDOWS} FCATLastGlobal.CATSerialPort[i] := SerDefaultPortName(i);
FCATLastGlobal.CATSerialPort[i] := 'COM' + IntToStr(i + 1);
{$ELSE}
FCATLastGlobal.CATSerialPort[i] := '/dev/ttyS' + IntToStr(i);
{$ENDIF}
end; end;
FController.FSettings.LoadCATSettings(FCATLastGlobal); FController.FSettings.LoadCATSettings(FCATLastGlobal);
FLightTheme := FController.FSettings.LoadTheme; FLightTheme := FController.FSettings.LoadTheme;
+420
View File
@@ -0,0 +1,420 @@
unit SerialPort;
{
SerialPort.pas последовательный порт: один API на все три платформы.
ЗАЧЕМ СВОЙ. Модуль `Serial` из RTL собирается только для
[android, linux, netbsd, openbsd, win32, win64] Darwin в списке нет
(rtl-extra/fpmake.pp), поэтому под macOS проект не собирался вовсе, а CAT и
телеграфный ключ приходилось глушить заглушкой.
★И скопировать чужой исходник было нельзя. `Serial.SerSetParams` кладёт
B-константу скорости прямо в c_cflag идиома Linux, где это битовая маска.
На BSD и macOS `B115200` это просто ЧИСЛО 115200, и в c_cflag прилетает
$1C200, то есть CLOCAL | HUPCL | CCTS_OFLOW плюс мусор в поле CSIZE:
молча включается аппаратный CTS-flow, и передача встаёт, если железка не
держит CTS. Ошибки при этом никакой порт «открылся». Поэтому скорость
ставим единственным переносимым способом: CFSetISpeed/CFSetOSpeed, а c_cflag
собираем с нуля.
Устройство:
Unix (Linux и macOS одним путём) termios напрямую, без развилок по ОС:
разница между ними спрятана в константах RTL. Модемные линии ioctl
TIOCM*, они есть и там, и там.
Windows тонкая переадресация в RTL `Serial` (там он собирается и работает).
Имена и сигнатуры намеренно повторяют RTL-модуль: точки вызова (CATSerial,
CWKeyer) меняют только строку uses. ★Отличие ровно одно, и оно к лучшему:
неуспех SerOpen на ВСЕХ платформах даёт SER_INVALID_HANDLE (RTL возвращал 0
на Windows и 1 на Unix, из-за чего вызывающие держали свои развилки).
Проверять результат следует через SerValid.
}
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
type
{$IFDEF WINDOWS}
TSerialHandle = THandle;
{$ELSE}
TSerialHandle = LongInt;
{$ENDIF}
TParityType = (NoneParity, OddParity, EvenParity);
TSerialFlag = (RtsCtsFlowControl);
TSerialFlags = set of TSerialFlag;
const
// На Windows THandle(-1) — это и есть INVALID_HANDLE_VALUE.
SER_INVALID_HANDLE = TSerialHandle(-1);
{ Открыть порт. Имя как его пишет система:
Linux /dev/ttyS0, /dev/ttyUSB0, /dev/ttyACM0
macOS /dev/cu.usbserial-XXXX ★именно cu, а не tty: tty-устройство
блокируется на open до появления DCD
Windows COM1, \\.\COM12 для номеров больше девяти
Неуспех SER_INVALID_HANDLE. }
function SerOpen(const DeviceName: string): TSerialHandle;
procedure SerClose(Handle: TSerialHandle);
{ Годен ли хендл (одна проверка вместо платформенных развилок у вызывающих). }
function SerValid(Handle: TSerialHandle): Boolean;
procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
ByteSize: Integer; Parity: TParityType; StopBits: Integer;
Flags: TSerialFlags);
function SerRead(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt;
function SerWrite(Handle: TSerialHandle; const Buffer; Count: LongInt): LongInt;
{ Ждать ОДИН байт не дольше TimeOutMs. Результат — сколько прочитано (0 или 1). }
function SerReadTimeout(Handle: TSerialHandle; var Buffer;
TimeOutMs: LongInt): LongInt;
procedure SerSetDTR(Handle: TSerialHandle; State: Boolean);
procedure SerSetRTS(Handle: TSerialHandle; State: Boolean);
function SerGetCTS(Handle: TSerialHandle): Boolean;
function SerGetDSR(Handle: TSerialHandle): Boolean;
function SerGetCD(Handle: TSerialHandle): Boolean;
function SerGetRI(Handle: TSerialHandle): Boolean;
{$IFNDEF WINDOWS}
{ Флаги c_cflag для заданного формата. Вынесено в интерфейс РАДИ СТЕНДА:
псевдотерминал хранит не всё, что ему ставят (CS7 и чётность он молча
заменяет на CS8 без чётности pty восьмибитно-чистый), поэтому проверять
сборку флагов обратным чтением termios нельзя, а проверять надо. }
function SerCFlags(ByteSize: Integer; Parity: TParityType; StopBits: Integer;
Flags: TSerialFlags): Cardinal;
{$ENDIF}
{ Имя порта по умолчанию для настроек и подсказок в UI: у каждой системы своё,
и '/dev/ttyS0' на маке заведомо неверная подсказка. Index 0..N. }
function SerDefaultPortName(Index: Integer): string;
{ Пример имени для подсказки под полем ввода. }
function SerPortNameHint: string;
implementation
uses
SysUtils
{$IFDEF WINDOWS}
, Serial // RTL: на Windows он есть и работает
{$ELSE}
, BaseUnix, termio, Unix
{$ENDIF};
{$IFDEF WINDOWS}
// ── Windows: переадресация в RTL ───────────────────────────────────────────
// Своей реализации здесь не нужно: RTL-модуль под Windows собирается и в
// битовые поля termios не лезет — там свой DCB. Приводим только к нашим типам
// и к единому «неуспех = SER_INVALID_HANDLE».
function RtlParity(P: TParityType): Serial.TParityType;
begin
case P of
OddParity: Result := Serial.OddParity;
EvenParity: Result := Serial.EvenParity;
else
Result := Serial.NoneParity;
end;
end;
function RtlFlags(F: TSerialFlags): Serial.TSerialFlags;
begin
Result := [];
if RtsCtsFlowControl in F then Include(Result, Serial.RtsCtsFlowControl);
end;
function SerOpen(const DeviceName: string): TSerialHandle;
begin
Result := Serial.SerOpen(DeviceName);
// ★RTL под Windows отдаёт 0 при неудаче, под Unix −1. Приводим к одному.
if Result = 0 then Result := SER_INVALID_HANDLE;
end;
procedure SerClose(Handle: TSerialHandle);
begin
if SerValid(Handle) then Serial.SerClose(Handle);
end;
procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
ByteSize: Integer; Parity: TParityType; StopBits: Integer;
Flags: TSerialFlags);
begin
Serial.SerSetParams(Handle, BitsPerSec, ByteSize, RtlParity(Parity),
StopBits, RtlFlags(Flags));
end;
function SerRead(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt;
begin
Result := Serial.SerRead(Handle, Buffer, Count);
end;
function SerWrite(Handle: TSerialHandle; const Buffer; Count: LongInt): LongInt;
begin
Result := Serial.SerWrite(Handle, Buffer, Count);
end;
function SerReadTimeout(Handle: TSerialHandle; var Buffer;
TimeOutMs: LongInt): LongInt;
begin
Result := Serial.SerReadTimeout(Handle, Buffer, TimeOutMs);
end;
procedure SerSetDTR(Handle: TSerialHandle; State: Boolean);
begin
Serial.SerSetDTR(Handle, State);
end;
procedure SerSetRTS(Handle: TSerialHandle; State: Boolean);
begin
Serial.SerSetRTS(Handle, State);
end;
function SerGetCTS(Handle: TSerialHandle): Boolean;
begin
Result := Serial.SerGetCTS(Handle);
end;
function SerGetDSR(Handle: TSerialHandle): Boolean;
begin
Result := Serial.SerGetDSR(Handle);
end;
function SerGetCD(Handle: TSerialHandle): Boolean;
begin
Result := Serial.SerGetCD(Handle);
end;
function SerGetRI(Handle: TSerialHandle): Boolean;
begin
Result := Serial.SerGetRI(Handle);
end;
{$ELSE}
// ── Unix: termios напрямую, один путь для Linux и macOS ────────────────────
function BaudConst(BitsPerSec: LongInt): Cardinal;
// Скорость → константа termios. На Linux это битовая маска, на BSD/macOS —
// само число; обе прячутся за одним именем, поэтому развилки по ОС не нужно.
begin
case BitsPerSec of
50: Result := B50;
75: Result := B75;
110: Result := B110;
134: Result := B134;
150: Result := B150;
200: Result := B200;
300: Result := B300;
600: Result := B600;
1200: Result := B1200;
1800: Result := B1800;
2400: Result := B2400;
4800: Result := B4800;
9600: Result := B9600;
19200: Result := B19200;
38400: Result := B38400;
57600: Result := B57600;
115200: Result := B115200;
230400: Result := B230400;
else
Result := B9600;
end;
end;
function SerCFlags(ByteSize: Integer; Parity: TParityType; StopBits: Integer;
Flags: TSerialFlags): Cardinal;
// ★Только флаги — никаких скоростей (см. шапку модуля). CLOCAL = «модемных
// линий не ждём», без него open и read на кабеле без DCD ведут себя по-разному
// на разных системах.
begin
Result := CREAD or CLOCAL;
case ByteSize of
5: Result := Result or CS5;
6: Result := Result or CS6;
7: Result := Result or CS7;
else
Result := Result or CS8;
end;
case Parity of
OddParity: Result := Result or PARENB or PARODD;
EvenParity: Result := Result or PARENB;
end;
if StopBits = 2 then Result := Result or CSTOPB;
// Аппаратный поток — ТОЛЬКО по явной просьбе. Случайно включённый CRTSCTS
// вешает передачу намертво на кабеле без CTS.
if RtsCtsFlowControl in Flags then Result := Result or CRTSCTS;
end;
function SerOpen(const DeviceName: string): TSerialHandle;
var
Fl: LongInt;
begin
// ★O_NONBLOCK на открытии обязателен: часть USB-драйверов (и любое tty-, а не
// cu-устройство на macOS) висит в open до поднятия DCD. Сразу после открытия
// флаг снимаем — дальше нам нужны обычные блокирующие чтение и запись, а
// ожидание делает fpSelect в SerReadTimeout.
Result := fpOpen(DeviceName, O_RDWR or O_NOCTTY or O_NONBLOCK);
if Result < 0 then Exit(SER_INVALID_HANDLE);
Fl := fpFcntl(Result, F_GetFl, 0);
if Fl >= 0 then fpFcntl(Result, F_SetFl, Fl and (not O_NONBLOCK));
end;
procedure SerClose(Handle: TSerialHandle);
begin
if SerValid(Handle) then fpClose(Handle);
end;
procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
ByteSize: Integer; Parity: TParityType; StopBits: Integer;
Flags: TSerialFlags);
var
Tios: termios;
Speed: Cardinal;
begin
if not SerValid(Handle) then Exit;
FillChar(Tios, SizeOf(Tios), 0);
Tios.c_cflag := SerCFlags(ByteSize, Parity, StopBits, Flags);
// Сырой режим: ни канонической обработки строк, ни эха, ни трансляции
// символов на входе и выходе. CAT — двоичный поток с ';' в роли конца
// команды, любая «помощь» терминала его портит.
Tios.c_iflag := 0;
Tios.c_oflag := 0;
Tios.c_lflag := 0;
Tios.c_cc[VMIN] := 0; // read возвращает то, что есть, и не ждёт
Tios.c_cc[VTIME] := 0;
Speed := BaudConst(BitsPerSec);
CFSetISpeed(Tios, Speed);
CFSetOSpeed(Tios, Speed);
TCFlush(Handle, TCIOFLUSH);
TCSetAttr(Handle, TCSANOW, Tios);
end;
function SerRead(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt;
begin
if not SerValid(Handle) then Exit(0);
Result := fpRead(Handle, Buffer, Count);
if Result < 0 then Result := 0;
end;
function SerWrite(Handle: TSerialHandle; const Buffer; Count: LongInt): LongInt;
begin
if not SerValid(Handle) then Exit(0);
Result := fpWrite(Handle, Buffer, Count);
if Result < 0 then Result := 0;
end;
function SerReadTimeout(Handle: TSerialHandle; var Buffer;
TimeOutMs: LongInt): LongInt;
var
FDS: TFDSet;
TV: TimeVal;
N: LongInt;
begin
Result := 0;
if not SerValid(Handle) then Exit;
fpFD_Zero(FDS);
fpFD_Set(Handle, FDS);
TV.tv_sec := TimeOutMs div 1000;
TV.tv_usec := (TimeOutMs mod 1000) * 1000;
N := fpSelect(Handle + 1, @FDS, nil, nil, @TV);
if N <= 0 then Exit; // таймаут или ошибка — байта нет
Result := fpRead(Handle, Buffer, 1);
if Result < 0 then Result := 0;
end;
procedure SetModemBit(Handle: TSerialHandle; Bit: Cardinal; State: Boolean);
var
Bits: Cardinal;
begin
if not SerValid(Handle) then Exit;
Bits := Bit;
if State then
fpIOCtl(Handle, TIOCMBIS, @Bits)
else
fpIOCtl(Handle, TIOCMBIC, @Bits);
end;
function ModemBitSet(Handle: TSerialHandle; Bit: Cardinal): Boolean;
var
Bits: Cardinal;
begin
Result := False;
if not SerValid(Handle) then Exit;
Bits := 0;
if fpIOCtl(Handle, TIOCMGET, @Bits) < 0 then Exit;
Result := (Bits and Bit) <> 0;
end;
procedure SerSetDTR(Handle: TSerialHandle; State: Boolean);
begin
SetModemBit(Handle, TIOCM_DTR, State);
end;
procedure SerSetRTS(Handle: TSerialHandle; State: Boolean);
begin
SetModemBit(Handle, TIOCM_RTS, State);
end;
function SerGetCTS(Handle: TSerialHandle): Boolean;
begin
Result := ModemBitSet(Handle, TIOCM_CTS);
end;
function SerGetDSR(Handle: TSerialHandle): Boolean;
begin
Result := ModemBitSet(Handle, TIOCM_DSR);
end;
function SerGetCD(Handle: TSerialHandle): Boolean;
begin
Result := ModemBitSet(Handle, TIOCM_CAR);
end;
function SerGetRI(Handle: TSerialHandle): Boolean;
begin
Result := ModemBitSet(Handle, TIOCM_RNG);
end;
{$ENDIF}
// ── Общее для всех платформ ────────────────────────────────────────────────
function SerValid(Handle: TSerialHandle): Boolean;
begin
// Ноль сюда попадает от RTL под Windows (там это признак неудачи) и не может
// быть настоящим портом на Unix: дескриптор 0 занят стандартным вводом.
Result := (Handle <> SER_INVALID_HANDLE) and (Handle <> 0);
end;
function SerDefaultPortName(Index: Integer): string;
begin
{$IF DEFINED(WINDOWS)}
Result := 'COM' + IntToStr(Index + 1);
{$ELSEIF DEFINED(DARWIN)}
// ★На маке имя порта зависит от переходника (/dev/cu.usbserial-A1B2C3), так
// что осмысленного умолчания не существует — пустая строка честнее наугад
// придуманной. Формат подсказывает SerPortNameHint в окне настроек.
Result := '';
{$ELSE}
Result := '/dev/ttyS' + IntToStr(Index);
{$ENDIF}
end;
function SerPortNameHint: string;
begin
{$IF DEFINED(WINDOWS)}
Result := 'COM3, \\.\COM12';
{$ELSEIF DEFINED(DARWIN)}
Result := '/dev/cu.usbserial-XXXX';
{$ELSE}
Result := '/dev/ttyUSB0, /dev/ttyS0';
{$ENDIF}
end;
end.
+4 -16
View File
@@ -7,7 +7,7 @@ unit Settings;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses SysUtils, Classes, Math, fpJSON, jsonparser, jsonscanner, PlatformUtils, uses SysUtils, Classes, Math, fpJSON, jsonparser, jsonscanner, PlatformUtils,
RadioModes; SerialPort, RadioModes;
const const
SETTINGS_FILE = 'hpsdr_settings.json'; SETTINGS_FILE = 'hpsdr_settings.json';
@@ -1048,11 +1048,7 @@ begin
// CAT defaults // CAT defaults
for i := 0 to 3 do begin for i := 0 to 3 do begin
G.CATSerialEnabled[i] := False; G.CATSerialEnabled[i] := False;
{$IFDEF MSWINDOWS} G.CATSerialPort[i] := SerDefaultPortName(i);
G.CATSerialPort[i] := 'COM' + IntToStr(i+1);
{$ELSE}
G.CATSerialPort[i] := '/dev/ttyS' + IntToStr(i);
{$ENDIF}
G.CATSerialBaud[i] := 9600; G.CATSerialBaud[i] := 9600;
G.CATSerialDataBits[i] := 8; G.CATSerialDataBits[i] := 8;
G.CATSerialStopBits[i] := 1; G.CATSerialStopBits[i] := 1;
@@ -1314,11 +1310,7 @@ begin
// CAT serial settings // CAT serial settings
for i := 0 to 3 do begin for i := 0 to 3 do begin
G.CATSerialEnabled[i] := JB(GObj,'cat_serial_en_'+IntToStr(i), False); G.CATSerialEnabled[i] := JB(GObj,'cat_serial_en_'+IntToStr(i), False);
{$IFDEF MSWINDOWS} G.CATSerialPort[i] := JS(GObj,'cat_serial_port_'+IntToStr(i), SerDefaultPortName(i));
G.CATSerialPort[i] := JS(GObj,'cat_serial_port_'+IntToStr(i), 'COM'+IntToStr(i+1));
{$ELSE}
G.CATSerialPort[i] := JS(GObj,'cat_serial_port_'+IntToStr(i), '/dev/ttyS'+IntToStr(i));
{$ENDIF}
G.CATSerialBaud[i] := JI(GObj,'cat_serial_baud_'+IntToStr(i), 9600); G.CATSerialBaud[i] := JI(GObj,'cat_serial_baud_'+IntToStr(i), 9600);
G.CATSerialDataBits[i] := JI(GObj,'cat_serial_dbits_'+IntToStr(i), 8); G.CATSerialDataBits[i] := JI(GObj,'cat_serial_dbits_'+IntToStr(i), 8);
G.CATSerialStopBits[i] := JI(GObj,'cat_serial_sbits_'+IntToStr(i), 1); G.CATSerialStopBits[i] := JI(GObj,'cat_serial_sbits_'+IntToStr(i), 1);
@@ -1658,11 +1650,7 @@ begin
for i := 0 to 3 do for i := 0 to 3 do
begin begin
G.CATSerialEnabled[i] := JB(O, 'ser_en_' +IntToStr(i), False); G.CATSerialEnabled[i] := JB(O, 'ser_en_' +IntToStr(i), False);
{$IFDEF MSWINDOWS} G.CATSerialPort[i] := JS(O, 'ser_port_' +IntToStr(i), SerDefaultPortName(i));
G.CATSerialPort[i] := JS(O, 'ser_port_' +IntToStr(i), 'COM'+IntToStr(i+1));
{$ELSE}
G.CATSerialPort[i] := JS(O, 'ser_port_' +IntToStr(i), '/dev/ttyS'+IntToStr(i));
{$ENDIF}
G.CATSerialBaud[i] := JI(O, 'ser_baud_' +IntToStr(i), 9600); G.CATSerialBaud[i] := JI(O, 'ser_baud_' +IntToStr(i), 9600);
G.CATSerialDataBits[i] := JI(O, 'ser_dbits_' +IntToStr(i), 8); G.CATSerialDataBits[i] := JI(O, 'ser_dbits_' +IntToStr(i), 8);
G.CATSerialStopBits[i] := JI(O, 'ser_sbits_' +IntToStr(i), 1); G.CATSerialStopBits[i] := JI(O, 'ser_sbits_' +IntToStr(i), 1);
+3 -7
View File
@@ -30,7 +30,7 @@ uses
FlatButton, FlatCheckBox, FlatComboBox, FlatEdit, FlatSpinEdit, FlatFloatSpinEdit, FlatButton, FlatCheckBox, FlatComboBox, FlatEdit, FlatSpinEdit, FlatFloatSpinEdit,
FlatRadioButton, FlatMemo, FlatRadioButton, FlatMemo,
EqualizerControl, OverlayScrollBar, AudioOutput, AudioInput, AppTheme, Settings, EqualizerControl, OverlayScrollBar, AudioOutput, AudioInput, AppTheme, Settings,
BoardUtils, DpiUtils; BoardUtils, DpiUtils, SerialPort;
const const
// Подвкладки страницы Transmit: Profile / EQ / Hardware / Display. // Подвкладки страницы Transmit: Profile / EQ / Hardware / Display.
@@ -2162,7 +2162,7 @@ begin
FEdCWKeyPort.Font.Color := CLR_INPUT_TEXT; FEdCWKeyPort.Font.Color := CLR_INPUT_TEXT;
FEdCWKeyPort.Font.Size := 9; FEdCWKeyPort.Font.Size := 9;
FEdCWKeyPort.OnExit := OnCWAnyChange; FEdCWKeyPort.OnExit := OnCWAnyChange;
MakeLbl(Grp, '/dev/ttyUSB0, COM3', PAD + 492, R1 + 7 * STEP + 5, 200); MakeLbl(Grp, SerPortNameHint, PAD + 492, R1 + 7 * STEP + 5, 200);
MakeLbl(Grp, 'Dot line', PAD, R1 + 8 * STEP + 5, 70); MakeLbl(Grp, 'Dot line', PAD, R1 + 8 * STEP + 5, 70);
FCmbCWDotLine := MkCmbCW(Grp, PAD + 74, R1 + 8 * STEP, 90); FCmbCWDotLine := MkCmbCW(Grp, PAD + 74, R1 + 8 * STEP, 90);
@@ -4637,11 +4637,7 @@ begin
Ed.Font.Size := 9; Ed.Font.Size := 9;
Ed.Tag := i; Ed.Tag := i;
Ed.OnChange := OnCATSerialChange; Ed.OnChange := OnCATSerialChange;
{$IFDEF MSWINDOWS} Ed.Text := SerDefaultPortName(i);
Ed.Text := 'COM' + IntToStr(i + 1);
{$ELSE}
Ed.Text := '/dev/ttyS' + IntToStr(i);
{$ENDIF}
FCATSerialPort[i] := Ed; FCATSerialPort[i] := Ed;
MakeLbl(Grp, 'Baud rate:', PAD, R1 + 2 * STEP + 6, LW); MakeLbl(Grp, 'Baud rate:', PAD, R1 + 2 * STEP + 6, LW);
+50 -27
View File
@@ -1,44 +1,67 @@
#!/bin/sh #!/bin/sh
# Проверка ветвей PlatformUtils под Windows и macOS БЕЗ этих платформ. # Проверка платформенных ветвей БЕЗ самих платформ (Windows и macOS).
# #
# Зачем. Кросс-RTL обычно не установлен, поэтому ветки {$IFDEF WINDOWS} и # Зачем. Кросс-RTL обычно не установлен, поэтому ветки {$IFDEF WINDOWS} и
# {$IFDEF DARWIN} на Linux не компилируются ВООБЩЕ — ошибка в них всплывает # {$IFDEF DARWIN} на Linux не компилируются ВООБЩЕ — ошибка в них всплывает
# только на сборочной машине, через полчаса после коммита. Так и вышло: unit # только на сборочной машине, через полчаса после коммита. Так и вышло: модуль
# Windows, добавленный ради QueryPerformanceCounter, перекрыл однопараметрический # Windows, добавленный ради QueryPerformanceCounter, перекрыл однопараметрический
# SysUtils.GetEnvironmentVariable, и win64-сборка легла на трёх вызовах. # SysUtils.GetEnvironmentVariable, и win64-сборка легла на трёх вызовах.
# #
# Как. Копию PlatformUtils.pas переписываем так, чтобы платформенные условия # Как. Копии файлов переписываются так, чтобы платформенные условия читались как
# читались как наши собственные (-dSIMWIN / -dSIMMAC), и компилируем БЕЗ # наши собственные (-dSIMWIN / -dSIMMAC), и компилируются БЕЗ ЛИНКОВКИ (-Cn):
# ЛИНКОВКИ (-Cn): системных функций на Linux нет, но синтаксис, типы и — главное — # системных функций на Linux нет, но синтаксис, типы и — главное — разрешение
# разрешение имён проверяются по-настоящему. Для Windows подкладывается # имён проверяются по-настоящему. Для Windows подкладываются заглушки модулей
# заглушка unit Windows с теми же перекрывающими объявлениями (win_stub/). # Windows и Serial (win_stub/) с теми же объявлениями, что у настоящих.
# #
# Чего проверка НЕ делает: живых вызовов системных счётчиков. Их правильность # Чего проверка НЕ делает: живых вызовов системных функций. Их правильность
# доказывает только прогон на самой платформе. # доказывает только прогон на самой платформе.
set -e set -e
cd "$(dirname "$0")" cd "$(dirname "$0")"
SRC=../../PlatformUtils.pas HERE=$(pwd)
ROOT=../..
FILES="PlatformUtils.pas SerialPort.pas"
WORK=$(mktemp -d) WORK=$(mktemp -d)
trap 'rm -rf "$WORK"' EXIT trap 'rm -rf "$WORK"' EXIT
FAILED=0
COUNT=0
# ── Windows ── sim_build() { # $1 = win|mac
mkdir -p "$WORK/win" MODE=$1
cp win_stub/Windows.pas "$WORK/win/" DIR="$WORK/$MODE"
sed -e 's/{\$IFDEF WINDOWS}/{$IFDEF SIMWIN}/g' \ mkdir -p "$DIR"
-e 's/{\$IFNDEF WINDOWS}/{$IFNDEF SIMWIN}/g' "$SRC" > "$WORK/win/PlatformUtils.pas" if [ "$MODE" = win ]; then
( cd "$WORK/win" && fpc -B -Mobjfpc -dHEADLESS -dSIMWIN -Fu. -FU. -Cn PlatformUtils.pas >"$WORK/win.log" 2>&1 ) \ cp win_stub/*.pas "$DIR/"
|| { echo "WINDOWS-ветка НЕ компилируется:"; cat "$WORK/win.log"; exit 1; } DEF=-dSIMWIN
echo " ok PlatformUtils: ветка WINDOWS компилируется (заглушка unit Windows перекрывает SysUtils, как настоящий)" else
DEF=-dSIMMAC
fi
for F in $FILES; do
if [ "$MODE" = win ]; then
sed -e 's/{\$IFDEF WINDOWS}/{$IFDEF SIMWIN}/g' \
-e 's/{\$IFNDEF WINDOWS}/{$IFNDEF SIMWIN}/g' \
-e 's/{\$IF DEFINED(WINDOWS)}/{$IF DEFINED(SIMWIN)}/g' \
"$ROOT/$F" > "$DIR/$F"
else
sed -e 's/{\$IFDEF LINUX}/{$IFDEF SIMLINUX}/g' \
-e 's/{\$IFDEF DARWIN}/{$IFDEF SIMMAC}/g' \
-e 's/{\$ELSEIF DEFINED(DARWIN)}/{$ELSEIF DEFINED(SIMMAC)}/g' \
-e 's/{\$IF DEFINED(DARWIN) AND NOT DEFINED(HEADLESS)}/{$IF DEFINED(SIMMAC) AND NOT DEFINED(HEADLESS)}/g' \
"$ROOT/$F" > "$DIR/$F"
fi
COUNT=$((COUNT + 1))
if ( cd "$DIR" && fpc -B -Mobjfpc -dHEADLESS $DEF -Fu. -FU. -Cn "$F" >"$DIR/$F.log" 2>&1 ); then
echo " ok $F: ветка $MODE компилируется"
else
echo " FAIL $F: ветка $MODE НЕ компилируется"
cat "$DIR/$F.log"
FAILED=$((FAILED + 1))
fi
done
}
# ── macOS ── sim_build win
mkdir -p "$WORK/mac" sim_build mac
sed -e 's/{\$IFDEF LINUX}/{$IFDEF SIMLINUX}/g' \
-e 's/{\$IFDEF DARWIN}/{$IFDEF SIMMAC}/g' \
-e 's/{\$IF DEFINED(DARWIN) AND NOT DEFINED(HEADLESS)}/{$IF DEFINED(SIMMAC) AND NOT DEFINED(HEADLESS)}/g' \
"$SRC" > "$WORK/mac/PlatformUtils.pas"
( cd "$WORK/mac" && fpc -B -Mobjfpc -dHEADLESS -dSIMMAC -Fu. -FU. -Cn PlatformUtils.pas >"$WORK/mac.log" 2>&1 ) \
|| { echo "DARWIN-ветка НЕ компилируется:"; cat "$WORK/mac.log"; exit 1; }
echo " ok PlatformUtils: ветка DARWIN компилируется (mach_absolute_time, без линковки)"
echo echo
echo "Итого: 2 проверки, провалено 0" echo "Итого: $COUNT проверок, провалено $FAILED"
[ "$FAILED" -eq 0 ]
+54
View File
@@ -0,0 +1,54 @@
unit Serial;
{
Заглушка RTL-модуля Serial для проверки WINDOWS-ветки SerialPort.pas на Linux.
Повторяет ровно ту часть API, которую наша обёртка переадресует под Windows,
включая типы: разъезд сигнатур должен ловиться здесь, а не на сборочной
машине.
}
{$MODE Delphi}
interface
uses
SysUtils;
type
TSerialHandle = THandle;
TParityType = (NoneParity, OddParity, EvenParity);
TSerialFlags = set of (RtsCtsFlowControl);
function SerOpen(const DeviceName: string): TSerialHandle;
procedure SerClose(Handle: TSerialHandle);
procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
ByteSize: Integer; Parity: TParityType; StopBits: Integer;
Flags: TSerialFlags);
function SerRead(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt;
function SerWrite(Handle: TSerialHandle; const Buffer; Count: LongInt): LongInt;
function SerReadTimeout(Handle: TSerialHandle; var Buffer; mSec: LongInt): LongInt;
procedure SerSetDTR(Handle: TSerialHandle; State: Boolean);
procedure SerSetRTS(Handle: TSerialHandle; State: Boolean);
function SerGetCTS(Handle: TSerialHandle): Boolean;
function SerGetDSR(Handle: TSerialHandle): Boolean;
function SerGetCD(Handle: TSerialHandle): Boolean;
function SerGetRI(Handle: TSerialHandle): Boolean;
implementation
function SerOpen(const DeviceName: string): TSerialHandle; begin Result := 0; end;
procedure SerClose(Handle: TSerialHandle); begin end;
procedure SerSetParams(Handle: TSerialHandle; BitsPerSec: LongInt;
ByteSize: Integer; Parity: TParityType; StopBits: Integer;
Flags: TSerialFlags); begin end;
function SerRead(Handle: TSerialHandle; var Buffer; Count: LongInt): LongInt; begin Result := 0; end;
function SerWrite(Handle: TSerialHandle; const Buffer; Count: LongInt): LongInt; begin Result := 0; end;
function SerReadTimeout(Handle: TSerialHandle; var Buffer; mSec: LongInt): LongInt; begin Result := 0; end;
procedure SerSetDTR(Handle: TSerialHandle; State: Boolean); begin end;
procedure SerSetRTS(Handle: TSerialHandle; State: Boolean); begin end;
function SerGetCTS(Handle: TSerialHandle): Boolean; begin Result := False; end;
function SerGetDSR(Handle: TSerialHandle): Boolean; begin Result := False; end;
function SerGetCD(Handle: TSerialHandle): Boolean; begin Result := False; end;
function SerGetRI(Handle: TSerialHandle): Boolean; begin Result := False; end;
end.
+40
View File
@@ -0,0 +1,40 @@
# Стенд последовательного порта
Проверяет обёртку `SerialPort.pas` на **псевдотерминале**: настоящего COM-порта
на сборочной машине нет, а проверить надо ровно то, на чём обжигается перенос —
как обёртка **настраивает** порт.
```
test/serial/run.sh
```
## Что проверяется
* **Открытие**: несуществующий порт даёт `SER_INVALID_HANDLE` (а не ноль и не
случайное число), живой — годный хендл.
* **termios обратным чтением**: скорость, стоп-биты, `CREAD`/`CLOCAL`, сырой
режим (нет `ICANON`, `ECHO`, `OPOST`).
* ★**Аппаратный поток `CRTSCTS` не включается сам** — только по явной просьбе.
Это главная проверка стенда: на кабеле без CTS случайно включённый CRTSCTS
вешает передачу намертво, и никакой ошибки при этом нет. Ровно так ломается
RTL-модуль `Serial` на BSD и macOS — там B-константы это числа, а он кладёт
их в `c_cflag` (подробнее — в шапке `SerialPort.pas`).
* ★**В `c_cflag` нет ничего, кроме наших флагов** (маска `CBAUD` снимается) —
прямая ловушка на ту же ошибку. Негативный контроль: если в `SerSetParams`
дописать `or Cardinal(BitsPerSec)`, проверка падает с «1CAB0 против 8B0».
* **Формат** (размер символа, чётность, стоп-биты, флаг потока) — через чистую
`SerCFlags`. Обратным чтением его не проверить: pty восьмибитно-чистый, ядро
молча заменяет `CS7` на `CS8` и снимает `PARENB`.
* **Обмен**: запись и чтение в обе стороны, срок у `SerReadTimeout`, `CR` не
превращается в `CR+LF`, эха нет.
* **Сквозной прогон**: байты на мастере → поток `CATSerial``TCATEngine`
ответ обратно (командой `ID`, она отвечает константой и радио не трогает).
## Чего стенд НЕ проверяет
Модемные линии `DTR`/`RTS`/`CTS`/`DSR`/`CD`/`RI`: ioctl `TIOCM*` на
псевдотерминале не работает. Это остаётся на живой порт с железкой — там же
проверяется и телеграфный ключ на `CWKeyer`.
Компиляцию платформенных ветвей (Windows, macOS) проверяет соседний стенд
`test/platform`.
+18
View File
@@ -0,0 +1,18 @@
#!/bin/sh
# Стенд обёртки последовательного порта: сборка и прогон на псевдотерминале.
# Флаги те же, что у демона и у стенда TCI (см. test/tci/run.sh): -Mobjfpc ради
# вложенных комментариев, -dHEADLESS чтобы PlatformUtils не тянул LCL, каталог
# .ppu свой и абсолютным путём, -B обязателен (fpc сверяет .ppu по времени с
# точностью до секунды).
set -e
cd "$(dirname "$0")"
HERE=$(pwd)
CPU=$(fpc -iTP)
OS=$(fpc -iTO)
OUTUNITS="$HERE/units/${CPU}-${OS}"
OUT="$HERE/bin/${CPU}-${OS}"
mkdir -p "$OUTUNITS" "$OUT"
fpc -B -Mobjfpc -O2 -dHEADLESS \
-Fu../.. -FU"$OUTUNITS" -k-L/usr/local/lib \
-o"$OUT/serialtest" serialtest.pas
exec "$OUT/serialtest" "$@"
+329
View File
@@ -0,0 +1,329 @@
program serialtest;
{
Стенд обёртки последовательного порта (SerialPort.pas) на псевдотерминале.
Зачем именно pty. Настоящего COM-порта на сборочной машине нет, а проверить
надо ровно то, на чём обжигается перенос: как обёртка НАСТРАИВАЕТ порт.
Псевдотерминал тот же tty с той же дисциплиной линии, поэтому termios
проверяется всерьёз: скорость, размер символа, чётность, стоп-биты и самое
важное что аппаратный поток CRTSCTS НЕ включился сам собой. Именно этим
грешит `Serial` из RTL на BSD/macOS: там B-константы это числа, а он кладёт
их в c_cflag, и в поле прилетает CCTS_OFLOW (см. шапку SerialPort.pas).
Чего pty НЕ проверяет: модемные линии DTR/RTS/CTS/DSR/CD/RI ioctl TIOCM* на
псевдотерминале не работает. Это остаётся на живой порт с железкой.
}
{$MODE Delphi}
uses
cthreads, SysUtils, BaseUnix, termio, Unix,
SerialPort, CATEngine, CATSerial;
var
Passed, Failed: Integer;
procedure Check(const Name: string; Cond: Boolean; const Extra: string = '');
begin
if Cond then
begin
Inc(Passed);
WriteLn(' ok ', Name);
end
else
begin
Inc(Failed);
if Extra <> '' then
WriteLn(' FAIL ', Name, ' ', Extra)
else
WriteLn(' FAIL ', Name);
end;
end;
// ── Псевдотерминал ──────────────────────────────────────────────────────────
function posix_openpt(Flags: cint): cint; cdecl; external 'c' name 'posix_openpt';
function grantpt(Fd: cint): cint; cdecl; external 'c' name 'grantpt';
function unlockpt(Fd: cint): cint; cdecl; external 'c' name 'unlockpt';
function ptsname(Fd: cint): PChar; cdecl; external 'c' name 'ptsname';
function OpenPty(out Master: cint; out SlaveName: string): Boolean;
var P: PChar;
begin
Result := False;
SlaveName := '';
Master := posix_openpt(O_RDWR or O_NOCTTY);
if Master < 0 then Exit;
if (grantpt(Master) <> 0) or (unlockpt(Master) <> 0) then
begin
fpClose(Master);
Exit;
end;
P := ptsname(Master);
if P = nil then
begin
fpClose(Master);
Exit;
end;
SlaveName := string(P);
Result := True;
end;
function MasterWrite(Master: cint; const S: AnsiString): Boolean;
begin
Result := (Length(S) > 0) and (fpWrite(Master, S[1], Length(S)) = Length(S));
end;
function MasterReadStr(Master: cint; TimeoutMs: Integer): AnsiString;
// Собирает всё, что мастер отдаёт, пока не замолчит на TimeoutMs.
var
FDS: TFDSet;
TV: TimeVal;
Buf: array[0..255] of Byte;
N, i: LongInt;
begin
Result := '';
repeat
fpFD_Zero(FDS);
fpFD_Set(Master, FDS);
TV.tv_sec := TimeoutMs div 1000;
TV.tv_usec := (TimeoutMs mod 1000) * 1000;
if fpSelect(Master + 1, @FDS, nil, nil, @TV) <= 0 then Break;
N := fpRead(Master, Buf[0], SizeOf(Buf));
if N <= 0 then Break;
for i := 0 to N - 1 do Result := Result + Chr(Buf[i]);
until False;
end;
// ── A. Открытие ─────────────────────────────────────────────────────────────
procedure TestOpen;
var
H, Master: cint;
Slave: string;
begin
WriteLn('A. Открытие порта');
H := SerOpen('/dev/does-not-exist-ewsdr');
Check('несуществующий порт не открывается', not SerValid(H));
Check('неуспех даёт SER_INVALID_HANDLE, а не ноль',
H = SER_INVALID_HANDLE, IntToStr(H));
if not OpenPty(Master, Slave) then
begin
Check('псевдотерминал создан', False);
Exit;
end;
H := SerOpen(Slave);
Check('порт открывается', SerValid(H), Slave);
SerClose(H);
Check('после закрытия хендл больше не годится', not SerValid(SER_INVALID_HANDLE));
fpClose(Master);
end;
// ── B. Настройка порта ──────────────────────────────────────────────────────
procedure TestParams;
var
H, Master: cint;
Slave: string;
T: termios;
function Attrs: Boolean;
begin
FillChar(T, SizeOf(T), 0);
Result := TCGetAttr(H, T) = 0;
end;
begin
WriteLn('B. Настройка порта (termios читается обратно)');
if not OpenPty(Master, Slave) then
begin
Check('псевдотерминал создан', False);
Exit;
end;
H := SerOpen(Slave);
if not SerValid(H) then
begin
Check('порт открыт', False);
fpClose(Master);
Exit;
end;
SerSetParams(H, 115200, 8, NoneParity, 1, []);
if not Attrs then
Check('termios читается', False)
else
begin
Check('скорость встала (115200)',
(T.c_cflag and CBAUD) = B115200, IntToStr(T.c_cflag and CBAUD));
Check('символ 8 бит', (T.c_cflag and CSIZE) = CS8);
Check('чётности нет', (T.c_cflag and PARENB) = 0);
Check('один стоп-бит', (T.c_cflag and CSTOPB) = 0);
Check('приём и CLOCAL подняты',
(T.c_cflag and CREAD) <> 0, IntToStr(T.c_cflag));
// ★Главная проверка всего стенда. Аппаратный поток обязан быть выключен,
// пока его не просили: на кабеле без CTS включённый CRTSCTS вешает
// передачу намертво, а ошибки при этом никакой. Именно это и делает
// RTL-модуль на BSD/macOS, кладя скорость в c_cflag.
Check('★аппаратный поток НЕ включился сам',
(T.c_cflag and CRTSCTS) = 0, IntToStr(T.c_cflag and CRTSCTS));
// ★И ещё жёстче: кроме битов скорости в c_cflag не должно быть НИЧЕГО,
// кроме наших флагов. Ровно этим и ломается RTL-модуль на BSD/macOS: там
// B-константа это число, и оно ложится в c_cflag посторонними битами.
Check('★в c_cflag только наши флаги, скорость в него не попала',
(T.c_cflag and (not CBAUD)) = SerCFlags(8, NoneParity, 1, []),
Format('%x против %x', [T.c_cflag and (not CBAUD),
SerCFlags(8, NoneParity, 1, [])]));
Check('сырой режим: канонической обработки нет', (T.c_lflag and ICANON) = 0);
Check('сырой режим: эха нет', (T.c_lflag and ECHO) = 0);
Check('сырой режим: перевода строк на выходе нет', (T.c_oflag and OPOST) = 0);
end;
// Позитивный контроль к предыдущей проверке: попросили — значит включился.
SerSetParams(H, 9600, 8, NoneParity, 1, [RtsCtsFlowControl]);
if Attrs then
Check('аппаратный поток включается по просьбе',
(T.c_cflag and CRTSCTS) <> 0);
SerSetParams(H, 4800, 7, EvenParity, 2, []);
if Attrs then
begin
Check('скорость 4800', (T.c_cflag and CBAUD) = B4800);
Check('два стоп-бита', (T.c_cflag and CSTOPB) <> 0);
end;
// ★Размер символа и чётность обратным чтением НЕ проверяются: pty
// восьмибитно-чистый, ядро молча заменяет CS7 на CS8 и снимает PARENB
// (проверено отдельной пробой: ставим CS7|PARENB|PARODD — читаем CS8 без
// PARENB). Поэтому сборка флагов вынесена в чистую SerCFlags, и проверяем
// именно её — на живом порту в c_cflag уходит ровно это значение.
Check('формат: 8N1', SerCFlags(8, NoneParity, 1, []) =
Cardinal(CREAD or CLOCAL or CS8));
Check('формат: 7 бит', (SerCFlags(7, NoneParity, 1, []) and CSIZE) = CS7);
Check('формат: 6 бит', (SerCFlags(6, NoneParity, 1, []) and CSIZE) = CS6);
Check('формат: 5 бит', (SerCFlags(5, NoneParity, 1, []) and CSIZE) = CS5);
Check('формат: чётная чётность',
(SerCFlags(8, EvenParity, 1, []) and (PARENB or PARODD)) = PARENB);
Check('формат: нечётная чётность',
(SerCFlags(8, OddParity, 1, []) and (PARENB or PARODD)) =
Cardinal(PARENB or PARODD));
Check('формат: два стоп-бита',
(SerCFlags(8, NoneParity, 2, []) and CSTOPB) <> 0);
Check('★формат: без просьбы аппаратного потока нет',
(SerCFlags(8, NoneParity, 1, []) and CRTSCTS) = 0);
Check('формат: по просьбе аппаратный поток есть',
(SerCFlags(8, NoneParity, 1, [RtsCtsFlowControl]) and CRTSCTS) <> 0);
SerClose(H);
fpClose(Master);
end;
// ── C. Обмен ────────────────────────────────────────────────────────────────
procedure TestIO;
var
H, Master: cint;
Slave, Got: string;
S: AnsiString;
B: Byte;
N: LongInt;
T0, Dt: QWord;
begin
WriteLn('C. Обмен и таймаут');
if not OpenPty(Master, Slave) then
begin
Check('псевдотерминал создан', False);
Exit;
end;
H := SerOpen(Slave);
SerSetParams(H, 115200, 8, NoneParity, 1, []);
S := 'FA00014200000;';
Check('запись прошла целиком',
SerWrite(H, S[1], Length(S)) = Length(S));
Got := MasterReadStr(Master, 200);
Check('на другом конце то же самое', Got = S, Got);
// ★Сырой режим на выходе: CR обязан дойти как CR. Если бы остался ONLCR,
// терминал подменил бы его на CR+LF, и CAT-ответы приезжали бы битыми.
S := #13;
SerWrite(H, S[1], 1);
Got := MasterReadStr(Master, 200);
Check('★CR не превращается в CR+LF', Got = #13, IntToStr(Length(Got)));
MasterWrite(Master, 'Z');
N := SerReadTimeout(H, B, 500);
Check('чтение с таймаутом отдаёт байт', (N = 1) and (B = Ord('Z')),
Format('n=%d b=%d', [N, B]));
// Эхо выключено: то, что мы прочитали, не должно вернуться мастеру.
Got := MasterReadStr(Master, 100);
Check('★эха нет: принятое не возвращается отправителю', Got = '', Got);
T0 := GetTickCount64;
N := SerReadTimeout(H, B, 150);
Dt := GetTickCount64 - T0;
Check('таймаут возвращает 0', N = 0, IntToStr(N));
Check('таймаут выдерживает срок и не висит',
(Dt >= 120) and (Dt < 900), Format('%d мс', [Dt]));
SerClose(H);
fpClose(Master);
end;
// ── D. Сквозной прогон: CAT поверх обёртки ─────────────────────────────────
procedure TestCatThrough;
// Байты на мастере → поток CATSerial → разбор в TCATEngine → ответ обратно.
// Контекст радио пустой намеренно: команда ID отвечает константой и ни одного
// колбэка не трогает — стенду нужен транспорт, а не радио (его проверяет
// test/cat).
var
Master: cint;
Slave, Got: string;
Ctx: TCATContext;
Eng: TCATEngine;
Cfg: TCATSerialConfig;
Port: TCATSerialPort;
begin
WriteLn('D. Сквозной прогон: CAT через обёртку');
if not OpenPty(Master, Slave) then
begin
Check('псевдотерминал создан', False);
Exit;
end;
FillChar(Ctx, SizeOf(Ctx), 0);
Eng := TCATEngine.Create(Ctx);
FillChar(Cfg, SizeOf(Cfg), 0);
Cfg.Enabled := True;
Cfg.PortName := Slave;
Cfg.BaudRate := 9600;
Cfg.DataBits := 8;
Cfg.StopBits := 1;
Cfg.Parity := cspNone;
Port := TCATSerialPort.Create(Eng, Cfg);
try
Port.Start;
Check('порт CAT поднялся', Port.Active, Port.LastError);
MasterWrite(Master, 'ID;');
Got := MasterReadStr(Master, 1000);
Check('на команду пришёл ответ', Copy(Got, 1, 2) = 'ID', Got);
Check('ответ закрыт точкой с запятой',
(Length(Got) > 0) and (Got[Length(Got)] = ';'), Got);
finally
Port.Stop;
Port.Free;
Eng.Free;
fpClose(Master);
end;
end;
begin
Passed := 0;
Failed := 0;
WriteLn('=== Стенд последовательного порта (SerialPort.pas на pty) ===');
TestOpen;
TestParams;
TestIO;
TestCatThrough;
WriteLn;
WriteLn(Format('Итого: %d проверок, провалено %d', [Passed + Failed, Failed]));
if Failed > 0 then Halt(1);
end.