spcomm.pas

PC机控制系统程序

//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Tries to gracefully signal all communication threads to
//    close, but terminates them if it has to.
//
//

procedure TComm.StopComm;
begin
     // No need to continue if we're not communicating.
  if hCommFile = 0 then
    Exit;

     // Close the threads.
  CloseReadThread;
  CloseWriteThread;

     // Not needed anymore.
  CloseHandle(hCloseEvent);

     // Now close the comm port handle.
  CloseHandle(hCommFile);
  hCommFile := 0
end;                                    {TComm.StopComm}

//
//  FUNCTION: WriteCommData(PChar, Word)
//
//  PURPOSE: Send a String to the Write Thread to be written to the Comm.
//
//  PARAMETERS:
//    pszStringToWrite     - String to Write to Comm port.
//    nSizeofStringToWrite - length of pszStringToWrite.
//
//  RETURN VALUE:
//    Returns TRUE if the PostMessage is successful.
//    Returns FALSE if PostMessage fails or Write thread doesn't exist.
//
//  COMMENTS:
//
//    This is a wrapper function so that other modules don't care that
//    Comm writing is done via PostMessage to a Write thread.  Note that
//    using PostMessage speeds up response to the UI (very little delay to
//    'write' a string) and provides a natural buffer if the comm is slow
//    (ie: the messages just pile up in the message queue).
//
//    Note that it is assumed that pszStringToWrite is allocated with
//    LocalAlloc, and that if WriteCommData succeeds, its the job of the
//    Write thread to LocalFree it.  If WriteCommData fails, then its
//    the job of the calling function to free the string.
//
//

function TComm.WriteCommData(pDataToWrite: PChar; dwSizeofDataToWrite: Word):
  Boolean;
var
  Buffer       : Pointer;
begin
  if (WriteThread <> nil) and (dwSizeofDataToWrite <> 0) then
  begin
    Buffer := Pointer(LocalAlloc(LPTR, dwSizeofDataToWrite + 1));
    Move(pDataToWrite^, Buffer^, dwSizeofDataToWrite);
    if PostThreadMessage(WriteThread.ThreadID, PWM_COMMWRITE,
      WPARAM(dwSizeofDataToWrite), LPARAM(Buffer)) then
    begin
      FSendDataEmpty := False;
      Result := True;
      Exit
    end
  end;

  Result := False
end;                                    {TComm.WriteCommData}

//
//  FUNCTION: GetModemState
//
//  PURPOSE: Read the state of modem input pin right now
//
//  PARAMETERS:
//     none
//
//  RETURN VALUE:
//
//     A DWORD variable containing one or more of following codes:
//
//     Value       Meaning
//     ----------  -----------------------------------------------------------
//     MS_CTS_ON   The CTS (clear-to-send) signal is on.
//     MS_DSR_ON   The DSR (data-set-ready) signal is on.
//     MS_RING_ON  The ring indicator signal is on.
//     MS_RLSD_ON  The RLSD (receive-line-signal-detect) signal is on.
//
//     If this comm have bad handle or not yet opened, the return value is 0
//
//  COMMENTS:
//
//    This member function calls GetCommModemStatus and return its value.
//    Before calling this member function, you must have a successful
//    'StartOpen' call.
//
//

function TComm.GetModemState: DWORD;
var
  dwModemState : DWORD;
begin
  if not GetCommModemStatus(hCommFile, dwModemState) then
    Result := 0
  else
    Result := dwModemState
end;


(******************************************************************************)
//  TComm PROTECTED METHODS
(******************************************************************************)

//
//  FUNCTION: CloseReadThread
//
//  PURPOSE: Close the Read Thread.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Closes the Read thread by signaling the CloseEvent.
//    Purges any outstanding reads on the comm port.
//
//    Note that terminating a thread leaks memory.
//    Besides the normal leak incurred, there is an event object
//    that doesn't get closed.  This isn't worth worrying about
//    since it shouldn't happen anyway.
//
//

