ewsdr/test/serial/serialtest.pas

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;

// ── A2. Имя устройства для Windows ─────────────────────────────────────────
procedure TestWinName;
// ★COM10 и выше CreateFile открывает ТОЛЬКО в форме \\.\COM10 — короткое имя
// система резолвит лишь для COM1..COM9, а у USB-переходников номер за десяток
// заезжает легко. Функция чистая, поэтому проверяется и на Linux.
begin
  WriteLn('A2. Имя устройства для Windows (COM10 и выше)');
  Check('COM1 остаётся коротким', SerWinDeviceName('COM1') = 'COM1');
  Check('COM9 остаётся коротким', SerWinDeviceName('COM9') = 'COM9');
  Check('★COM10 получает префикс',
        SerWinDeviceName('COM10') = '\\.\COM10', SerWinDeviceName('COM10'));
  Check('COM123 получает префикс',
        SerWinDeviceName('COM123') = '\\.\COM123', SerWinDeviceName('COM123'));
  Check('строчные буквы тоже узнаются',
        SerWinDeviceName('com12') = '\\.\com12', SerWinDeviceName('com12'));
  Check('пробелы вокруг имени не мешают',
        SerWinDeviceName('  COM12  ') = '\\.\COM12', SerWinDeviceName('  COM12  '));
  // ★Пробелы CreateFile не прощает и коротким именам тоже: опознанное имя
  // отдаём нормализованным, а не «как ввели».
  Check('пробелы снимаются и у короткого имени',
        SerWinDeviceName('  COM3  ') = 'COM3', '[' + SerWinDeviceName('  COM3  ') + ']');
  Check('пробелы снимаются и у полной формы',
        SerWinDeviceName('  \\.\COM12  ') = '\\.\COM12',
        '[' + SerWinDeviceName('  \\.\COM12  ') + ']');
  Check('уже полная форма не удваивается',
        SerWinDeviceName('\\.\COM12') = '\\.\COM12');
  Check('путь Unix не трогаем',
        SerWinDeviceName('/dev/ttyUSB0') = '/dev/ttyUSB0');
  Check('/dev/cu.* не трогаем',
        SerWinDeviceName('/dev/cu.usbserial-A1') = '/dev/cu.usbserial-A1');
  Check('нечисловой хвост не трогаем', SerWinDeviceName('COM3:') = 'COM3:');
  Check('пустое имя не ломает', SerWinDeviceName('') = '');
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;

// ── C2. Законный дескриптор 0 ──────────────────────────────────────────────
procedure TestFdZero;
// ★Регрессия, которую легко внести и невозможно заметить на рабочем столе: на
// Unix дескриптор 0 — обычный номер, и если стандартный ввод закрыт (демон,
// запуск из службы), порт откроется именно как 0. Проверка вида «хендл ноль =
// ошибка» тогда не только теряет рабочий порт, но и оставляет дескриптор
// незакрытым: SerClose смотрит на ту же проверку.
var
  Master, H: cint;
  Slave: string;
  B: Byte;
  N: LongInt;
begin
  WriteLn('C2. Дескриптор 0 — законный порт (стандартный ввод закрыт)');
  if not OpenPty(Master, Slave) then
  begin
    Check('псевдотерминал создан', False);
    Exit;
  end;
  fpClose(0);                       // освобождаем нулевой дескриптор
  H := SerOpen(Slave);
  if H <> 0 then
    WriteLn('  ..   дескриптор 0 занял не порт (', H, ') — проверка ослаблена')
  else
    Check('порт открылся как дескриптор 0', True);
  Check('★нулевой дескриптор считается годным', SerValid(H), IntToStr(H));
  SerSetParams(H, 9600, 8, NoneParity, 1, []);
  MasterWrite(Master, 'X');
  N := SerReadTimeout(H, B, 500);
  Check('через него идут данные', (N = 1) and (B = Ord('X')),
        Format('n=%d b=%d', [N, B]));
  SerClose(H);
  fpClose(Master);
  // Возвращаем стандартный ввод на место: иначе следующий открытый файл снова
  // сядет на нулевой дескриптор, и это уже будет случайностью, а не проверкой.
  fpOpen('/dev/null', O_RDONLY);
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;
  TestWinName;
  TestParams;
  TestIO;
  TestFdZero;
  TestCatThrough;
  WriteLn;
  WriteLn(Format('Итого: %d проверок, провалено %d', [Passed + Failed, Failed]));
  if Failed > 0 then Halt(1);
end.