Сегодня в номере :

Порты.

Vcl Haunting

"Золотой Чайник"

Вопрос по дельфи N (N номер версии)

Help!

Реклама

Полезный линк

Наш сайт : pixelsoft.narod.ru

Книги по Дельфи которые ВЫ ОБЯЗАНЫ ПРОЧИТАТЬ...

• Базы данных и приложения в дельфи 6 , спешите купить
• Delphi 6 : Наиболее полное руководство

Не столько учебник, сколько справочное пособие по наиболее используемым алгоритмам и командам...

• Дельфи 6: Учебный курс

Пожалуй лучший учебник по дельфи 6 на сегодняшний день, вам даже не надо знать дельфи, чтобы начать ...

• Дельфи 5: Руководство разработчика БД

 

DirectX. Графика в проектах Delphi (+CD - ROM)
Лучшее пособие для тех кто решил связаться с DirectX, по слухам на CD помимо примеров есть DirectxSDK7.0 от Microsoft...

Среда программирования Delphi 5-6. Справочное пособие
Книга полностью описывает среду программирования Delphi, которая включает в себя полный набор визуальных инструментов для быстрой и профессиональной разработки приложений для различных операционных систем, кроме того рассмотрены проблемы перехода между этими версиями дельфи.

Программирование в Delphi 6 (+ floppy дискета ) Чайникам рекомендуется!!!

Книга содержит методические и справочные материалы по новой версии системы визуального объектно-ориентированного программирования Delphi 6 и предшествующим версиям Delphi 5 и 4. Рассмотрены такие новые возможности Delphi, как кросс-платформенные приложения, технологии доступа к данным ADO, InterBase Express, dbExpress, компоненты ; серверы СОМ, технологии распределенных приложений СОМ, CORBA, MIDAS, новая методика диспетчеризации действий...

{==============================================================================|
| Project : Delphree - Synapse | 005.000.000 |
|==============================================================================|
| Content: Serial port support |
|==============================================================================|
| Copyright (c)2001-2002, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of the Ararat s.r.o. nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}

{$Q-}
{$WEAKPACKAGEUNIT ON}

unit SynaSer;

interface

uses
{$IFDEF LINUX}
Libc, Types, KernelIoctl,
{$ELSE}
Windows, Classes,
{$ENDIF}
SysUtils;

const
LockfileDirectory = '/var/lock'; {HGJ}
PortIsClosed = -1; {HGJ}
ErrAlreadyOwned = 9991; {HGJ}
ErrAlreadyInUse = 9992; {HGJ}
ErrWrongParameter = 9993; {HGJ}
ErrPortNotOpen = 9994; {HGJ}
ErrNoDeviceAnswer = 9995; {HGJ}
ErrMaxBuffer = 9996;
ErrTimeout = 9997;
ErrNotRead = 9998;
ErrFrame = 9999;
ErrOverrun = 10000;
ErrRxOver = 10001;
ErrRxParity = 10002;
ErrTxFull = 10003;

dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensivity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;

{$IFDEF LINUX}
const
INVALID_HANDLE_VALUE = THandle(-1);
CS7fix = $0000020;

type
TDCB = packed record
DCBlength: DWORD;
BaudRate: DWORD;
Flags: Longint;
wReserved: Word;
XonLim: Word;
XoffLim: Word;
ByteSize: Byte;
Parity: Byte;
StopBits: Byte;
XonChar: CHAR;
XoffChar: CHAR;
ErrorChar: CHAR;
EofChar: CHAR;
EvtChar: CHAR;
wReserved1: Word;
end;
PDCB = ^TDCB;

const
MaxRates = 30;
Rates: array[0..MaxRates, 0..1] of cardinal =
(
(0, B0),
(50, B50),
(75, B75),
(110, B110),
(134, B134),
(150, B150),
(200, B200),
(300, B300),
(600, B600),
(1200, B1200),
(1800, B1800),
(2400, B2400),
(4800, B4800),
(9600, B9600),
(19200, B19200),
(38400, B38400),
(57600, B57600),
(115200, B115200),
(230400, B230400),
(460800, B460800),
(500000, B500000),
(576000, B576000),
(921600, B921600),
(1000000, B1000000),
(1152000, B1152000),
(1500000, B1500000),
(2000000, B2000000),
(2500000, B2500000),
(3000000, B3000000),
(3500000, B3500000),
(4000000, B4000000)
);
{$ENDIF}

type

THookSerialReason = (
HR_SerialClose,
HR_Connect,
HR_CanRead,
HR_CanWrite,
HR_ReadCount,
HR_WriteCount
);

THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason;
const Value: string) of object;

ESynaSerError = class(Exception)
public
ErrorCode: integer;
ErrorMessage: string;
end;

