synaser.pas

PIC全系列单片机的bootloader程序

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;