unit Comm32; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Misc; const PWM_GOTCOMMDATA = WM_USER + 1; PWM_REQUESTHANGUP = WM_USER + 2; type ECommsError = class( Exception ); TReadThread = class( TThread ) protected procedure Execute; override; public hCommFile: THandle; hCloseEvent: THandle; hComm32Window: THandle; function SetupCommEvent( lpOverlappedCommEvent: POverlapped; var lpfdwEvtMask: DWORD ): Boolean; function SetupReadEvent( lpOverlappedRead: POverlapped; lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD; var lpnNumberOfBytesRead: DWORD ): Boolean; function HandleCommEvent( lpOverlappedCommEvent: POverlapped; var lpfdwEvtMask: DWORD; fRetrieveEvent: Boolean ): Boolean; function HandleReadEvent( lpOverlappedRead: POverlapped; lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD; var lpnNumberOfBytesRead: DWORD ): Boolean; function HandleReadData( lpszInputBuffer: LPCSTR; dwSizeofBuffer: DWORD ): Boolean; function ReceiveData( lpNewString: LPSTR; dwSizeofNewString: DWORD ): BOOL; procedure PostHangupCall; end; TWriteThread = class( TThread ) protected procedure Execute; override; function HandleWriteData( lpOverlappedWrite: POverlapped; pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean; public hCommFile: THandle; hCloseEvent: THandle; hComm32Window: THandle; function WriteComm( pDataToWrite: LPCSTR; dwSizeofDataToWrite: DWORD ): Boolean; procedure PostHangupCall; end; TReceiveDataEvent = procedure(Sender:TObject; Buffer: Pointer; BufferLength: Word ) of object; TComm32 = class( TComponent ) private { Private declarations } ReadThread: TReadThread; WriteThread: TWriteThread; FCommsLogFileName, FCommPort: string; hCloseEvent: THandle; FOnReceiveData: TReceiveDataEvent; FOnRequestHangup: TNotifyEvent; FHWnd: THandle; FBaudRate: DWORD; FBits: DWORD; FStopBits: DWORD; FReadInterval:Integer; procedure SetCommsLogFileName( LogFileName: string ); function GetReceiveDataEvent: TReceiveDataEvent; procedure SetReceiveDataEvent( AReceiveDataEvent: TReceiveDataEvent ); function GetRequestHangupEvent: TNotifyEvent; procedure SetRequestHangupEvent( ARequestHangupEvent: TNotifyEvent ); procedure CommWndProc( var msg: TMessage ); protected { Protected declarations } procedure CloseReadThread; procedure CloseWriteThread; procedure ReceiveData( Buffer: PChar; BufferLength: Word ); procedure RequestHangup; public { Public declarations } hCommFile: THandle; constructor Create( AOwner: TComponent ); override; destructor Destroy; override; function StartComm: Boolean; procedure StopComm; function WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean; published { Published declarations } property BaudRate: DWORD read FBaudRate write FBaudRate; property Bits: DWORD read FBits write FBits; property StopBits: DWORD read FStopBits write FStopBits; property CommPort: string read FCommPort write FCommPort; property CommsLogFileName: string read FCommsLogFileName write SetCommsLogFileName; property OnReceiveData: TReceiveDataEvent read GetReceiveDataEvent write SetReceiveDataEvent; property OnRequestHangup: TNotifyEvent read GetRequestHangupEvent write SetRequestHangupEvent; property ReadInterval: Integer read FReadInterval write FReadInterval default 20; end; const PWM_COMMWRITE = WM_USER+1; INPUTBUFFERSIZE = 2048; var CommsLogFile: Text; procedure LogDebugInfo( outstr: PChar ); procedure LogDebugLastError( dwLastError: DWORD; szPrefix: LPSTR ); procedure Register; implementation var CommsLogName: string; constructor TComm32.Create( AOwner: TComponent ); begin inherited Create( AOwner ); FCommPort := 'COM2'; FCommsLogFileName := ''; CommsLogName := ''; ReadThread := nil; WriteThread := nil; hCommFile := 0; if not (csDesigning in ComponentState) then FHWnd := AllocateHWnd(CommWndProc); FReadInterval:=25; end; destructor TComm32.Destroy; begin if not (csDesigning in ComponentState) then begin DeallocateHWnd(FHwnd); end; inherited Destroy; end; function TComm32.StartComm: Boolean; var commtimeouts: TCommTimeouts; dcb: Tdcb; commprop: TCommProp; fdwEvtMask: DWORD; hNewCommFile: THandle; begin if (hCommFile <> 0) then raise ECommsError.Create( 'Порт уже открыт' ); if CommsLogFileName <> '' then begin AssignFile( CommsLogFile, fCommsLogFileName ); Rewrite( CommsLogFile ); end; hNewCommFile := CreateFile(PChar(fCommPort),GENERIC_READ+GENERIC_WRITE,0,nil,OPEN_EXISTING, {FILE_ATTRIBUTE_NORMAL+}FILE_FLAG_OVERLAPPED,0 ); if hNewCommFile = INVALID_HANDLE_VALUE then raise ECommsError.Create( 'Ошибка открытия порта' ); if GetFileType( hNewCommFile ) <> FILE_TYPE_CHAR then raise ECommsError.Create( 'Неверный указатель. ' ); hCommFile := hNewCommFile; GetCommState( hNewCommFile, dcb ); GetCommProperties( hNewCommFile, commprop ); GetCommMask( hCommFile, fdwEvtMask ); GetCommTimeouts( hCommFile, commtimeouts ); commtimeouts.ReadIntervalTimeout := FReadInterval; commtimeouts.ReadTotalTimeoutMultiplier := 0; commtimeouts.ReadTotalTimeoutConstant := 0; commtimeouts.WriteTotalTimeoutMultiplier := 0; commtimeouts.WriteTotalTimeoutConstant := 0; SetCommTimeouts( hCommFile, commtimeouts ); dcb.BaudRate := FBaudRate; dcb.StopBits:=ONESTOPBIT; dcb.ByteSize:=FBits; SetCommState( hNewCommFile, dcb ); GetCommState( hNewCommFile, dcb ); dcb.ByteSize:=8; hCloseEvent := CreateEvent( nil, True, False, nil ); if hCloseEvent = 0 then begin LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' ); hCommFile := 0; Result := False; Exit end; try ReadThread := TReadThread.Create( True {suspended} ); except LogDebugLastError( GetLastError, 'Unable to create Read thread' ); raise ECommsError.Create( 'Unable to create Read thread' ); end; ReadThread.hCommFile := hCommFile; ReadThread.hCloseEvent := hCloseEvent; ReadThread.hComm32Window := FHWnd; ReadThread.Resume; ReadThread.Priority := tpHighest; try WriteThread := TWriteThread.Create( True {suspended} ); except LogDebugLastError( GetLastError, 'Unable to create Write thread' ); raise ECommsError.Create( 'Unable to create Write thread' ); end; WriteThread.hCommFile := hCommFile; WriteThread.hCloseEvent := hCloseEvent; WriteThread.hComm32Window := FHWnd; WriteThread.Resume; ReadThread.Priority := tpHigher; Result := True; end; procedure TComm32.StopComm; begin if hCommFile = 0 then Exit; LogDebugInfo( 'Stopping the Comm' ); CloseReadThread; CloseWriteThread; CloseHandle( hCloseEvent ); CloseHandle( hCommFile ); hCommFile := 0; if fCommsLogFileName <> '' then CloseFile( CommsLogFile ); end; function TComm32.WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean; var Buffer: Pointer; begin if WriteThread <> nil then begin Buffer := Pointer(LocalAlloc( LPTR, dwSizeofDataToWrite+1 )); Move( pDataToWrite^, Buffer^, dwSizeofDataToWrite ); if PostThreadMessage( WriteThread.ThreadID, PWM_COMMWRITE, WPARAM(dwSizeofDataToWrite), LPARAM(Buffer) ) then begin Result := true; Exit; end else LogDebugInfo( 'Failed to Post to Write thread. ' ); end else LogDebugInfo( 'Write thread not created' ); Result := False; end; {TComm32.WriteCommData} procedure TComm32.CloseReadThread; begin // If it exists... if ReadThread <> nil then begin LogDebugInfo( 'Closing Read Thread '); // 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, 5000) = WAIT_TIMEOUT) then begin LogDebugInfo( 'Read thread not exiting. Terminating it.' ); ReadThread.Terminate; end; ReadThread.Free; ReadThread := nil; end; end; {TComm32.CloseReadThread} procedure TComm32.CloseWriteThread; begin // If it exists... if WriteThread <> nil then begin LogDebugInfo( 'Closing Write Thread' ); // Signal the event to close the worker threads. SetEvent(hCloseEvent); // Purge all outstanding writes. PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR); // Wait 10 seconds for it to exit. Shouldn't happen. if WaitForSingleObject( WriteThread.Handle, 5000 ) = WAIT_TIMEOUT then begin LogDebugInfo( 'Write thread not exiting. Terminating it.' ); WriteThread.Terminate; end; WriteThread.Free; WriteThread := nil; end; end; {TComm32.CloseWriteThread} procedure TComm32.ReceiveData( Buffer: PChar; BufferLength: Word ); var Str:String; begin Str:=Buffer; if copy(Str,1,10)='Comm Event' then exit; if Assigned(FOnReceiveData) then FOnReceiveData(self, Buffer, BufferLength ); end; procedure TComm32.RequestHangup; begin if Assigned(FOnRequestHangup) then FOnRequestHangup( Self ); end; (******************************************************************************) // TCOMM32 PRIVATE METHODS (******************************************************************************) procedure TComm32.SetCommsLogFileName( LogFileName: string ); begin CommsLogName := LogFileName; FCommsLogFileName := LogFileName; end; procedure TComm32.CommWndProc( var msg: TMessage ); begin case msg.msg of PWM_GOTCOMMDATA: begin ReceiveData( PChar(msg.LParam), msg.WParam ); LocalFree( msg.LParam ); end; PWM_REQUESTHANGUP: RequestHangup; end; end; function TComm32.GetReceiveDataEvent: TReceiveDataEvent; begin Result := FOnReceiveData; end; procedure TComm32.SetReceiveDataEvent( AReceiveDataEvent: TReceiveDataEvent ); begin FOnReceiveData := AReceiveDataEvent; end; function TComm32.GetRequestHangupEvent: TNotifyEvent; begin Result := FOnRequestHangup; end; procedure TComm32.SetRequestHangupEvent( ARequestHangupEvent: TNotifyEvent ); begin FOnRequestHangup := ARequestHangupEvent; end; procedure TReadThread.Execute; var szInputBuffer: array[0..INPUTBUFFERSIZE-1] of Char; nNumberOfBytesRead: DWORD; HandlesToWaitFor: array[0..2] of THandle; dwHandleSignaled: DWORD; fdwEvtMask: DWORD; // Needed for overlapped I/O (ReadFile) overlappedRead: TOverlapped; // Needed for overlapped Comm Event handling. overlappedCommEvent: TOverlapped; label EndReadThread; begin FillChar( overlappedRead, Sizeof(overlappedRead), 0 ); FillChar( overlappedCommEvent, Sizeof(overlappedCommEvent), 0 ); // Lets put an event in the Read overlapped structure. overlappedRead.hEvent := CreateEvent( nil, True, True, nil); if overlappedRead.hEvent = 0 then begin LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' ); PostHangupCall; goto EndReadThread; end; // And an event for the CommEvent overlapped structure. overlappedCommEvent.hEvent := CreateEvent( nil, True, True, nil); if overlappedCommEvent.hEvent = 0 then begin LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' ); PostHangupCall(); goto EndReadThread; end; // We will be waiting on these objects. HandlesToWaitFor[0] := hCloseEvent; HandlesToWaitFor[1] := overlappedCommEvent.hEvent; HandlesToWaitFor[2] := overlappedRead.hEvent; // Setup CommEvent handling. // Set the comm mask so we receive error signals. if not SetCommMask(hCommFile, EV_ERR) then begin LogDebugLastError( GetLastError, 'Unable to SetCommMask: ' ); PostHangupCall; goto EndReadThread; end; // Start waiting for CommEvents (Errors) if not SetupCommEvent( @overlappedCommEvent, fdwEvtMask ) then begin LogDebugLastError( GetLastError, 'Unable to SetupCommEvent1: ' ); PostHangupCall; goto EndReadThread; end; // Start waiting for Read events. if not SetupReadEvent( @overlappedRead, szInputBuffer, INPUTBUFFERSIZE, nNumberOfBytesRead ) then begin LogDebugLastError( GetLastError, 'Unable to SetupReadEvent: ' ); PostHangupCall; goto EndReadThread; end; // Keep looping until we break out. while True do begin // Wait until some event occurs (data to read; error; stopping). dwHandleSignaled := WaitForMultipleObjects(3, @HandlesToWaitFor, False, INFINITE); if dwHandleSignaled=WAIT_TIMEOUT then begin PostHangupCall; end; // Which event occured? case dwHandleSignaled of WAIT_OBJECT_0: // Signal to end the thread. begin // Time to exit. OutputDebugString( 'Time to Exit' ); goto EndReadThread; end; WAIT_OBJECT_0 + 1: // CommEvent signaled. begin // Handle the CommEvent. if not HandleCommEvent( @overlappedCommEvent, fdwEvtMask, TRUE ) then begin PostHangupCall; LogDebugLastError( GetLastError, 'Unable HandleCommEvent: ' ); goto EndReadThread; end; // Start waiting for the next CommEvent. if not SetupCommEvent( @overlappedCommEvent, fdwEvtMask ) then begin PostHangupCall; LogDebugLastError( GetLastError, 'Unable to SetupCommEvent2: ' ); goto EndReadThread; end; {break;??} end; WAIT_OBJECT_0 + 2: // Read Event signaled. begin // Get the new data! if not HandleReadEvent( @overlappedRead, szInputBuffer, INPUTBUFFERSIZE, nNumberOfBytesRead ) then begin PostHangupCall; LogDebugLastError( GetLastError, 'Unable to HandleReadEvent: ' ); goto EndReadThread; end; // Wait for more new data. if not SetupReadEvent( @overlappedRead, szInputBuffer, INPUTBUFFERSIZE, nNumberOfBytesRead ) then begin PostHangupCall; goto EndReadThread; end; {break;} end; WAIT_FAILED: // Wait failed. Shouldn't happen. begin LogDebugLastError( GetLastError, 'Read WAIT_FAILED: ' ); PostHangupCall; goto EndReadThread; end; else // This case should never occur. begin LogDebugInfo( PChar('Unexpected Wait return value '+ IntToStr(dwHandleSignaled)) ); PostHangupCall; goto EndReadThread; end; end; {case dwHandleSignaled} end; {while True} // Time to clean up Read Thread. EndReadThread: LogDebugInfo( 'Read thread shutting down' ); PurgeComm( hCommFile, PURGE_RXABORT + PURGE_RXCLEAR ); CloseHandle( overlappedRead.hEvent ); CloseHandle( overlappedCommEvent.hEvent ); end; {TReadThread.Execute} function TReadThread.SetupReadEvent( lpOverlappedRead: POverlapped; lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD; var lpnNumberOfBytesRead: DWORD ): Boolean; var dwLastError: DWORD; label StartSetupReadEvent; begin StartSetupReadEvent: Result := False; // Make sure the CloseEvent hasn't been signaled yet. // Check is needed because this function is potentially recursive. if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent, 10) then Exit; // Start the overlapped ReadFile. if ReadFile( hCommFile, lpszInputBuffer^, dwSizeofBuffer, lpnNumberOfBytesRead, lpOverlappedRead ) then begin // This would only happen if there was data waiting to be read. LogDebugInfo( 'Data waiting for ReadFile: '); // Handle the data. if not HandleReadData( lpszInputBuffer, lpnNumberOfBytesRead ) then Exit; // Start waiting for more data. goto StartSetupReadEvent; end; // ReadFile failed. Expected because of overlapped I/O. dwLastError := GetLastError; // LastError was ERROR_IO_PENDING, as expected. if dwLastError = ERROR_IO_PENDING then begin LogDebugInfo( 'Waiting for data from comm connection.' ); 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 begin LogDebugInfo( 'ERROR_INVALID_HANDLE, '+ 'Likely that the Service Provider has closed the port.' ); Exit; end; // Unexpected error. No idea what could cause this to happen. LogDebugLastError( dwLastError, 'Unexpected ReadFile error: ' ); PostHangupCall; end; {TReadThread.SetupReadEvent} function TReadThread.HandleReadData( lpszInputBuffer: LPCSTR; dwSizeofBuffer: DWORD ): Boolean; var lpszPostedBytes: LPSTR; tempstr: string; begin Result := False; // If we got data and didn't just time out empty... if dwSizeofBuffer <> 0 then begin tempstr := lpszInputBuffer; // Do something with the bytes read. LogDebugInfo( 'Got something from Comm port!!!' ); lpszPostedBytes := PChar( LocalAlloc( LPTR, dwSizeofBuffer+1 ) ); if lpszPostedBytes = nil{NULL} then begin LogDebugLastError( GetLastError, 'LocalAlloc: ' ); Exit; end; Move( lpszInputBuffer^, lpszPostedBytes^, dwSizeofBuffer ); lpszPostedBytes[dwSizeofBuffer] := #0; Result := ReceiveData( lpszPostedBytes, dwSizeofBuffer ); end; end; {TReadThread.HandleReadData} function TReadThread.HandleReadEvent( lpOverlappedRead: POverlapped; lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD; var lpnNumberOfBytesRead: DWORD ): Boolean; var dwLastError: DWORD; begin Result := False; if GetOverlappedResult( hCommFile, lpOverlappedRead^, lpnNumberOfBytesRead, False ) then begin Result := HandleReadData( lpszInputBuffer, lpnNumberOfBytesRead ); Exit; end; // Error in GetOverlappedResult; 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 begin LogDebugInfo( 'ERROR_INVALID_HANDLE, '+ 'Likely that the Service Provider has closed the port.' ); Exit; end; LogDebugLastError( dwLastError, 'Unexpected GetOverlappedResult Read Error: ' ); PostHangupCall; end; {TReadThread.HandleReadEvent} 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, 10 ) 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. LogDebugInfo( 'Event (Error) waiting before WaitCommEvent.' ); if not HandleCommEvent( nil, lpfdwEvtMask, False ) then {??? GetOverlappedResult does not handle "NIL" as defined by Borland} Exit; // 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 LogDebugInfo( 'Waiting for a CommEvent (Error) to occur.' ); 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 begin LogDebugInfo( 'ERROR_INVALID_HANDLE, '+ 'Likely that the Service Provider has closed the port.' ); Exit; end; // Unexpected error. No idea what could cause this to happen. LogDebugLastError( dwLastError, 'Unexpected WaitCommEvent error: ' ); end; {TReadThread.SetupCommEvent} function TReadThread.HandleCommEvent( lpOverlappedCommEvent: POverlapped; var lpfdwEvtMask: DWORD; fRetrieveEvent: Boolean ): Boolean; var dwDummy: DWORD; lpszOutput: LPSTR; szError: array[0..127] of Char; dwErrors, nOutput, dwLastError: DWORD; begin Result := False; szError[0] := #0; lpszOutput := PChar(LocalAlloc( LPTR, 256 )); if lpszOutput = nil{NULL} then begin LogDebugLastError( GetLastError, 'LocalAlloc: ' ); Exit; end; // 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 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 begin LogDebugInfo( 'ERROR_INVALID_HANDLE, '+ 'Likely that the Service Provider has closed the port.' ); Exit; end; LogDebugLastError( dwLastError, 'Unexpected GetOverlappedResult for WaitCommEvent: ' ); Exit; 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 begin LogDebugInfo( 'ERROR_INVALID_HANDLE, '+ 'Likely that the Service Provider has closed the port.' ); Exit; end; LogDebugLastError( GetLastError,'ClearCommError: ' ); 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 dwErrors = 0 then strcat( szError, 'NULL Error' ); if (dwErrors and CE_FRAME) <> 0 then begin if szError[0] <> #0 then strcat( szError, ' and ' ); strcat( szError,'CE_FRAME' ); end; if (dwErrors and CE_OVERRUN) <> 0 then begin if szError[0] <> #0 then strcat(szError, ' and ' ); strcat( szError, 'CE_OVERRUN' ); end; if (dwErrors and CE_RXPARITY) <> 0 then begin if szError[0] <> #0 then strcat( szError, ' and ' ); strcat( szError, 'CE_RXPARITY' ); end; if (dwErrors and not (CE_FRAME + CE_OVERRUN + CE_RXPARITY)) <> 0 then begin if szError[0] <> #0 then strcat( szError, ' and ' ); strcat( szError, 'EV_ERR Unknown EvtMask' ); end; nOutput := wsprintf(lpszOutput, PChar('Comm Event: '+szError+', EvtMask = '+IntToStr(dwErrors)) ); ReceiveData( lpszOutput, nOutput ); Result := True; Exit end; // Should not have gotten here. Only interested in ERR conditions. LogDebugInfo( PChar('Unexpected comm event '+IntToStr(lpfdwEvtMask)) ); end; {TReadThread.HandleCommEvent} function TReadThread.ReceiveData( lpNewString: LPSTR; dwSizeofNewString: DWORD ): BOOL; begin Result := PostMessage( hComm32Window, PWM_GOTCOMMDATA, WPARAM(dwSizeofNewString), LPARAM(lpNewString) ); end; procedure TReadThread.PostHangupCall; begin PostMessage( hComm32Window, PWM_REQUESTHANGUP, 0, 0 ); end; procedure TWriteThread.Execute; var msg: TMsg; dwHandleSignaled: DWORD; overlappedWrite: TOverLapped; 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 LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' ); PostHangupCall; goto EndWriteThread; end; // 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. 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 LogDebugLastError( GetLastError, 'Write WAIT_FAILED: ' ); PostHangupCall; goto EndWriteThread; end; else // This case should never occur. begin LogDebugInfo( PChar('Unexpected Wait return value ' +IntToStr(dwHandleSignaled)) ); PostHangupCall; goto EndWriteThread; end; end; end; // Make sure the CloseEvent isn't signaled while retrieving messages. if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent, 10) 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 LogDebugInfo( 'Writing to comm port' ); // 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; // Data was sent in a LocalAlloc()d buffer. Must free it. LocalFree( HLOCAL(msg.lParam) ); end; // What other messages could the thread get? else begin LogDebugInfo( PChar('Unexpected message posted to Write thread: '+ IntToStr(msg.message)) ); {break;} end; end; {case} end; {main loop} // Thats the end. Now clean up. EndWriteThread: LogDebugInfo( 'Write thread shutting down' ); PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR); CloseHandle(overlappedWrite.hEvent); end; {TWriteThread.Execute} function TWriteThread.HandleWriteData( lpOverlappedWrite: POverlapped; pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean; var dwLastError, dwNumberOfBytesWritten, dwWhereToStartWriting, dwHandleSignaled: DWORD; HandlesToWaitFor: array[0..1] of THandle; begin 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 begin LogDebugInfo( 'ERROR_INVALID_HANDLE, '+ 'Likely that the Service Provider has closed the port.' ); Result := False; Exit; end; // Unexpected error. No idea what. if dwLastError <> ERROR_IO_PENDING then begin LogDebugLastError( dwLastError, 'Error to writing to CommFile' ); LogDebugInfo( 'Closing TAPI' ); PostHangupCall; Result := False; 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, 5000); case dwHandleSignaled of WAIT_OBJECT_0: // CloseEvent signaled! begin // Time to exit. Result := False; Exit; end; WAIT_OBJECT_0 + 1: // Wait finished. begin // Time to get the results of the WriteFile end; WAIT_FAILED: // Wait failed. Shouldn't happen. begin LogDebugLastError( GetLastError, 'Write WAIT_FAILED: ' ); PostHangupCall; Result := False; Exit end; else // This case should never occur. begin LogDebugInfo( PChar('Unexpected Wait return value '+ IntToStr(dwHandleSignaled)) ); PostHangupCall; Result := False; Exit end; end; {case} 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 begin LogDebugInfo('ERROR_INVALID_HANDLE, '+ 'Likely that the Service Provider has closed the port.'); Result := False; Exit; end; // No idea what could cause another error. LogDebugLastError( dwLastError, 'Error writing to CommFile while waiting'); LogDebugInfo('Closing TAPI'); PostHangupCall; Result := False; Exit; end; 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} function TWriteThread.WriteComm( pDataToWrite: LPCSTR; dwSizeofDataToWrite: DWORD ): Boolean; begin Result := PostThreadMessage( ThreadID, PWM_COMMWRITE, WParam(dwSizeofDataToWrite), LParam(pDataToWrite) ); end; procedure TWriteThread.PostHangupCall; begin PostMessage( hComm32Window, PWM_REQUESTHANGUP, 0, 0 ); end; procedure LogDebugLastError( dwLastError: DWORD; szPrefix: LPSTR ); var szLastError: LPSTR; szOutputLastError: array[0..MAXOUTPUTSTRINGLENGTH-1] of Char; begin if szPrefix = nil then szPrefix := ''; // Pretty print the error. szLastError := FormatLastError(dwLastError, nil, 0); // The only reason FormatLastError should fail is "Out of memory". if szLastError = nil then begin wsprintf( szOutputLastError, PChar(szPrefix+'Out of memory') ); LogDebugInfo( szOutputLastError ); Exit; end; wsprintf( szOutputLastError, PChar(szPrefix+'GetLastError returned: "'+szLastError+'"') ); // Pointer returned from FormatLineError *must* be freed! LocalFree( HLOCAL(szLastError) ); // Print it! LogDebugInfo( szOutputLastError ); end; {LogDebugLastError} procedure LogDebugInfo( outstr: PChar ); begin if CommsLogName <> '' then Writeln( CommsLogFile, outstr ); end; {LogDebugInfo} procedure Register; begin RegisterComponents('CyD', [TComm32]); end; end.