synaser.pas

PIC全系列单片机的bootloader程序

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.