procedure TComm.CloseReadThread;
begin
     // If it exists...
  if ReadThread <> nil then
  begin
          // Signal the event to close the worker threads.
    SetEvent(hCloseEvent);

          // Purge all outstanding reads
    PurgeComm(hCommFile, PURGE_RXABORT + PURGE_RXCLEAR);

          // Wait 10 seconds for it to exit.  Shouldn't happen.
    if (WaitForSingleObject(ReadThread.Handle, 10000) = WAIT_TIMEOUT) then
      ReadThread.Terminate;
    ReadThread.Free;
    ReadThread := nil
  end
end;                                    {TComm.CloseReadThread}

//
//  FUNCTION: CloseWriteThread
//
//  PURPOSE: Closes the Write Thread.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Closes the write thread by signaling the CloseEvent.
//    Purges any outstanding writes on the comm port.
//
//    Note that terminating a thread leaks memory.
//    Besides the normal leak incurred, there is an event object
//    that doesn't get closed.  This isn't worth worrying about
//    since it shouldn't happen anyway.
//
//

procedure TComm.CloseWriteThread;
begin
     // If it exists...
  if WriteThread <> nil then
  begin
          // Signal the event to close the worker threads.
    SetEvent(hCloseEvent);

          // Purge all outstanding writes.
    PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR);
    FSendDataEmpty := True;

          // Wait 10 seconds for it to exit.  Shouldn't happen.
    if WaitForSingleObject(WriteThread.Handle, 10000) = WAIT_TIMEOUT then
      WriteThread.Terminate;
    WriteThread.Free;
    WriteThread := nil
  end
end;                                    {TComm.CloseWriteThread}

procedure TComm.ReceiveData(Buffer: PChar; BufferLength: Word);
begin
  if Assigned(FOnReceiveData) then
    FOnReceiveData(self, Buffer, BufferLength)
end;

procedure TComm.ReceiveError(EvtMask: DWORD);
begin
  if Assigned(FOnReceiveError) then
    FOnReceiveError(self, EvtMask)
end;

procedure TComm.ModemStateChange(ModemEvent: DWORD);
begin
  if Assigned(FOnModemStateChange) then
    FOnModemStateChange(self, ModemEvent)
end;

procedure TComm.RequestHangup;
begin
  if Assigned(FOnRequestHangup) then
    FOnRequestHangup(Self)
end;

procedure TComm._SendDataEmpty;
begin
  if Assigned(FOnSendDataEmpty) then
    FOnSendDataEmpty(self)
end;

(******************************************************************************)
//  TComm PRIVATE METHODS
(******************************************************************************)

procedure TComm.CommWndProc(var msg: TMessage);
begin
  case msg.msg of
    PWM_GOTCOMMDATA:
      begin
        ReceiveData(PChar(msg.LParam), msg.WParam);
        LocalFree(msg.LParam)
      end;
    PWM_RECEIVEERROR: ReceiveError(msg.LParam);
    PWM_MODEMSTATECHANGE: ModemStateChange(msg.LParam);
    PWM_REQUESTHANGUP: RequestHangup;
    PWM_SENDDATAEMPTY: _SendDataEmpty
  end
end;

procedure TComm._SetCommState;
var
  dcb          : Tdcb;
  commprop     : TCommProp;
  fdwEvtMask   : DWORD;
