synaser.pas

Synapse The synchronyous socket library. File content: 1.) About Synapse 2.) Distribution pa

  FBuffer := '';
  FDevice := comport;
  GetComNr(comport);
{$IFDEF WIN32}
  SetLastError (sOK);
{$ELSE}
  {$IFNDEF FPC}
  SetLastError (sOK);
  {$ELSE}
  __errno_location^ := sOK;
  {$ENDIF}
{$ENDIF}
{$IFNDEF WIN32}
  if FComNr <> PortIsClosed then
    FDevice := '/dev/ttyS' + IntToStr(FComNr);
  // Comport already owned by another process?          {HGJ}
  if FLinuxLock then
    if not cpomComportAccessible then
    begin
      RaiseSynaError(ErrAlreadyOwned);
      Exit;
    end;
  FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC));
  SerialCheck(integer(FHandle));
  {$IFDEF LINUX}
  if FLastError <> sOK then
    if FLinuxLock then
      cpomReleaseComport;
  {$ENDIF}
  ExceptCheck;
  if FLastError <> sOK then
    Exit;
{$ELSE}
  if FComNr <> PortIsClosed then
    FDevice := '\\.\COM' + IntToStr(FComNr + 1);
  FHandle := THandle(CreateFile(PChar(FDevice), GENERIC_READ or GENERIC_WRITE,
    0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0));
  SerialCheck(integer(FHandle));
  ExceptCheck;
  if FLastError <> sOK then
    Exit;
  SetCommMask(FHandle, 0);
  SetupComm(Fhandle, FRecvBuffer, 0);
  CommTimeOuts.ReadIntervalTimeout := MAXWORD;
  CommTimeOuts.ReadTotalTimeoutMultiplier := 0;
  CommTimeOuts.ReadTotalTimeoutConstant := 0;
  CommTimeOuts.WriteTotalTimeoutMultiplier := 0;
  CommTimeOuts.WriteTotalTimeoutConstant := 0;
  SetCommTimeOuts(FHandle, CommTimeOuts);
  FPortAddr := GetPortAddr;
{$ENDIF}
  SetSynaError(sOK);
  if not TestCtrlLine then  {HGJ}
  begin
    SetSynaError(ErrNoDeviceAnswer);
    FileClose(integer(FHandle));         {HGJ}
    {$IFDEF LINUX}
    if FLinuxLock then
      cpomReleaseComport;                {HGJ}
    {$ENDIF}                             {HGJ}
    Fhandle := INVALID_HANDLE_VALUE;     {HGJ}
    FComNr:= PortIsClosed;               {HGJ}
  end
  else
  begin
    FInstanceActive:= True;
    RTS := True;
    DTR := True;
    Purge;
  end;
  ExceptCheck;
  DoStatus(HR_Connect, FDevice);
end;

function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer;
{$IFDEF WIN32}
var
  Overlapped: TOverlapped;
  x, y, Err: DWord;
{$ENDIF}
begin
  Result := 0;
  if PreTestFailing then   {HGJ}
    Exit;                  {HGJ}
  LimitBandwidth(Length, FMaxSendBandwidth, FNextsend);
  if FRTSToggle then
  begin
    Flush;
    RTS := True;
  end;
{$IFNDEF WIN32}
  result := FileWrite(integer(Fhandle), Buffer^, Length);
  serialcheck(result);
{$ELSE}
  FillChar(Overlapped, Sizeof(Overlapped), 0);
  SetSynaError(sOK);
  y := 0;
  if not WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped) then
    y := GetLastError;
  if y = ERROR_IO_PENDING then
  begin
    x := WaitForSingleObject(FHandle, FDeadlockTimeout);
    if x = WAIT_TIMEOUT then
    begin
      PurgeComm(FHandle, PURGE_TXABORT);
      SetSynaError(ErrTimeout);
    end;
    GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
  end
  else
    SetSynaError(y);
  ClearCommError(FHandle, err, nil);
  if err <> 0 then
    DecodeCommError(err);
{$ENDIF}
  if FRTSToggle then
  begin
    Flush;
    CanWrite(255);
    RTS := False;
  end;
  ExceptCheck;
  DoStatus(HR_WriteCount, IntToStr(Result));
