ewsdr/SerialPort.pas

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}

{ Имя устройства в той форме, которую понимает CreateFile под Windows.
  ★COM10 и выше открываются ТОЛЬКО как \\.\COM10: короткое имя система
  резолвит лишь для COM1..COM9, а у USB-переходников номер за десяток заезжает
  легко. Функция чистая и считает одинаково на всех платформах (ради стенда),
  а зовёт её только Windows-ветка SerOpen: на Unix имя порта — это путь, и
  трогать его нечего. }
function  SerWinDeviceName(const Name: string): string;

{ Имя порта по умолчанию для настроек и подсказок в 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(SerWinDeviceName(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 SerWinDeviceName(const Name: string): string;
var
  S: string;
  i, N: Integer;
begin
  // ★Имя, которое не опознано как COM-порт, возвращаем БЕЗ изменений: это может
  // быть путь, и обрезать у него что-либо мы не вправе. А вот опознанное имя
  // отдаём нормализованным — пробелы вокруг ' COM3 ' CreateFile не прощает, и
  // оператор, скопировавший имя из документации с хвостовым пробелом, получал
  // бы «не удалось открыть» на ровном месте.
  Result := Name;
  S := Trim(Name);
  if Length(S) < 4 then Exit;
  // Уже полная форма — только снимаем пробелы.
  if Copy(S, 1, 4) = '\\.\' then Exit(S);
  if UpperCase(Copy(S, 1, 3)) <> 'COM' then Exit;
  N := 0;
  for i := 4 to Length(S) do
  begin
    if (S[i] < '0') or (S[i] > '9') then Exit;   // COM3:, COM-что-то — не трогаем
    N := N * 10 + (Ord(S[i]) - Ord('0'));
    if N > 999 then Exit;
  end;
  // COM1..COM9 открываются и коротким именем — префикс им не нужен.
  if N >= 10 then
    Result := '\\.\' + S
  else
    Result := S;
end;

function SerValid(Handle: TSerialHandle): Boolean;
// ★Ноль значит РАЗНОЕ на разных системах, и одной проверкой тут не обойтись.
begin
{$IFDEF WINDOWS}
  // Ядро Windows нулевой хендл не выдаёт никогда: ноль здесь — либо отказ RTL
  // (SerOpen переводит его в SER_INVALID_HANDLE), либо просто неинициализированное
  // поле. Отвергаем, чтобы контракт был верен и для значения, пришедшего извне.
  Result := (Handle <> SER_INVALID_HANDLE) and (Handle <> 0);
{$ELSE}
  // А на Unix ноль ЗАКОНЕН: при закрытом стандартном вводе (демон, запуск из
  // службы) fpOpen отдаст именно его. Объявить такой порт ошибкой значит не
  // только потерять рабочий порт, но и не закрыть дескриптор — SerClose
  // смотрит сюда же. Признак неудачи один: SER_INVALID_HANDLE.
  Result := Handle <> SER_INVALID_HANDLE;
{$ENDIF}
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.