spcomm.pas

PC机控制系统程序

//
//  COMMENTS:
//
//    This function is a helper function for the Read Thread that sets up
//    the WaitCommEvent so we can deal with comm events (like Comm errors)
//    if they occur.
//
//

function TReadThread.SetupCommEvent(lpOverlappedCommEvent: POverlapped;
  var lpfdwEvtMask: DWORD): Boolean;
var
  dwLastError  : DWORD;
label
  StartSetupCommEvent;
begin
  Result := False;

  StartSetupCommEvent:

     // Make sure the CloseEvent hasn't been signaled yet.
     // Check is needed because this function is potentially recursive.
  if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent, 0) then
    Exit;

     // Start waiting for Comm Errors.
  if WaitCommEvent(hCommFile, lpfdwEvtMask, lpOverlappedCommEvent) then
  begin
          // This could happen if there was an error waiting on the
          // comm port.  Lets try and handle it.

    if not HandleCommEvent(nil, lpfdwEvtMask, False) then
    begin
               {??? GetOverlappedResult does not handle "NIL" as defined by Borland}
      Exit
    end;

          // What could cause infinite recursion at this point?
    goto StartSetupCommEvent
  end;

     // We expect ERROR_IO_PENDING returned from WaitCommEvent
     // because we are waiting with an overlapped structure.

  dwLastError := GetLastError;

     // LastError was ERROR_IO_PENDING, as expected.
  if dwLastError = ERROR_IO_PENDING then
  begin
    Result := True;
    Exit
  end;

     // Its possible for this error to occur if the
     // service provider has closed the port.  Time to end.
  if dwLastError = ERROR_INVALID_HANDLE then
    Exit;

     // Unexpected error. No idea what could cause this to happen.
  PostHangupCall
end;                                    {TReadThread.SetupCommEvent}

//
//  FUNCTION: HandleCommEvent(LPOVERLAPPED, LPDWORD, BOOL)
//
//  PURPOSE: Handle an outstanding Comm Event.
//
//  PARAMETERS:
//    lpOverlappedCommEvent - Pointer to the overlapped structure to use.
//    lpfdwEvtMask          - Pointer to DWORD to received Event data.
//     fRetrieveEvent       - Flag to signal if the event needs to be
//                            retrieved, or has already been retrieved.
//
//  RETURN VALUE:
//    TRUE if able to handle a Comm Event.
//    FALSE if unable to setup WaitCommEvent, unable to handle
//    an existing outstanding event or if the CloseEvent has been signaled.
//
//  COMMENTS:
//
//    This function is a helper function for the Read Thread that (if
//    fRetrieveEvent == TRUE) retrieves an outstanding CommEvent and
//    deals with it.  The only event that should occur is an EV_ERR event,
//    signalling that there has been an error on the comm port.
//
//    Normally, comm errors would not be put into the normal data stream
//    as this sample is demonstrating.  Putting it in a status bar would
//    be more appropriate for a real application.
//
//

function TReadThread.HandleCommEvent(lpOverlappedCommEvent: POverlapped;
  var lpfdwEvtMask: DWORD; fRetrieveEvent: Boolean): Boolean;
var
  dwDummy      : DWORD;
  dwErrors     : DWORD;
  dwLastError  : DWORD;
  dwModemEvent : DWORD;
begin
  Result := False;

     // If this fails, it could be because the file was closed (and I/O is
     // finished) or because the overlapped I/O is still in progress.  In
     // either case (or any others) its a bug and return FALSE.
  if fRetrieveEvent then
  begin
    if not GetOverlappedResult(hCommFile,
      lpOverlappedCommEvent^, dwDummy, False) then
    begin
      dwLastError := GetLastError;

               // Its possible for this error to occur if the
               // service provider has closed the port.  Time to end.
      if dwLastError = ERROR_INVALID_HANDLE then
        Exit;

      PostHangupCall;
      Exit
    end
  end;

     // Was the event an error?
  if (lpfdwEvtMask and EV_ERR) <> 0 then
  begin
          // Which error was it?
    if not ClearCommError(hCommFile, dwErrors, nil) then
    begin
      dwLastError := GetLastError;

               // Its possible for this error to occur if the
               // service provider has closed the port.  Time to end.
      if dwLastError = ERROR_INVALID_HANDLE then
        Exit;

      PostHangupCall;
      Exit
    end;

          // Its possible that multiple errors occured and were handled
          // in the last ClearCommError.  Because all errors were signaled
          // individually, but cleared all at once, pending comm events
          // can yield EV_ERR while dwErrors equals 0.  Ignore this event.

    if not ReceiveError(dwErrors) then
      Exit;

    Result := True
  end;

  dwModemEvent := 0;

  if ((lpfdwEvtMask and EV_RLSD) <> 0) then
    dwModemEvent := ME_RLSD;
  if ((lpfdwEvtMask and EV_RING) <> 0) then
    dwModemEvent := dwModemEvent or ME_RING;

  if dwModemEvent <> 0 then
  begin
    if not ModemStateChange(dwModemEvent) then
    begin
      Result := False;
      Exit
    end;

    Result := True
  end;

  if ((lpfdwEvtMask and EV_ERR) = 0) and (dwModemEvent = 0) then
  begin
          // Should not have gotten here.
    PostHangupCall
  end
