synaser.pas

Synapse串口同步库。功能有：它不是控件

{==============================================================================|
| Project : Delphree - Synapse                                   | 001.000.000 |
|==============================================================================|
| Content: Serial port support                                                 |
|==============================================================================|
| The contents of this file are subject to the Mozilla Public License Ver. 1.0 |
| (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 Synapse Delphi Library.                                 |
|==============================================================================|
| 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):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

unit SynaSer;

interface

uses
  windows, SysUtils;

const
  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;

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


{TBlockSerial}
TBlockSerial = class (TObject)
Protected
  Fhandle:THandle;
  FLastError:integer;
  FBuffer:string;
  FRaiseExcept:boolean;
  FRecvBuffer:integer;
  FSendBuffer:integer;
  procedure SetSizeRecvBuffer(size:integer);
  procedure SetSizeSendBuffer(size:integer);
public
  DCB:Tdcb;
  constructor Create;
  destructor Destroy; override;

  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 RecvByte(timeout:integer):byte;
  function Recvstring(timeout:integer):string;
  function WaitingData:integer;
  function SendingData:integer;
  procedure EnableRTSToggle(value:boolean);
  procedure Flush;
  procedure Purge;
  function CanRead(Timeout:integer):boolean;
  function CanWrite(Timeout:integer):boolean;
  function ModemStatus:integer;
  function ATCommand(value:string):string;

  function SerialCheck(SerialResult:integer):integer;
  procedure ExceptCheck;
published
  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 SizeSendBuffer:integer read FSendBuffer write SetSizeSendBuffer;
end;

function GetErrorDesc(ErrorCode:integer): string;


implementation

{TBlockSerial.Create}
constructor TBlockSerial.Create;
begin
  inherited create;
  FRaiseExcept:=false;
  FHandle:=INVALID_HANDLE_VALUE;
  Fbuffer:='';
end;

{TBlockSerial.Destroy}
destructor TBlockSerial.Destroy;
begin
  CloseSocket;
  inherited destroy;
end;

{TBlockSerial.CreateSocket}
Procedure TBlockSerial.CreateSocket;
begin
// dummy for compatibility with TBlockSocket classes
end;


{TBlockSerial.CloseSocket}
Procedure TBlockSerial.CloseSocket;
begin
  if Fhandle<>INVALID_HANDLE_VALUE
    then CloseHandle(FHandle);
  Fhandle:=INVALID_HANDLE_VALUE;
end;

{TBlockSerial.Connect}
procedure TBlockSerial.Connect(comport:string;baud,bits:integer;
                parity:char;stop:integer;softflow,hardflow:boolean);
var
  x:integer;
begin
  FBuffer:='';
	FHandle:=CreateFile(pchar(comport),GENERIC_READ or GENERIC_WRITE,
                       0,nil,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
  SerialCheck(FHandle);
  ExceptCheck;
  FSendBuffer:=16384;
  FRecvBuffer:=16384;
  setupComm(Fhandle,FRecvBuffer,FSendBuffer);
  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;
  dcb.StopBits:=stop;
  if hardflow
    then dcb.Flags:=dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
  if softflow
    then dcb.Flags:=dcb.Flags or dcb_OutX or dcb_InX;
  dcb.Flags := dcb.Flags or dcb_DtrControlEnable;
  SetCommState;
end;

{TBlockSerial.SendBuffer}
function TBlockSerial.SendBuffer(buffer:pointer;length:integer):integer;
var
  x:integer;
begin
  x:=integer(WriteFile(Fhandle,buffer^,length,result,nil));
  serialcheck(x);
  ExceptCheck;
end;

{TBlockSerial.SendByte}
procedure TBlockSerial.SendByte(data:byte);
var
  x,y:integer;
begin
  x:=integer(WriteFile(Fhandle,data,1,y,nil));
  serialcheck(x);
  ExceptCheck;
end;

{TBlockSerial.SendString}
procedure TBlockSerial.SendString(data:string);
var
  x,y:integer;
begin
  x:=integer(WriteFile(Fhandle,pchar(data)^,length(data),y,nil));
  serialcheck(x);
  ExceptCheck;
end;

{TBlockSerial.RecvBuffer}
function TBlockSerial.RecvBuffer(buffer:pointer;length:integer):integer;
var
  x:integer;
begin
  x:=integer(ReadFile(FHandle,Buffer^,length,Result,nil));
  serialcheck(x);
  ExceptCheck;
end;

{TBlockSerial.RecvBufferEx}
function TBlockSerial.RecvBufferEx(buffer:pointer;length:integer;timeout:integer):integer;
var
  s,ss,st:string;
  x,y,l,lss:integer;
  fb,fs:integer;
  max:integer;
begin
  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;
      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:=integer(ReadFile(FHandle,pointer(st)^,l,y,nil));
              serialcheck(x);
              if y=0 then FLastError:=1;
              x:=y;
              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:=30;
          if Flasterror<>0
            then break;
        end;
      fs:=system.length(ss);
    end;
  result:=fb+fs;
  s:=s+ss;
  move(pointer(s)^,buffer^,result);
  ExceptCheck;
end;

{TBlockSerial.RecvByte}
function TBlockSerial.RecvByte(timeout:integer):byte;
var
  x,y:integer;
  data:byte;
begin
  data:=0;
  result:=0;
  if CanRead(timeout) then
    begin
      x:=integer(ReadFile(FHandle,data,1,y,nil));
      if y<1
        then x:=30;
      serialcheck(x);
      result:=data;
    end
    else FLastError:=30; //???
  ExceptCheck;
end;

{TBlockSerial.Recvstring}
function TBlockSerial.Recvstring(timeout:integer):string;
const
  maxbuf=1024;
var
  x,y:integer;
  s:string;
  c:char;
  r:integer;
begin
  s:='';
  FLastError:=0;
  c:=#0;
  repeat
    if FBuffer='' then
      begin
        x:=waitingdata;
        if x=0 then x:=1;
        if x>maxbuf then x:=maxbuf;
        if x=1 then
          begin
            c:=char(RecvByte(timeout));
            if FLastError<>0 then break;
            Fbuffer:=c;
          end
        else
          begin
            setlength(Fbuffer,x);
            r:=integer(ReadFile(FHandle,pointer(FBuffer)^,x,y,nil));
            serialcheck(r);
            if y=0 then FLastError:=30;
            if FLastError<>0 then break;
          end;
      end;
    x:=pos(#10,Fbuffer);
    if x<=0 then x:=length(Fbuffer);
    s:=s+copy(Fbuffer,1,x-1);
    c:=Fbuffer[x];
    delete(Fbuffer,1,x);
    s:=s+c;
  until c = #10;

  if FLastError=0 then
    begin
      s:=AdjustLineBreaks(s);
      x:=pos(#13+#10,s);
      if x>0 then s:=copy(s,1,x-1);
      result:=s;
    end
  else result:='';
  ExceptCheck;
end;

{TBlockSerial.WaitingData}
function TBlockSerial.WaitingData:integer;
var
  stat:TComStat;
  err:DWORD;
  x:integer;
begin
  result:=0;
  x:=integer(ClearCommError(FHandle,err,@stat));
  serialcheck(x);
  ExceptCheck;
  result:=stat.cbInQue;
end;

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

{TBlockSerial.SetCommState}
procedure TBlockSerial.SetCommState;
var
  x:integer;
begin
  x:=integer(windows.SetCommState(Fhandle,dcb));
  SerialCheck(x);
  ExceptCheck;
end;

{TBlockSerial.GetCommState}
procedure TBlockSerial.GetCommState;
var
  x:integer;
begin
  x:=integer(windows.GetCommState(Fhandle,dcb));
  SerialCheck(x);
  ExceptCheck;
end;

{TBlockSerial.SetSizeRecvBuffer}
procedure TBlockSerial.SetSizeRecvBuffer(size:integer);
begin
  SetupComm(Fhandle,size,FSendBuffer);
end;

{TBlockSerial.SetSizeRecvBuffer}
procedure TBlockSerial.SetSizeSendBuffer(size:integer);
begin
  SetupComm(Fhandle,FRecvBuffer,size);
end;

{TBlockSerial.CanRead}
function TBlockSerial.CanRead(Timeout:integer):boolean;
var
  x:integer;
begin
  result:=true;
  x:=getTickCount+Timeout;
  while WaitingData<1 do
    begin
      if gettickCount>=x then
        begin
          result:=false;
          break;
        end;
      sleep(1);
    end;
end;

{TBlockSerial.CanWrite}
function TBlockSerial.CanWrite(Timeout:integer):boolean;
var
  x:integer;
begin
  result:=true;
  x:=getTickCount+Timeout;
  while SendingData>0 do
    begin
      if gettickCount>=x then
        begin
          result:=false;
          break;
        end;
      sleep(1);
    end;
end;

{TBlockSerial.EnableRTSToggle}
procedure TBlockSerial.EnableRTSToggle(value:boolean);
begin
  GetCommState;
  if value
    then dcb.Flags:=dcb.Flags or dcb_RtsControlToggle
    else dcb.flags:=dcb.flags and (not dcb_RtsControlToggle);
  SetCommState;
end;

{TBlockSerial.Flush}
procedure TBlockSerial.Flush;
begin
  SerialCheck(integer(Flushfilebuffers(FHandle)));
  ExceptCheck;
end;

{TBlockSerial.Purge}
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;

{TBlockSerial.ModemStatus}
function TBlockSerial.ModemStatus:integer;
begin
  SerialCheck(integer(GetCommModemStatus(FHandle, Result)));
  ExceptCheck;
end;

{TBlockSerial.ATCommand}
function TBlockSerial.ATCommand(value:string):string;
var
  s:string;
begin
  result:='';
  SendString(value+#$0d+#$0a);
  repeat
    s:=RecvString(1000);
    if s<>value
      then result:=result+s+#$0d+#$0a;
    if s='OK' then break;
    if s='ERROR' then break;
  until FLastError<>0;
end;

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

{TBlockSerial.ExceptCheck}
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;

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

{GetErrorDesc}
function GetErrorDesc(ErrorCode:integer): string;
var
  x:integer;
begin
  setlength(result,1023);
  x:=Formatmessage(FORMAT_MESSAGE_FROM_SYSTEM,nil,ErrorCode,0,pchar(result),1023,nil);
  result:=copy(result,1,x);
end;

begin
  exit;
  asm
    db 'Synapse Serial Communication library by Lukas Gebauer',0
  end;
end.