TBlockSerial = class(TObject)
protected
FOnStatus: THookSerialStatus;
Fhandle: THandle;
FLastError: integer;
FBuffer: string;
FRaiseExcept: boolean;
FRecvBuffer: integer;
FSendBuffer: integer;
FModemWord: integer;
FRTSToggle: Boolean;
FDeadlockTimeout: integer;
FInstanceActive: boolean; {HGJ}
FTestDSR: Boolean;
FTestCTS: Boolean;
FMaxLineLength: Integer;
FLinuxLock: Boolean;
{$IFNDEF LINUX}
FEventHandle: THandle;
function CanEvent(Event: dword; Timeout: integer): boolean;
procedure DecodeCommError(Error: DWord);
{$ENDIF}
procedure SetSizeRecvBuffer(size: integer);
function GetDSR: Boolean;
procedure SetDTRF(Value: Boolean);
function GetCTS: Boolean;
procedure SetRTSF(Value: Boolean);
function GetCarrier: Boolean;
function GetRing: Boolean;
procedure DoStatus(Reason: THookSerialReason; const Value: string);
procedure GetComNr(Value: string);
function PreTestFailing: boolean; {HGJ}
function TestCtrlLine: Boolean;
{$IFDEF LINUX}
procedure DcbToTermios(const dcb: TDCB; var term: termios);
procedure TermiosToDcb(const term: termios; var dcb: TDCB);
function ReadLockfile: integer;
function LockfileName: String;
procedure CreateLockfile(PidNr: integer);
procedure ErrorMethod(ErrNumber: integer); {HGJ}
{$ENDIF}
public
DCB: Tdcb;
FComNr: integer;
{$IFDEF LINUX}
TermiosStruc: termios;
{$ENDIF}
constructor Create;
destructor Destroy; override;
function GetVersion: string;
procedure CreateSocket;
procedure CloseSocket;
//stopbits is: 0- 1 stop bit, 1- 1.5 stop bits, 2- 2 stop bits
procedure Connect(comport: string; baud, bits: integer; parity: char; stop: integer;
softflow, hardflow: boolean);
procedure SetCommState;
procedure GetCommState;
function SendBuffer(buffer: pointer; length: integer): integer;
procedure SendByte(data: byte);
procedure SendString(data: string);
function RecvBuffer(buffer: pointer; length: integer): integer;
function RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer;
function RecvPacket(Timeout: Integer): string;
function RecvByte(timeout: integer): byte;
function RecvTerminated(Timeout: Integer; const Terminator: string): string;
function Recvstring(timeout: integer): string;
function WaitingData: integer;
function WaitingDataEx: integer;
function SendingData: integer;
procedure EnableRTSToggle(value: boolean);
procedure EnableSoftRTSToggle(value: boolean);
procedure Flush;
procedure Purge;
function CanRead(Timeout: integer): boolean;
function CanWrite(Timeout: integer): boolean;
function CanReadEx(Timeout: integer): boolean;
function ModemStatus: integer;
procedure SetBreak(Duration: integer);
function ATCommand(value: string): string;
function SerialCheck(SerialResult: integer): integer;
procedure ExceptCheck;
procedure ErrorMethod(ErrNumber: integer); {HGJ}
{$IFDEF LINUX}
function cpomComportAccessible: boolean; {HGJ}
procedure cpomReleaseComport; {HGJ}
{$ENDIF}
published
class function GetErrorDesc(ErrorCode: integer): string;
property Handle: THandle read Fhandle write FHandle;
property LastError: integer read FLastError;
property LineBuffer: string read FBuffer write FBuffer;
property RaiseExcept: boolean read FRaiseExcept write FRaiseExcept;
property SizeRecvBuffer: integer read FRecvBuffer write SetSizeRecvBuffer;
property OnStatus: THookSerialStatus read FOnStatus write FOnStatus;
property RTS: Boolean write SetRTSF;
property CTS: boolean read GetCTS;
property DTR: Boolean write SetDTRF;
property DSR: boolean read GetDSR;
property Carrier: boolean read GetCarrier;
property Ring: boolean read GetRing;
property InstanceActive: boolean read FInstanceActive; {HGJ}
property TestDSR: boolean read FTestDSR write FTestDSR;
property TestCTS: boolean read FTestCTS write FTestCTS;
property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout;
property LinuxLock: Boolean read FLinuxLock write FLinuxLock;
end;

implementation

constructor TBlockSerial.Create;
begin
inherited create;
FRaiseExcept := false;
FHandle := INVALID_HANDLE_VALUE;
FComNr:= PortIsClosed; {HGJ}
FInstanceActive:= false; {HGJ}
Fbuffer := '';
FRTSToggle := False;
FMaxLineLength := 0;
FTestDSR := False;
FTestCTS := False;
FDeadlockTimeout := 30000;
FLinuxLock := True;
{$IFNDEF LINUX}
FEventHandle := INVALID_HANDLE_VALUE;
{$ENDIF}
end;

destructor TBlockSerial.Destroy;
begin
CloseSocket;
{$IFNDEF LINUX}
if FEventHandle <> INVALID_HANDLE_VALUE then
CloseHandle(FEventHandle);
{$ENDIF}
inherited destroy;
end;

function TBlockSerial.GetVersion: string;
begin
Result := 'SynaSer 5.0.0';
end;

procedure TBlockSerial.CreateSocket;
begin
// dummy for compatibility with TBlockSocket classes
end;

procedure TBlockSerial.CloseSocket;
begin
if Fhandle <> INVALID_HANDLE_VALUE then
begin
Purge;
RTS := False;
DTR := False;
FileClose(integer(FHandle));
end;
if InstanceActive then
begin
{$IFDEF LINUX}
if FLinuxLock then
cpomReleaseComport;
{$ENDIF}
FInstanceActive:= false
end;
Fhandle := INVALID_HANDLE_VALUE;
FComNr:= PortIsClosed;
DoStatus(HR_SerialClose, '');
end;

procedure TBlockSerial.GetComNr(Value: string);
begin
FComNr := PortIsClosed;
if pos('COM', uppercase(Value)) = 1 then
begin
FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1;
end;
if pos('/DEV/TTYS', uppercase(Value)) = 1 then
begin
FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1) + 1;
end;
end;

procedure TBlockSerial.Connect(comport: string; baud, bits: integer;
parity: char; stop: integer; softflow, hardflow: boolean);
{$IFNDEF LINUX}
var
CommTimeouts: TCommTimeouts;
{$ENDIF}
begin
// Is this TBlockSerial Instance already busy?
if InstanceActive then {HGJ}
begin {HGJ}
ErrorMethod(ErrAlreadyInUse); {HGJ}
Exit; {HGJ}
end; {HGJ}
FBuffer := '';
GetComNr(comport);
if FComNr = PortIsClosed then
begin
ErrorMethod(ErrWrongParameter);
Exit;
end;
SetLastError (0);
{$IFDEF LINUX}
comport := '/dev/ttyS' + IntToStr(FComNr);
// Comport already owned by another process? {HGJ}
if FLinuxLock then
if not cpomComportAccessible then
begin
ErrorMethod(ErrAlreadyOwned);
Exit;
end;
FHandle := THandle(Libc.open(pchar(comport), O_RDWR or O_SYNC));
SerialCheck(integer(FHandle));
if FLastError <> 0 then
begin
if FLinuxLock then
cpomReleaseComport;
end;
ExceptCheck;
if FLastError <> 0 then
Exit;
{$ELSE}
comport := '\\.\COM' + IntToStr(FComNr + 1);
FHandle := THandle(CreateFile(PChar(comport), GENERIC_READ or GENERIC_WRITE,
0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0));
SerialCheck(integer(FHandle));
ExceptCheck;
if FLastError <> 0 then
Exit;
SetCommMask(FHandle, 0);
FEventhandle := CreateEvent(nil, True, False, nil);
CommTimeOuts.ReadIntervalTimeout := MAXWORD;
CommTimeOuts.ReadTotalTimeoutMultiplier := 0;
CommTimeOuts.ReadTotalTimeoutConstant := 0;
CommTimeOuts.WriteTotalTimeoutMultiplier := 0;
CommTimeOuts.WriteTotalTimeoutConstant := 0;
SetCommTimeOuts(FHandle, CommTimeOuts);
{$ENDIF}
GetCommState;
dcb.BaudRate := baud;
dcb.ByteSize := bits;
case parity of
'N', 'n': dcb.parity := 0;
'O', 'o': dcb.parity := 1;
'E', 'e': dcb.parity := 2;
'M', 'm': dcb.parity := 3;
'S', 's': dcb.parity := 4;
end;
if dcb.Parity > 0 then
dcb.Flags := dcb.Flags or dcb_ParityCheck
else
dcb.Flags := dcb.Flags and (not dcb_ParityCheck);
dcb.StopBits := stop;
dcb.Flags := dcb.Flags and (not dcb_RtsControlMask);
if hardflow then
dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake
else
begin
dcb.Flags := dcb.Flags and (not dcb_OutxCtsFlow);
dcb.Flags := dcb.Flags or dcb_RtsControlEnable;
end;
if softflow then
dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX
else
dcb.Flags := dcb.Flags and (not (dcb_OutX or dcb_InX));
dcb.Flags := dcb.Flags and (not dcb_DtrControlMask);
dcb.Flags := dcb.Flags or dcb_DtrControlEnable;
SetCommState;
if FLastError <> 0 then {HGJ}
begin {HGJ}
FileClose(FHandle); {HGJ}
{$IFDEF LINUX}
if FLinuxLock then
cpomReleaseComport;
{$ENDIF}
ExceptCheck;
Exit; {HGJ}
end; {HGJ}
SizeRecvBuffer := 4096;
FInstanceActive:= True; {HGJ}
if not TestCtrlLine then {HGJ}
begin {HGJ}
FLastError := ErrNoDeviceAnswer; {HGJ}
FileClose(integer(FHandle)); {HGJ}
{$IFDEF LINUX}
if FLinuxLock then
cpomReleaseComport; {HGJ}
{$ENDIF} {HGJ}
FInstanceActive := false; {HGJ}
Fhandle := INVALID_HANDLE_VALUE; {HGJ}
FComNr:= PortIsClosed; {HGJ}
end; {HGJ}
if FLastError = 0 then
begin
Purge;
RTS := True;
DTR := True;
end;
ExceptCheck;
DoStatus(HR_Connect, comport);
end;

function TBlockSerial.SendBuffer(buffer: pointer; length: integer): integer;
{$IFNDEF LINUX}
var
Overlapped: TOverlapped;
X, Err: DWord;
{$ENDIF}
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
if FRTSToggle then
begin
Flush;
RTS := True;
end;
{$IFDEF LINUX}
result := FileWrite(integer(Fhandle), Buffer^, Length);
serialcheck(result);
{$ELSE}
FillChar(Overlapped, Sizeof(Overlapped), 0);
ResetEvent(FEventHandle);
Overlapped.hEvent := FEventHandle;
x := DWord(WriteFile(FHandle, Buffer^, Length, DWord(Result), @Overlapped));
if (x = 0) or (x = DWord(INVALID_HANDLE_VALUE)) then
FLastError := GetLastError;
if FlastError = ERROR_IO_PENDING then
begin
x := WaitForSingleObject(FEventHandle, FDeadlockTimeout);
SerialCheck(integer(GetOverlappedResult(FHandle, Overlapped, Dword(Result), False)));
if FLastError = ERROR_IO_INCOMPLETE then
CancelIO(FHandle);
if x = WAIT_TIMEOUT then
FLastError := ErrTimeout;
end;
ResetEvent(FEventHandle);
ClearCommError(FHandle, err, nil);
if err <> 0 then
DecodeCommError(err);
{$ENDIF}
if FRTSToggle then
begin
Flush;
RTS := False;
end;
ExceptCheck;
DoStatus(HR_WriteCount, IntToStr(Result));
end;