end;                                    {TReadThread.HandleCommEvent}

function TReadThread.ReceiveData(lpNewString: LPSTR; dwSizeofNewString: DWORD):
  BOOL;
begin
  Result := False;

  if not PostMessage(hComm32Window, PWM_GOTCOMMDATA,
    WPARAM(dwSizeofNewString), LPARAM(lpNewString)) then
    PostHangupCall
  else
    Result := True
end;

function TReadThread.ReceiveError(EvtMask: DWORD): BOOL;
begin
  Result := False;

  if not PostMessage(hComm32Window, PWM_RECEIVEERROR, 0, LPARAM(EvtMask)) then
    PostHangupCall
  else
    Result := True
end;

function TReadThread.ModemStateChange(ModemEvent: DWORD): BOOL;
begin
  Result := False;

  if not PostMessage(hComm32Window, PWM_MODEMSTATECHANGE, 0, LPARAM(ModemEvent))
    then
    PostHangupCall
  else
    Result := True
end;

procedure TReadThread.PostHangupCall;
begin
  PostMessage(hComm32Window, PWM_REQUESTHANGUP, 0, 0)
end;

(******************************************************************************)
//  WRITE THREAD
(******************************************************************************)

//
//  PROCEDURE: TWriteThread.Execute
//
//  PURPOSE: The starting point for the Write thread.
//
//  PARAMETERS:
//    lpvParam - unused.
//
//  RETURN VALUE:
//    DWORD - unused.
//
//  COMMENTS:
//
//    The Write thread uses a PeekMessage loop to wait for a string to write,
//    and when it gets one, it writes it to the Comm port.  If the CloseEvent
//    object is signaled, then it exits.  The use of messages to tell the
//    Write thread what to write provides a natural desynchronization between
//    the UI and the Write thread.
//
//

procedure TWriteThread.Execute;
var
  msg          : TMsg;
  dwHandleSignaled: DWORD;
  overlappedWrite: TOverLapped;
  CompleteOneWriteRequire: Boolean;
label
  EndWriteThread;
begin
     // Needed for overlapped I/O.
  FillChar(overlappedWrite, SizeOf(overlappedWrite), 0); {0, 0, 0, 0, NULL}

  overlappedWrite.hEvent := CreateEvent(nil, True, True, nil);
  if overlappedWrite.hEvent = 0 then
  begin
    PostHangupCall;
    goto EndWriteThread
  end;

  CompleteOneWriteRequire := True;

     // This is the main loop.  Loop until we break out.
  while True do
  begin
    if not PeekMessage(msg, 0, 0, 0, PM_REMOVE) then
    begin
               // If there are no messages pending, wait for a message or
               // the CloseEvent.

      pFSendDataEmpty^ := True;

      if CompleteOneWriteRequire then
      begin
        if not PostMessage(hComm32Window, PWM_SENDDATAEMPTY, 0, 0) then
        begin
          PostHangupCall;
          goto EndWriteThread
        end
      end;

      CompleteOneWriteRequire := False;

      dwHandleSignaled := MsgWaitForMultipleObjects(1, hCloseEvent, False,
        INFINITE, QS_ALLINPUT);

      case dwHandleSignaled of
        WAIT_OBJECT_0:                  // CloseEvent signaled!
          begin
                    // Time to exit.
            goto EndWriteThread
          end;

        WAIT_OBJECT_0 + 1:              // New message was received.
          begin
                    // Get the message that woke us up by looping again.
            Continue
          end;

        WAIT_FAILED:                    // Wait failed.  Shouldn't happen.
          begin
            PostHangupCall;
            goto EndWriteThread
          end

      else                              // This case should never occur.
        begin
          PostHangupCall;
          goto EndWriteThread
        end
      end
    end;

          // Make sure the CloseEvent isn't signaled while retrieving messages.
    if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent, 0) then
      goto EndWriteThread;

          // Process the message.
          // This could happen if a dialog is created on this thread.
          // This doesn't occur in this sample, but might if modified.
    if msg.hwnd <> 0 {NULL} then
    begin
      TranslateMessage(msg);
      DispatchMessage(msg);
      Continue
    end;

          // Handle the message.
    case msg.message of
      PWM_COMMWRITE:                    // New string to write to Comm port.
        begin
               // Write the string to the comm port.  HandleWriteData
               // does not return until the whole string has been written,
               // an error occurs or until the CloseEvent is signaled.
          if not HandleWriteData(@overlappedWrite,
            PChar(msg.lParam), DWORD(msg.wParam)) then
          begin
                    // If it failed, either we got a signal to end or there
                    // really was a failure.

            LocalFree(HLOCAL(msg.lParam));
            goto EndWriteThread
          end;

          CompleteOneWriteRequire := True;
               // Data was sent in a LocalAlloc()d buffer.  Must free it.
          LocalFree(HLOCAL(msg.lParam))
        end
    end
  end;                                  {main loop}

     // Thats the end.  Now clean up.
  EndWriteThread:

  PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR);
  pFSendDataEmpty^ := True;
  CloseHandle(overlappedWrite.hEvent)
end;                                    {TWriteThread.Execute}


//
//  FUNCTION: HandleWriteData(LPOVERLAPPED, LPCSTR, DWORD)
//
//  PURPOSE: Writes a given string to the comm file handle.
//
//  PARAMETERS:
//    lpOverlappedWrite  - Overlapped structure to use in WriteFile
//    pDataToWrite       - String to write.
//    dwNumberOfBytesToWrite - Length of String to write.
//
//  RETURN VALUE:
//    TRUE if all bytes were written.  False if there was a failure to
//    write the whole string.
//
//  COMMENTS:
//
//    This function is a helper function for the Write Thread.  It
//    is this call that actually writes a string to the comm file.
//    Note that this call blocks and waits for the Write to complete
//    or for the CloseEvent object to signal that the thread should end.
//    Another possible reason for returning FALSE is if the comm port
//    is closed by the service provider.
//
//

function TWriteThread.HandleWriteData(lpOverlappedWrite: POverlapped;
  pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean;
var
  dwLastError,

  dwNumberOfBytesWritten,
    dwWhereToStartWriting,

  dwHandleSignaled: DWORD;
  HandlesToWaitFor: array[0..1] of THandle;
begin
  Result := False;

  dwNumberOfBytesWritten := 0;
  dwWhereToStartWriting := 0;           // Start at the beginning.

  HandlesToWaitFor[0] := hCloseEvent;
  HandlesToWaitFor[1] := lpOverlappedWrite^.hEvent;

     // Keep looping until all characters have been written.
  repeat
           // Start the overlapped I/O.
    if not WriteFile(hCommFile,
      pDataToWrite[dwWhereToStartWriting],
      dwNumberOfBytesToWrite, dwNumberOfBytesWritten,
      lpOverlappedWrite) then
    begin
                // WriteFile failed.  Expected; lets handle it.
      dwLastError := GetLastError;

                // Its possible for this error to occur if the
                // service provider has closed the port.  Time to end.
      if dwLastError = ERROR_INVALID_HANDLE then
        Exit;

                // Unexpected error.  No idea what.
      if dwLastError <> ERROR_IO_PENDING then
      begin
        PostHangupCall;
        Exit
      end;

                // This is the expected ERROR_IO_PENDING case.

                // Wait for either overlapped I/O completion,
                // or for the CloseEvent to get signaled.
      dwHandleSignaled := WaitForMultipleObjects(2, @HandlesToWaitFor,
        False, INFINITE);

      case dwHandleSignaled of
        WAIT_OBJECT_0:                  // CloseEvent signaled!
          begin
                     // Time to exit.
            Exit
          end;

        WAIT_OBJECT_0 + 1:              // Wait finished.
          begin
                     // Time to get the results of the WriteFile
            if not GetOverlappedResult(hCommFile,
              lpOverlappedWrite^,
              dwNumberOfBytesWritten, True) then
            begin
              dwLastError := GetLastError;

                          // Its possible for this error to occur if the
                          // service provider has closed the port.
              if dwLastError = ERROR_INVALID_HANDLE then
                Exit;

                          // No idea what could cause another error.
              PostHangupCall;
              Exit
            end
          end;

        WAIT_FAILED:                    // Wait failed.  Shouldn't happen.
          begin
            PostHangupCall;
            Exit
          end

      else                              // This case should never occur.
        begin
          PostHangupCall;
          Exit
        end
      end                               {case}
    end;                                {WriteFile failure}

           // Some data was written.  Make sure it all got written.

    Dec(dwNumberOfBytesToWrite, dwNumberOfBytesWritten);
    Inc(dwWhereToStartWriting, dwNumberOfBytesWritten)
  until (dwNumberOfBytesToWrite <= 0);  // Write the whole thing!

     // Wrote the whole string.
  Result := True
end;                                    {TWriteThread.HandleWriteData}

procedure TWriteThread.PostHangupCall;
begin
  PostMessage(hComm32Window, PWM_REQUESTHANGUP, 0, 0)
end;

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

end.