synaser.pas

PIC全系列单片机的bootloader程序

{==============================================================================|
| Project : Delphree - Synapse                                   | 005.000.000 |
|==============================================================================|
| Content: Serial port support                                                 |
|==============================================================================|
| Copyright (c)2001-2002, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of the Ararat s.r.o. nor the names of its contributors may  |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| 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):                                                              |
|  (c)2002, Hans-Georg Joepgen (cpom Comport Ownership Manager and bugfixes    |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{$Q-}
{$WEAKPACKAGEUNIT ON}

unit SynaSer;

interface

uses
{$IFDEF LINUX}
  Libc, Types, KernelIoctl,
{$ELSE}
  Windows, Classes,
{$ENDIF}
  SysUtils;

const
  LockfileDirectory = '/var/lock'; {HGJ}
  PortIsClosed = -1;               {HGJ}
  ErrAlreadyOwned = 9991;          {HGJ}
  ErrAlreadyInUse = 9992;          {HGJ}
  ErrWrongParameter = 9993;        {HGJ}
  ErrPortNotOpen = 9994;           {HGJ}
  ErrNoDeviceAnswer =  9995;       {HGJ}
  ErrMaxBuffer = 9996;
  ErrTimeout = 9997;
  ErrNotRead = 9998;
  ErrFrame = 9999;
  ErrOverrun = 10000;
  ErrRxOver = 10001;
  ErrRxParity = 10002;
  ErrTxFull = 10003;

  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;

{$IFDEF LINUX}
const
  INVALID_HANDLE_VALUE = THandle(-1);
  CS7fix = $0000020;

type
  TDCB = packed record
    DCBlength: DWORD;
    BaudRate: DWORD;
    Flags: Longint;
    wReserved: Word;
    XonLim: Word;
    XoffLim: Word;
    ByteSize: Byte;
    Parity: Byte;
    StopBits: Byte;
    XonChar: CHAR;
    XoffChar: CHAR;
    ErrorChar: CHAR;
    EofChar: CHAR;
    EvtChar: CHAR;
    wReserved1: Word;
  end;
  PDCB = ^TDCB;

const
  MaxRates = 30;
  Rates: array[0..MaxRates, 0..1] of cardinal =
  (
    (0, B0),
    (50, B50),
    (75, B75),
    (110, B110),
    (134, B134),
    (150, B150),
    (200, B200),
    (300, B300),
    (600, B600),
    (1200, B1200),
    (1800, B1800),
    (2400, B2400),
    (4800, B4800),
    (9600, B9600),
    (19200, B19200),
    (38400, B38400),
    (57600, B57600),
    (115200, B115200),
    (230400, B230400),
    (460800, B460800),
    (500000, B500000),
    (576000, B576000),
    (921600, B921600),
    (1000000, B1000000),
    (1152000, B1152000),
    (1500000, B1500000),
    (2000000, B2000000),
    (2500000, B2500000),
    (3000000, B3000000),
    (3500000, B3500000),
    (4000000, B4000000)
    );
{$ENDIF}

type

  THookSerialReason = (
    HR_SerialClose,
    HR_Connect,
    HR_CanRead,
    HR_CanWrite,
    HR_ReadCount,
    HR_WriteCount
    );

  THookSerialStatus = procedure(Sender: TObject; Reason: THookSerialReason;
    const Value: string) of object;

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

  TBlockSerial = class(TObject)
  protected
    FOnStatus: THookSerialStatus;
    Fhandle: THandle;
    FLastError: integer;
    FBuffer: string;
    FRaiseExcept: boolean;
    FRecvBuffer: integer;
    FSendBuffer: integer;
    FModemWord: integer;
    FRTSToggle: Boolean;
    FDeadlockTimeout: integer;
    FInstanceActive: boolean;      {HGJ}
    FTestDSR: Boolean;
    FTestCTS: Boolean;
    FMaxLineLength: Integer;
    FLinuxLock: Boolean;
{$IFNDEF LINUX}
    FEventHandle: THandle;
    function CanEvent(Event: dword; Timeout: integer): boolean;
    procedure DecodeCommError(Error: DWord);
{$ENDIF}
    procedure SetSizeRecvBuffer(size: integer);
    function GetDSR: Boolean;
    procedure SetDTRF(Value: Boolean);
    function GetCTS: Boolean;
    procedure SetRTSF(Value: Boolean);
    function GetCarrier: Boolean;
    function GetRing: Boolean;
    procedure DoStatus(Reason: THookSerialReason; const Value: string);
    procedure GetComNr(Value: string);
    function  PreTestFailing: boolean; {HGJ}
    function  TestCtrlLine: Boolean;
{$IFDEF LINUX}
    procedure DcbToTermios(const dcb: TDCB; var term: termios);
    procedure TermiosToDcb(const term: termios; var dcb: TDCB);
    function ReadLockfile: integer;
    function LockfileName: String;
    procedure CreateLockfile(PidNr: integer);
    procedure ErrorMethod(ErrNumber: integer); {HGJ}
{$ENDIF}
  public
    DCB: Tdcb;
    FComNr: integer;
{$IFDEF LINUX}
    TermiosStruc: termios;
{$ENDIF}
    constructor Create;
    destructor Destroy; override;
    function GetVersion: string;
    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 RecvPacket(Timeout: Integer): string;
    function RecvByte(timeout: integer): byte;
    function RecvTerminated(Timeout: Integer; const Terminator: string): string;
    function Recvstring(timeout: integer): string;
    function WaitingData: integer;
    function WaitingDataEx: integer;
    function SendingData: integer;
    procedure EnableRTSToggle(value: boolean);
    procedure EnableSoftRTSToggle(value: boolean);
    procedure Flush;
    procedure Purge;
    function CanRead(Timeout: integer): boolean;
    function CanWrite(Timeout: integer): boolean;
    function CanReadEx(Timeout: integer): boolean;
    function ModemStatus: integer;
    procedure SetBreak(Duration: integer);
    function ATCommand(value: string): string;
    function SerialCheck(SerialResult: integer): integer;
    procedure ExceptCheck;
    procedure ErrorMethod(ErrNumber: integer); {HGJ}
{$IFDEF LINUX}
    function  cpomComportAccessible: boolean; {HGJ}
    procedure cpomReleaseComport;  {HGJ}
{$ENDIF}
  published
    class function GetErrorDesc(ErrorCode: integer): string;
    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 OnStatus: THookSerialStatus read FOnStatus write FOnStatus;
    property RTS: Boolean write SetRTSF;
    property CTS: boolean read GetCTS;
    property DTR: Boolean write SetDTRF;
    property DSR: boolean read GetDSR;
    property Carrier: boolean read GetCarrier;
    property Ring: boolean read GetRing;
    property InstanceActive: boolean read FInstanceActive; {HGJ}
    property TestDSR: boolean read FTestDSR write FTestDSR;
    property TestCTS: boolean read FTestCTS write FTestCTS;
    property MaxLineLength: Integer read FMaxLineLength Write FMaxLineLength;
    property DeadlockTimeout: Integer read FDeadlockTimeout Write FDeadlockTimeout;
    property LinuxLock: Boolean read FLinuxLock write FLinuxLock;
  end;

implementation

constructor TBlockSerial.Create;
begin
  inherited create;
  FRaiseExcept := false;
  FHandle := INVALID_HANDLE_VALUE;
  FComNr:= PortIsClosed;               {HGJ}
  FInstanceActive:= false;             {HGJ}
  Fbuffer := '';
  FRTSToggle := False;
  FMaxLineLength := 0;
  FTestDSR := False;
  FTestCTS := False;
  FDeadlockTimeout := 30000;
  FLinuxLock := True;
{$IFNDEF LINUX}
  FEventHandle := INVALID_HANDLE_VALUE;
{$ENDIF}
end;

destructor TBlockSerial.Destroy;
begin
  CloseSocket;
{$IFNDEF LINUX}
  if FEventHandle <> INVALID_HANDLE_VALUE then
    CloseHandle(FEventHandle);
{$ENDIF}
  inherited destroy;
end;

function TBlockSerial.GetVersion: string;
begin
	Result := 'SynaSer 5.0.0';
end;

procedure TBlockSerial.CreateSocket;
begin
// dummy for compatibility with TBlockSocket classes
end;

procedure TBlockSerial.CloseSocket;
begin
  if Fhandle <> INVALID_HANDLE_VALUE then
  begin
    Purge;
    RTS := False;
    DTR := False;
    FileClose(integer(FHandle));
  end;
  if InstanceActive then
  begin
    {$IFDEF LINUX}
    if FLinuxLock then
      cpomReleaseComport;
    {$ENDIF}
    FInstanceActive:= false
  end;
  Fhandle := INVALID_HANDLE_VALUE;
  FComNr:= PortIsClosed;
  DoStatus(HR_SerialClose, '');
end;

procedure TBlockSerial.GetComNr(Value: string);
begin
  FComNr := PortIsClosed;
  if pos('COM', uppercase(Value)) = 1 then
  begin
    FComNr := StrToIntdef(copy(Value, 4, Length(Value) - 3), PortIsClosed + 1) - 1;
  end;
  if pos('/DEV/TTYS', uppercase(Value)) = 1 then
  begin
    FComNr := StrToIntdef(copy(Value, 10, Length(Value) - 9), PortIsClosed - 1) + 1;
  end;
end;

procedure TBlockSerial.Connect(comport: string; baud, bits: integer;
  parity: char; stop: integer; softflow, hardflow: boolean);
{$IFNDEF LINUX}
var
  CommTimeouts: TCommTimeouts;
{$ENDIF}
begin
  // Is this TBlockSerial Instance already busy?
  if InstanceActive then           {HGJ}
  begin                            {HGJ}
    ErrorMethod(ErrAlreadyInUse);  {HGJ}
    Exit;                          {HGJ}
  end;                             {HGJ}
  FBuffer := '';
  GetComNr(comport);
  if FComNr = PortIsClosed then
  begin
    ErrorMethod(ErrWrongParameter);
    Exit;
  end;
  SetLastError (0);
{$IFDEF LINUX}
  comport := '/dev/ttyS' + IntToStr(FComNr);
  // Comport already owned by another process?          {HGJ}
  if FLinuxLock then
    if not cpomComportAccessible then
    begin
      ErrorMethod(ErrAlreadyOwned);
      Exit;
    end;
  FHandle := THandle(Libc.open(pchar(comport), O_RDWR or O_SYNC));
  SerialCheck(integer(FHandle));
  if FLastError <> 0 then
  begin
  if FLinuxLock then
    cpomReleaseComport;
  end;
  ExceptCheck;
  if FLastError <> 0 then
    Exit;
{$ELSE}
  comport := '\\.\COM' + IntToStr(FComNr + 1);
  FHandle := THandle(CreateFile(PChar(comport), GENERIC_READ or GENERIC_WRITE,
    0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED, 0));
  SerialCheck(integer(FHandle));
  ExceptCheck;
  if FLastError <> 0 then
    Exit;
  SetCommMask(FHandle, 0);
  FEventhandle := CreateEvent(nil, True, False, nil);
  CommTimeOuts.ReadIntervalTimeout := MAXWORD;
  CommTimeOuts.ReadTotalTimeoutMultiplier := 0;
  CommTimeOuts.ReadTotalTimeoutConstant := 0;
  CommTimeOuts.WriteTotalTimeoutMultiplier := 0;
  CommTimeOuts.WriteTotalTimeoutConstant := 0;
  SetCommTimeOuts(FHandle, CommTimeOuts);
{$ENDIF}
  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;
  if dcb.Parity > 0 then
    dcb.Flags := dcb.Flags or dcb_ParityCheck
  else
    dcb.Flags := dcb.Flags and (not dcb_ParityCheck);
  dcb.StopBits := stop;
  dcb.Flags := dcb.Flags and (not dcb_RtsControlMask);
  if hardflow then
    dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake
  else
  begin
    dcb.Flags := dcb.Flags and (not dcb_OutxCtsFlow);
    dcb.Flags := dcb.Flags or dcb_RtsControlEnable;
  end;
  if softflow then
    dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX
  else
    dcb.Flags := dcb.Flags and (not (dcb_OutX or dcb_InX));
  dcb.Flags := dcb.Flags and (not dcb_DtrControlMask);
  dcb.Flags := dcb.Flags or dcb_DtrControlEnable;
  SetCommState;
  if FLastError <> 0 then  {HGJ}
  begin                   {HGJ}
    FileClose(FHandle);   {HGJ}
    {$IFDEF LINUX}
    if FLinuxLock then
      cpomReleaseComport;
    {$ENDIF}
    ExceptCheck;
    Exit;                 {HGJ}
  end;                    {HGJ}
  SizeRecvBuffer := 4096;
  FInstanceActive:= True; {HGJ}
  if not TestCtrlLine then  {HGJ}
  begin                                  {HGJ}
    FLastError := ErrNoDeviceAnswer;     {HGJ}
    FileClose(integer(FHandle));         {HGJ}
    {$IFDEF LINUX}
    if FLinuxLock then
      cpomReleaseComport;                {HGJ}
    {$ENDIF}                             {HGJ}
    FInstanceActive := false;            {HGJ}
    Fhandle := INVALID_HANDLE_VALUE;     {HGJ}
    FComNr:= PortIsClosed;               {HGJ}
  end;                                   {HGJ}
  if FLastError = 0 then
  begin
    Purge;
    RTS := True;
    DTR := True;
  end;
  ExceptCheck;
  DoStatus(HR_Connect, comport);
end;