end;

procedure TBlockSerial.SendByte(data: byte);
begin
  SendBuffer(@Data, 1);
end;

procedure TBlockSerial.SendString(data: string);
begin
  SendBuffer(Pointer(Data), Length(Data));
end;

procedure TBlockSerial.SendInteger(Data: integer);
begin
  SendBuffer(@data, SizeOf(Data));
end;

procedure TBlockSerial.SendBlock(const Data: string);
begin
  SendInteger(Length(data));
  SendString(Data);
end;

procedure TBlockSerial.SendStreamRaw(const Stream: TStream);
var
  si: integer;
  x, y, yr: integer;
  s: string;
begin
  si := Stream.Size - Stream.Position;
  x := 0;
  while x < si do
  begin
    y := si - x;
    if y > cSerialChunk then
      y := cSerialChunk;
    Setlength(s, y);
    yr := Stream.read(Pchar(s)^, y);
    if yr > 0 then
    begin
      SetLength(s, yr);
      SendString(s);
      Inc(x, yr);
    end
    else
      break;
  end;
end;

procedure TBlockSerial.SendStreamIndy(const Stream: TStream);
var
  si: integer;
begin
  si := Stream.Size - Stream.Position;
  si := Swapbytes(si);
  SendInteger(si);
  SendStreamRaw(Stream);
end;

procedure TBlockSerial.SendStream(const Stream: TStream);
var
  si: integer;
begin
  si := Stream.Size - Stream.Position;
  SendInteger(si);
  SendStreamRaw(Stream);
end;

function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer;
{$IFNDEF WIN32}
begin
  Result := 0;
  if PreTestFailing then   {HGJ}
    Exit;                  {HGJ}
  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
  result := FileRead(integer(FHandle), Buffer^, length);
  serialcheck(result);
{$ELSE}
var
  Overlapped: TOverlapped;
  x, y, Err: DWord;
begin
  Result := 0;
  if PreTestFailing then   {HGJ}
    Exit;                  {HGJ}
  LimitBandwidth(Length, FMaxRecvBandwidth, FNextRecv);
  FillChar(Overlapped, Sizeof(Overlapped), 0);
  SetSynaError(sOK);
  y := 0;
  if not ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped) then
    y := GetLastError;
  if y = ERROR_IO_PENDING then
  begin
    x := WaitForSingleObject(FHandle, FDeadlockTimeout);
    if x = WAIT_TIMEOUT then
    begin
      PurgeComm(FHandle, PURGE_RXABORT);
      SetSynaError(ErrTimeout);
    end;
    GetOverlappedResult(FHandle, Overlapped, Dword(Result), False);
  end
  else
    SetSynaError(y);
  ClearCommError(FHandle, err, nil);
  if err <> 0 then
    DecodeCommError(err);
{$ENDIF}
  ExceptCheck;
  DoStatus(HR_ReadCount, IntToStr(Result));
end;

function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer;
var
  s: string;
  rl, l: integer;
  ti: ULong;
begin
  Result := 0;
  if PreTestFailing then   {HGJ}
    Exit;                  {HGJ}
  SetSynaError(sOK);
  rl := 0;
  repeat
    ti := GetTick;
    s := RecvPacket(Timeout);
    l := System.Length(s);
    if (rl + l) > Length then
      l := Length - rl;
    Move(Pointer(s)^, IncPoint(Buffer, rl)^, l);
    rl := rl + l;
    if FLastError <> sOK then
      Break;
    if rl >= Length then
      Break;
    if not FInterPacketTimeout then
    begin
      Timeout := Timeout - integer(TickDelta(ti, GetTick));
      if Timeout <= 0 then
      begin
        SetSynaError(ErrTimeout);
        Break;
      end;
    end;
  until False;
  delete(s, 1, l);
  FBuffer := s;
  Result := rl;
end;

function TBlockSerial.RecvBufferStr(Length: Integer; Timeout: Integer): string;
var
  x: integer;
