unit ProThread;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, ComErrorCode, ErrorStr;
type
TRecvDataProc = procedure (Buf:Pointer;Size:Integer);stdcall;
TErrorProc = procedure (ID:Integer;ErrStr:PWideChar);stdcall;
TNotifyProc = procedure;stdcall;
TProState = (ProNone,ProBreak,ProWriteBegin,ProWriting,ProReading,ProReadBegin);
TParity = ( None, Odd, Even, Mark, Space );
TStopBits = ( _1, _1_5, _2 );
TByteSize = ( _5, _6, _7, _8 );
TDtrControl = ( DtrEnable, DtrDisable, DtrHandshake );
TRtsControl = ( RtsEnable, RtsDisable, RtsHandshake, RtsTransmissionAvailable );
TFrame = Int64;
PFrame = ^TFrame;
TWriteReadBuf = packed record
Head:BYTE;
Buf:TFrame;
Check:WORD;
Re:BYTE;
end;
EComError = class( Exception );
const
INPUTBUFFERSIZE = 32;
RetryTimes = 8;
type
TEventType=(WriteErr,WriteOK,ReadOK,ReadErr,OpenComState,ComErr);
TProThread = class(TThread)
private
FReadPos:DWord;
FRetryTimes:Integer;
FComEvtMask:DWord;
FInputBuffer: array[0..INPUTBUFFERSIZE-1] of Char;
FNumberOfBytesRead:DWORD;
FWriteCallBuffered:Boolean;
FoverlappedRead:TOverlapped;
FoverlappedCommEvent:TOverlapped;
FoverlappedWrite:TOverLapped;
FComHandle:THandle;
FState:TProState;
FStateSection:TRTLCriticalSection;
FWriteCallEvent:THandle;
FCloseCallEvent:THandle;
FOpenComCallEvent:THandle;
FCloseComCallEvent:THandle;
FReadComeInEvent:THandle;
FWriteOverEvent:THandle;
FCommEvent:THandle;
FSetCommCallEvent:THandle;
FWriteBuf:TWriteReadBuf;
FReadBuf:TWriteReadBuf;
FComName: WideString;
FWriteTotalTimeoutMultiplier: DWORD;
FReadTotalTimeoutConstant: DWORD;
FReadIntervalTimeout: DWORD;
FReadTotalTimeoutMultiplier: DWORD;
FWriteTotalTimeoutConstant: DWORD;
FReplacedChar: AnsiChar;
FXoffChar: AnsiChar;
FXonChar: AnsiChar;
FIgnoreNullChar: Boolean;
FOutx_DsrFlow: Boolean;
FDsrSensitivity: Boolean;
FParityCheck: Boolean;
FTxContinueOnXoff: Boolean;
FOutx_XonXoffFlow: Boolean;
FInx_XonXoffFlow: Boolean;
FOutx_CtsFlow: Boolean;
FReplaceWhenParityError: Boolean;
FBaudRate: DWORD;
FByteSize: TByteSize;
FDtrControl: TDtrControl;
FParity: TParity;
FRtsControl: TRtsControl;
FStopBits: TStopBits;
FXoffLimit: WORD;
FXonLimit: WORD;
FOnCommErr: TErrorProc;
FOnReadErr: TErrorProc;
FOnWriteErr: TErrorProc;
FOnRead: TRecvDataProc;
FOnWriteOk: TNotifyProc;
FOnOpenCom:TErrorProc;
function RandomBool:Boolean;
function CheckRecvBuf(var Buf:TWriteReadBuf):Boolean;
procedure SetState(State:TProState);
procedure SetComName(const Value: WideString);
procedure SetCommState;
procedure SetCommTimeout;
procedure SetReadIntervalTimeout(const Value: DWORD);
procedure SetReadTotalTimeoutConstant(const Value: DWORD);
procedure SetReadTotalTimeoutMultiplier(const Value: DWORD);
procedure SetWriteTotalTimeoutConstant(const Value: DWORD);
procedure SetWriteTotalTimeoutMultiplier(const Value: DWORD);
procedure SetBaudRate(const Value: DWORD);
procedure SetByteSize(const Value: TByteSize);
procedure SetDsrSensitivity(const Value: Boolean);
procedure SetDtrControl(const Value: TDtrControl);
procedure SetIgnoreNullChar(const Value: Boolean);
procedure SetInx_XonXoffFlow(const Value: Boolean);
procedure SetOutx_CtsFlow(const Value: Boolean);
procedure SetOutx_DsrFlow(const Value: Boolean);
procedure SetOutx_XonXoffFlow(const Value: Boolean);
procedure SetParity(const Value: TParity);
procedure SetParityCheck(const Value: Boolean);
procedure SetReplacedChar(const Value: AnsiChar);
procedure SetReplaceWhenParityError(const Value: Boolean);
procedure SetRtsControl(const Value: TRtsControl);
procedure SetStopBits(const Value: TStopBits);
procedure SetTxContinueOnXoff(const Value: Boolean);
procedure SetXoffChar(const Value: AnsiChar);
procedure SetXoffLimit(const Value: WORD);
procedure SetXonChar(const Value: AnsiChar);
procedure SetXonLimit(const Value: WORD);
function SetupCommEvent: Boolean;
function SetupReadEvent: Boolean;
function WriteChar(C:Char):Boolean;
function WriteBuf(Buf:Pointer;Size:Integer):Boolean;
procedure CalcCRC16(var CRC: Word;Buf:Pointer;sz: integer);
function CalcBufCRC16(Buf:Pointer;Size:Integer;var CRC:WORD):Boolean;
function CheckCRC(Buf:Pointer;Size:Integer;CRC:WORD):Boolean;
procedure SetOnCommErr(const Value: TErrorProc);
procedure SetOnRead(const Value: TRecvDataProc);
procedure SetOnReadErr(const Value: TErrorProc);
procedure SetOnWriteErr(const Value: TErrorProc);
procedure SetOnWriteOk(const Value: TNotifyProc);
protected
procedure DoComErr(ErrID:Integer;ErrStr:WideString);
procedure DoOpenComState(ErrID:Integer;ErrStr:WideString);
procedure DoReadErr(ErrID:Integer;ErrStr:WideString);
procedure DoWriteErr(ErrID:Integer;ErrStr:WideString);
procedure DoReadOk;
procedure DoWriteOk;
procedure DoReadBegin;virtual;
procedure DoBreak;virtual;
procedure DoWriting;virtual;
procedure DoWriteBegin;virtual;
procedure DoReading;virtual;
procedure DoCloseCall;virtual;
procedure DoWaitTimeOut;virtual;
procedure DoWriteCall;virtual;
procedure DoCloseComCall;virtual;
procedure DoOpenComCall;virtual;
procedure DoWriteOver;virtual;
procedure DoRead;virtual;
procedure DoComm;virtual;
procedure DoSetCommCall;virtual;
procedure Execute; override;
public
property ComName:WideString read FComName write SetComName;
property ReadIntervalTimeout: DWORD read FReadIntervalTimeout write SetReadIntervalTimeout;
property ReadTotalTimeoutMultiplier: DWORD read FReadTotalTimeoutMultiplier write SetReadTotalTimeoutMultiplier;
property ReadTotalTimeoutConstant: DWORD read FReadTotalTimeoutConstant write SetReadTotalTimeoutConstant;
property WriteTotalTimeoutMultiplier: DWORD read FWriteTotalTimeoutMultiplier write SetWriteTotalTimeoutMultiplier;
property WriteTotalTimeoutConstant: DWORD read FWriteTotalTimeoutConstant write SetWriteTotalTimeoutConstant;
property BaudRate: DWORD read FBaudRate write SetBaudRate;
property ParityCheck: Boolean read FParityCheck write SetParityCheck;
property Outx_CtsFlow: Boolean read FOutx_CtsFlow write SetOutx_CtsFlow;
property Outx_DsrFlow: Boolean read FOutx_DsrFlow write SetOutx_DsrFlow;
property DtrControl: TDtrControl read FDtrControl write SetDtrControl;
property DsrSensitivity: Boolean read FDsrSensitivity write SetDsrSensitivity;
property TxContinueOnXoff: Boolean read FTxContinueOnXoff write SetTxContinueOnXoff;
property Outx_XonXoffFlow: Boolean read FOutx_XonXoffFlow write SetOutx_XonXoffFlow;
property Inx_XonXoffFlow: Boolean read FInx_XonXoffFlow write SetInx_XonXoffFlow;
property ReplaceWhenParityError: Boolean read FReplaceWhenParityError write SetReplaceWhenParityError;
property IgnoreNullChar: Boolean read FIgnoreNullChar write SetIgnoreNullChar;
property RtsControl: TRtsControl read FRtsControl write SetRtsControl;
property XonLimit: WORD read FXonLimit write SetXonLimit;
property XoffLimit: WORD read FXoffLimit write SetXoffLimit;
property ByteSize: TByteSize read FByteSize write SetByteSize;
property Parity: TParity read FParity write SetParity;
property StopBits: TStopBits read FStopBits write SetStopBits;
property XonChar: AnsiChar read FXonChar write SetXonChar;
property XoffChar: AnsiChar read FXoffChar write SetXoffChar;
property ReplacedChar: AnsiChar read FReplacedChar write SetReplacedChar;
property OnRead:TRecvDataProc read FOnRead write SetOnRead;
property OnReadErr:TErrorProc read FOnReadErr write SetOnReadErr;
property OnWriteErr:TErrorProc read FOnWriteErr write SetOnWriteErr;
property OnCommErr:TErrorProc read FOnCommErr write SetOnCommErr;
property OnWriteOk:TNotifyProc read FOnWriteOk write SetOnWriteOk;
constructor Create;reintroduce;
destructor Destroy;override;
function WriteFrame(Frame:TFrame):Integer;
procedure CloseCom;
procedure OpenCom;
end;
TEventThread = class(TThread)
private
FProThread:TProThread;
FBuf:TFrame;
FEventType:TEventType;
FErrID:Integer;
FErrstr:WideString;
protected
procedure Execute;override;
public
constructor Create(ProThread:TProThread;EventType:TEventType;Buf:TFrame);overload;
constructor Create(ProThread:TProThread;EventType:TEventType;ErrID:Integer;Errstr:WideString);overload;
constructor Create(ProThread:TProThread;EventType:TEventType);overload;
end;
const
ME_CTS = 1;
ME_DSR = 2;
ME_RING = 4;
ME_RLSD = 8;
function CreateComm(CommName:PWideChar):THandle;stdcall;
procedure OpenComm(Handle:THandle);stdcall;
procedure CloseComm(Handle:THandle);stdcall;
procedure DestroyComm(Handle:THandle);stdcall;
procedure WriteFrame(Handle:THandle;Frame:TFrame);stdcall;
procedure SetRecvDataCallback(Handle:THandle;Proc:TRecvDataProc);stdcall;
procedure SetRecvErrorCallback(Handle:THandle;Proc:TErrorProc);stdcall;
procedure SetWriteDataOverCallback(Handle:THandle;Proc:TNotifyProc);stdcall;
procedure SetWriteDataErrorCallback(Handle:THandle;Proc:TErrorProc);stdcall;
procedure SetCommErrorCallback(Handle:THandle;Proc:TErrorProc);stdcall;
procedure SetOpenComCallback(Handle:THandle;Proc:TErrorProc);stdcall;
implementation
function CreateComm(CommName:PWideChar):THandle;stdcall;
begin
Result:=THandle(TProThread.Create);
TProThread(Result).ComName:=CommName;
end;
procedure OpenComm(Handle:THandle);stdcall;
begin
TProThread(Handle).OpenCom;
end;
procedure CloseComm(Handle:THandle);stdcall;
begin
TProThread(Handle).CloseCom;
end;
procedure DestroyComm(Handle:THandle);stdcall;
begin
TProThread(Handle).Terminate;
TProThread(Handle).CloseCom;
end;
procedure WriteFrame(Handle:THandle;Frame:TFrame);stdcall;
begin
TProThread(Handle).WriteFrame(Frame);
end;
procedure SetRecvDataCallback(Handle:THandle;Proc:TRecvDataProc);stdcall;
begin
TProThread(Handle).OnRead:=Proc;
end;
procedure SetRecvErrorCallback(Handle:THandle;Proc:TErrorProc);stdcall;
begin
TProThread(Handle).OnReadErr:=Proc;
end;
procedure SetWriteDataOverCallback(Handle:THandle;Proc:TNotifyProc);stdcall;
begin
TProThread(Handle).OnWriteOk:=Proc;
end;
procedure SetWriteDataErrorCallback(Handle:THandle;Proc:TErrorProc);stdcall;
begin
TProThread(Handle).OnWriteErr:=Proc;
end;
procedure SetCommErrorCallback(Handle:THandle;Proc:TErrorProc);stdcall;
begin
TProThread(Handle).OnCommErr:=Proc;
end;
procedure SetOpenComCallback(Handle:THandle;Proc:TErrorProc);stdcall;
begin
TProThread(Handle).FOnOpenCom:=Proc;
end;
const
CRC16Table : Array[0..255] of Word =
( $0000, $C0C1, $C181, $0140, $C301, $03C0, $0280,
$C241, $C601, $06C0, $0780, $C741, $0500, $C5C1,
$C481, $0440, $CC01, $0CC0, $0D80, $CD41, $0F00,
$CFC1, $CE81, $0E40, $0A00, $CAC1, $CB81, $0B40,
$C901, $09C0, $0880, $C841, $D801, $18C0, $1980,
$D941, $1B00, $DBC1, $DA81, $1A40, $1E00, $DEC1,
$DF81, $1F40, $DD01, $1DC0, $1C80, $DC41, $1400,
$D4C1, $D581, $1540, $D701, $17C0, $1680, $D641,
$D201, $12C0, $1380, $D341, $1100, $D1C1, $D081,
$1040, $F001, $30C0, $3180, $F141, $3300, $F3C1,
$F281, $3240, $3600, $F6C1, $F781, $3740, $F501,
$35C0, $3480, $F441, $3C00, $FCC1, $FD81, $3D40,
$FF01, $3FC0, $3E80, $FE41, $FA01, $3AC0, $3B80,
$FB41, $3900, $F9C1, $F881, $3840, $2800, $E8C1,
$E981, $2940, $EB01, $2BC0, $2A80, $EA41, $EE01,
$2EC0, $2F80, $EF41, $2D00, $EDC1, $EC81, $2C40,
$E401, $24C0, $2580, $E541, $2700, $E7C1, $E681,
$2640, $2200, $E2C1, $E381, $2340, $E101, $21C0,
$2080, $E041, $A001, $60C0, $6180, $A141, $6300,
$A3C1, $A281, $6240, $6600, $A6C1, $A781, $6740,
$A501, $65C0, $6480, $A441, $6C00, $ACC1, $AD81,
$6D40, $AF01, $6FC0, $6E80, $AE41, $AA01, $6AC0,
$6B80, $AB41, $6900, $A9C1, $A881, $6840, $7800,
$B8C1, $B981, $7940, $BB01, $7BC0, $7A80, $BA41,
$BE01, $7EC0, $7F80, $BF41, $7D00, $BDC1, $BC81,
$7C40, $B401, $74C0, $7580, $B541, $7700, $B7C1,
$B681, $7640, $7200, $B2C1, $B381, $7340, $B101,
$71C0, $7080, $B041, $5000, $90C1, $9181, $5140,
$9301, $53C0, $5280, $9241, $9601, $56C0, $5780,
$9741, $5500, $95C1, $9481, $5440, $9C01, $5CC0,
$5D80, $9D41, $5F00, $9FC1, $9E81, $5E40, $5A00,
$9AC1, $9B81, $5B40, $9901, $59C0, $5880, $9841,
$8801, $48C0, $4980, $8941, $4B00, $8BC1, $8A81,
$4A40, $4E00, $8EC1, $8F81, $4F40, $8D01, $4DC0,
$4C80, $8C41, $4400, $84C1, $8581, $4540, $8701,
$47C0, $4680, $8641, $8201, $42C0, $4380, $8341,
$4100, $81C1, $8081, $4040
);
{ TProThread }
constructor TProThread.Create;
begin
inherited Create(True);
FComName := 'COM2';
FBaudRate := 9600;
FParityCheck := False;
FOutx_CtsFlow := False;
FOutx_DsrFlow := False;
FDtrControl := DtrDisable;//DtrEnable;
FDsrSensitivity := False;
FTxContinueOnXoff := False;//True;
FOutx_XonXoffFlow := False;//True;
FInx_XonXoffFlow := False;//True;
FReplaceWhenParityError := False;
FIgnoreNullChar := False;
FRtsControl := RtsDisable;//RtsEnable;
FXonLimit := 500;
FXoffLimit := 500;
FByteSize := _8;
FParity := None;
FStopBits := _1;
FXonChar := chr($11); // Ctrl-Q
FXoffChar := chr($13); // Ctrl-S
FReplacedChar := chr(0);
FReadIntervalTimeout := 1;
FReadTotalTimeoutMultiplier := 0;
FReadTotalTimeoutConstant := 0;
FWriteTotalTimeoutMultiplier := 0;
FWriteTotalTimeoutConstant := 0;
FWriteCallBuffered:=False;
FNumberOfBytesRead:=0;
FWriteCallEvent:=CreateEvent(nil,True,False,nil);
FCloseCallEvent:=CreateEvent(nil,True,False,nil);
FReadComeInEvent:=CreateEvent(nil,True,False,nil);
FWriteOverEvent:=CreateEvent(nil,True,False,nil);
FCommEvent:=CreateEvent(nil,True,False,nil);
FSetCommCallEvent:=CreateEvent(nil,True,False,nil);
FOpenComCallEvent:=CreateEvent(nil,True,False,nil);
FCloseComCallEvent:=CreateEvent(nil,True,False,nil);
InitializeCriticalSection(FStateSection);
FComHandle:=INVALID_HANDLE_VALUE;
Priority:=tpHighest;
FreeOnTerminate:=True;
FRetryTimes:=0;
FReadPos:=0;
Resume;
end;
destructor TProThread.Destroy;
begin
SetEvent(FCloseCallEvent);
inherited;
end;
procedure TProThread.DoBreak;
begin
if FInputBuffer[0]=Char($FF) then
begin
if FWriteCallBuffered then
begin
if RandomBool then
begin
DoWriteCall;
end else
begin
if WriteChar(Char($FE)) then
begin
FRetryTimes:=0;
FReadPos:=0;
FState:=ProReading;
end else
DoCloseComCall;
end;
end else
begin
if WriteChar(Char($FE)) then
begin
FRetryTimes:=0;
FReadPos:=0;
FState:=ProReading;
end else
DoCloseComCall;
end;
end else if FInputBuffer[0]<>Char($FA) then
begin
if not WriteChar(Char($FA)) then
DoCloseComCall;
end;
end;
procedure TProThread.DoCloseCall;
begin
ResetEvent(FCloseCallEvent);
FState:=ProNone;
FWriteCallBuffered:=False;
CloseHandle(FComHandle);
FComHandle:=INVALID_HANDLE_VALUE;
Terminate;
end;
procedure TProThread.DoCloseComCall;
begin
ResetEvent(FCloseComCallEvent);
ResetEvent(FReadComeInEvent);
ResetEvent(FWriteOverEvent);
ResetEvent(FCommEvent);
FState:=ProNone;
FWriteCallBuffered:=False;
CloseHandle(FComHandle);
FNumberOfBytesRead:=0;
FComHandle:=INVALID_HANDLE_VALUE;
FReadPos:=0;
end;
procedure TProThread.DoComErr(ErrID: Integer; ErrStr: WideString);
begin
if Assigned(FOnCommErr) then
TEventThread.Create(Self,ComErr,ErrID,ErrStr);
end;
procedure TProThread.DoComm;
var
Errors:DWord;
Dummy:DWORD;
begin
if not GetOverlappedResult( FComHandle,FoverlappedCommEvent, Dummy, False ) then
begin
if not GetLastError = ERROR_INVALID_HANDLE then
begin
CloseHandle(FComHandle);
end;
FState:=ProNone;
FComHandle:=INVALID_HANDLE_VALUE;
end else
begin
ResetEvent(FCommEvent);
if (FComEvtMask and EV_ERR) <> 0 then
begin
if not ClearCommError( FComHandle, Errors, nil ) then
begin
if not GetLastError = ERROR_INVALID_HANDLE then
begin
CloseHandle(FComHandle);
end;
FState:=ProNone;
FComHandle:=INVALID_HANDLE_VALUE;
end else
DoComErr(ErCom,ErComStr+IntToStr(Errors));
end else
begin
if (FComEvtMask and EV_RLSD) <> 0 then
DoComErr(ErComChange,ErComChangeStr);
if not SetupCommEvent then
CloseCom;
end;
end;
end;
procedure TProThread.DoOpenComCall;
begin
try
ResetEvent(FOpenComCallEvent);
if FState=ProNone then
begin
FillChar(FoverlappedRead,SizeOf(TOverlapped),0);
FillChar(FoverlappedCommEvent,SizeOf(TOverlapped),0);
FillChar(FoverlappedWrite,SizeOf(TOverlapped),0);
FoverlappedRead.hEvent:=FReadComeInEvent;
FoverlappedCommEvent.hEvent:=FCommEvent;
FoverlappedWrite.hEvent:=FWriteOverEvent;
FComHandle:=CreateFileW( PWideChar(FComName),
GENERIC_READ or GENERIC_WRITE,
0, {not shared}
nil, {no security ??}
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED,
0 {template} );
if FComHandle<>INVALID_HANDLE_VALUE then
begin
SetCommTimeout;
SetCommState;
PurgeComm( FComHandle, PURGE_TXABORT or PURGE_RXABORT or
PURGE_TXCLEAR or PURGE_RXCLEAR ) ;
if GetFileType( FComHandle ) <> FILE_TYPE_CHAR then
begin
CloseHandle(FComHandle);
FComHandle:=INVALID_HANDLE_VALUE;
DoOpenComState(ErComFileWrang,OpenComFileTypeWrangStr);
end else if not SetupComm( FComHandle, 4096, 4096 ) then
begin
CloseHandle(FComHandle);
FComHandle:=INVALID_HANDLE_VALUE;
DoOpenComState(ErSetupComBuf,OpenComSetBufWrangStr);
end else if not SetCommMask(FComHandle, EV_ERR or EV_RLSD{ or EV_RING} ) then
begin
CloseHandle(FComHandle);
FComHandle:=INVALID_HANDLE_VALUE;
DoOpenComState(ErSetupComMask,OpenComSetMaskWrangStr);
end else if not SetupCommEvent then
begin
CloseHandle(FComHandle);
FComHandle:=INVALID_HANDLE_VALUE;
DoOpenComState(ErSetComEvent,OpenComSetEventWrangStr);
end else if not SetupReadEvent then
begin
CloseHandle(FComHandle);
FComHandle:=INVALID_HANDLE_VALUE;
DoOpenComState(ErSetComReadEvent,OpenComSetReadWrangStr);
end else
begin
FState:=ProBreak;
DoOpenComState(NoError,OpenComOK);
end;
end else
DoOpenComState(ErOpenComError,OpenComWrangStr);
end else
DoOpenComState(ErReOpenCom,ReopenCom);
except
FState:=ProNone;
CloseHandle(FComHandle);
FComHandle:=INVALID_HANDLE_VALUE;
DoOpenComState(ErOpenComError,OpenComWrangStr);
end;
end;
procedure TProThread.DoRead;
begin
if GetOverlappedResult( FComHandle,
FOverlappedRead, FNumberOfBytesRead, False ) then
begin
case FState of
ProBreak:DoBreak;
ProWriteBegin:DoWriteBegin;
ProWriting:DoWriting;
ProReading:DoReading;
ProReadBegin:DoReadBegin;
end;
ResetEvent(FReadComeInEvent);
if not SetupReadEvent then
DoCloseComCall;
end else if GetLastError<>ERROR_IO_PENDING then
DoCloseComCall;
end;
procedure TProThread.DoReadErr(ErrID: Integer; ErrStr: WideString);
begin
if Assigned(FOnReadErr) then
TEventThread.Create(Self,ReadErr,ErrID,ErrStr);
end;
function TProThread.CheckRecvBuf(var Buf:TWriteReadBuf): Boolean;
begin
if (Buf.Re=0)and (Buf.Head=$DE) then
begin
Result:=CheckCRC(@Buf.Buf,8,Buf.Check);
end else
begin
Result:=False;
end;
end;
procedure TProThread.DoReading;
begin
if (FReadPos+FNumberOfBytesRead)<=SizeOf(TWriteReadBuf) then
begin
Move(FInputBuffer[0],Pointer(DWORD(@FReadBuf)+FReadPos)^,FNumberOfBytesRead);
Inc(FReadPos,FNumberOfBytesRead);
if FReadPos=SizeOf(TWriteReadBuf) then
begin
FReadPos:=0;
if CheckRecvBuf(FReadBuf) then
begin
if WriteChar(Char($FD)) then
begin
FState:=ProBreak;
end else
DoCloseComCall;
FRetryTimes:=0;
DoReadOk;
if FWriteCallBuffered then
DoWriteCall;
end else
begin
if FRetryTimes<RetryTimes then
begin
PurgeComm( FComHandle, PURGE_RXABORT or PURGE_RXCLEAR);
if WriteChar(Char($FB)) then
Inc(FRetryTimes)
else
DoCloseComCall;
end else
begin
PurgeComm( FComHandle, PURGE_RXABORT or PURGE_RXCLEAR);
if WriteChar(Char($FA)) then
begin
FState:=ProBreak;
DoReadErr(ErReadMoreError,ErReadMoreErrorStr);
if FWriteCallBuffered then
DoWriteCall;
end else
DoCloseComCall;
end;
end;
end;
end else
begin
FReadPos:=0;
if FRetryTimes<RetryTimes then
begin
PurgeComm( FComHandle, PURGE_RXABORT or PURGE_RXCLEAR);
if WriteChar(Char($FB)) then
Inc(FRetryTimes)
else
DoCloseComCall;
end else
begin
PurgeComm( FComHandle, PURGE_RXABORT or PURGE_RXCLEAR);
if WriteChar(Char($FA)) then
begin
FState:=ProBreak;
FReadPos:=0;
DoReadErr(ErReadMoreError,ErReadMoreErrorStr);
if FWriteCallBuffered then
DoWriteCall;
end else
DoCloseComCall;
end;
end;
end;
procedure TProThread.DoSetCommCall;
begin
ResetEvent(FSetCommCallEvent);
if FState=ProBreak then
SetCommState;
end;
procedure TProThread.CalcCRC16(var CRC:Word;Buf:Pointer;sz:Integer);
var
I:Integer;
begin
for I:=0 to sz-1 do
begin
CRC:=((CRC SHR 8) AND $FF) XOR CRC16Table[(CRC XOR BYTE(Pointer(Integer(Buf)+I)^)) AND $FF];
end;
end;
function TProThread.CalcBufCRC16(Buf:Pointer;Size:Integer;var CRC:WORD):Boolean;
begin
try
CRC:=0;
CalcCRC16(CRC,Buf,Size);
Result:=True;
except
Result:=False;
end;
end;
function TProThread.CheckCRC(Buf: Pointer; Size: Integer;
CRC: WORD): Boolean;
var
tCRC:WORD;
begin
try
tCRC:=0;
CalcCRC16(tCRC,Buf,Size);
Result:=tCRC=CRC;
except
Result:=False;
end;
end;
procedure TProThread.DoWaitTimeOut;
begin
if (FState<>ProBreak)and(FState<>ProNone)then
begin
PurgeComm( FComHandle, PURGE_TXABORT or PURGE_TXCLEAR);
PurgeComm( FComHandle, PURGE_RXABORT or PURGE_RXCLEAR);
ResetEvent(FReadComeInEvent);
ResetEvent(FCommEvent);
if FRetryTimes<RetryTimes then
begin
case FState of
ProWriteBegin:
begin
if WriteChar(Char($FF)) then
Inc(FRetryTimes)
else
begin
DoCloseComCall;
end;
end;
ProWriting:
begin
if WriteBuf(@FWriteBuf,SizeOf(TWriteReadBuf)) then
Inc(FRetryTimes)
else
DoCloseComCall;
end;
ProReading:
begin
if WriteChar(Char($FB)) then
begin
Inc(FRetryTimes);
FReadPos:=0;
end else
DoCloseComCall;
end;
ProReadBegin:
begin
if not WriteChar(Char($FE)) then
DoCloseComCall;
end;
end;
end else
begin
case FState of
ProWriteBegin:
begin
if WriteChar(Char($FA)) then
begin
FRetryTimes:=0;
FState:=ProBreak;
DoWriteErr(ErWriteHandShankTimeOut,ErWriteHandShankTimeOutStr);
end else
DoCloseComCall;
end;
ProWriting:
begin
if WriteChar(Char($FA)) then
begin
FRetryTimes:=0;
FState:=ProBreak;
DoWriteErr(ErWriteTimeOut,ErWriteTimeOutStr);
end else
DoCloseComCall;
end;
ProReading:
begin
if WriteChar(Char($FA)) then
begin
FRetryTimes:=0;
FReadPos:=0;
FState:=ProBreak;
DoReadErr(ErReadTimeOut,ErReadTimeOutStr);
end else
DoCloseComCall;
end;
ProReadBegin:
begin
end;
end;
FState:=ProBreak;
if FWriteCallBuffered then
DoWriteCall;
end;
if not SetupReadEvent then
DoCloseComCall;
end;
end;
function TProThread.RandomBool: Boolean;
begin
Result:=Random>0.5;
end;
procedure TProThread.DoWriteBegin;
begin
if FInputBuffer[0]=Char($FE) then
begin
WriteBuf(@FWriteBuf,SizeOf(TWriteReadBuf));
FRetryTimes:=0;
FState:=ProWriting;
end else if FInputBuffer[0]=Char($FF) then
begin
if RandomBool then
begin
if WriteChar(Char($FF)) then
FRetryTimes:=0
else
DoCloseComCall;
end else
begin
if WriteChar(Char($FE)) then
begin
FRetryTimes:=0;
FWriteCallBuffered:=True;
FState:=ProReadBegin;
end else
DoCloseComCall;
end;
end else if FInputBuffer[0]=Char($FB) then
begin
if FRetryTimes<RetryTimes then
begin
if WriteChar(Char($FF)) then
Inc(FRetryTimes)
else
DoCloseComCall;
end else
begin
if WriteChar(Char($FA)) then
begin
FRetryTimes:=0;
FState:=ProBreak;
DoWriteErr(ErWriteHandShankMoreError,ErWriteHandShankMoreErrorStr);
end else
DoCloseComCall;
end;
end else if FInputBuffer[0]=Char($FA) then
begin
FState:=ProBreak;
FRetryTimes:=0;
DoWriteErr(ErWriteHandShankRecvCancel,ErWriteHandShankRecvCancelStr);
//DoWriteCall;
end else
begin
if FRetryTimes<RetryTimes then
begin
if WriteChar(Char($FF)) then
Inc(FRetryTimes)
else
DoCloseComCall;
end else
begin
if WriteChar(Char($FA)) then
begin
FRetryTimes:=0;
FState:=ProBreak;
DoWriteErr(ErWriteHandShankEocError,ErWriteHandShankEocErrorStr);
end else
DoCloseComCall;
end;
end;
end;
procedure TProThread.DoWriteCall;
begin
ResetEvent(FWriteCallEvent);
if FState = ProBreak then
begin
FlushFileBuffers(FComHandle);
if WriteChar(Char($FF)) then
begin
FState:=ProWriteBegin;
FWriteCallBuffered:=False;
FRetryTimes:=0;
FWriteBuf.Head:=$DE;
FWriteBuf.Re:=0;
CalcBufCRC16(@FWriteBuf.Buf,8,FWriteBuf.Check)
end else
begin
DoCloseComCall;
end;
end;
end;
procedure TProThread.DoWriteErr(ErrID: Integer; ErrStr: WideString);
begin
if Assigned(FOnWriteErr) then
TEventThread.Create(Self,WriteErr,ErrID,ErrStr);
end;
procedure TProThread.DoWriteOver;
begin
ResetEvent(FWriteOverEvent);
end;
procedure TProThread.DoWriting;
begin
PurgeComm( FComHandle, PURGE_TXABORT or PURGE_TXCLEAR);
if FInputBuffer[0]=Char($FD) then
begin
FState:=ProBreak;
FRetryTimes:=0;
DoWriteOk;
end else if FInputBuffer[0]=Char($FB) then
begin
if FRetryTimes<RetryTimes then
begin
if WriteBuf(@FWriteBuf,SizeOf(TWriteReadBuf)) then
Inc(FRetryTimes)
else
DoCloseComCall;
end else
begin
if WriteChar(Char($FA)) then
begin
FRetryTimes:=0;
FState:=ProBreak;
DoWriteErr(ErWriteEocError,ErWriteEocErrorStr);
end else
DoCloseComCall;
end;
end else if FInputBuffer[0]=Char($FA) then
begin
FState:=ProBreak;
FRetryTimes:=0;
DoWriteErr(ErWriteRecvCancel,ErWriteRecvCancelStr);
//DoWriteCall;
end else
begin
if FRetryTimes<RetryTimes then
begin
if WriteBuf(@FWriteBuf,SizeOf(TWriteReadBuf)) then
Inc(FRetryTimes)
else
DoCloseComCall;
end else
begin
if WriteChar(Char($FA)) then
begin
FRetryTimes:=0;
FState:=ProBreak;
DoWriteErr(ErWriteEocError,ErWriteEocErrorStr);
end else
DoCloseComCall;
end;
end;
end;
procedure TProThread.Execute;
var
HandlesToWaitFor:array[0..7] of THandle;
HandleSignaled:DWord;
begin
HandlesToWaitFor[0]:=FWriteCallEvent;
HandlesToWaitFor[1]:=FCloseCallEvent;
HandlesToWaitFor[2]:=FReadComeInEvent;
//HandlesToWaitFor[3]:=FWriteOverEvent;
HandlesToWaitFor[3]:=FCommEvent;
HandlesToWaitFor[4]:=FSetCommCallEvent;
HandlesToWaitFor[5]:=FCloseComCallEvent;
HandlesToWaitFor[6]:=FOpenComCallEvent;
while not Terminated do
begin
HandleSignaled := WaitForMultipleObjects(7, @HandlesToWaitFor,False, 1000);
case HandleSignaled of
WAIT_OBJECT_0:DoWriteCall;
WAIT_OBJECT_0+1:DoCloseCall;
WAIT_OBJECT_0+2:DoRead;
//WAIT_OBJECT_0+3:DoWriteOver;
WAIT_OBJECT_0+3:DoComm;
WAIT_OBJECT_0+4:DoSetCommCall;
WAIT_OBJECT_0+5:DoCloseComCall;
WAIT_OBJECT_0+6:DoOpenComCall;
WAIT_TIMEOUT:DoWaitTimeOut;
else
begin
Terminate;
FState:=ProNone;
CloseHandle(FComHandle);
FComHandle:=INVALID_HANDLE_VALUE;
end;
end;
Sleep(0);
end;
end;
procedure TProThread.SetBaudRate(const Value: DWORD);
begin
FBaudRate := Value;
end;
procedure TProThread.SetByteSize(const Value: TByteSize);
begin
FByteSize := Value;
end;
procedure TProThread.SetCommState;
var
dcb: Tdcb;
commprop: TCommProp;
fdwEvtMask: DWORD;
begin
GetCommState( FComHandle, dcb );
GetCommProperties( FComHandle, commprop );
GetCommMask( FComHandle, fdwEvtMask );
dcb.BaudRate := FBaudRate;
dcb.Flags := 1; // Enable fBinary
if FParityCheck then
dcb.Flags := dcb.Flags or 2; // Enable parity check
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;
Windows.SetCommState( FComHandle, dcb )
end;
procedure TProThread.SetCommTimeout;
var
commtimeouts: TCommTimeouts;
begin
GetCommTimeouts( FComHandle, commtimeouts );
commtimeouts.ReadIntervalTimeout := FReadIntervalTimeout;
commtimeouts.ReadTotalTimeoutMultiplier := FReadTotalTimeoutMultiplier;
commtimeouts.ReadTotalTimeoutConstant := FReadTotalTimeoutConstant;
commtimeouts.WriteTotalTimeoutMultiplier := FWriteTotalTimeoutMultiplier;
commtimeouts.WriteTotalTimeoutConstant := FWriteTotalTimeoutConstant;
SetCommTimeouts( FComHandle, commtimeouts );
end;
procedure TProThread.SetComName(const Value: WideString);
begin
FComName := Value;
end;
procedure TProThread.SetDsrSensitivity(const Value: Boolean);
begin
FDsrSensitivity := Value;
end;
procedure TProThread.SetDtrControl(const Value: TDtrControl);
begin
FDtrControl := Value;
end;
procedure TProThread.SetIgnoreNullChar(const Value: Boolean);
begin
FIgnoreNullChar := Value;
end;
procedure TProThread.SetInx_XonXoffFlow(const Value: Boolean);
begin
FInx_XonXoffFlow := Value;
end;
procedure TProThread.SetOutx_CtsFlow(const Value: Boolean);
begin
FOutx_CtsFlow := Value;
end;
procedure TProThread.SetOutx_DsrFlow(const Value: Boolean);
begin
FOutx_DsrFlow := Value;
end;
procedure TProThread.SetOutx_XonXoffFlow(const Value: Boolean);
begin
FOutx_XonXoffFlow := Value;
end;
procedure TProThread.SetParity(const Value: TParity);
begin
FParity := Value;
end;
procedure TProThread.SetParityCheck(const Value: Boolean);
begin
FParityCheck := Value;
end;
procedure TProThread.SetReadIntervalTimeout(const Value: DWORD);
begin
FReadIntervalTimeout := Value;
end;
procedure TProThread.SetReadTotalTimeoutConstant(const Value: DWORD);
begin
FReadTotalTimeoutConstant := Value;
end;
procedure TProThread.SetReadTotalTimeoutMultiplier(const Value: DWORD);
begin
FReadTotalTimeoutMultiplier := Value;
end;
procedure TProThread.SetReplacedChar(const Value: AnsiChar);
begin
FReplacedChar := Value;
end;
procedure TProThread.SetReplaceWhenParityError(const Value: Boolean);
begin
FReplaceWhenParityError := Value;
end;
procedure TProThread.SetRtsControl(const Value: TRtsControl);
begin
FRtsControl := Value;
end;
procedure TProThread.SetState(State: TProState);
begin
EnterCriticalSection(FStateSection);
FState:=State;
LeaveCriticalSection(FStateSection);
end;
procedure TProThread.SetStopBits(const Value: TStopBits);
begin
FStopBits := Value;
end;
procedure TProThread.SetTxContinueOnXoff(const Value: Boolean);
begin
FTxContinueOnXoff := Value;
end;
function TProThread.SetupCommEvent:Boolean;
var
Errors:DWord;
begin
while WaitCommEvent(FComHandle, FComEvtMask, @FOverlappedCommEvent ) do
begin
if WAIT_TIMEOUT <> WaitForSingleObject(FCloseCallEvent,0) then
begin
Result:=False;
Terminate;
Exit;
end;
if (FComEvtMask and EV_ERR) <> 0 then
begin
if not ClearCommError( FComHandle, Errors, nil ) then
begin
if not GetLastError = ERROR_INVALID_HANDLE then
begin
CloseHandle(FComHandle);
end;
FState:=ProNone;
FComHandle:=INVALID_HANDLE_VALUE;
end else
DoComErr(ErCom,ErComStr+IntToStr(Errors));
end;
ResetEvent(FCommEvent);
end;
if GetLastError = ERROR_IO_PENDING then
Result := True
else
Result := False;
end;
function TProThread.SetupReadEvent: Boolean;
var
LastErr:DWORD;
begin
while ReadFile( FComHandle,
FInputBuffer[0], INPUTBUFFERSIZE,
FNumberOfBytesRead, @FOverlappedRead ) do
begin
if WAIT_TIMEOUT <> WaitForSingleObject(FCloseCallEvent,0) then
begin
Result:=False;
Terminate;
Exit;
end;
case FState of
ProBreak:DoBreak;
ProWriteBegin:DoWriteBegin;
ProWriting:DoWriting;
ProReading:DoReading;
ProReadBegin:DoReadBegin;
end;
end;
LastErr:=GetLastError;
if LastErr= ERROR_IO_PENDING then
begin
Result := True;
end else
begin
Result:=False;
end;
end;
procedure TProThread.SetWriteTotalTimeoutConstant(const Value: DWORD);
begin
FWriteTotalTimeoutConstant := Value;
end;
procedure TProThread.SetWriteTotalTimeoutMultiplier(const Value: DWORD);
begin
FWriteTotalTimeoutMultiplier := Value;
end;
procedure TProThread.SetXoffChar(const Value: AnsiChar);
begin
FXoffChar := Value;
end;
procedure TProThread.SetXoffLimit(const Value: WORD);
begin
FXoffLimit := Value;
end;
procedure TProThread.SetXonChar(const Value: AnsiChar);
begin
FXonChar := Value;
end;
procedure TProThread.SetXonLimit(const Value: WORD);
begin
FXonLimit := Value;
end;
function TProThread.WriteBuf(Buf: Pointer; Size: Integer): Boolean;
var
{NumberOfBytesWritten:DWord;
LastError:DWord;}
I:DWORD;
begin
{if not WriteFile(FComHandle,Buf^,Size, NumberOfBytesWritten,@FOverlappedWrite) then
begin
LastError := GetLastError;
if LastError = ERROR_INVALID_HANDLE then
begin
Result:=False;
end else if LastError <> ERROR_IO_PENDING then
begin
Result:=False;
end else
Result:=True;
end else
Result:=True;}
for I:=0 to Size-1 do
begin
if not WriteChar(Char(Pointer(DWORD(Buf)+I)^)) then
begin
Result:=False;
Exit;
end else
Sleep(1);
end;
Result:=True;
end;
function TProThread.WriteChar(C: Char): Boolean;
var
NumberOfBytesWritten:DWord;
LastError:DWord;
HandleSignaled:DWORD;
HandlesToWaitFor: array[0..2] of THandle;
begin
HandlesToWaitFor[0]:=FCloseCallEvent;
HandlesToWaitFor[1]:=FCloseComCallEvent;
HandlesToWaitFor[2]:=FWriteOverEvent;
if not WriteFile(FComHandle,C,1, NumberOfBytesWritten,@FOverlappedWrite ) then
begin
LastError := GetLastError;
if LastError = ERROR_INVALID_HANDLE then
begin
Result:=False;
end else if LastError <> ERROR_IO_PENDING then
begin
Result:=False;
end else
begin
HandleSignaled := WaitForMultipleObjects(3, @HandlesToWaitFor,
False, INFINITE);
case HandleSignaled of
WAIT_OBJECT_0:Result:=False;
WAIT_OBJECT_0 + 1:Result:=False;
WAIT_OBJECT_0 + 2:
begin
Result:=GetOverlappedResult( FComHandle,
FOverlappedWrite,
NumberOfBytesWritten, True);
end;
WAIT_FAILED:Result:=False;
else Result:=False;
end
end;
end else
Result:=True;
end;
function TProThread.WriteFrame(Frame: TFrame): Integer;
begin
if ((FState=ProBreak) or (FState=ProReading))and(not FWriteCallBuffered) then
begin
FWriteBuf.Buf:=Frame;
FWriteCallBuffered:=True;
SetEvent(FWriteCallEvent);
Result:=1;
end else
Result:=0;
end;
procedure TProThread.DoReadOk;
begin
if Assigned(FOnRead) then
TEventThread.Create(Self,ReadOk,FReadBuf.Buf);
end;
procedure TProThread.DoWriteOk;
begin
if Assigned(FOnWriteOk) then
TEventThread.Create(Self,WriteOk);
end;
procedure TProThread.DoReadBegin;
begin
//PurgeComm( FComHandle, PURGE_RXABORT or PURGE_RXCLEAR);
if FInputBuffer[0]=Char($FE) then
begin
if RandomBool then
begin
if WriteChar(Char($FF)) then
begin
FRetryTimes:=0;
FState:=ProWriteBegin;
FWriteCallBuffered:=False;
end else
DoCloseComCall;
end else
begin
if WriteChar(Char($FE)) then
begin
FReadPos:=0;
FRetryTimes:=0
end else
DoCloseComCall;
end;
end else
begin
FState:=ProReading;
DoReading;
end;
end;
procedure TProThread.SetOnCommErr(const Value: TErrorProc);
begin
FOnCommErr := Value;
end;
procedure TProThread.SetOnRead(const Value: TRecvDataProc);
begin
FOnRead := Value;
end;
procedure TProThread.SetOnReadErr(const Value: TErrorProc);
begin
FOnReadErr := Value;
end;
procedure TProThread.SetOnWriteErr(const Value: TErrorProc);
begin
FOnWriteErr := Value;
end;
procedure TProThread.CloseCom;
begin
SetEvent(FCloseComCallEvent);
end;
procedure TProThread.OpenCom;
begin
SetEvent(FOpenComCallEvent);
end;
procedure TProThread.SetOnWriteOk(const Value: TNotifyProc);
begin
FOnWriteOk := Value;
end;
procedure TProThread.DoOpenComState(ErrID: Integer; ErrStr: WideString);
begin
if Assigned(FOnOpenCom) then
TEventThread.Create(Self,OpenComState,ErrID,ErrStr);
end;
{ TEventThread }
constructor TEventThread.Create(ProThread:TProThread;EventType: TEventType; Buf: TFrame);
begin
inherited Create(True);
FProThread:=ProThread;
FEventType:=EventType;
FBuf:=Buf;
FreeOnTerminate:=True;
Resume;
end;
constructor TEventThread.Create(ProThread:TProThread;EventType: TEventType; ErrID: Integer;
Errstr: WideString);
begin
inherited Create(True);
FProThread:=ProThread;
FEventType:=EventType;
FErrID:=ErrID;
FErrStr:=ErrStr;
FreeOnTerminate:=True;
Resume;
end;
constructor TEventThread.Create(ProThread:TProThread;EventType: TEventType);
begin
inherited Create(True);
FProThread:=ProThread;
FEventType:=EventType;
FreeOnTerminate:=True;
Resume;
end;
procedure TEventThread.Execute;
begin
inherited;
if FEventType=WriteErr then
begin
FProThread.FOnWriteErr(FErrID,PWideChar(FErrStr));
end else if FEventType=WriteOK then
begin
FProThread.FOnWriteOk;
end else if FEventType=ReadOK then
begin
FProThread.FOnRead(@FBuf,SizeOf(FBuf));
end else if FEventType=ReadErr then
begin
FProThread.FOnReadErr(FErrID,PWideChar(FErrStr));
end else if FEventType=OpenComState then
begin
FProThread.FOnOpenCom(FErrID,PWideChar(FErrStr));
end else if FEventType=ComErr then
begin
FProThread.FOnCommErr(FErrID,PWideChar(FErrStr));
end;
end;
end.
1万+
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
