serialng.pas

RS232 Source using delphi

unit SerialNG;
// DomIS Internet Solutions http://www.domis.de
// This Source is distributet under the terms of GNU Licence
// This mean You can use this Source free for Open-Source development
// Additionally I allow the use for inhouse Projects
// It is prohibited to use this source for military Products!!!
// If You want to make a Closed-Source Project with this Source, please contact me
// Any changes should be marked and this header should remain here

// This is Version 2 of the Basic Communication Component
// I've made a complete redesign of the whole Component
// So the Component is incompatible with the Version 1
// News:
// Using Overlapped features for Windows Platform Compatiblity
// Using CommEvents for state detection
// More (and more meaningfull) Events
// Sending will not block the main Program


// Usage
// You have to register this component with the Delphi funktion "Component/New"
// create a new component library and add this component
// the TSerialNG component appears in the "Samples" part of the component toolbar

// The Base of this unit is taken from "TSerialPort: Basic Serial Communications in Delphi"
// created by Jason "Wedge" Perry, but I could not find him again

// 2.0.0 28.August.2001, Basic stable Version
// 2.0.1 30.August.2001, Fixing Thread stoperror in PortWord
// 2.0.2 17. September 2001, Deleting double declared Property Error, use instead CommError
//                           Changed declaration of procedure GetCommNames(CommNames : TStrings);
//                           prevent duplicate Entries in this function
// 2.0.3 9. November 2001, Changed Cardinal type to DWORD in TWorkThread.Execute for
//                         Delphi 3 backcompatibility
// 2.0.4 28. November 2001, Problem in not Active Mode fixed (
//                         sleep(200) prevent consuming 100% of cpu-time in inactive mode)
// 2.0.5 8. Januar 2002, Problem in GetDataAsPChar fixed (
//                         The pending Zero was not patched in the right place)
// 2.0.6 4. April 2002, Changed *all* Cardinal type to DWORD and made several Changes in
//                         Demo Forms for Delphi 3 backcompatibility
// 2.0.7 16. April 2002, Found and fixed the norty Error which occours sometimes after
//                         the Termination of the Threads (the Overlapped Result wrote into undefined Memory)
//                         The Thread waits now until everything Pending Overlapped is done

interface

uses
  Windows, Messages, SysUtils, Classes,
  Graphics, Controls, Forms, Dialogs;

  // Definitions for the DCB found in windows.pas for reference only
  // All of the baud rates that the DCB supports.
const
  BaudRateCount = 15;
  BaudRates : array[0..BaudRateCount-1] of DWord =
    (CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600, CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200, CBR_128000, CBR_256000);
// The business with the TimeOuts during sending Data, and esspeccialy during
// reception of Data depends on the selected Baudrate.
// while on 9600 Baud every 1ms a Char is received, is this time on 256KBaud only 4?s
// Strange enough, windows support only 1ms as shortest Intervall!
// Below some standard TimeOuts for the given Baudrates in ?s
  XTOCharDelayDef : array [0..BaudRateCount-1] of DWord =
(100000, 37000, 18000, 9000, 4500, 2300, 1100, 760, 570, 290, 200, 190, 95, 85, 43);
  // Parity types for parity error checking
  // NOPARITY = 0;  ODDPARITY = 1;  EVENPARITY = 2;  MARKPARITY = 3;  SPACEPARITY = 4;
  // Stopbits
  // ONESTOPBIT = 0;   ONE5STOPBITS = 1;  TWOSTOPBITS = 2;
  // Bitmasks for the "Flags" Field of the DCB record
const
  bmfBinary = $0001;          // binary mode, no EOF check
  bmfParity = $0002;          // enable parity checking
  bmfOutxCtsFlow = $0004;      // CTS output flow control
  bmfOutxDsrFlow = $0008;      // DSR output flow control
// DTR Control Flow Values  DTR_CONTROL_DISABLE = 0;  DTR_CONTROL_ENABLE = 1;  DTR_CONTROL_HANDSHAKE = 2;
  bmfDtrControlEnable = $0010;       // DTR Enable
  bmfDtrControlHandshake = $0020;       // DTR Handshake
  bmfDsrSensitivity = $0040;   // DSR sensitivity
  bmfTXContinueOnXoff = $0080; // XOFF continues Tx
  bmfOutX = $0100;            // XON/XOFF out flow control
  bmfInX = $0200;             // XON/XOFF in flow control
  bmfErrorChar = $0400;       // enable error replacement
  bmfNull = $0800;            // enable null stripping
// RTS Control Flow Values  RTS_CONTROL_DISABLE = 0;  RTS_CONTROL_ENABLE = 1;  RTS_CONTROL_HANDSHAKE = 2;  RTS_CONTROL_TOGGLE = 3;
  bmfRtsControlEnable = $1000;       // RTS Enable
  bmfRtsControlHandshake = $2000;       // RTS Enable
  bmfRtsControlToggle = $3000;       // RTS Enable
  bmfAbortOnError = $4000;     // abort reads/writes on error

// Basic FlowControlModes
// You may declare more _exotic_ Modes, like Sending RTS/CTS, receiving XOn/XOff :-)
const
  fcNone = 0;
  fcXON_XOFF = bmfOutX or bmfInX or  bmfTXContinueOnXoff;
  fcRTS_CTS = bmfOutxCtsFlow or bmfRtsControlHandshake;
  fcDSR_DTR = bmfOutxDsrFlow or bmfDtrControlHandshake;
  fcClearFlowCtrl = Not (fcXON_XOFF or fcRTS_CTS or fcDSR_DTR or bmfDtrControlEnable or bmfRtsControlEnable);
const BasicFlowModes : array[0..3] of Word = (fcNone, fcXON_XOFF, fcRTS_CTS, fcDSR_DTR);

// Constants for using in the ErrorNoise Property
// I tried to catch Errors, send Warnings or sometimes Messages for Your convinience.
// If You set the ErrorNoise Property to one of the Values this kind of Messages will be reported
// while those with higher Numbers not
const
  enError = 0;   // Errors like unable to Open Port
  enWarning = 1; // Warnings like cant pause Thread
  enMsg = 2;     // Messages like starting with Port opening
  enDebug = 3;   // Debughelpermessage like im am here or there
  enAll = 255;   // Show all

const
// Set some constant defaults.
// These are the equivalent of COM2:9600,N,8,1;
  dflt_CommPort = 'COM2';
  dflt_BaudRate = CBR_9600;
  dflt_ParityType = NOPARITY;
  dflt_ParityErrorChar = #0;
  dflt_ParityErrorReplacement = False;
  dflt_StopBits = ONESTOPBIT;
  dflt_DataBits = 8;
  dflt_XONChar = #$11;  {ASCII 11h}
  dflt_XOFFChar = #$13; {ASCII 13h}
  dflt_XONLimDiv = 33; // Set the XONLimit to dflt_XONLimDiv/100*RxQueueSize
  dflt_XOFFLimDiv = 33; // Set the XONLimit to dflt_XONLimDiv/100*RxQueueSize
  dflt_FlowControl = fcNone;
  dflt_StripNullChars = False;
  dflt_BinaryMode = True;
  dflt_EventChar = #0;
// Timeout defaults, fits only to 9600 Baud!
// Look that CharDelay is in micro, ExtraDely in milli Seconds!
  dflt_RTOCharDelayTime = 1100; // 1100microsec (1100E-06 secs)
  dflt_RTOExtraDelayTime = 250; // 250msec      ( 250E-03 secs)
  dflt_WTOCharDelayTime = 1100; // 1100microsec (1100E-06 secs)
  dflt_WTOExtraDelayTime = 250; // 1000msec     ( 250E-03 secs)
  dflt_XTOAuto = True; // lets the Component adjust CharDelay timing on every Baudrate change
  dflt_ClusterSize = 3072; //Max Clustersize
  dflt_RTSState = True;
  dflt_DTRState = True;
  dflt_ErrorNoise = enMsg;
  dflt_BREAKState = False;
  dflt_RxQueueSize = 4096;
  dflt_TxQueueSize = 4096;


type

// Special Event function for the Error and Warning
  TNotifyErrorEvent = procedure(Sender : TObject;Place, Code: DWord; Msg : String) of object;

// TSerialCluster is a Object for the Receiving Process.
// If You just want to receive some Data, don't care
// Under normal circumstances You have not to deal with this Object

// I decided to realize the receiving Process as follow:
// Between two cycles in the WorkThread may the SerialPort receive more than one Character.
// Basicly those Chars are named "Cluster" (and not "Telegram", as You might expect)
// How many Chars are stored in one TSerialCluster depeds on, User controlled,  Conditions
// 1. the ClusterSize is reched
// 2. the Receivingtime is reached
// 3. an (Line-) Error occoured
// 4. The Program set the "ReadRequest" Property to "True"
// If the condition is met, the received Chars are Stored as a Cluster into the ClusterList

  PSerialCluster = ^TSerialCluster;
  TSerialCluster = class (TObject)
    private
      ClusterData : Pointer; // Pointer to Data
      ClusterSize : Integer; // How many Bytes in Datafield
      ClusterCCError : DWord; // This Value comes from the ClearCommError function and is a Bitfield
