pascal/synapse
1
0
Fork 0
Code Issues Releases Activity

synaser.pas - POSIX and Android support by ACBr

Browse Source 
git-svn-id: https://svn.code.sf.net/p/synalist/code/trunk@253 7c85be65-684b-0410-a082-b2ed4fbef004
This commit is contained in:
geby 2022-01-14 17:08:30 +00:00
parent aa1fdbacc4
commit 49454ea6e1
1 changed files with 136 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

181
synaser.pas
View File

@ -1,9 +1,9 @@
{==============================================================================| {==============================================================================|
| Project : Ararat Synapse | 007.006.002 | | Project : Ararat Synapse | 007.007.000 |
|==============================================================================| |==============================================================================|
| Content: Serial port support | | Content: Serial port support |
|==============================================================================| |==============================================================================|
| Copyright (c)2001-2021, Lukas Gebauer | | Copyright (c)2001-2022, Lukas Gebauer |
| All rights reserved. | | All rights reserved. |
| | | |
| Redistribution and use in source and binary forms, with or without | | Redistribution and use in source and binary forms, with or without |
@ -83,6 +83,15 @@ case with my USB modem):
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
{$IFDEF UNIX}
{$DEFINE USE_LINUX_LOCK}
{$ENDIF}
{$IFDEF ANDROID}
{$DEFINE UNIX}
{$UNDEF USE_LINUX_LOCK}
{$ENDIF}
{$IFDEF FPC} {$IFDEF FPC}
{$MODE DELPHI} {$MODE DELPHI}
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
@ -96,6 +105,17 @@ case with my USB modem):
{define working mode w/o LIBC for fpc} {define working mode w/o LIBC for fpc}
{$DEFINE NO_LIBC} {$DEFINE NO_LIBC}
{$ENDIF} {$ENDIF}
{$IFDEF POSIX}
{$WARN UNIT_PLATFORM OFF}
{$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}
{$IFDEF NEXTGEN}
{$LEGACYIFEND ON}
{$ZEROBASEDSTRINGS OFF}
{$ENDIF}
{$Q-} {$Q-}
{$H+} {$H+}
{$M+} {$M+}
@ -106,11 +126,18 @@ interface
uses uses
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
{$IFNDEF NO_LIBC} {$IFDEF POSIX}
Libc, Posix.Termios, Posix.Fcntl, Posix.Unistd, Posix.Stropts, Posix.SysSelect, Posix.SysTime,
KernelIoctl, {$IFDEF LINUX}
Linuxapi.KernelIoctl,
{$ENDIF}
{$ELSE} {$ELSE}
termio, baseunix, unix, {$IFNDEF NO_LIBC}
Libc,
KernelIoctl,
{$ELSE}
termio, baseunix, unix,
{$ENDIF}
{$ENDIF} {$ENDIF}
{$IFNDEF FPC} {$IFNDEF FPC}
Types, Types,
@ -132,6 +159,7 @@ const
LockfileDirectory = '/var/lock'; {HGJ} LockfileDirectory = '/var/lock'; {HGJ}
PortIsClosed = -1; {HGJ} PortIsClosed = -1; {HGJ}
ErrAccessDenied = 9990; {DSA}
ErrAlreadyOwned = 9991; {HGJ} ErrAlreadyOwned = 9991; {HGJ}
ErrAlreadyInUse = 9992; {HGJ} ErrAlreadyInUse = 9992; {HGJ}
ErrWrongParameter = 9993; {HGJ} ErrWrongParameter = 9993; {HGJ}
@ -203,7 +231,7 @@ type
const const
{$IFDEF UNIX} {$IFDEF UNIX}
{$IFDEF BSD} {$IFDEF BSD}
MaxRates = 18; //MAC MaxRates = 18; //MAC
{$ELSE} {$ELSE}
{$IFDEF CPUARM} {$IFDEF CPUARM}
MaxRates = 19; //CPUARM MaxRates = 19; //CPUARM
@ -261,10 +289,27 @@ const // From fcntl.h
O_SYNC = $0080; { synchronous writes } O_SYNC = $0080; { synchronous writes }
{$ENDIF} {$ENDIF}
{$IFDEF ANDROID}
const
TIOCMSET = $5418;
TIOCMGET = $5415;
TCSBRK = $5409;
{$ENDIF}
const const
sOK = 0; sOK = 0;
sErr = integer(-1); sErr = integer(-1);
{$IFDEF POSIX}
const
TIOCM_DTR = $002;
TIOCM_RTS = $004;
TIOCM_CTS = $020;
TIOCM_CAR = $040;
TIOCM_RNG = $080;
TIOCM_DSR = $100;
{$ENDIF}
type type
{:Possible status event types for @link(THookSerialStatus)} {:Possible status event types for @link(THookSerialStatus)}
@ -341,9 +386,11 @@ type
procedure GetComNr(Value: string); virtual; procedure GetComNr(Value: string); virtual;
function PreTestFailing: boolean; virtual;{HGJ} function PreTestFailing: boolean; virtual;{HGJ}
function TestCtrlLine: Boolean; virtual; function TestCtrlLine: Boolean; virtual;
{$IFDEF UNIX} {$IFNDEF MSWINDOWS}
procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual; procedure DcbToTermios(const dcb: TDCB; var term: termios); virtual;
procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual; procedure TermiosToDcb(const term: termios; var dcb: TDCB); virtual;
{$ENDIF}
{$IFDEF USE_LINUX_LOCK}
function ReadLockfile: integer; virtual; function ReadLockfile: integer; virtual;
function LockfileName: String; virtual; function LockfileName: String; virtual;
procedure CreateLockfile(PidNr: integer); virtual; procedure CreateLockfile(PidNr: integer); virtual;
@ -354,7 +401,7 @@ type
{: data Control Block with communication parameters. Usable only when you {: data Control Block with communication parameters. Usable only when you
need to call API directly.} need to call API directly.}
DCB: Tdcb; DCB: Tdcb;
{$IFDEF UNIX} {$IFNDEF MSWINDOWS}
TermiosStruc: termios; TermiosStruc: termios;
{$ENDIF} {$ENDIF}
{:Object constructor.} {:Object constructor.}
@ -632,7 +679,7 @@ type
{:Raise Synaser error with ErrNumber code. Usually used by internal routines.} {:Raise Synaser error with ErrNumber code. Usually used by internal routines.}
procedure RaiseSynaError(ErrNumber: integer); virtual; procedure RaiseSynaError(ErrNumber: integer); virtual;
{$IFDEF UNIX} {$IFDEF USE_LINUX_LOCK}
function cpomComportAccessible: boolean; virtual;{HGJ} function cpomComportAccessible: boolean; virtual;{HGJ}
procedure cpomReleaseComport; virtual; {HGJ} procedure cpomReleaseComport; virtual; {HGJ}
{$ENDIF} {$ENDIF}
@ -807,7 +854,7 @@ begin
end; end;
if InstanceActive then if InstanceActive then
begin begin
{$IFDEF UNIX} {$IFDEF USE_LINUX_LOCK}
if FLinuxLock then if FLinuxLock then
cpomReleaseComport; cpomReleaseComport;
{$ENDIF} {$ENDIF}
@ -882,7 +929,7 @@ begin
sleep(x); sleep(x);
end; end;
end; end;
Next := GetTick + Trunc((Length / MaxB) * 1000); Next := GetTick + LongWord(Trunc((Length / MaxB) * 1000));
end; end;
end; end;
@ -946,23 +993,34 @@ begin
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
if FComNr <> PortIsClosed then if FComNr <> PortIsClosed then
FDevice := '/dev/ttyS' + IntToStr(FComNr); FDevice := '/dev/ttyS' + IntToStr(FComNr);
// Comport already owned by another process? {HGJ} {$IFDEF USE_LINUX_LOCK}
if FLinuxLock then // Comport already owned by another process? {HGJ}
if not cpomComportAccessible then if FLinuxLock then
begin if not cpomComportAccessible then
RaiseSynaError(ErrAlreadyOwned); begin
Exit; if FileExists(LockfileName) then
end; RaiseSynaError(ErrAlreadyOwned)
{$IFNDEF FPC} else
FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC)); RaiseSynaError(ErrAccessDenied);
{$ELSE}
FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC)); Exit;
{$ENDIF} end;
{$ENDIF}
{$IFNDEF FPC}
{$IFDEF POSIX}
FHandle := open(MarshaledAString(AnsiString(FDevice)), O_RDWR or O_SYNC);
{$ELSE}
FHandle := THandle(Libc.open(pchar(FDevice), O_RDWR or O_SYNC));
{$ENDIF}
{$ELSE}
FHandle := THandle(fpOpen(FDevice, O_RDWR or O_SYNC));
{$ENDIF}
if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms! if FHandle = INVALID_HANDLE_VALUE then //because THandle is not integer on all platforms!
SerialCheck(-1) SerialCheck(-1)
else else
SerialCheck(0); SerialCheck(0);
{$IFDEF UNIX} {$IFDEF USE_LINUX_LOCK}
if FLastError <> sOK then if FLastError <> sOK then
if FLinuxLock then if FLinuxLock then
cpomReleaseComport; cpomReleaseComport;
@ -999,7 +1057,7 @@ begin
begin begin
SetSynaError(ErrNoDeviceAnswer); SetSynaError(ErrNoDeviceAnswer);
FileClose(FHandle); {HGJ} FileClose(FHandle); {HGJ}
{$IFDEF UNIX} {$IFDEF USE_LINUX_LOCK}
if FLinuxLock then if FLinuxLock then
cpomReleaseComport; {HGJ} cpomReleaseComport; {HGJ}
{$ENDIF} {HGJ} {$ENDIF} {HGJ}
@ -1648,7 +1706,11 @@ end;
procedure TBlockSerial.SetCommState; procedure TBlockSerial.SetCommState;
begin begin
DcbToTermios(dcb, termiosstruc); DcbToTermios(dcb, termiosstruc);
SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc)); {$IfDef POSIX}
ioctl(Fhandle, TCSANOW, PInteger(@TermiosStruc));
{$Else}
SerialCheck(tcsetattr(FHandle, TCSANOW, termiosstruc));
{$EndIf}
ExceptCheck; ExceptCheck;
end; end;
{$ELSE} {$ELSE}
@ -1811,7 +1873,7 @@ end;
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
function TBlockSerial.CanRead(Timeout: integer): boolean; function TBlockSerial.CanRead(Timeout: integer): boolean;
var var
FDSet: TFDSet; FDSet: {$IFDEF POSIX}FD_Set{$ELSE}TFDSet{$ENDIF};
TimeVal: PTimeVal; TimeVal: PTimeVal;
TimeV: TTimeVal; TimeV: TTimeVal;
x: Integer; x: Integer;
@ -1823,7 +1885,7 @@ begin
TimeVal := nil; TimeVal := nil;
{$IFNDEF FPC} {$IFNDEF FPC}
FD_ZERO(FDSet); FD_ZERO(FDSet);
FD_SET(FHandle, FDSet); {$IFDEF POSIX}_FD_SET{$ELSE}FD_SET{$ENDIF}(FHandle, FDSet);
x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal); x := Select(FHandle + 1, @FDSet, nil, nil, TimeVal);
{$ELSE} {$ELSE}
fpFD_ZERO(FDSet); fpFD_ZERO(FDSet);
@ -1853,7 +1915,7 @@ end;
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
function TBlockSerial.CanWrite(Timeout: integer): boolean; function TBlockSerial.CanWrite(Timeout: integer): boolean;
var var
FDSet: TFDSet; FDSet: {$IFDEF POSIX}FD_Set{$ELSE}TFDSet{$ENDIF};
TimeVal: PTimeVal; TimeVal: PTimeVal;
TimeV: TTimeVal; TimeV: TTimeVal;
x: Integer; x: Integer;
@ -1865,7 +1927,7 @@ begin
TimeVal := nil; TimeVal := nil;
{$IFNDEF FPC} {$IFNDEF FPC}
FD_ZERO(FDSet); FD_ZERO(FDSet);
FD_SET(FHandle, FDSet); {$IFDEF POSIX}_FD_SET{$ELSE}FD_SET{$ENDIF}(FHandle, FDSet);
x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal); x := Select(FHandle + 1, nil, @FDSet, nil, TimeVal);
{$ELSE} {$ELSE}
fpFD_ZERO(FDSet); fpFD_ZERO(FDSet);
@ -1882,8 +1944,10 @@ begin
end; end;
{$ELSE} {$ELSE}
function TBlockSerial.CanWrite(Timeout: integer): boolean; function TBlockSerial.CanWrite(Timeout: integer): boolean;
{$IFDEF WIN32}
var var
t: LongWord; t: LongWord;
{$ENDIF}
begin begin
Result := SendingData = 0; Result := SendingData = 0;
if not Result then if not Result then
@ -1942,7 +2006,11 @@ end;
procedure TBlockSerial.Flush; procedure TBlockSerial.Flush;
begin begin
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
SerialCheck(tcdrain(FHandle)); {$IFDEF ANDROID}
ioctl(FHandle, TCSBRK, 1);
{$ELSE}
SerialCheck(tcdrain(FHandle));
{$ENDIF}
{$ELSE} {$ELSE}
SetSynaError(sOK); SetSynaError(sOK);
if not Flushfilebuffers(FHandle) then if not Flushfilebuffers(FHandle) then
@ -2197,7 +2265,7 @@ end;
Ownership Manager. Ownership Manager.
} }
{$IFDEF UNIX} {$IFDEF USE_LINUX_LOCK}
function TBlockSerial.LockfileName: String; function TBlockSerial.LockfileName: String;
var var
@ -2209,8 +2277,13 @@ end;
procedure TBlockSerial.CreateLockfile(PidNr: integer); procedure TBlockSerial.CreateLockfile(PidNr: integer);
var var
f: TextFile;
s: string; s: string;
{$IFDEF FPC}
m: Word;
FS: TFileStream;
{$ELSE}
f: TextFile;
{$ENDIF}
begin begin
// Create content for file // Create content for file
s := IntToStr(PidNr); s := IntToStr(PidNr);
@ -2218,6 +2291,7 @@ begin
s := ' ' + s; s := ' ' + s;
// Create file // Create file
try try
{$IFNDEF FPC}
AssignFile(f, LockfileName); AssignFile(f, LockfileName);
try try
Rewrite(f); Rewrite(f);
@ -2225,6 +2299,21 @@ begin
finally finally
CloseFile(f); CloseFile(f);
end; end;
{$ELSE}
s := s + sLineBreak;
if FileExists(LockfileName) then
m := fmOpenReadWrite
else
m := fmCreate;
FS := TFileStream.Create(LockfileName, m or fmShareDenyWrite);
try
FS.Seek(0, soEnd);
FS.Write(Pointer(s)^, Length(s));
finally
FS.Free ;
end;
{$ENDIF}
// Allow all users to enjoy the benefits of cpom // Allow all users to enjoy the benefits of cpom
s := 'chmod a+rw ' + LockfileName; s := 'chmod a+rw ' + LockfileName;
{$IFNDEF FPC} {$IFNDEF FPC}
@ -2263,7 +2352,7 @@ var
begin begin
Filename := LockfileName; Filename := LockfileName;
{$IFNDEF FPC} {$IFNDEF FPC}
MyPid := Libc.getpid; MyPid := {$IFNDEF POSIX}Libc.{$ENDIF}getpid;
{$ELSE} {$ELSE}
MyPid := fpGetPid; MyPid := fpGetPid;
{$ENDIF} {$ENDIF}
@ -2271,20 +2360,20 @@ begin
if not DirectoryExists(LockfileDirectory) then if not DirectoryExists(LockfileDirectory) then
CreateDir(LockfileDirectory); CreateDir(LockfileDirectory);
// Check the Lockfile // Check the Lockfile
if not FileExists (Filename) then if not FileExists(Filename) then
begin // comport is not locked. Lock it for us. begin // comport is not locked. Lock it for us.
CreateLockfile(MyPid); CreateLockfile(MyPid);
result := true; result := FileExists(Filename);
exit; // done. exit; // done.
end; end;
// Is port owned by orphan? Then it's time for error recovery. // Is port owned by orphan? Then it's time for error recovery.
//FPC forgot to add getsid.. :-( //FPC forgot to add getsid.. :-(
{$IFNDEF FPC} {$IFNDEF FPC}
if Libc.getsid(ReadLockfile) = -1 then if {$IFNDEF POSIX}Libc.{$ENDIF}getsid(ReadLockfile) = -1 then
begin // Lockfile was left from former desaster begin // Lockfile was left from former desaster
DeleteFile(Filename); // error recovery DeleteFile(Filename); // error recovery
CreateLockfile(MyPid); CreateLockfile(MyPid);
result := true; result := FileExists(Filename);
exit; exit;
end; end;
{$ENDIF} {$ENDIF}
@ -2330,13 +2419,15 @@ end;
{$ENDIF} {$ENDIF}
{$IFNDEF MSWINDOWS} {$IFNDEF MSWINDOWS}
function GetSerialPortNames: string; function GetSerialPortNames: string;
const
ATTR = {$IFDEF POSIX}$7FFFFFFF{$ELSE}$FFFFFFFF{$ENDIF};
var var
sr : TSearchRec; sr : TSearchRec;
begin begin
Result := ''; Result := '';
if FindFirst('/dev/ttyS*', $FFFFFFFF, sr) = 0 then if FindFirst('/dev/ttyS*', ATTR, sr) = 0 then
repeat repeat
if (sr.Attr and $FFFFFFFF) = Sr.Attr then if (sr.Attr and ATTR) = Sr.Attr then
begin begin
if Result <> '' then if Result <> '' then
Result := Result + ','; Result := Result + ',';
@ -2344,18 +2435,18 @@ begin
end; end;
until FindNext(sr) <> 0; until FindNext(sr) <> 0;
FindClose(sr); FindClose(sr);
if FindFirst('/dev/ttyUSB*', $FFFFFFFF, sr) = 0 then begin if FindFirst('/dev/ttyUSB*', ATTR, sr) = 0 then begin
repeat repeat
if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin if (sr.Attr and ATTR) = Sr.Attr then begin
if Result <> '' then Result := Result + ','; if Result <> '' then Result := Result + ',';
Result := Result + '/dev/' + sr.Name; Result := Result + '/dev/' + sr.Name;
end; end;
until FindNext(sr) <> 0; until FindNext(sr) <> 0;
end; end;
FindClose(sr); FindClose(sr);
if FindFirst('/dev/ttyAM*', $FFFFFFFF, sr) = 0 then begin if FindFirst('/dev/ttyAM*', ATTR, sr) = 0 then begin
repeat repeat
if (sr.Attr and $FFFFFFFF) = Sr.Attr then begin if (sr.Attr and ATTR) = Sr.Attr then begin
if Result <> '' then Result := Result + ','; if Result <> '' then Result := Result + ',';
Result := Result + '/dev/' + sr.Name; Result := Result + '/dev/' + sr.Name;
end; end;