begin
  Result := '';
  if PreTestFailing then   {HGJ}
    Exit;                  {HGJ}
  SetSynaError(sOK);
  if Length > 0 then
  begin
    Setlength(Result, Length);
    x := RecvBufferEx(PChar(Result), Length , Timeout);
    if FLastError = sOK then
      SetLength(Result, x)
    else
      Result := '';
  end;
end;

function TBlockSerial.RecvPacket(Timeout: Integer): string;
var
  x: integer;
begin
  Result := '';
  if PreTestFailing then   {HGJ}
    Exit;                  {HGJ}
  SetSynaError(sOK);
  if FBuffer <> '' then
  begin
    Result := FBuffer;
    FBuffer := '';
  end
  else
  begin
    //not drain CPU on large downloads...
    Sleep(0);
    x := WaitingData;
    if x > 0 then
    begin
      SetLength(Result, x);
      x := RecvBuffer(Pointer(Result), x);
      if x >= 0 then
        SetLength(Result, x);
    end
    else
    begin
      if CanRead(Timeout) then
      begin
        x := WaitingData;
        if x = 0 then
          SetSynaError(ErrTimeout);
        if x > 0 then
        begin
          SetLength(Result, x);
          x := RecvBuffer(Pointer(Result), x);
          if x >= 0 then
            SetLength(Result, x);
        end;
      end
      else
        SetSynaError(ErrTimeout);
    end;
  end;
  ExceptCheck;
end;


function TBlockSerial.RecvByte(timeout: integer): byte;
begin
  Result := 0;
  if PreTestFailing then   {HGJ}
    Exit;                  {HGJ}
  SetSynaError(sOK);
  if FBuffer = '' then
    FBuffer := RecvPacket(Timeout);
  if (FLastError = sOK) and (FBuffer <> '') then
  begin
    Result := Ord(FBuffer[1]);
    System.Delete(FBuffer, 1, 1);
  end;
  ExceptCheck;
end;

function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: string): string;
var
  x: Integer;
  s: string;
  l: Integer;
  CorCRLF: Boolean;
  t: string;
  tl: integer;
  ti: ULong;
begin
  Result := '';
  if PreTestFailing then   {HGJ}
    Exit;                  {HGJ}
  SetSynaError(sOK);
  l := system.Length(Terminator);
  if l = 0 then
    Exit;
  tl := l;
  CorCRLF := FConvertLineEnd and (Terminator = CRLF);
  s := '';
  x := 0;
  repeat
    ti := GetTick;
    //get rest of FBuffer or incomming new data...
    s := s + RecvPacket(Timeout);
    if FLastError <> sOK then
      Break;
    x := 0;
    if Length(s) > 0 then
      if CorCRLF then
      begin
        if FLastCR and (s[1] = LF) then
          Delete(s, 1, 1);
        if FLastLF and (s[1] = CR) then
          Delete(s, 1, 1);
        FLastCR := False;
        FLastLF := False;
        t := '';
        x := PosCRLF(s, t);
        tl := system.Length(t);
        if t = CR then
          FLastCR := True;
        if t = LF then
          FLastLF := True;
      end
      else
      begin
        x := pos(Terminator, s);
        tl := l;
      end;
    if (FMaxLineLength <> 0) and (system.Length(s) > FMaxLineLength) then
    begin
      SetSynaError(ErrMaxBuffer);
      Break;
    end;
    if x > 0 then
      Break;
    if not FInterPacketTimeout then
    begin
      Timeout := Timeout - integer(TickDelta(ti, GetTick));
      if Timeout <= 0 then
      begin
        SetSynaError(ErrTimeout);
        Break;
      end;
    end;
  until False;
  if x > 0 then
  begin
    Result := Copy(s, 1, x - 1);
    System.Delete(s, 1, x + tl - 1);
  end;
  FBuffer := s;
  ExceptCheck;
end;


function TBlockSerial.RecvString(Timeout: Integer): string;
var
  s: string;
begin
  Result := '';
  s := RecvTerminated(Timeout, #13 + #10);
  if FLastError = sOK then
    Result := s;
end;