procedure TBlockSerial.SendByte(data: byte);
begin
SendBuffer(@Data, 1);
end;

procedure TBlockSerial.SendString(data: string);
begin
SendBuffer(Pointer(Data), Length(Data));
end;

function TBlockSerial.RecvBuffer(buffer: pointer; length: integer): integer;
{$IFDEF LINUX}
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
result := FileRead(integer(FHandle), Buffer^, length);
serialcheck(result);
{$ELSE}
var
Overlapped: TOverlapped;
x, Err: DWord;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
FillChar(Overlapped, Sizeof(Overlapped), 0);
Overlapped.hEvent := FEventHandle;
x := DWord(ReadFile(FHandle, Buffer^, length, Dword(Result), @Overlapped));
if (x = 0) or (x = Dword(INVALID_HANDLE_VALUE)) then
FLastError := GetLastError;
if FlastError = ERROR_IO_PENDING then
begin
x := WaitForSingleObject(FEventHandle, FDeadlockTimeout);
SerialCheck(integer(GetOverlappedResult(Handle, Overlapped, DWord(Result), False)));
if FLastError = ERROR_IO_INCOMPLETE then
CancelIO(FHandle);
if x = WAIT_TIMEOUT then
FLastError := ErrTimeout;
end;
ResetEvent(FEventHandle);
ClearCommError(FHandle, err, nil);
if err <> 0 then
DecodeCommError(err);
{$ENDIF}
ExceptCheck;
DoStatus(HR_ReadCount, IntToStr(Result));
end;

function TBlockSerial.RecvBufferEx(buffer: pointer; length: integer; timeout: integer): integer;
var
s, ss, st: string;
x, l, lss: integer;
fb, fs: integer;
max: integer;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
FLastError := 0;
x := system.length(FBuffer);
if length <= x then
begin
fb := length;
fs := 0;
end
else
begin
fb := x;
fs := length - x;
end;
ss := '';
if fb > 0 then
begin
s := copy(FBuffer, 1, fb);
delete(Fbuffer, 1, fb);
end;
if fs > 0 then
begin
Max := FRecvBuffer;
if Max = 0 then
Max := 1024;
ss := '';
while system.length(ss) < fs do
begin
if canread(timeout) then
begin
l := WaitingData;
if l > max then
l := max;
if (system.length(ss) + l) > fs then
l := fs - system.length(ss);
setlength(st, l);
x := RecvBuffer(Pointer(st), l);
if FlastError <> 0 then
break;
lss := system.length(ss);
setlength(ss, lss + x);
Move(pointer(st)^, Pointer(@ss[lss + 1])^, x);
{It is 3x faster then ss:=ss+copy(st,1,x);}
sleep(0);
end
else
FLastError := ErrTimeout;
if Flasterror <> 0 then
break;
end;
fs := system.length(ss);
end;
result := fb + fs;
s := s + ss;
move(pointer(s)^, buffer^, result);
ExceptCheck;
end;

function TBlockSerial.RecvPacket(Timeout: Integer): string;
var
x: integer;
s: string;
begin
Result := '';
if PreTestFailing then {HGJ}
Exit; {HGJ}
FLastError := 0;
x := -1;
if FBuffer <> '' then
begin
Result := FBuffer;
FBuffer := '';
end
else
repeat
if CanRead(Timeout) then
begin
x := WaitingData;
if x > 0 then
begin
SetLength(s, x);
x := RecvBuffer(Pointer(s), x);
Result := Copy(s, 1, x);
end;
end
else
FLastError := ErrTimeout;
until not((FlastError = 0) and (x = 0));
ExceptCheck;
if x = 0 then
FLastError := integer(-1);
end;

function TBlockSerial.RecvByte(timeout: integer): byte;
var
s: String;
x: integer;
begin
Result := 0;
if PreTestFailing then {HGJ}
Exit; {HGJ}
if CanRead(timeout) then
begin
x := WaitingData;
if x > 0 then
begin
SetLength(s, 1);
x := RecvBuffer(Pointer(s), 1);
SetLength(s, x);
if s <> '' then
Result := Ord(s[1])
else
FLastError := ErrNotRead;
end
else
FLastError := ErrNotRead;
end
else
FLastError := ErrTimeout;
ExceptCheck;
end;

function TBlockSerial.RecvTerminated(Timeout: Integer; const Terminator: string): string;
var
x: Integer;
s: string;
l: Integer;
begin
Result := '';
if PreTestFailing then {HGJ}
Exit; {HGJ}
s := '';
l := Length(Terminator);
if l = 0 then
Exit;
FLastError := 0;
repeat
x := 0;
if x > 0 then {nothing; work around for warning bug}; {HGJ}
if FBuffer = '' then
begin
FBuffer := RecvPacket(Timeout);
if FLastError <> 0 then
Break;
end;
s := s + FBuffer;
FBuffer := '';
x := Pos(Terminator, s);
if x > 0 then
begin
FBuffer := Copy(s, x + l, Length(s) - x - l + 1);
s := Copy(s, 1, x - 1);
end;
if (FMaxLineLength <> 0) and (Length(s) > FMaxLineLength) then
begin
FLastError := ErrMaxBuffer;
Break;
end;
until x > 0;
if FLastError = 0 then
Result := s
else
Result := '';
ExceptCheck;
end;