//  CE_RXOVER = 1;        { Receive Queue overflow }
//  CE_OVERRUN = 2;       { Receive Overrun Error }
//  CE_RXPARITY = 4;      { Receive Parity Error }
//  CE_FRAME = 8;         { Receive Framing error }
//  CE_BREAK = $10;       { Break Detected }
//  CE_TXFULL = $100;     { TX Queue is full }
//  CE_MODE = $8000;      { Requested mode unsupported }

    public
    constructor Create(Data : Pointer; Size : Integer; CCError : DWord);
    function GetCCError : DWord;
    function GetSize : Integer;
    procedure GetData(Dest : Pointer);
    function GetDataAsString : String;
    function GetDataAsPChar(Dest : PChar) : PChar;
    destructor Destroy; override;
  end;

// TSerialPortNG is the Heart of the Job, everything what has to do with the
// SerialPort should be done with this Component
// The Concept is as follows:
// After instancing the Port is still closed
// You should set the Property "CommPort" to the full Name of the Port e.g. 'COM1'
// After this set the "Active" Property to "True"
// Sending Data ist performed with the SendData or the SendString procedures
// since Sendig is "Overlapped" the procedures returns immidiatly and You can do
// some other Jobs in Your main Programm
// You should not reentry this Procedures until they done there Job (Will give a warning).
// If send is done the component call the "OnWriteDone" Event.
// You also can ask the "WriteInProgress" Property.
// Reading Data is faily simple, just Read the Data with one of the "ReadNextCluster..." functions
// You place the read Access into the "OnRxClusterEvent".
// See sample Programs for more Information
  TSerialPortNG = class(TComponent)
  private
    // Variables holding Values for Properties
    fCommPort : ShortString;
    fBaudRate : DWord;
    fParityType : Byte;
    fParityErrorChar : Char;
    fParityErrorReplacement : Boolean;
    fStopBits : Byte;
    fDataBits : Byte;
    fXONChar : Char;
    fXOFFChar : Char;
    fXONLimDiv : Byte; // 0..100
    fXOFFLimDiv : Byte; // 0..100
    fFlowControl : LongInt;
    fStripNullChars : Boolean;  // Strip null chars?
    fEventChar : Char;
    fErrorNoise : Byte;
    // These fields are set in the EventThread
    fCommStateFlags : TComStateFlags;
    fCommStateInQueue : DWord;
    fCommStateOutQueue : DWord;
    fCommError : DWord;
    fCommEvent : DWord;
    fModemState : DWord;
    // TimeOut definitions
    fRTOCharDelayTime : DWord;     // in ?s max: 4.294.967.295?s aprox 1h 20min
    fRTOExtraDelayTime : Word;    // in ms
    fWTOCharDelayTime : DWord;     // in ?s
    fWTOExtraDelayTime : Word;    // in ms
    fXTOAuto : Boolean;
    fActive : Boolean;
    fRTSState : Boolean;
    fDTRState : Boolean;
    fBREAKState : Boolean;
    fCTSState : Boolean;
    fDSRState : Boolean;
    fRLSDState : Boolean;
    fRingState : Boolean;
    fClusterSize : Word;
    fRxQueueSize : Word;
    fTxQueueSize : Word;
    fReadRequest : Boolean; // Force Thread to Read the Queue
    fSendInProgress : Boolean;
    fWrittenBytes : DWord;

    // Eventvariables
    fOnTxQueueEmptyEvent : TNotifyEvent;
    fOnCommEvent : TNotifyEvent;
    fOnCommStat : TNotifyEvent;
    fOnBreakEvent : TNotifyEvent;
    fOnCTSEvent : TNotifyEvent;
    fOnDSREvent : TNotifyEvent;
    fOnLineErrorEvent : TNotifyEvent;
    fOnRingEvent : TNotifyEvent;
    fOnRLSDEvent : TNotifyEvent;
    fOnRxClusterEvent : TNotifyEvent;
    fOnRxCharEvent : TNotifyEvent;
    fOnRxEventCharEvent : TNotifyEvent;
    fOnWriteDone : TNotifyEvent;
    fOnProcessError : TNotifyErrorEvent;

    hCommPort : THandle; // Handle to the port.
    WriteOverlapped : TOverlapped; //Overlapped field for Write
    ReadOverlapped : TOverlapped;  //Overlapped field for Read
    StatusOverlapped : TOverlapped; //Overlapped field for Status
    BytesToWrite : DWord;
    WriteStartTime : DWord;
    WorkThread : TThread;
    WorkThreadIsRunning : Boolean;
    WorkThreadIsTerminated : Boolean;
    ShutdownInProgress : Boolean;
    RxDClusterList : TList;
    LastErr : Integer;
    Platform : Integer; // 0 Win32s on Win3.11, 1 Win 9x, 2 WinNT

    // Procedures for setting the variables, refrenced in the Properties
    procedure SetCommPort(value : ShortString);
    procedure SetBaudRate(value : DWord);
    procedure SetParityType(value : Byte);
    procedure SetParityErrorChar(value : Char);
    procedure SetParityErrorReplacement(value : Boolean);
    procedure SetStopBits(value : Byte);
    procedure SetDataBits(value : Byte);
    procedure SetXONChar(value : Char);
    procedure SetXOFFChar(value : Char);
    procedure SetXONLimDiv(value : Byte);
    procedure SetXOFFLimDiv(value : Byte);
    procedure SetFlowControl(value : LongInt);
    procedure SetStripNullChars(value : Boolean);
    procedure SetEventChar(value : Char);
    procedure SetRTOCharDelayTime(value : DWord);
    procedure SetRTOExtraDelayTime(value : Word);
    procedure SetWTOCharDelayTime(value : DWord);
    procedure SetWTOExtraDelayTime(value : Word);
    procedure SetXTOAuto(value : Boolean);
    procedure SetClusterSize(value : Word);
    procedure SetRxQueueSize(value : Word);
    procedure SetTxQueueSize(value : Word);
    procedure SetErrorNoise(value : Byte);
    procedure SetSignalRTS(State : Boolean);
    procedure SetSignalDTR(State : Boolean);
    procedure SetSignalBREAK(State : Boolean);
    procedure SetReadRequest(value : Boolean);
    procedure SetActive(NewState : Boolean);
    // Rest of Procedures
    procedure InitOverlapped(var Overlapped : TOverlapped; EventName : PChar);
    procedure ResetOverlapped(var Overlapped : TOverlapped);
    procedure SetupDCB;
    procedure PortWork (ReOpen : Boolean); //If ReOpen is True the Port will be (Re-) Opened, otherwise closed. The ActiveFlag will bes Set!
    procedure EnableEvents;
    procedure ProcessError(Place, Code : DWord; Msg : String; Noise : Byte);
    procedure WorkThreadDone(Sender: TObject);
  protected
  public
    // Procedures for external calling
    constructor Create(AOwner : TComponent); override; //Create the Component
    destructor Destroy; override; //Destroy
    procedure SendData (Data : Pointer; Size : DWord); //Send binary Data
    procedure SendString(S : String); //Send String Data
    // Clusterfunctions works on received Datapackages
    function NextClusterSize : Integer;
    function NextClusterCCError : DWord;
    function ReadNextCluster(var ClusterSize : Integer; var CCError : DWord) : Pointer;
    function ReadNextClusterAsString : String;
    function ReadNextClusterAsPChar(Dest : PChar) : PChar;
    // Clears the Queues
    procedure ClearTxDQueue;
    procedure ClearRxDQueue;
    // Sets the Timingfields in depedecy to the Baudrate
    procedure XTODefault;
    // Save and retrieves the Setting to/from the registry
    procedure WriteSettings(Regkey, RegSubKey : String); // e.g. WriteSettings('Software/DomIS','SerialNGAdvDemo') will save to HKEY_CURRENT_USER\Software\DomIS\SerialAdvDemo
    procedure ReadSettings(Regkey, RegSubKey : String);
  published
    //If You set Active to True, the component tries to Open the Port, if Opened the state remains True.
    property Active : Boolean read FActive write SetActive default False;
    property ComHandle : THandle read hCommPort default INVALID_HANDLE_VALUE;
    property CommPort : ShortString read fCommPort write SetCommPort;
    property BaudRate :  DWord read fBaudRate write SetBaudRate default dflt_BaudRate;
    property ParityType : Byte read fParityType write SetParityType default dflt_ParityType;
    property ParityErrorChar : Char read fParityErrorChar write SetParityErrorChar default dflt_ParityErrorChar;
    property ParityErrorReplacement :  Boolean read fParityErrorReplacement  write SetParityErrorReplacement  default dflt_ParityErrorReplacement;
    property StopBits : Byte read fStopBits write SetStopBits default dflt_StopBits;
    property DataBits : Byte read fDataBits write SetDataBits default dflt_DataBits;
    property XONChar : Char read fXONChar  write SetXONChar  default dflt_XONChar;
    property XOFFChar : Char read fXOFFChar write SetXOFFChar  default dflt_XOFFChar;
    property XONLimDiv : Byte read fXONLimDiv  write SetXONLimDiv default dflt_XOnLimDiv;
    property XOFFLimDiv : Byte read fXOFFLimDiv  write SetXOFFLimDiv default dflt_XOffLimDiv;
    property FlowControl : LongInt read fFlowControl write SetFlowControl default dflt_FlowControl;
    property StripNullChars : Boolean read fStripNullChars write SetStripNullChars default dflt_StripNullChars;
    property EventChar : Char read fEventChar write SetEventChar default dflt_EventChar;