commconnect.pas

boomerang library 5.11 internet ed

    term.c_iflag:= term.c_iflag and not IGNPAR or PARMRK  // prefix a character with a parity error or  framing  error  with \377 \0.
  else
    term.c_iflag:= term.c_iflag or IGNPAR;

  if fParity in [paOdd, paEven] then
    term.c_iflag:= term.c_iflag or INPCK  // check parity
  else
    term.c_iflag:= term.c_iflag and not INPCK;

  if FFlowControl = fcSoftware then
    term.c_iflag := term.c_iflag or (IXON or IXOFF or IXANY)
  else if FFlowControl <> fcDefault then
    term.c_iflag := term.c_iflag and not (IXON or IXOFF or IXANY);

  // control flags
  term.c_cflag := term.c_cflag or CREAD or HUPCL or CLOCAL;

  term.c_cflag := term.c_cflag and not CSIZE;
  if CommDataBits[fDataBits] = -1 then
    ComError(sCommErrDatabits);
  term.c_cflag := term.c_cflag and not CSIZE or Cardinal(CommDataBits[fDataBits]);

  case fStopBits of
    sb10: term.c_cflag := term.c_cflag and not CSTOPB;
    sb15: ComError(sCommErrStopBits);
    sb20: term.c_cflag := term.c_cflag or CSTOPB;
  end;

  if fParity = paNone then
    term.c_cflag := term.c_cflag and not PARENB
  else
    term.c_cflag := term.c_cflag or PARENB;

  case fParity of
    paOdd:
      term.c_cflag := term.c_cflag or PARODD;
    paEven:
      term.c_cflag := term.c_cflag and not PARODD;
    paMark, paSpace:
      ComError(sCommErrParity);
  end;

  if FFlowControl in [fcCTS] then
    term.c_cflag := term.c_cflag or CRTSCTS
  else if FFlowControl = fcDTR then
    ComError(sCommErrFlow)
  else if FFlowControl <> fcDefault then
    term.c_cflag := term.c_cflag and not CRTSCTS;

  if CommBaudRates[fBaudRate] = -1 then
    ComError(sCommErrBaudrate);

  cfsetospeed(term, CommBaudRates[fBaudRate]);
  cfsetispeed(term, CommBaudRates[fBaudRate]);

  // local modec
  term.c_lflag:= term.c_lflag and not ICANON;

  // character slots
  term.c_cc[VEOF]:= EofChar;  // only canonical
  term.c_cc[VSTART]:= XonChar;
  term.c_cc[VSTOP]:= XoffChar;
  term.c_cc[VINTR]:= EvtChar;
    // ErrorChar .. not supported
  term.c_cc[VMIN]:= TChar(#0);
  term.c_cc[VTIME]:= TChar(#0);

  if tcsetattr(Integer(FhCommDev), TCSANOW, term) < 0 then
    ComError2('tcsetattr TSCANOW');
  {$ELSE}
  GetCommState(FhCommDev, DCB);
  DCB.BaudRate := CommBaudRates[FBaudRate];
  DCB.Parity := CommParity[FParity];
  DCB.Stopbits := CommStopbits[FStopbits];
  DCB.Bytesize := CommDatabits[FDatabits];
  DCB.XonChar := XonChar;
  DCB.XoffChar := XOffChar;
  DCB.ErrorChar := ErrorChar;
  DCB.EofChar := EofChar;
  DCB.EvtChar := EvtChar;
  DCB.XonLim := FReadBufSize div 4;
  DCB.XoffLim := FReadBufSize div 4;

  case FFlowControl of
    fcNone: //Clear all flags
      DCB.Flags := fBinary;
    fcDefault:; //do nothing;
    fcCTS:
      DCB.Flags := DCB.Flags or fOutxCtsFlow or fRtsControlHandshake;
    fcDTR:
      DCB.Flags := DCB.Flags or fOutxDsrFlow or fDtrControlHandshake;
    fcSoftware:
      DCB.Flags := DCB.Flags or fOutX or fInX;
  end;
  for OptIndex := Low(TCommOption) to High(TCommOption) do
    if OptIndex in FOptions then DCB.Flags := DCB.Flags or CommOptions[OptIndex]
                            else DCB.Flags := DCB.Flags and not CommOptions[OptIndex];

  if not SetCommState(FhCommDev, DCB) then
    ComError2('SetCommState');
  {$ENDIF}
end;

procedure TCommHandle.UpdateCommTimeouts;
{$IFNDEF LINUX}
var
  CommTimeouts: TCommTimeouts;
{$ENDIF}
begin
{$IFNDEF LINUX}
  {$IFNDEF CLR}
  FillChar(CommTimeOuts, Sizeof(CommTimeOuts), 0);
  {$ENDIF}
  CommTimeOuts.ReadIntervalTimeout := MAXDWORD;
  if not SetCommTimeOuts(FhCommDev, CommTimeOuts) then
    ComError2('SetCommTimeouts');
{$ENDIF}
end;

procedure TCommHandle.PurgeIn;
begin
  if Active then
    {$IFDEF LINUX}
    ioctl(integer(FhCommDev), TCFLSH, TCIFLUSH);
    {$ELSE}
    PurgeComm(FhCommDev, PURGE_RXABORT + PURGE_RXCLEAR);
    {$ENDIF}
end;

procedure TCommHandle.PurgeOut;
begin
  if Active then
    {$IFDEF LINUX}
    ioctl(integer(FhCommDev), TCFLSH, TCOFLUSH);
    {$ELSE}
    PurgeComm(FhCommDev, PURGE_TXABORT + PURGE_TXCLEAR);
    {$ENDIF}
end;

constructor TComm.Create(aOwner: TComponent);
begin
  inherited Create(AOwner);
  FDeviceName:= DefaultDeviceName;
end;

procedure TComm.SetDeviceName(const Value: string);
begin
  CheckInactive;
  FDeviceName := Value;
end;

procedure TComm.OpenConn;
begin
  if csDesigning in ComponentState then
    Exit;
  {$IFDEF LINUX}
  AcquireLock(fDeviceName);
  FhCommDev := THandle(Libc.open(PChar(fDeviceName), O_RDWR or O_NOCTTY or O_NONBLOCK));
  if FhCommDev = INVALID_HANDLE_VALUE then
    ReleaseLock(fDeviceName);
  {$ELSE}
  FhCommDev := CreateFile({$IFNDEF CLR}PChar{$ENDIF}(FDeviceName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
  {$ENDIF}
  inherited;
end;

procedure TComm.CloseConn;
begin
  if csDesigning in ComponentState then
    Exit;
  {$IFDEF LINUX}
  if FhCommDev <> INVALID_HANDLE_VALUE then
    begin
      inherited;
      ReleaseLock(fDeviceName);
    end
  else
  {$ENDIF}
    inherited;
end;

{$IFDEF LINUX}
procedure AcquireLock(DeviceName: string);
var
  FName, S: string;
  f: TextFile;
begin
  FName:= _PATH_LOCK+'/LCK..'+ExtractFileName(DeviceName);
  ForceDirectories(_PATH_LOCK);
  // Check the Lockfile
  if FileExists (FName) then
  begin
    AssignFile(f, FName);
    Reset(f);
    Readln(f, S);
    CloseFile(f);
    // Is port owned by orphan? Then it's time for error recovery.
    if Libc.getsid(StrToIntDef(S, -1)) <> -1 then
      ComError(Format(sDeviceLocked, [DeviceName]));
  end;
  // comport is not locked or lockfile was left from former crash, lock it
  AssignFile(f, FName);
  Rewrite(f);
  writeln(f, Libc.getpid():10);
  CloseFile(f);
  // Allow all users to enjoy the benefits of cpom
  chmod(PChar(FName),  S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH);
end;

procedure ReleaseLock(DeviceName: string);
begin
  DeleteFile(_PATH_LOCK+'/LCK..'+ExtractFileName(DeviceName));
end;

function GetTickCount;
var
  tms: TTimes;
begin
  Result:= times(tms)*1000 div CLK_TCK{tick->ms};
end;

type
{$IFNDEF VER140}
{$MESSAGE WARN 'Check TEvent object definiction in SyncObjs'}
{$ENDIF}
  TEvent2 = class(THandleObject)
  private
    FEvent: TSemaphore;
    FManualReset: Boolean;
    FEventCS: TCriticalSection;
  end;
{$ENDIF}

function Event_WaitFor(fEvent: TEvent; aTimeout: LongWord): TWaitResult;
{$IFDEF LINUX}
var
  I: Integer;
  Tick: LongWord;
{$ENDIF}
begin
{$IFDEF LINUX}
  if (aTimeout > 0) and (aTimeout < LongWord($FFFFFFFF)) then
    begin
      Result:= wrTimeout;
      Tick:= GetTickCount;
      repeat
        sem_getvalue(TEvent2(fEvent).fEvent, I);
        if I > 0 then
          begin
            Result := wrSignaled;
            if TEvent2(fEvent).FManualReset then
            begin
              TEvent2(fEvent).FEventCS.Enter;
              try
                { the event might have been signaled between the sem_wait above and now so we reset it again }
                fEvent.ResetEvent;
                fEvent.SetEvent;
              finally
                TEvent2(fEvent).FEventCS.Leave;
              end;
            end;
          end
        else
          sleep(1); { do not eat full CPU time }
      until (I > 0) or (LongWord(Abs(GetTickCount-Tick)) >= aTimeout);
    end
  else
    Result:= fEvent.WaitFor(aTimeout);
{$ELSE}
  Result:= fEvent.WaitFor(aTimeout);
{$ENDIF}
end;

const
  Bauds: array[br110..br256000] of Longint =
     (110, 300, 600, 1200, 2400, 4800, 9600, 14400, 19200, 38400, 56000, 57600, 115200, 128000, 256000);

function Int2BaudRate(BR1: Longint; var BR: TBaudRate): Boolean;
var
  I: TBaudRate;
begin
  Result:= False;
  for I:= Low(Bauds) to High(Bauds) do
    if Bauds[I] = BR1 then
    begin
      BR:= I;
      Result:= True;
      Break;
    end;
end;

function BaudRate2Int(BR: TBaudRate): Longint;
begin
  Result:= Bauds[BR];
end;

{ TModem }

constructor TModem.Create(aOwner: TComponent);
begin
  inherited;
  fCommands:= TStringList.Create;
  cInit:= 'ATZ';
  rInit:= 'OK';
  cDial:= 'ATM1L1X3DT';  { speaker on when dialing, no dial tone detection, tone dial }

  fDelayBeforeInit:= 500;
  fDelayAfterInit:= 1000;
  fResponseTimeout:= 500;
  fConnectTimeout:= 30000;
  rConnect:= 'CONNECT';
  rBusy:= 'BUSY';
  rNoCarrier:= 'NO CARRIER';
  rNoDialtone:= 'NO DIALTONE';
  cHangUp:= '+++ATH';
  rHangUp:= 'OK';
  fCommandEvent:= TSimpleEvent.Create;
end;

destructor TModem.Destroy;
begin
  inherited;
  fCommands.Free;
  fCommandEvent.Free;
end;

function TModem.GetCommand(Index: Integer): TString;
begin
  if fCommands.Count > Index then
    Result:= fCommands[Index]
  else
    Result:= '';
end;

procedure TModem.SetCommand(Index: Integer; Value: TString);
begin
  while fCommands.Count <= Index do
    fCommands.Add('');
  fCommands[Index]:= Value;
end;

procedure TModem.OpenConn;
var
  I: Integer;
begin
  inherited;
  if csDesigning in ComponentState then
    Exit;

  fCancel:= False;
  fIsMakingCall:= True;
  try
    Sleep(fDelayBeforeInit);
    if not SendAndReceive(cInit, [rInit], fResponseTimeout, I) then
      ComError(Format(sModemNoResponse, [string(cInit)]));   // *** CLR Format
    Sleep(fDelayAfterInit);
    if not SendAndReceive(cDial+PhoneNumber, [rConnect, rBusy, rNoCarrier, rNoDialTone], fConnectTimeout, I) then
      ComError(Format(sModemNoResponse, [string(cDial+PhoneNumber)]))  // *** CLR Format
    else
      case I of
        1: ComError(sModemBusy);
        2: ComError(sModemNoConnection);
        3: ComError(sModemNoDialTone);
      end;
  finally
    fIsMakingCall:= False;
    fCancel:= False;
  end;
end;

procedure TModem.CloseConn;
var
  I: Integer;
begin
  if not (csDesigning in ComponentState) then
    SendAndReceive(cHangUp, [rHangUp], fResponseTimeout, I);
  inherited;
end;

procedure TModem.DoOnRxChar(Count: Integer);
var
  S: TString;
begin
  if fCapturing then
    begin
      S:= Retrieve(Count);
      Lock;
      try
        fReceivedBuffer:= fReceivedBuffer+S;
      finally
        UnLock;
      end;
      if Pos(TChar(#13), S) > 0 then  { received eol = commend in buffer }
        fCommandEvent.SetEvent;
      if Assigned(fOnRxCommand) then
        fOnRxCommand(Self, S); { in comm thread }
    end
  else
    inherited
end;

function TModem.SendAndReceive;
var
  Tick: LongWord;
  S: TString;
  I: Integer;
  SFlag: Boolean;
begin
  if fCancel then
    Abort;
  Result:= False;
  Lock;
  try
    fReceivedBuffer:= '';
  finally
    Unlock;
  end;
  SFlag:= DontSynchronize;
  DontSynchronize:= True;
  fCapturing:= True;
  try
    Send(aSend+TString(#13#10));
    repeat
      Tick:= GetTickCount();
      if Event_WaitFor(fCommandEvent, aTimeout) = wrTimeout then
        Break;
      if fCancel then
        Abort;
      Lock;
      try
        S:= fReceivedBuffer;
      finally
        Unlock;
      end;
      I:= 1;
      while I <= Length(S) do
      begin
        if S[I] = TChar(#10) then
          S[I]:= TChar(#13);
        Inc(I);
      end;
      for I:= Low(aResponses) to High(aResponses) do
        if Pos(TChar(#13)+aResponses[I], TChar(#13)+S) > 0 then
        begin
          aRespCode:= I;
          Result:= True;
          Break;
        end;
      Dec(aTimeout, Abs(GetTickCount()-Tick));
    until (aTimeout <= 0) or Result;
  finally
    DontSynchronize:= SFlag;
    fCapturing:= False;
  end;
end;

procedure TModem.Drop;
begin
  if fIsMakingCall then
  begin
    fCancel:= True;
    fCommandEvent.SetEvent;
  end;
end;

procedure Register;
begin
  RegisterComponents('Communication', [TComm, TModem]);
end;

{$IFDEF LINUX}

var
  SaveExitProc: Pointer;

procedure CommExitProc;
var
  I: Integer;
begin
  for I:= CommEventThreadList.Count-1 downto 0 do
  begin
    with TCommEventThread(CommEventThreadList[0]) do
    begin
      Terminate;
      WaitFor;  // set fFinished:= True;
    end;
  end;
  CommEventThreadList.Free;
  ExitProc:= SaveExitProc;
end;
{$ENDIF}

begin
{$IFDEF LINUX}
  SaveExitProc:= ExitProc;
  ExitProc:= @CommExitProc;
  {  install the signal handler to catch signals }
//sigaction(SIGIO, @saio, @savesaio);
  CommEventThreadList:= TList.Create;                            
{$ENDIF}
end.