easylinux/SignauxComplexes
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
aad2526b3ddd1f4e80cb3e9286392ed0c04f871b
SignauxComplexes/LNSWin32.pas
f1iwq2 7d2c4bd591 V9.2
2024-08-24 09:12:51 +02:00

1279 lines
44 KiB
ObjectPascal
Raw Blame History

(***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower Async Professional
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1991-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
* Stephen W. Boyd - Created this module to replace serial port
* dispatcher. The old dispatcher was too
* prone to suffering input overruns if the
* event handlers didn't return control to
* the dispatch thread fast enough.
* August 2005.
* Sulaiman Mah
* Sean B. Durkin
* Sebastian Zierer
* ***** END LICENSE BLOCK ***** *)
{*********************************************************}
{* LNSWIN32.PAS 4.06 *}
{*********************************************************}
{* Win32 serial device layer and dispatcher *}
{*********************************************************}
{Global defines potentially affecting this unit}
{$I AWDEFINE.INC}
{ A direct replacement for AwWin32.pas. The multithreading aspects have been
redesigned where necessary to make it more efficient and less prone to
data overruns. Anything not directly related to multithreading has been
stolen from AwWin32.pas mostly unchanged.
TApdTAPIDispatcher stolen in its entirety from AwWin32.pas
The Win32 Dispatcher now consists of 4 threads. These are:
1) TReadThread - Waits for TStatusThread to notify it that an EV_RXCHAR
event has occured and reads as much data as is
available at that time. It also reads any available data
every 50 ms just in case we have a misbehaving driver
that doesn't provide the EV_RXCHAR event reliably.
All data read is placed onto a QueueProp for TDispThread
to process. This allows TDispThread, and hence any
event handlers, to take as much time as they need
without worrying about data overruns.
2) TWriteThread - Waits for output to appear in the dispatcher's output
buffer. It copies all available output to a temporary
buffer, marks the dispatcher's buffer as empty and
sends the data from the temporary buffer. This provides
a crude double buffering capability and improves
performance for streaming protocols like zmodem.
3) TStatusThread - Waits for serial port events by calling WaitCommEvent.
When an event occurs it either wakes up TReadThread or
queues a status change notification to TDispThread as
appropriate.
4) TDispThread - This is the original TDispThread from AwUser. It
continues largely unchanged from the original. The
only real difference is that it now waits for data to
appear in the QueueProp and reads from the QueueProp rather than
issuing its own WaitCommEvent and ReadFile calls.
The original serial port dispatcher in AwWin32 can still be used by setting
the condition UseAwWin32 and recompiling.
}
unit LNSWin32;
interface
uses Windows, AwUser, SysUtils, OoMisc, LNSQueue, SyncObjs;
type
TApdWin32Thread = class(TApdDispatcherThread)
private
function GetComHandle : THandle;
function GetDLoggingOn : Boolean;
function GetGeneralEvent : THandle;
function GetKillThreads : Boolean;
function GetQueue : TIOQueue;
function GetSerialEvent : TEvent;
procedure SetKillThreads(value : Boolean);
procedure ThreadGone(Sender : TObject);
procedure ThreadStart(Sender : TObject);
protected
procedure AddDispatchEntry(DT : TDispatchType;
DST : TDispatchSubType;
Data : Cardinal;
Buffer : Pointer;
BufferLen : Cardinal);
function WaitForOverlapped(ovl : POverlapped) : Integer; virtual;
property ComHandle : THandle read GetComHandle;
property DLoggingOn : Boolean read GetDLoggingOn;
property GeneralEvent : THandle read GetGeneralEvent;
property KillThreads : Boolean read GetKillThreads write SetKillThreads;
property QueueProp : TIOQueue read GetQueue;
property SerialEvent : TEvent read GetSerialEvent;
end;
TReadThread = class(TApdWin32Thread)
protected
procedure Execute; override;
function ReadSerial(Buf : PAnsiChar;
Size: Integer;
ovl : POverlapped) : Integer;
end;
TWriteThread = class(TApdWin32Thread)
private
function GetOutFlushEvent : THandle;
function GetOutputEvent : THandle;
protected
function DataInBuffer : Boolean;
procedure Execute; override;
function WaitForOverlapped(ovl : POverlapped) : Integer; override;
function WriteSerial(ovl : POverlapped) : Integer;
property OutFlushEvent : THandle read GetOutFlushEvent;
property OutputEvent : THandle read GetOutputEvent;
end;
TStatusThread = class(TApdWin32Thread)
private
LastMask : DWORD;
protected
procedure Execute; override;
function WaitSerialEvent(var EvtMask : DWORD;
ovl : POverlapped) : Integer;
end;
TApdWin32Dispatcher = class(TApdBaseDispatcher)
private
FSerialEvent : TEvent;
protected
function EscapeComFunction(Func : Integer) : Integer; override;
function FlushCom(QueueProp : Integer) : Integer; override;
function GetComError(var Stat : TComStat) : Integer; override;
function GetComEventMask(EvtMask : Integer) : Cardinal; override;
function GetComState(var DCB: TDCB): Integer; override;
function InQueueUsed : Cardinal; override;
function OutBufUsed: Cardinal; override;
function ReadCom(Buf : PAnsiChar; Size: Integer) : Integer; override;
function SetComState(var DCB : TDCB) : Integer; override;
function SetupCom(InSize, OutSize : Integer) : Boolean; override;
procedure StartDispatcher; override;
procedure StopDispatcher; override;
function WaitComEvent(var EvtMask : DWORD;
lpOverlapped : POverlapped) : Boolean; override;
function WriteCom(Buf : PAnsiChar; Size: Integer) : Integer; override;
public
constructor Create(Owner : TObject);
destructor Destroy; override;
function CloseCom : Integer; override;
function OpenCom(ComName: PChar; InQueue, OutQueue : Cardinal) : Integer; override;
function ProcessCommunications : Integer; override;
function CheckPort(ComName: PChar): Boolean; override;
end;
TApdTAPI32Dispatcher = class(TApdWin32Dispatcher)
public
constructor Create(Owner : TObject; InCid : Integer);
function OpenCom(ComName: PChar; InQueue,
OutQueue : Cardinal) : Integer; override;
end;
implementation
uses Math, StrUtils;
// TApdWin32Dispatcher methods
//
constructor TApdWin32Dispatcher.Create(Owner : TObject);
begin
inherited Create(Owner);
FSerialEvent := TEvent.Create(nil, False, False, '');
end;
destructor TApdWin32Dispatcher.Destroy;
begin
if (Assigned(FSerialEvent)) then
FSerialEvent.Free;
inherited Destroy;
end;
function TApdWin32Dispatcher.CheckPort(ComName: PChar): Boolean;
// Returns true if a port exists
var
Tmp: string;
CC: PCommConfig;
Len: Cardinal;
begin
Tmp := ComName;
if AnsiStartsText('\\.\', Tmp) then
Delete(Tmp, 1, 4);
New(CC);
try
FillChar(CC^, SizeOf(CC^), 0);
CC^.dwSize := SizeOf(CC^);
Len := SizeOf(CC^);
Result := GetDefaultCommConfig(PChar(Tmp), CC^, Len);
finally
Dispose(CC);
end;
if (not Result) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
begin
GetMem(CC, Len);
try
FillChar(CC^, SizeOf(CC^), 0);
CC^.dwSize := SizeOf(CC^);
Result := GetDefaultCommConfig(PChar(Tmp), CC^, Len);
finally
FreeMem(CC);
end;
end;
end;
// Close the comport and wait for the I/O threads to terminate
function TApdWin32Dispatcher.CloseCom : Integer;
var
ET : EventTimer;
begin
// Under certain circumstances, it is possible that CloseCom can be called
// recursively. In that event, we don't want to be re-executing this code.
// So, set a flag to show that we are inside this method and check it
// every time we enter. If it is already set, just exit and do nothing.
// This used to be accomplished by acquiring the DataSection critical section
// but this lead to occasional deadlocks.
EnterCriticalSection(DataSection);
if (CloseComActive) then
begin
LeaveCriticalSection(DataSection);
Result := 0;
Exit;
end;
CloseComActive := True;
LeaveCriticalSection(DataSection);
try
if DispActive then
begin
{ Set the flag to kill the threads next time they wake, or after }
{ their current processing }
KillThreads := True;
if Assigned(StatusThread) then
begin
{Force the comm thread to wake...}
SetCommMask(CidEx, 0);
SetEvent(ReadyEvent);
{...and wait for it to die}
while (StatusThread <> nil) do
SafeYield;
end;
if Assigned(OutThread) then
begin
{Force the output thread to wake...}
SetEvent(OutFlushEvent);
{...and wait for it to die}
while (OutThread <> nil) do
SafeYield;
end;
if Assigned(ComThread) then
begin
{Force the comm thread to wake...}
FSerialEvent.SetEvent;
{... and wait for it to die}
ResetEvent(GeneralEvent);
while (ComThread <> nil) do
SafeYield;
end;
{Now kill the timer}
KillTimer(0, TimerID);
if Assigned(DispThread) then
begin
{Wait for it to die}
NewTimer(ET, 36); { start a 2-second timer to prevent blocks }
while (DispThread <> nil) and not(TimerExpired(ET)) do
SafeYield;
if DispThread <> nil then
begin
{$IFDEF DebugThreadConsole}
WriteLn('DispThread<>nil');
{$ENDIF}
{ thread didn't die, reset the event }
SetEvent(ComEvent);
{Wait for it to die yet again}
NewTimer(ET, 36); { start a 2-second timer to prevent blocks }
while (DispThread <> nil) and not(TimerExpired(ET)) do
SafeYield;
if DispThread <> nil then
{ disp thread is not responding, brutally terminate it }
DispThread.Free;
end;
{$IFDEF DebugThreadConsole}
Writeln(ThreadStatus(DispKill));
{$ENDIF}
end;
{$IFDEF DebugThreadConsole}
Writeln(ThreadStatus(ComKill));
{$ENDIF}
end;
{Close the comport}
if (CidEx >= 0) then
begin
if CloseHandle(CidEx) then
begin
Result := 0;
CidEx := -1;
end else
Result := -1;
end else
Result := 0;
finally
CloseComActive := False;
end;
end;
function TApdWin32Dispatcher.EscapeComFunction(Func: Integer): Integer;
begin
EscapeCommFunction(CidEx, Func);
Result := 0;
end;
// Flush the I/O buffers. QueueProp = 0 - flush output queues. QueueProp = 1 - flush input.
function TApdWin32Dispatcher.FlushCom(QueueProp : Integer) : Integer;
begin
Result := 0;
if ((QueueProp = 0) and Assigned(OutThread)) then
begin
// Flush output buffers
EnterCriticalSection(OutputSection);
try
OBufFull := False;
OBufHead := 0;
OBufTail := 0;
finally
LeaveCriticalSection(OutputSection);
end;
Result := Integer(PurgeComm(CidEx, PURGE_TXABORT or PURGE_TXCLEAR));
// Wake up the output thread in case it was waiting for I/O completion
// and Windows failed to wake it up after we flushed the buffers.
SetEvent(OutFlushEvent);
WaitForSingleObject(GeneralEvent, 5000);
end;
if (QueueProp = 1) then
begin
// Flush input buffers
Result := Integer(PurgeComm(CidEx, PURGE_RXABORT or PURGE_RXCLEAR));
FQueue.Clear;
end;
end;
// Get the current error and status
function TApdWin32Dispatcher.GetComError(var Stat: TComStat): Integer;
var
Errors : DWORD;
begin
if (ClearCommError(CidEx, Errors, @Stat)) then
Result := Errors
else
Result := 0;
{Replace information about Windows output buffer with our own}
Stat.cbOutQue := OutBufUsed;
end;
// Set the communications event mask
function TApdWin32Dispatcher.GetComEventMask(EvtMask: Integer): Cardinal;
begin
Result := 0;
end;
// Fill in DCB with the current communications state
function TApdWin32Dispatcher.GetComState(var DCB: TDCB): Integer;
begin
if Integer(GetCommState(CidEx, DCB)) = 1 then
Result := 0
else
Result := -1;
end;
// Open the COM port specified by ComName
function TApdWin32Dispatcher.OpenCom(ComName: PChar; InQueue, OutQueue: Cardinal): Integer;
begin
{Open the device}
Result := CreateFile(ComName, {name}
GENERIC_READ or GENERIC_WRITE, {access attributes}
0, {no sharing}
nil, {no security}
OPEN_EXISTING, {creation action}
FILE_ATTRIBUTE_NORMAL or
FILE_FLAG_OVERLAPPED, {attributes}
0); {no template}
if Result <> Integer(INVALID_HANDLE_VALUE) then
begin
CidEx := Result;
end else
{Failed to open port, just return error signal, caller will
call GetLastError to get actual error code}
Result := -1;
end;
// Return the number of bytes available to be read from the input QueueProp. Returns
// zero if the first buffer on the QueueProp is not a data buffer, returns the number
// of bytes available in the first buffer otherwise.
function TApdWin32Dispatcher.InQueueUsed : Cardinal;
var
bfr : TIOBuffer;
begin
bfr := FQueue.Peek;
if (Assigned(bfr)) then
begin
if (bfr is TDataBuffer) then
begin
Result := TDataBuffer(bfr).BytesUsed - TDataBuffer(bfr).BytesRead;
bfr.InUse := False;
end else
begin
Result := 0;
bfr.InUse := False;
end;
end else
Result := 0;
end;
// Return the number of bytes currently used in the output buffer
function TApdWin32Dispatcher.OutBufUsed: Cardinal;
begin
EnterCriticalSection(OutputSection);
try
Result := 0;
if OBufFull then
Result := OutQue
else if OBufHead > OBufTail then
{Buffer is not wrapped}
Result := OBufHead - OBufTail
else if OBufHead < OBufTail then
{Buffer is wrapped}
Result := OBufHead + (OutQue - OBufTail);
finally
LeaveCriticalSection(OutputSection);
end;
end;
// Communications are running in separate threads -- give them a chance
function TApdWin32Dispatcher.ProcessCommunications : Integer;
begin
Sleep(0);
Result := 0;
end;
// Rather than reading directly from the serial port, as we used to do, we
// now read from the input QueueProp.
function TApdWin32Dispatcher.ReadCom(Buf : PAnsiChar; Size: Integer) : Integer;
var
bfr : TIOBuffer;
len : Integer;
bytesToRead : Integer;
done : Boolean;
begin
len := Size;
done := False;
while (not done) do
begin
bfr := FQueue.Peek;
// We can only read if the first buffer on the QueueProp is a data buffer.
// If it is a status buffer, it must be processed first.
if (Assigned(bfr)) then
begin
if (bfr is TDataBuffer) then
begin
with TDataBuffer(bfr) do
begin
// Read either all the data in the buffer or as much as the caller
// can accept.
bytesToRead := Min(len, BytesUsed - BytesRead);
Move((Data + BytesRead)^, Buf^, bytesToRead);// --sm check
BytesRead := BytesRead + bytesToRead;
Dec(len, bytesToRead);
Inc(Buf, bytesToRead);
// If all data has been read from the buffer, remove it from the QueueProp
// and free it. Otherwise, leave it on the QueueProp so we can read
// the remainder on the next call to this subroutine.
if (BytesRead >= BytesUsed) then
begin
FQueue.Pop;
Free;
end else
InUse := False;
if (len <= 0) then
done := True;
end;
end else
begin
bfr.InUse := False;
done := True;
end;
end else
done := True;
end;
Result := Size - len; // ttl # bytes read
end;
// Set the a new communications device state from DCB
function TApdWin32Dispatcher.SetComState(var DCB: TDCB): Integer;
begin
if SetCommState(CidEx, DCB) then
Result := 0
else
Result := -Integer(GetLastError);
end;
// Set new in/out buffer sizes
function TApdWin32Dispatcher.SetupCom(InSize, OutSize : Integer) : Boolean;
begin
Result := SetupComm(CidEx, InSize, OutSize);
end;
// Start all threads and generally get the dispatcher ready to go
procedure TApdWin32Dispatcher.StartDispatcher;
begin
EnterCriticalSection(DataSection);
try
if (DispActive) then
raise Exception.Create('Dispatcher already started.');
DispActive := True;
KillThreads := False;
ComThread := TReadThread.Create(Self);
WaitForSingleObject(GeneralEvent, ThreadStartWait);
fDispThread := TDispThread.Create(Self);
WaitForSingleObject(GeneralEvent, ThreadStartWait);
OutThread := TWriteThread.Create(Self);
WaitForSingleObject(GeneralEvent, ThreadStartWait);
StatusThread := TStatusThread.Create(Self);
WaitForSingleObject(GeneralEvent, ThreadStartWait);
finally
LeaveCriticalSection(DataSection);
end;
end;
// Shutdown the dispatcher
procedure TApdWin32Dispatcher.StopDispatcher;
begin
if DispActive then
CloseCom;
if ComEvent <> INVALID_HANDLE_VALUE then
begin
if CloseHandle(ComEvent) then
ComEvent := INVALID_HANDLE_VALUE;
end;
if ReadyEvent <> INVALID_HANDLE_VALUE then
begin
if CloseHandle(ReadyEvent) then
ReadyEvent := INVALID_HANDLE_VALUE;
end;
if GeneralEvent <> INVALID_HANDLE_VALUE then
begin
if CloseHandle(GeneralEvent) then
GeneralEvent := INVALID_HANDLE_VALUE;
end;
if OutputEvent <> INVALID_HANDLE_VALUE then
begin
if CloseHandle(OutputEvent) then
OutputEvent := INVALID_HANDLE_VALUE;
end;
if SentEvent <> INVALID_HANDLE_VALUE then
begin
if CloseHandle(SentEvent) then
SentEvent := INVALID_HANDLE_VALUE;
end;
if OutFlushEvent <> INVALID_HANDLE_VALUE then
begin
if CloseHandle(OutFlushEvent) then
OutFlushEvent := INVALID_HANDLE_VALUE;
end;
end;
// This doesn't apply to WIN32 dispatcher any more
function TApdWin32Dispatcher.WaitComEvent(var EvtMask : DWORD;
lpOverlapped : POverlapped) : Boolean;
begin
EvtMask := 0;
Result := True;
end;
// Place outbound data into the output buffer & wake up the output thread
function TApdWin32Dispatcher.WriteCom(Buf: PAnsiChar; Size: Integer): Integer;
type
PBArray = ^TBArray;
TBArray = array[0..pred(High(Integer))] of Byte;
var
SizeAtEnd : Integer;
LeftOver : Integer;
begin
{Add the data to the output QueueProp}
EnterCriticalSection(OutputSection);
try
{we already know at this point that there is enough room for the block}
SizeAtEnd := OutQue - OBufHead;
if SizeAtEnd >= Size then
begin
{can move data to output QueueProp in one block}
Move(Buf^, OBuffer^[OBufHead], Size);
if SizeAtEnd = Size then
OBufHead := 0
else
Inc(OBufHead, Size);
end else
begin
{ need to use two moves }
Move(Buf^, OBuffer^[OBufHead], SizeAtEnd);
LeftOver := Size - SizeAtEnd;
Move(PBArray(Buf)^[SizeAtEnd], OBuffer^, LeftOver);
OBufHead := LeftOver;
end;
finally
LeaveCriticalSection(OutputSection);
end;
{...finally, wake up the output thread to send the data}
SetEvent(OutputEvent);
Result := Size; {report all was sent}
end;
// TApdWin32Threads. Contains some general support routines required by both
// read & write threads.
procedure TApdWin32Thread.AddDispatchEntry(DT : TDispatchType;
DST : TDispatchSubType;
Data : Cardinal;
Buffer : Pointer;
BufferLen : Cardinal);
begin
TApdWin32Dispatcher(H).AddDispatchEntry(DT, DST, Data, Buffer, BufferLen);
end;
function TApdWin32Thread.GetComHandle : THandle;
begin
Result := TApdWin32Dispatcher(H).ComHandle;
end;
function TApdWin32Thread.GetDLoggingOn : Boolean;
begin
Result := TApdWin32Dispatcher(H).DLoggingOn;
end;
function TApdWin32Thread.GetGeneralEvent : THandle;
begin
Result := TApdWin32Dispatcher(H).GeneralEvent;
end;
function TApdWin32Thread.GetKillThreads : Boolean;
begin
Result := TApdWin32Dispatcher(H).KillThreads;
end;
function TApdWin32Thread.GetQueue : TIOQueue;
begin
Result := TApdWin32Dispatcher(H).FQueue;
end;
function TApdWin32Thread.GetSerialEvent : TEvent;
begin
Result := TApdWin32Dispatcher(H).FSerialEvent;
end;
procedure TApdWin32Thread.SetKillThreads(value : Boolean);
begin
TApdWin32Dispatcher(H).KillThreads := value;
end;
procedure TApdWin32Thread.ThreadGone(Sender : TObject);
begin
TApdWin32Dispatcher(H).ThreadGone(Sender);
end;
procedure TApdWin32Thread.ThreadStart(Sender : TObject);
begin
TApdWin32Dispatcher(H).ThreadStart(Sender);
end;
// Wait for an overlapped I/O to complete. We wake up every 100ms and check to
// see if the dispatcher has been shutdown.
function TApdWin32Thread.WaitForOverlapped(ovl : POverlapped) : Integer;
var
stat : DWORD;
bytesRead : Cardinal;
begin
repeat
stat := WaitForSingleObject(ovl.hEvent, 100);
until ((stat <> WAIT_TIMEOUT) or Terminated or KillThreads);
case stat of
WAIT_OBJECT_0:
if (GetOverlappedResult(ComHandle,
ovl^,
bytesRead,
True)) then
begin
Result := bytesRead;
ResetEvent(ovl.hEvent);
end else
Result := ecDeviceRead;
WAIT_TIMEOUT:
Result := 0;
else
Result := ecDeviceRead;
end;
end;
// TReadThread methods. This thread does nothing except wait for input
// from the comm port. When input is received it is placed onto the QueueProp
// for the dispatcher thread to process.
procedure TReadThread.Execute;
var
dbfr : TDataBuffer;
bytesRead : Integer;
stat : TWaitResult;
rovl : TOverlapped;
Timeouts : TCommTimeouts;
istat : Integer;
begin
ThreadStart(Self);
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadStart, 1, nil, 0);
{$ENDIF}
FillChar(rovl, SizeOf(rovl), 0);
rovl.hEvent := CreateEvent(nil, True, False, nil);
dbfr := nil;
try
// Set the timeouts so that a read will return immediately.
FillChar(Timeouts, SizeOf(TCommTimeouts), 0);
Timeouts.ReadIntervalTimeout := MaxDWord;
SetCommTimeouts(ComHandle, Timeouts);
ReturnValue := 0;
while ((not Terminated) and (not KillThreads)) do
begin
// Wait for something to happen on the serial port
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadSleep, 1, nil, 0);
{$ENDIF}
stat := SerialEvent.WaitFor(50);
if ((stat <> wrSignaled) and (stat <> wrTimeout)) then
begin
ReturnValue := ecDeviceRead;
KillThreads := True;
Continue;
end;
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadWake, 1, nil, 0);
{$ENDIF}
// Was it an input arrival notification? If so, read the
// available input & QueueProp it to the dispatcher thread.
try
if (not Assigned(dbfr)) then
dbfr := TDataBuffer.Create(IO_BUFFER_SIZE);
except
dbfr := nil;
ReturnValue := ecNoMem;
KillThreads := True;
Continue;
end;
bytesRead := ReadSerial(dbfr.Data, dbfr.Size, @rovl);
while (bytesRead > 0) do
begin
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread,
dstThreadDataQueued,
ComHandle,
dbfr.Data,
bytesRead);
{$ENDIF}
dbfr.BytesUsed := bytesRead;
QueueProp.Push(dbfr);
try
dbfr := TDataBuffer.Create(IO_BUFFER_SIZE);
except
dbfr := nil;
ReturnValue := ecNoMem;
KillThreads := True;
Break;
end;
bytesRead := ReadSerial(dbfr.Data, dbfr.Size, @rovl);
end;
if (bytesRead < 0) then
begin
istat := GetLastError;
{$IFDEF DebugSerialIO}
MessageBox(0,
PChar(Format('ReadSerial failed! Error = %d.',
[istat])),
'',
MB_OK or MB_APPLMODAL or MB_ICONEXCLAMATION);
{$ENDIF}
// An invalid handle error means that someone else (probably
// TAPI) has closed the port. So just quit without an error.
if (istat <> ERROR_INVALID_HANDLE) then
ReturnValue := ecDeviceRead;
KillThreads := True;
Continue;
end;
end;
finally
CloseHandle(rovl.hEvent);
if (Assigned(dbfr)) then
dbfr.Free;
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadExit, 1, nil, 0);
{$ENDIF}
ThreadGone(Self);
end;
end;
// Read up to Size bytes from the serial port into Buf. Return the number of
// bytes read or a negative error number. An error code of ERROR_OPERATION_ABORTED
// is caused by flushing the com port so we just ignore it.
function TReadThread.ReadSerial(Buf : PAnsiChar;
Size : Integer;
ovl : POverlapped) : Integer;
var
bytesRead : Cardinal;
istat : Integer;
begin
if (not ReadFile(ComHandle, Buf^, Size, bytesRead, ovl)) then
begin
istat := GetLastError;
if (istat = ERROR_IO_PENDING) then
begin
Result := WaitForOverlapped(ovl);
if (Result < 0) then
begin
istat := GetLastError;
if (GetLastError = ERROR_OPERATION_ABORTED) then
Result := 0
else
TApdBaseDispatcher(H).LastWinError := istat;
end;
end else
begin
TApdBaseDispatcher(H).LastWinError := istat;
Result := ecDeviceRead;
end;
end else
Result := bytesRead;
end;
// TWriteThread methods. This thread does nothing except wait for data to
// be written to the comm port. When output arrives it is written to the
// port.
function TWriteThread.DataInBuffer : Boolean;
begin
with TApdWin32Dispatcher(H) do begin
EnterCriticalSection(OutputSection);
try
DataInBuffer := OBufFull or (OBufHead <> OBufTail);
finally
LeaveCriticalSection(OutputSection);
end;
end;
end;
procedure TWriteThread.Execute;
var
outEvents : array [0..1] of THandle;
stat : DWORD;
ovl : TOverlapped;
istat : Integer;
begin
ThreadStart(Self);
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadStart, 3, nil, 0);
{$ENDIF}
outEvents[0] := OutputEvent;
outEvents[1] := OutFlushEvent;
FillChar(ovl, SizeOf(ovl), 0);
ovl.hEvent := CreateEvent(nil, True, False, nil);
try
ReturnValue := 0;
while ((not Terminated) and (not KillThreads)) do
begin
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadSleep, 3, nil, 0);
{$ENDIF}
// Wait for output to appear in the QueueProp or for a flush request
stat := WaitForMultipleObjects(Length(outEvents),
@outEvents[0],
False,
100);
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadWake, 3, nil, 0);
{$ENDIF}
case stat of
WAIT_OBJECT_0:
// Output has arrived in buffer, send it
if (not KillThreads) then
if (WriteSerial(@ovl) <> 0) then
begin
istat := GetLastError;
{$IFDEF DebugSerialIO}
MessageBox(0,
PChar(Format('WriteSerial failed! Error = %d.',
[istat])),
'',
MB_OK or MB_APPLMODAL or MB_ICONEXCLAMATION);
{$ENDIF}
// An invalid handle error means that someone else (probably
// TAPI) has closed the port. So just quit without an error.
if (istat <> ERROR_INVALID_HANDLE) then
begin
TApdBaseDispatcher(H).LastWinError := istat;
ReturnValue := ecDeviceWrite;
end;
KillThreads := True;
end;
WAIT_OBJECT_0 + 1:
// Flush of output buffer requested, acknowledge & continue
SetEvent(GeneralEvent);
WAIT_TIMEOUT:
;
else
begin
TApdBaseDispatcher(H).LastWinError := GetLastError;
ReturnValue := ecDeviceWrite;
KillThreads := True;
end;
end;
end;
finally
CloseHandle(ovl.hEvent);
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadExit, 3, nil, 0);
{$ENDIF}
ThreadGone(Self);
end;
end;
function TWriteThread.GetOutFlushEvent : THandle;
begin
Result := TApdWin32Dispatcher(H).OutFlushEvent;
end;
function TWriteThread.GetOutputEvent : THandle;
begin
Result := TApdWin32Dispatcher(H).OutputEvent;
end;
// Write all data currently in the output buffer to the serial port. The
// output is copied to a temporary buffer first to free the main output buffer
// faster and to make buffer flush requests easier to handle properly.
function TWriteThread.WriteSerial(ovl : POverlapped) : Integer;
var
numToWrite : Integer;
numWritten : Cardinal;
count : Integer;
tempBuff : POBuffer;
stat : Integer;
begin
tempBuff := nil;
try
while (DataInBuffer) do
begin
with TApdWin32Dispatcher(H) do
begin
EnterCriticalSection(OutputSection);
try
// Move everything from the main buffer to a temporary buffer.
// This accomplishes 2 things: 1) It frees the main buffer so that
// that main thread can continue writing sooner. 2) It simplifies
// matters when we receive a flush request while waiting for I/O
// to complete because the flush routine can do its thing without
// having to worry about messing with our buffer management.
if OBufTail < OBufHead then
begin
numToWrite := OBufHead - OBufTail;
GetMem(tempBuff, numToWrite);
Move(OBuffer^[OBufTail], tempBuff^, numToWrite);
end else
begin
numToWrite := (OutQue - OBufTail) + OBufHead;
GetMem(tempBuff, numToWrite);
Move(OBuffer^[OBufTail], tempBuff^, OutQue - OBufTail);
Move(OBuffer^[0], tempBuff^[OutQue - OBufTail], OBufHead);
end;
// Reset the QueueProp head and tail
OBufHead := 0;
OBufTail := 0;
OBufFull := False;
finally
LeaveCriticalSection(OutputSection);
end;
// write the data that we found in tbe buffer & wait for I/O
// completion. Wait for all data in tempBuff to be written
count := 0;
while (count < numToWrite) do
begin
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread,
dstThreadDataWritten,
ComHandle,
tempBuff,
numToWrite - count);
{$ENDIF}
if (not WriteFile(ComHandle,
tempBuff^[count],
numToWrite - count,
numWritten,
ovl)) then
if (GetLastError = ERROR_IO_PENDING) then
begin
stat := WaitForOverlapped(ovl);
case stat of
// Flush request. Set the general event & quit.
-(WAIT_OBJECT_0 + 1):
begin
SetEvent(GeneralEvent);
Result := 0;
Exit;
end;
// I/O error. Propogate the error and quit.
// An error of ERROR_OPERATION_ABORTED is caused
// by flushing the com port so we just ignore it.
ecDeviceWrite:
begin
stat := GetLastError;
if (stat = ERROR_OPERATION_ABORTED) then
Result := 0
else
begin
LastWinError := stat;
Result := ecDeviceWrite;
end;
Exit;
end;
// I/O complete. Increment count of bytes written & loop
else
Inc(count, stat);
end;
end else
begin
LastWinError := GetLastError;
Result := ecDeviceWrite;
Exit;
end
else
// Increment count of bytes written & loop
Inc(count, numWritten);
end;
// All data written, release the buffer
FreeMem(tempBuff);
tempBuff := nil;
// No more data in buffer, if in RS485 mode wait for TE
if Win32Platform <> VER_PLATFORM_WIN32_NT then
if RS485Mode then
begin
repeat
until (PortIn(BaseAddress+5) and $40) <> 0;
SetRTS(False);
end;
end;
end;
Result := 0;
finally
if (Assigned(tempBuff)) then
FreeMem(tempBuff);
end;
end;
// Wait for either the event signalling I/O completion of the OutputFlushEvent.
// Returns the number of bytes written if I/O complete, -(WAIT_IBJECT_0 + 1) if
// flush requested or ecDeviceWrite if error.
function TWriteThread.WaitForOverlapped(ovl : POverlapped) : Integer;
var
waitEvents : array [0..1] of THandle;
stat : DWORD;
bytesWritten : Cardinal;
begin
waitEvents[0] := ovl.hEvent;
waitEvents[1] := OutFlushEvent;
repeat
stat := WaitForMultipleObjects(Length(waitEvents),
@waitEvents[0],
False,
100);
until ((stat <> WAIT_TIMEOUT) or Terminated or KillThreads);
case stat of
WAIT_OBJECT_0:
if (GetOverlappedResult(ComHandle, ovl^, bytesWritten, True)) then
begin
Result := BytesWritten;
ResetEvent(ovl.hEvent);
end else
begin
TApdBaseDispatcher(H).LastWinError := GetLastError;
Result := ecDeviceWrite;
end;
WAIT_OBJECT_0 + 1:
Result := -(WAIT_OBJECT_0 + 1);
else
begin
TApdBaseDispatcher(H).LastWinError := GetLastError;
Result := ecDeviceWrite;
end;
end;
end;
// TStatusThread methods. This thread does nothing except wait for line and / or
// modem events. When an event occurs a status buffer is added to the QueueProp
// for processing by the dispatcher thread.
procedure TStatusThread.Execute;
var
evt : DWORD;
stat : Integer;
wovl : TOverlapped;
sbfr : TStatusBuffer;
istat : Integer;
begin
ThreadStart(Self);
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadStart, 4, nil, 0);
{$ENDIF}
FillChar(wovl, SizeOf(wovl), 0);
wovl.hEvent := CreateEvent(nil, True, False, nil);
sbfr := nil;
try
// Set the mask used to signal WaitCommEvent which events to wait for.
{ Note, NuMega's BoundsChecker will flag a bogus error on the }
{ following statement because we use the undocumented ring_te flag }
if Win32Platform = VER_PLATFORM_WIN32_NT then
LastMask := DefEventMask and (not ev_RingTe)
else
LastMask := DefEventMask;
SetCommMask(ComHandle, LastMask);
ReturnValue := 0;
while ((not Terminated) and (not KillThreads)) do
begin
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadSleep, 4, nil, 0);
{$ENDIF}
stat := WaitSerialEvent(evt, @wovl);
if (stat < 0) then
begin
istat := GetLastError;
{$IFDEF DebugSerialIO}
MessageBox(0,
PChar(Format('ReadSerial failed! Error = %d.',
[istat])),
'',
MB_OK or MB_APPLMODAL or MB_ICONEXCLAMATION);
{$ENDIF}
// An invalid handle error means that someone else (probably
// TAPI) has closed the port. So just quit without an error.
if (istat <> ERROR_INVALID_HANDLE) then
ReturnValue := stat;
KillThreads := True;
Continue;
end;
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadWake, 4, nil, 0);
{$ENDIF}
// Was it a data notification event? If so, kick the read thread
// in the butt.
if ((evt and EV_RXCHAR) <> 0) then
SerialEvent.SetEvent;
// Was it a modem or line status change? If so, QueueProp
// a status buffer to the dispatcher thread.
if ((evt and (ModemEvent or LineEvent)) <> 0) then
begin
try
sbfr := TStatusBuffer.Create;
except
sbfr := nil;
ReturnValue := ecNoMem;
KillThreads := True;
end;
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread,
dstThreadStatusQueued,
ComHandle,
@evt,
SizeOf(evt));
{$ENDIF}
sbfr.Status := evt;
QueueProp.Push(sbfr);
sbfr := nil;
end;
end;
finally
CloseHandle(wovl.hEvent);
if (Assigned(sbfr)) then
sbfr.Free;
{$IFDEF DebugThreads}
if (DLoggingOn) then
AddDispatchEntry(dtThread, dstThreadExit, 4, nil, 0);
{$ENDIF}
ThreadGone(Self);
end;
end;
// Wait for an event on the serial port. Returns 0 if OK, or a negative error
// number otherwise. It is OK to wait indefinitely for the overlapped I/O
// to complete because we do a SetCommMask in StopDispatcher, which causes
// WaitCommEvent to wake up.
function TStatusThread.WaitSerialEvent(var EvtMask : DWORD;
ovl : POverlapped) : Integer;
var
bStat : Boolean;
istat : Integer;
begin
EvtMask := 0;
bStat := WaitCommEvent(ComHandle, EvtMask, ovl);
if (not bStat) then
begin
// If error is ERROR_INVALID_PARAMETER, assume it's our use of
// ev_RingTe. Clear the flag and try again.
if ((GetLastError = ERROR_INVALID_PARAMETER) and
((LastMask and EV_RINGTE) <> 0)) then
begin
LastMask := LastMask and (not EV_RINGTE);
SetCommMask(ComHandle, LastMask);
bStat := WaitCommEvent(ComHandle, EvtMask, ovl);
end;
end;
if (not bStat) then
begin
istat := GetLastError;
if (istat = ERROR_IO_PENDING) then
Result := WaitForOverlapped(ovl)
else
begin
TApdBaseDispatcher(H).LastWinError := istat;
Result := ecDeviceRead;
end;
end else
Result := 0;
end;
constructor TApdTAPI32Dispatcher.Create(Owner : TObject; InCid : Integer);
begin
CidEx := InCid;
inherited Create(Owner);
end;
function TApdTAPI32Dispatcher.OpenCom(ComName: PChar; InQueue, OutQueue : Cardinal) : Integer;
begin
if CidEx <> 0 then
Result := CidEx
else
begin
Result := ecCommNotOpen;
SetLastError(-Result);
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink