unit ucomport;

{$mode objfpc}{$H+}

interface

uses
  Forms,Classes, SysUtils,LCLIntf, Dialogs,LCLProc
  {$IFNDEF WINCE}
  ,Synaser
  {$ELSE}
  ,Windows
  {$ENDIF}
  ;
  
type

  TComport = class;

  { TRecvThread }

  TRecvThread = class(TThread)
  private
    FPort : TComPort;
    FBuffer : string;
    procedure DataRecived;
  public
    constructor Create(Port : TComPort);
    procedure Execute;override;
  end;
  
  TCharNotification = procedure(Port : TComport;c : char) of object;
  TLineNotification = procedure(Port : TComport;line : string) of object;

  { TComPort }

  TComPort = class(TObject)
  private
    FActive: Boolean;
    FBaudrate: Integer;
    FCharRecived: TCharNotification;
    FDatabits: Integer;
    FFormat: string;
    FHardflow: Boolean;
    FLineRecived: TLineNotification;
    FParity: char;
    {$IFNDEF WINCE}
    FPort: TBlockSerial;
    {$ELSE}
    hPort : THandle;
    {$ENDIF}
    FPortName : string;
    FSoftflow: Boolean;
    FStopbits: Integer;
    FRecvThread : TRecvThread;
    FTerminator: char;
    FBuffer : string;
    procedure SetActive(const AValue: Boolean);
  public
    constructor Create(APortName : string);
    destructor Destroy;override;
    property Port : string read FPortName write FPortname;
    property Baudrate : Integer read FBaudrate write FBaudrate;
    property Parity : char read FParity write FParity;
    property Stopbits : Integer read FStopbits write FStopbits;
    property Databits : Integer read FDatabits write FDataBits;
    property Hardflow : Boolean read FHardflow write FHardflow;
    property Softflow : Boolean read FSoftflow write FSoftflow;
    property Buffer : string read FBuffer;
    property Active : Boolean read FActive write SetActive;
    function SetParamsFromString(params : string) : Boolean;
    property LineTerminator : char read FTerminator write FTerminator;
    procedure Open;virtual;
    procedure Close;virtual;
    procedure ClearBuffer;
    function ATCommand(cmd : string) : string;
    function SendString(data : string) : Boolean;
    function LastErrorDesc : string;
    property OnCharRecived : TCharNotification read FCharRecived write FCharRecived;
    property OnLineRecived : TLineNotification read FLineRecived write FLineRecived;
    function CheckLineRecived(var Line : string) : Boolean;
    function CheckCharRecived(var c : char) : Boolean;
    function RecivLine(Timeout : Integer) : string;
  end;

implementation

{ TComPort }

procedure TComPort.SetActive(const AValue: Boolean);
begin
  if FActive=AValue then exit;
  FActive:=AValue;
  if FActive then
    Open
  else
    Close;
end;

constructor TComPort.Create(APortName: string);
begin
  FDatabits := 8;
  FStopbits := 1;
  FParity := 'N';
  FBaudrate := 9600;
  FPortname := APortName;
{$IFDEF WINCE}
  hPort := INVALID_HANDLE_VALUE;
{$ENDIF}
  FTerminator := #13;
end;

destructor TComPort.Destroy;
begin
  if Active then
    Close;
end;

function TComPort.SetParamsFromString(params: string): Boolean;
var
  tmp: String;
begin
  Result := True;
  try
    if pos(',',Params) = 0 then
      begin
        Result := False;
        exit;
      end;
    FBaudrate := StrToInt(copy(Params,0,pos(',',Params)-1));
    tmp := copy(Params,pos(',',Params)+1,length(Params));
    FDatabits := StrToInt(copy(tmp,0,1));
    FParity := copy(tmp,2,1)[1];
    FStopbits := StrToInt(copy(tmp,3,1));
  except
    result := False;
    exit;
  end;
end;

procedure TComPort.Open;
{$IFDEF WINCE}
var
  dcb: TDCB;
  comm : TCommTimeouts;
{$ENDIF}
begin
  if
{$IFNDEF WINCE}
  Assigned(FPort)
{$ELSE}
  hPort <> INVALID_HANDLE_VALUE
{$ENDIF}
  then
    begin
      FActive := True;
      exit;
    end;
{$IFNDEF WINCE}
  FPort := TBlockSerial.Create;
  try
    FPort.Connect(FPortName);
  except
  end;
  if FPort.LastError <> 0 then
    begin
      FActive := false;
      exit;
    end;
  case FStopBits of
  1:FPort.Config(FBaudrate,FDatabits,FParity,SB1,False,True);
  2:FPort.Config(FBaudrate,FDatabits,FParity,SB2,False,True);
  end;
  FActive := True;
{$ELSE}
  FActive := False;
  hPort:=CreateFileW(StringToPWideChar(FPortName+':'), GENERIC_READ or GENERIC_WRITE,0, nil, OPEN_EXISTING, 0, 0);
  if (SetupComm (hPort, 40, 40)) then
    begin
      dcb.DCBLength:=SizeOf(TDCB);
      if (GetCommState (hPort, @dcb)) then
        begin
          dcb.BaudRate := FBaudrate;
          dcb.ByteSize:=FDataBits;
          if FParity = 'Y' then
            dcb.Parity:=1
          else
            dcb.Parity:=0;
          case FStopBits of
          1:dcb.StopBits:=0;
          2:dcb.StopBits:=1;
          end;
          if SetCommState(hPort, @dcb) then
            FActive := True;
          GetCommTimeouts(hPort, comm);
          comm.ReadIntervalTimeout := 50;
          comm.ReadTotalTimeoutConstant := 100;
          comm.ReadTotalTimeoutMultiplier := 20;
          comm.WriteTotalTimeoutConstant := 1000;
          comm.WriteTotalTimeoutMultiplier := 20;
          SetCommTimeouts( hPort, comm);
        end;
    end;
{$ENDIF}
  if FActive then
    FRecvThread := TRecvThread.Create(Self);
end;

procedure TComPort.Close;
begin
{$IFNDEF WINCE}
  FPort.free;
  FPort := nil;
{$ELSE}
  CloseHandle (hPort);
  hPort := INVALID_HANDLE_VALUE;
//  FRecvThread.Terminate;
//  while not FRecvThread.Terminated do;
{$ENDIF}
  FRecvThread.Free;
  FrecvThread := nil;
end;

procedure TComPort.ClearBuffer;
begin
  FBuffer := '';
end;

function TComPort.SendString(data : string) : Boolean;
{$IFDEF WINCE}
var
  res: LongWord;
{$ENDIF}
begin
  Debugln('SendString:'+data);
{$IFDEF WINCE}
  WriteFile(hPort,PChar(data)^,length(data), res, nil);
  Result := res = length(data);
{$ELSE}
  FPort.SendString(data);
  Result := FPort.LastError = 0;
{$ENDIF}
end;

function TComPort.ATCommand(cmd: string): string;
{$IFDEF WINCE}
var
  res: LongWord;
  aBuffer: array[0..40] of char;
  tmp: String;
{$ENDIF}
begin
{$IFDEF WINCE}
  Debugln('ATCommand:'+cmd);
  tmp := cmd+#13;
  WriteFile(hPort,PChar(tmp)^,length(tmp), res, nil);
  aBuffer[0] := #0;
  ReadFile(hPort, aBuffer, 40 , res, nil);
  aBuffer[res] := #0;
  Result := aBuffer;
{$ELSE}
  Result := FPort.ATCommand(cmd);
{$ENDIF}
  Result := StringReplace(Result,#10,'',[rfReplaceAll]);
  Result := StringReplace(Result,#13,'',[rfReplaceAll]);
  if pos('OK',result) > 0 then
    Result := copy(Result,0,pos('OK',Result)-1);
end;

function TComPort.LastErrorDesc: string;
begin
{$IFDEF WINCE}
  Result := SysErrorMessage(GetLastError);
{$ELSE}
  Result := FPort.LastErrorDesc;
{$ENDIF}
end;

function TComPort.CheckLineRecived(var Line: string): Boolean;
begin
  Result := false;
  if pos(FTerminator,FBuffer) > 0 then
    begin
      Line := copy(FBuffer,0,pos(FTerminator,FBuffer));
      Fbuffer := copy(FBuffer,pos(FTerminator,FBuffer)+1,length(FBuffer));
      Result := True;
    end;
end;

function TComPort.CheckCharRecived(var c: char): Boolean;
begin
  Result := False;
  if length(FBuffer) > 0 then
    begin
      c := FBuffer[1];
      FBuffer := copy(Fbuffer,2,length(FBuffer));
      Result := True;
    end;
end;

function TComPort.RecivLine(Timeout: Integer): string;
var
  atm: Int64;
begin
  atm := GetTickCount;
  while (TimeOut) > (GetTickCount - atm) do
    begin
      if pos(FTerminator,FBuffer) > 0 then
        begin
          Result := copy(FBuffer,0,pos(FTerminator,FBuffer)-1);
          FBuffer := copy(FBuffer,pos(FTerminator,FBuffer)+1,length(Fbuffer));
          exit;
        end;
      Application.Processmessages;
    end;
end;

{ TRecvThread }

procedure TRecvThread.DataRecived;
var
  i: Integer;
  f : TextFile;
begin
  if not Assigned(FPort) then exit;
  if length(Fbuffer) > 0 then
    begin
      if Assigned(FPort.OnCharRecived) then
        for i := 0 to length(FBuffer) do
          FPort.OnCharRecived(FPort,FBuffer[i]);
      if Assigned(FPort.OnLineRecived) then
        begin
          if (pos(FPort.FTerminator,FBuffer) > 0) and Assigned(FPort.OnLineRecived) then
            begin
              FPort.OnLineRecived(FPort,StringReplace(copy(FBuffer,0,pos(FPort.FTerminator,FBuffer)),#10,'',[rfReplaceAll]));
              Debugln(TimeToStr(Time)+' '+copy(FBuffer,0,pos(FPort.FTerminator,FBuffer)));
              FBuffer := copy(FBuffer,pos(FPort.FTerminator,FBuffer)+1,length(FBuffer));
            end;
        end
      else
        begin
          if Assigned(FPort.OnCharRecived) then
            FBuffer := ''
          else
            begin
              FPort.FBuffer := FPort.FBuffer+FBuffer;
              FBuffer := '';
            end;
        end;
    end;
end;

constructor TRecvThread.Create(Port : TComPort);
begin
  FPort := Port;
  FBuffer := '';
  inherited Create(False);
end;

procedure TRecvThread.Execute;
{$IFDEF WINCE}
var
  Buffer: array[0..40] of char;
  res : LongWord;
{$ENDIF}
begin
  while not Terminated do
    begin
{$IFNDEF WINCE}
      if Assigned(fPort) and Assigned(FPort.FPort) and (fPort.FPort.LastError = 0) THEN
        begin
          while FPort.FPort.WaitingdataEx > 0 do
            FBuffer := Fbuffer+char(FPort.FPort.RecvByte(100));
          if FBuffer <> '' then
            Self.Synchronize(@DataRecived);
        end;
{$ELSE}
      if FPort.hPort <> INVALID_HANDLE_VALUE then
        begin
          Buffer[0] := #0;
          ReadFile(FPort.hPort, Buffer, 40 , res, nil);
          Buffer[res] := #0;
          FBuffer := FBuffer+Buffer;
          if FBuffer <> '' then
//            Synchronize(@DataRecived);
            DataRecived;
         end;
{$ENDIF}
      sleep(100);
    end;
end;

end.