begin
     // Configure the comm settings.
     // NOTE: Most Comm settings can be set through TAPI, but this means that
     //       the CommFile will have to be passed to this component.

  GetCommState(hCommFile, dcb);
  GetCommProperties(hCommFile, commprop);
  GetCommMask(hCommFile, fdwEvtMask);

     // fAbortOnError is the only DCB dependancy in TapiComm.
     // Can't guarentee that the SP will set this to what we expect.
     {dcb.fAbortOnError := False; NOT VALID}

  dcb.BaudRate := FBaudRate;

  dcb.Flags := 1;                       // Enable fBinary

  if FParityCheck then
    dcb.Flags := dcb.Flags or 2;        // Enable parity check

     // setup hardware flow control

  if FOutx_CtsFlow then
    dcb.Flags := dcb.Flags or 4;

  if FOutx_DsrFlow then
    dcb.Flags := dcb.Flags or 8;

  if FDtrControl = DtrEnable then
    dcb.Flags := dcb.Flags or $10
  else if FDtrControl = DtrHandshake then
    dcb.Flags := dcb.Flags or $20;

  if FDsrSensitivity then
    dcb.Flags := dcb.Flags or $40;

  if FTxContinueOnXoff then
    dcb.Flags := dcb.Flags or $80;

  if FOutx_XonXoffFlow then
    dcb.Flags := dcb.Flags or $100;

  if FInx_XonXoffFlow then
    dcb.Flags := dcb.Flags or $200;

  if FReplaceWhenParityError then
    dcb.Flags := dcb.Flags or $400;

  if FIgnoreNullChar then
    dcb.Flags := dcb.Flags or $800;

  if FRtsControl = RtsEnable then
    dcb.Flags := dcb.Flags or $1000
  else if FRtsControl = RtsHandshake then
    dcb.Flags := dcb.Flags or $2000
  else if FRtsControl = RtsTransmissionAvailable then
    dcb.Flags := dcb.Flags or $3000;

  dcb.XonLim := FXonLimit;
  dcb.XoffLim := FXoffLimit;

  dcb.ByteSize := Ord(FByteSize) + 5;
  dcb.Parity := Ord(FParity);
  dcb.StopBits := Ord(FStopBits);

  dcb.XonChar := FXonChar;
  dcb.XoffChar := FXoffChar;

  dcb.ErrorChar := FReplacedChar;

  SetCommState(hCommFile, dcb)
end;

procedure TComm._SetCommTimeout;
var
  commtimeouts : TCommTimeouts;
begin
  GetCommTimeouts(hCommFile, commtimeouts);

     // The CommTimeout numbers will very likely change if you are
     // coding to meet some kind of specification where
     // you need to reply within a certain amount of time after
     // recieving the last byte.  However,  If 1/4th of a second
     // goes by between recieving two characters, its a good
     // indication that the transmitting end has finished, even
     // assuming a 1200 baud modem.

  commtimeouts.ReadIntervalTimeout := FReadIntervalTimeout;
  commtimeouts.ReadTotalTimeoutMultiplier := FReadTotalTimeoutMultiplier;
  commtimeouts.ReadTotalTimeoutConstant := FReadTotalTimeoutConstant;
  commtimeouts.WriteTotalTimeoutMultiplier := FWriteTotalTimeoutMultiplier;
  commtimeouts.WriteTotalTimeoutConstant := FWriteTotalTimeoutConstant;

  SetCommTimeouts(hCommFile, commtimeouts);
end;

procedure TComm.SetBaudRate(Rate: DWORD);
begin
  if Rate = FBaudRate then
    Exit;

  FBaudRate := Rate;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetParityCheck(b: Boolean);
begin
  if b = FParityCheck then
    Exit;

  FParityCheck := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetOutx_CtsFlow(b: Boolean);
begin
  if b = FOutx_CtsFlow then
    Exit;

  FOutx_CtsFlow := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetOutx_DsrFlow(b: Boolean);
begin
  if b = FOutx_DsrFlow then
    Exit;

  FOutx_DsrFlow := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetDtrControl(c: TDtrControl);
begin
  if c = FDtrControl then
    Exit;

  FDtrControl := c;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetDsrSensitivity(b: Boolean);
begin
  if b = FDsrSensitivity then
    Exit;

  FDsrSensitivity := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetTxContinueOnXoff(b: Boolean);
begin
  if b = FTxContinueOnXoff then
    Exit;

  FTxContinueOnXoff := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetOutx_XonXoffFlow(b: Boolean);
begin
  if b = FOutx_XonXoffFlow then
    Exit;

  FOutx_XonXoffFlow := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetInx_XonXoffFlow(b: Boolean);
begin
  if b = FInx_XonXoffFlow then
    Exit;

  FInx_XonXoffFlow := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetReplaceWhenParityError(b: Boolean);
begin
  if b = FReplaceWhenParityError then
    Exit;

  FReplaceWhenParityError := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetIgnoreNullChar(b: Boolean);
begin
  if b = FIgnoreNullChar then
    Exit;

  FIgnoreNullChar := b;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetRtsControl(c: TRtsControl);
begin
  if c = FRtsControl then
    Exit;

  FRtsControl := c;

  if hCommFile <> 0 then
    _SetCommState
end;

procedure TComm.SetXonLimit(Limit: WORD);
begin
  if Limit = FXonLimit then
    Exit;