function TBlockSerial.RecvString(Timeout: Integer): string;
var
s: string;
begin
Result := '';
s := RecvTerminated(Timeout, #13 + #10);
if FLastError = 0 then
Result := s;
end;

{$IFDEF LINUX}
function TBlockSerial.WaitingData: integer;
begin
serialcheck(ioctl(integer(FHandle), FIONREAD, @result));
ExceptCheck;
end;
{$ELSE}
function TBlockSerial.WaitingData: integer;
var
stat: TComStat;
err: DWORD;
x: integer;
begin
x := integer(ClearCommError(FHandle, err, @stat));
serialcheck(x);
ExceptCheck;
result := stat.cbInQue;
end;
{$ENDIF}

function TBlockSerial.WaitingDataEx: integer;
begin
if FBuffer <> '' then
Result := Length(FBuffer)
else
Result := Waitingdata;
end;

{$IFDEF LINUX}
function TBlockSerial.SendingData: integer;
begin
FLastError := 0;
Result := 0;
end;
{$ELSE}
function TBlockSerial.SendingData: integer;
var
stat: TComStat;
err: DWORD;
x: integer;
begin
x := integer(ClearCommError(FHandle, err, @stat));
serialcheck(x);
ExceptCheck;
result := stat.cbOutQue;
end;
{$ENDIF}

{$IFDEF LINUX}
procedure TBlockSerial.DcbToTermios(const dcb: TDCB; var term: termios);
var
n: integer;
x: cardinal;
begin
//others
cfmakeraw(term);
term.c_cflag := term.c_cflag or CREAD;
term.c_cflag := term.c_cflag or CLOCAL;
term.c_cflag := term.c_cflag or HUPCL;
//hardware handshake
if (dcb.flags and dcb_RtsControlHandshake) > 0 then
term.c_cflag := term.c_cflag or CRTSCTS
else
term.c_cflag := term.c_cflag and (not CRTSCTS);
//software handshake
if (dcb.flags and dcb_OutX) > 0 then
term.c_iflag := term.c_iflag or IXON or IXOFF or IXANY
else
term.c_iflag := term.c_iflag and (not (IXON or IXOFF or IXANY));
//size of byte
term.c_cflag := term.c_cflag and (not CSIZE);
case dcb.bytesize of
5:
term.c_cflag := term.c_cflag or CS5;
6:
term.c_cflag := term.c_cflag or CS6;
7:
term.c_cflag := term.c_cflag or CS7fix;
8:
term.c_cflag := term.c_cflag or CS8;
end;
//parity
if (dcb.flags and dcb_ParityCheck) > 0 then
term.c_cflag := term.c_cflag or PARENB
else
term.c_cflag := term.c_cflag and (not PARENB);
case dcb.parity of
1: //'O'
term.c_cflag := term.c_cflag and PARODD;
2: //'E'
term.c_cflag := term.c_cflag and (not PARODD);
end;
//stop bits
if dcb.stopbits > 0 then
term.c_cflag := term.c_cflag or CSTOPB
else
term.c_cflag := term.c_cflag and (not CSTOPB);
//set baudrate;
x := 0;
for n := 0 to Maxrates do
if rates[n, 0] = dcb.BaudRate then
begin
x := rates[n, 1];
break;
end;
cfsetospeed(term, x);
cfsetispeed(term, x);
end;

procedure TBlockSerial.TermiosToDcb(const term: termios; var dcb: TDCB);
var
n: integer;
x: cardinal;
begin
//set baudrate;
dcb.baudrate := 0;
x := cfgetospeed(term);
for n := 0 to Maxrates do
if rates[n, 1] = x then
begin
dcb.baudrate := rates[n, 0];
break;
end;
//hardware handshake
if (term.c_cflag and CRTSCTS) > 0 then
dcb.flags := dcb.flags or dcb_RtsControlHandshake or dcb_OutxCtsFlow
else
dcb.flags := dcb.flags and (not (dcb_RtsControlHandshake or dcb_OutxCtsFlow));
//software handshake
if (term.c_cflag and IXOFF) > 0 then
dcb.flags := dcb.flags or dcb_OutX or dcb_InX
else
dcb.flags := dcb.flags and (not (dcb_OutX or dcb_InX));
//size of byte
case term.c_cflag and CSIZE of
CS5:
dcb.bytesize := 5;
CS6:
dcb.bytesize := 6;
CS7fix:
dcb.bytesize := 7;
CS8:
dcb.bytesize := 8;
end;
//parity
if (term.c_cflag and PARENB) > 0 then
dcb.flags := dcb.flags or dcb_ParityCheck
else
dcb.flags := dcb.flags and (not dcb_ParityCheck);
dcb.parity := 0;
if (term.c_cflag and PARODD) > 0 then
dcb.parity := 1
else
dcb.parity := 2;
//stop bits
if (term.c_cflag and CSTOPB) > 0 then
dcb.stopbits := 2
else
dcb.stopbits := 0;
end;
{$ENDIF}

{$IFDEF LINUX}
procedure TBlockSerial.SetCommState;
begin
DcbToTermios(dcb, termiosstruc);
SerialCheck(tcsetattr(integer(FHandle), TCSANOW, termiosstruc));
ExceptCheck;
end;
{$ELSE}
procedure TBlockSerial.SetCommState;
begin
SerialCheck(integer(windows.SetCommState(Fhandle, dcb)));
ExceptCheck;
end;
{$ENDIF}

{$IFDEF LINUX}
procedure TBlockSerial.GetCommState;
begin
SerialCheck(tcgetattr(integer(FHandle), termiosstruc));
ExceptCheck;
TermiostoDCB(termiosstruc, dcb);
end;
{$ELSE}
procedure TBlockSerial.GetCommState;
begin
SerialCheck(integer(windows.GetCommState(Fhandle, dcb)));
ExceptCheck;
end;
{$ENDIF}

procedure TBlockSerial.SetSizeRecvBuffer(size: integer);
begin
{$IFNDEF LINUX}
SetupComm(Fhandle, size, 0);
GetCommState;
dcb.XonLim := size div 4;
dcb.XoffLim := size div 4;
SetCommState;
{$ENDIF}
FRecvBuffer := size;
end;

function TBlockSerial.GetDSR: Boolean;
begin
ModemStatus;
{$IFDEF LINUX}
Result := (FModemWord and TIOCM_DSR) > 0;
{$ELSE}
Result := (FModemWord and MS_DSR_ON) > 0;
{$ENDIF}
end;

procedure TBlockSerial.SetDTRF(Value: Boolean);
begin
{$IFDEF LINUX}
ModemStatus;
if Value then
FModemWord := FModemWord or TIOCM_DTR
else
FModemWord := FModemWord and not TIOCM_DTR;
ioctl(integer(FHandle), TIOCMSET, @FModemWord);
{$ELSE}
if Value then
EscapeCommFunction(FHandle, SETDTR)
else
EscapeCommFunction(FHandle, CLRDTR);
{$ENDIF}
end;

function TBlockSerial.GetCTS: Boolean;
begin
ModemStatus;
{$IFDEF LINUX}
Result := (FModemWord and TIOCM_CTS) > 0;
{$ELSE}
Result := (FModemWord and MS_CTS_ON) > 0;
{$ENDIF}
end;

procedure TBlockSerial.SetRTSF(Value: Boolean);
begin
{$IFDEF LINUX}
ModemStatus;
if Value then
FModemWord := FModemWord or TIOCM_RTS
else
FModemWord := FModemWord and not TIOCM_RTS;
ioctl(integer(FHandle), TIOCMSET, @FModemWord);
{$ELSE}
if Value then
EscapeCommFunction(FHandle, SETRTS)
else
EscapeCommFunction(FHandle, CLRRTS);
{$ENDIF}
end;

function TBlockSerial.GetCarrier: Boolean;
begin
ModemStatus;
{$IFDEF LINUX}
Result := (FModemWord and TIOCM_CAR) > 0;
{$ELSE}
Result := (FModemWord and MS_RLSD_ON) > 0;
{$ENDIF}
end;

function TBlockSerial.GetRing: Boolean;
begin
ModemStatus;
{$IFDEF LINUX}
Result := (FModemWord and TIOCM_RNG) > 0;
{$ELSE}
Result := (FModemWord and MS_RING_ON) > 0;
{$ENDIF}
end;

{$IFNDEF LINUX}
function TBlockSerial.CanEvent(Event: dword; Timeout: integer): boolean;
var
ex: DWord;
y: Integer;
Overlapped: TOverlapped;
begin
FillChar(Overlapped, Sizeof(Overlapped), 0);
ResetEvent(FEventHandle);
Overlapped.hEvent := FEventHandle;
SetCommMask(FHandle, Event);
y := integer(WaitCommEvent(FHandle, ex, @Overlapped));
if (y = 0) or (y = integer(INVALID_HANDLE_VALUE)) then
FLastError := GetLastError;
if FLastError = ERROR_IO_PENDING then
begin
WaitForSingleObject(FEventHandle, Timeout);
GetOverlappedResult(FHandle, Overlapped, DWord(y), False);
if GetLastError = ERROR_IO_INCOMPLETE then
CancelIO(FHandle);
ResetEvent(FEventHandle);
FLastError := 0;
end;
Result := (ex and Event) = Event;
SetCommMask(FHandle, 0);
end;
{$ENDIF}

{$IFDEF LINUX}
function TBlockSerial.CanRead(Timeout: integer): boolean;
var
FDSet: TFDSet;
TimeVal: PTimeVal;
TimeV: TTimeVal;
x: Integer;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
FD_ZERO(FDSet);
FD_SET(integer(FHandle), FDSet);
x := Select(integer(FHandle) + 1, @FDSet, nil, nil, TimeVal);
SerialCheck(x);
if FLastError <> 0 then
x := 0;
Result := x > 0;
ExceptCheck;
if Result then
DoStatus(HR_CanRead, '');
end;
{$ELSE}
function TBlockSerial.CanRead(Timeout: integer): boolean;
begin
Result := WaitingData > 0;
if not Result then
Result := CanEvent(EV_RXCHAR, Timeout);
if Result then
DoStatus(HR_CanRead, '');
end;
{$ENDIF}

{$IFDEF LINUX}
function TBlockSerial.CanWrite(Timeout: integer): boolean;
var
FDSet: TFDSet;
TimeVal: PTimeVal;
TimeV: TTimeVal;
x: Integer;
begin
TimeV.tv_usec := (Timeout mod 1000) * 1000;
TimeV.tv_sec := Timeout div 1000;
TimeVal := @TimeV;
if Timeout = -1 then
TimeVal := nil;
FD_ZERO(FDSet);
FD_SET(integer(FHandle), FDSet);
x := Select(integer(FHandle) + 1, nil, @FDSet, nil, TimeVal);
SerialCheck(x);
if FLastError <> 0 then
x := 0;
Result := x > 0;
ExceptCheck;
if Result then
DoStatus(HR_CanWrite, '');
end;
{$ELSE}
function TBlockSerial.CanWrite(Timeout: integer): boolean;
begin
Result := SendingData = 0;
if not Result then
Result := CanEvent(EV_TXEMPTY, Timeout);
if Result then
DoStatus(HR_CanWrite, '');
end;
{$ENDIF}

function TBlockSerial.CanReadEx(Timeout: integer): boolean;
begin
if Fbuffer<>'' then
Result := True
else
Result := CanRead(Timeout);
end;

procedure TBlockSerial.EnableRTSToggle(Value: boolean);
begin
{$IFDEF LINUX}
EnableSoftRTSToggle(Value);
{$ELSE}
GetCommState;
if value
then dcb.Flags := dcb.Flags or dcb_RtsControlToggle
else
dcb.flags := dcb.flags and (not dcb_RtsControlToggle);
SetCommState;
{$ENDIF}
end;

procedure TBlockSerial.EnableSoftRTSToggle(Value: boolean);
begin
FRTSToggle := Value;
end;

procedure TBlockSerial.Flush;
begin
{$IFDEF LINUX}
SerialCheck(tcdrain(integer(FHandle)));
{$ELSE}
SerialCheck(integer(Flushfilebuffers(FHandle)));
{$ENDIF}
ExceptCheck;
end;

{$IFDEF LINUX}
procedure TBlockSerial.Purge;
begin
SerialCheck(ioctl(integer(FHandle), TCFLSH, TCIOFLUSH));
FBuffer := '';
ExceptCheck;
end;
{$ELSE}
procedure TBlockSerial.Purge;
var
x: integer;
begin
x := PURGE_TXABORT or PURGE_TXCLEAR or PURGE_RXABORT or PURGE_RXCLEAR;
SerialCheck(integer(PurgeComm(FHandle, x)));
FBuffer := '';
ExceptCheck;
end;
{$ENDIF}

function TBlockSerial.ModemStatus: integer;
begin
{$IFDEF LINUX}
SerialCheck(ioctl(integer(FHandle), TIOCMGET, @Result));
{$ELSE}
SerialCheck(integer(GetCommModemStatus(FHandle, dword(Result))));
{$ENDIF}
ExceptCheck;
FModemWord := Result;
end;

procedure TBlockSerial.SetBreak(Duration: integer);
begin
{$IFDEF LINUX}
SerialCheck(tcsendbreak(integer(FHandle), Duration));
{$ELSE}
SetCommBreak(FHandle);
Sleep(Duration);
SerialCheck(integer(ClearCommBreak(FHandle)));
{$ENDIF}
end;

{$IFNDEF LINUX}
procedure TBlockSerial.DecodeCommError(Error: DWord);
begin
if (Error and DWord(CE_FRAME)) > 1 then
FLastError := ErrFrame;
if (Error and DWord(CE_OVERRUN)) > 1 then
FLastError := ErrOverrun;
if (Error and DWord(CE_RXOVER)) > 1 then
FLastError := ErrRxOver;
if (Error and DWord(CE_RXPARITY)) > 1 then
FLastError := ErrRxParity;
if (Error and DWord(CE_TXFULL)) > 1 then
FLastError := ErrTxFull;
end;
{$ENDIF}

function TBlockSerial.PreTestFailing: Boolean; {HGJ}
begin {HGJ}
if not FInstanceActive then {HGJ}
begin
ErrorMethod(ErrPortNotOpen); {HGJ}
result:= true; {HGJ}
Exit; {HGJ}
end; {HGJ}
Result := not TestCtrlLine;
if result then
ErrorMethod(ErrNoDeviceAnswer) {HGJ}
end;

function TBlockSerial.TestCtrlLine: Boolean;
begin
result := ((not FTestDSR) or DSR) and ((not FTestCTS) or CTS);
end;

function TBlockSerial.ATCommand(value: string): string;
var
s: string;
begin
result := '';
SendString(value + #$0D);
repeat
s := RecvTerminated(1000, #$0D);
if s <> '' then
if s[1] = #$0a then
s := Copy(s, 2, Length(s) - 1);
if (s <> value) and (s <> value + #$0d) then
result := result + s + #$0D + #$0A;
if s = 'OK' then
break;
if s = 'ERROR' then
break;
until FLastError <> 0;
end;

function TBlockSerial.SerialCheck(SerialResult: integer): integer;
begin
if SerialResult = integer(INVALID_HANDLE_VALUE) then
result := GetLastError
else
result := 0;
FLastError := result;
end;

procedure TBlockSerial.ExceptCheck;
var
e: ESynaSerError;
s: string;
begin
if FRaiseExcept and (FLastError <> 0) then
begin
s := GetErrorDesc(LastError);
e := ESynaSerError.CreateFmt('Communication error %d: %s', [LastError, s]);
e.ErrorCode := FLastError;
e.ErrorMessage := s;
raise e;
end;
end;

procedure TBlockSerial.ErrorMethod(ErrNumber: integer);
begin
FLastError := ErrNumber;
ExceptCheck;
end;

procedure TBlockSerial.DoStatus(Reason: THookSerialReason; const Value: string);
begin
if assigned(OnStatus) then
OnStatus(Self, Reason, Value);
end;

{======================================================================}

{$IFDEF LINUX}
class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string;
begin
case ErrorCode of
ErrAlreadyOwned: Result:= 'Port owned by other process';{HGJ}
ErrAlreadyInUse: Result:= 'Instance already in use'; {HGJ}
ErrWrongParameter: Result:= 'Wrong paramter at call'; {HGJ}
ErrPortNotOpen: Result:= 'Instance not yet connected'; {HGJ}
ErrNoDeviceAnswer: Result:= 'No device answer detected'; {HGJ}
ErrMaxBuffer: Result:= 'Maximal buffer length exceeded';
ErrTimeout: Result:= 'Timeout during operation';
ErrNotRead: Result:= 'Reading of data failed';
ErrFrame: Result:= 'Receive framing error';
ErrOverrun: Result:= 'Receive Overrun Error';
ErrRxOver: Result:= 'Receive Queue overflow';
ErrRxParity: Result:= 'Receive Parity Error';
ErrTxFull: Result:= 'Tranceive Queue is full';
else
Result := 'SynaSer error: ' + IntToStr(ErrorCode);
end;
end;
{$ELSE}
class function TBlockSerial.GetErrorDesc(ErrorCode: integer): string;
var
x: integer;
begin
Result:= '';
case ErrorCode of
ErrAlreadyOwned: Result:= 'Port owned by other process';{HGJ}
ErrAlreadyInUse: Result:= 'Instance already in use'; {HGJ}
ErrWrongParameter: Result:= 'Wrong paramter at call'; {HGJ}
ErrPortNotOpen: Result:= 'Instance not yet connected'; {HGJ}
ErrNoDeviceAnswer: Result:= 'No device answer detected'; {HGJ}
ErrMaxBuffer: Result:= 'Maximal buffer length exceeded';
ErrTimeout: Result:= 'Timeout during operation';
ErrNotRead: Result:= 'Reading of data failed';
ErrFrame: Result:= 'Receive framing error';
ErrOverrun: Result:= 'Receive Overrun Error';
ErrRxOver: Result:= 'Receive Queue overflow';
ErrRxParity: Result:= 'Receive Parity Error';
ErrTxFull: Result:= 'Tranceive Queue is full';
end;
if Result = '' then
begin
setlength(result, 1023);
x := Formatmessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrorCode, 0, pchar(result), 1023, nil);
result := copy(result, 1, x);
if (Result <> '') then
if Pos(#$0d+#$0a, Result) = (Length(Result) - 1) then
Result := Copy(Result, 1, Length(Result) - 2);
end;
end;
{$ENDIF}

{---------- cpom Comport Ownership Manager Routines -------------
by Hans-Georg Joepgen of Stuttgart, Germany.
Copyright (c) 2002, by Hans-Georg Joepgen

Stefan Krauss of Stuttgart, Germany, contributed literature and Internet
research results, invaluable advice and excellent answers to the Comport
Ownership Manager.
}

{$IFDEF LINUX}

function TBlockSerial.LockfileName: String;
begin
result := LockfileDirectory + '/LCK..ttyS' + IntToStr(FComNr);
end;

procedure TBlockSerial.CreateLockfile(PidNr: integer);
var
f: TextFile;
s: string;
begin
// Create content for file
s := IntToStr(PidNr);
while length(s) < 10 do
s := ' ' + s;
// Create file
AssignFile(f, LockfileName);
Rewrite(f);
writeln(f, s);
CloseFile(f);
// Allow all users to enjoy the benefits of cpom
s := 'chmod a+rw ' + LockfileName;
Libc.system(pchar(s));
end;

function TBlockSerial.ReadLockfile: integer;
{Returns PID from Lockfile. Lockfile must exist.}
var
f: TextFile;
s: string;
begin
AssignFile(f, LockfileName);
Reset(f);
readln(f, s);
CloseFile(f);
Result := StrToIntDef(s, -1)
end;

function TBlockSerial.cpomComportAccessible: boolean;
var
MyPid: integer;
Filename: string;
begin
Filename := LockfileName;
MyPid := Libc.getpid;
// Make sure, the Lock Files Directory exists. We need it.
if not DirectoryExists(LockfileDirectory) then
MkDir(LockfileDirectory);
// Check the Lockfile
if not FileExists (Filename) then
begin // comport is not locked. Lock it for us.
CreateLockfile(MyPid);
result := true;
exit; // done.
end;
// Is port owned by orphan? Then it's time for error recovery.
if Libc.getsid(ReadLockfile) = -1 then
begin // Lockfile was left from former desaster
DeleteFile(Filename); // error recovery
CreateLockfile(MyPid);
result := true;
exit;
end;
result := false // Sorry, port is owned by living PID and locked
end;

procedure TBlockSerial.cpomReleaseComport;
begin
DeleteFile(LockfileName);
end;

{$ENDIF}
{----------------------------------------------------------------}

end.